text: /* Licensed to the Apache Software Foundation (ASF) under one or more
   * contributor license agreements.  See the NOTICE file distributed with
   * this work for additional information regarding copyright ownership.
   * The ASF licenses this file to You 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"
  
  int modperl_require_module(pTHX_ const char *pv, int logfailure)
  {
      SV *sv;
  
      dSP;
      PUSHSTACKi(PERLSI_REQUIRE);
      ENTER;SAVETMPS;
      PUTBACK;
      sv = sv_newmortal();
      sv_setpv(sv, "require ");
      sv_catpv(sv, pv);
      eval_sv(sv, G_DISCARD);
      SPAGAIN;
      POPSTACK;
      FREETMPS;LEAVE;
  
      if (SvTRUE(ERRSV)) {
          if (logfailure) {
              (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
                                  NULL, NULL);
          }
          return FALSE;
      }
  
      return TRUE;
  }
  
  int modperl_require_file(pTHX_ const char *pv, int logfailure)
  {
      require_pv(pv);
  
      if (SvTRUE(ERRSV)) {
          if (logfailure) {
              (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
                                  NULL, NULL);
          }
          return FALSE;
      }
  
      return TRUE;
  }
  
  static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv)
  {
      static char *r_keys[] = { "r", "_r", NULL };
      HV *hv = (HV *)SvRV(in);
      SV *sv = (SV *)NULL;
      int i;
  
      for (i=0; r_keys[i]; i++) {
          int klen = i + 1; /* assumes r_keys[] will never change */
          SV **svp;
  
          if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) {
              if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) {
                  /* dig deeper */
                  return modperl_hv_request_find(aTHX_ sv, classname, cv);
              }
              break;
          }
      }
  
      if (!sv) {
          Perl_croak(aTHX_
                     "method `%s' invoked by a `%s' object with no `r' key!",
                     cv ? GvNAME(CvGV(cv)) : "unknown",
                     (SvRV(in) && SvSTASH(SvRV(in)))
                         ? HvNAME(SvSTASH(SvRV(in)))
                         : "unknown");
      }
  
      return SvROK(sv) ? SvRV(sv) : sv;
  }
  
  
  /* notice that if sv is not an Apache2::ServerRec object and
   * Apache2->request is not available, the returned global object might
   * be not thread-safe under threaded mpms, so use with care
   */
  
  MP_INLINE server_rec *modperl_sv2server_rec(pTHX_ SV *sv)
  {
      if (SvOBJECT(sv) || (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG))) {
          return INT2PTR(server_rec *, SvObjIV(sv));
      }
  
      /* next see if we have Apache2->request available */
      {
          request_rec *r = NULL;
          (void)modperl_tls_get_request_rec(&r);
          if (r) {
              return r->server;
          }
      }
  
      /* modperl_global_get_server_rec is not thread safe w/o locking */
      return modperl_global_get_server_rec();
  }
  
  MP_INLINE request_rec *modperl_sv2request_rec(pTHX_ SV *sv)
  {
      return modperl_xs_sv2request_rec(aTHX_ sv, NULL, (CV *)NULL);
  }
  
  request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
  {
      SV *sv = (SV *)NULL;
      MAGIC *mg;
  
      if (SvROK(in)) {
          SV *rv = (SV*)SvRV(in);
  
          switch (SvTYPE(rv)) {
            case SVt_PVMG:
              sv = rv;
              break;
            case SVt_PVHV:
              sv = modperl_hv_request_find(aTHX_ in, classname, cv);
              break;
            default:
              Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
                         (int)SvTYPE(rv));
          }
      }
  
      /* might be Apache2::ServerRec::warn method */
      if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) {
          request_rec *r = NULL;
          (void)modperl_tls_get_request_rec(&r);
  
          if (!r) {
              Perl_croak(aTHX_
                         "Apache2->%s called without setting Apache2->request!",
                         cv ? GvNAME(CvGV(cv)) : "unknown");
          }
  
          return r;
      }
  
      /* there could be pool magic attached to custom $r object, so make
       * sure that mg->mg_ptr is set */
      if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) {
          return (request_rec *)mg->mg_ptr;
      }
      else {
          if (classname && !sv_derived_from(in, classname)) {
              /* XXX: find something faster than sv_derived_from */
              return NULL;
          }
          return INT2PTR(request_rec *, SvIV(sv));
      }
  
      return NULL;
  }
  
  MP_INLINE SV *modperl_newSVsv_obj(pTHX_ SV *stashsv, SV *obj)
  {
      SV *newobj;
  
      if (!obj) {
          obj = stashsv;
          stashsv = (SV *)NULL;
      }
  
      newobj = newSVsv(obj);
  
      if (stashsv) {
          HV *stash = gv_stashsv(stashsv, TRUE);
          return sv_bless(newobj, stash);
      }
  
      return newobj;
  }
  
  MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr)
  {
      SV *sv = newSV(0);
  
      MP_TRACE_h(MP_FUNC, "sv_setref_pv(%s, 0x%lx)",
                 classname, (unsigned long)ptr);
      sv_setref_pv(sv, classname, ptr);
  
      return sv;
  }
  
  int modperl_errsv(pTHX_ int status, request_rec *r, server_rec *s)
  {
      SV *sv = ERRSV;
      STRLEN n_a;
  
      if (SvTRUE(sv)) {
          if (sv_derived_from(sv, "APR::Error") &&
              SvIVx(sv) == MODPERL_RC_EXIT) {
              /* ModPerl::Util::exit was called */
              return OK;
          }
  #if 0
          if (modperl_sv_is_http_code(ERRSV, &status)) {
              return status;
          }
  #endif
          if (r) {
              ap_log_rerror(APLOG_MARK, APLOG_ERR, 0, r, "%s", SvPV(sv, n_a));
          }
          else {
              ap_log_error(APLOG_MARK, APLOG_ERR, 0, s, "%s", SvPV(sv, n_a));
          }
  
          return status;
      }
  
      return status;
  }
  
  /* prepends the passed sprintf-like arguments to ERRSV, which also
   * gets stringified on the way */
  void modperl_errsv_prepend(pTHX_ const char *pat, ...)
  {
      SV *sv;
      va_list args;
  
      va_start(args, pat);
      sv = vnewSVpvf(pat, &args);
      va_end(args);
  
      sv_catsv(sv, ERRSV);
      sv_copypv(ERRSV, sv);
      sv_free(sv);
  }
  
  #define dl_librefs "DynaLoader::dl_librefs"
  #define dl_modules "DynaLoader::dl_modules"
  
  void modperl_xs_dl_handles_clear(pTHX)
  {
      AV *librefs = get_av(dl_librefs, FALSE);
      if (librefs) {
          av_clear(librefs);
      }
  }
  
  void **modperl_xs_dl_handles_get(pTHX)
  {
      I32 i;
      AV *librefs = get_av(dl_librefs, FALSE);
      AV *modules = get_av(dl_modules, FALSE);
      void **handles;
  
      if (!librefs) {
          MP_TRACE_r(MP_FUNC,
                     "Could not get @%s for unloading.",
                     dl_librefs);
          return NULL;
      }
  
      if (!(AvFILL(librefs) >= 0)) {
          /* dl_librefs and dl_modules are empty */
          return NULL;
      }
  
      handles = (void **)malloc(sizeof(void *) * (AvFILL(librefs)+2));
  
      for (i=0; i<=AvFILL(librefs); i++) {
          void *handle;
          SV *handle_sv = *av_fetch(librefs, i, FALSE);
          SV *module_sv = *av_fetch(modules, i, FALSE);
  
          if(!handle_sv) {
              MP_TRACE_r(MP_FUNC,
                         "Could not fetch $%s[%d]!",
                         dl_librefs, (int)i);
              continue;
          }
          handle = INT2PTR(void *, SvIV(handle_sv));
  
          MP_TRACE_r(MP_FUNC, "%s dl handle == 0x%lx",
                     SvPVX(module_sv), (unsigned long)handle);
          if (handle) {
              handles[i] = handle;
          }
      }
  
      av_clear(modules);
      av_clear(librefs);
  
      handles[i] = (void *)0;
  
      return handles;
  }
  
  void modperl_xs_dl_handles_close(void **handles)
  {
      int i;
  
      if (!handles) {
          return;
      }
  
      for (i=0; handles[i]; i++) {
          MP_TRACE_r(MP_FUNC, "close 0x%lx", (unsigned long)handles[i]);
          modperl_sys_dlclose(handles[i]);
      }
  
      free(handles);
  }
  
  /* XXX: There is no XS accessible splice() */
  static void modperl_av_remove_entry(pTHX_ AV *av, I32 index)
  {
      I32 i;
      AV *tmpav = newAV();
  
      /* stash the entries _before_ the item to delete */
      for (i=0; i<=index; i++) {
          av_store(tmpav, i, SvREFCNT_inc(av_shift(av)));
      }
  
      /* make size at the beginning of the array */
      av_unshift(av, index-1);
  
      /* add stashed entries back */
      for (i=0; i<index; i++) {
          av_store(av, i, *av_fetch(tmpav, i, 0));
      }
  
      sv_free((SV *)tmpav);
  }
  
  static void modperl_package_unload_dynamic(pTHX_ const char *package,
                                             I32 dl_index)
  {
      AV *librefs = get_av(dl_librefs, 0);
      SV *libref = *av_fetch(librefs, dl_index, 0);
  
      modperl_sys_dlclose(INT2PTR(void *, SvIV(libref)));
  
      /* remove package from @dl_librefs and @dl_modules */
      modperl_av_remove_entry(aTHX_ get_av(dl_librefs, 0), dl_index);
      modperl_av_remove_entry(aTHX_ get_av(dl_modules, 0), dl_index);
  
      return;
  }
  
  static int modperl_package_is_dynamic(pTHX_ const char *package,
                                        I32 *dl_index)
  {
     I32 i;
     AV *modules = get_av(dl_modules, FALSE);
  
     for (i=0; i<av_len(modules); i++) {
          SV *module = *av_fetch(modules, i, 0);
          if (strEQ(package, SvPVX(module))) {
              *dl_index = i;
              return TRUE;
          }
      }
      return FALSE;
  }
  
  modperl_cleanup_data_t *modperl_cleanup_data_new(apr_pool_t *p, void *data)
  {
      modperl_cleanup_data_t *cdata =
          (modperl_cleanup_data_t *)apr_pcalloc(p, sizeof(*cdata));
      cdata->pool = p;
      cdata->data = data;
      return cdata;
  }
  
  MP_INLINE void modperl_perl_av_push_elts_ref(pTHX_ AV *dst, AV *src)
  {
      I32 i, j, src_fill = AvFILLp(src), dst_fill = AvFILLp(dst);
  
      av_extend(dst, src_fill);
      AvFILLp(dst) += src_fill+1;
  
      for (i=dst_fill+1, j=0; j<=AvFILLp(src); i++, j++) {
          AvARRAY(dst)[i] = SvREFCNT_inc(AvARRAY(src)[j]);
      }
  }
  
  /*
   * similar to hv_fetch_ent, but takes string key and key len rather than SV
   * also skips magic and utf8 fu, since we are only dealing with internal tables
   */
  HE *modperl_perl_hv_fetch_he(pTHX_ HV *hv,
                               register char *key,
                               register I32 klen,
                               register U32 hash)
  {
      register XPVHV *xhv;
      register HE *entry;
  
      xhv = (XPVHV *)SvANY(hv);
      if (!HvARRAY(hv)) {
          return 0;
      }
  
  #ifdef HvREHASH
      if (HvREHASH(hv)) {
          PERL_HASH_INTERNAL(hash, key, klen);
      }
      else
  #endif
      if (!hash) {
          PERL_HASH(hash, key, klen);
      }
  
      entry = ((HE**)HvARRAY(hv))[hash & (I32)xhv->xhv_max];
  
      for (; entry; entry = HeNEXT(entry)) {
          if (HeHASH(entry) != hash) {
              continue;
          }
          if (HeKLEN(entry) != klen) {
              continue;
          }
          if (HeKEY(entry) != key && memNE(HeKEY(entry), key, klen)) {
              continue;
          }
          return entry;
      }
  
      return 0;
  }
  
  void modperl_str_toupper(char *str)
  {
      while (*str) {
          *str = apr_toupper(*str);
          ++str;
      }
  }
  
  /* XXX: same as Perl_do_sprintf();
   * but Perl_do_sprintf() is not part of the "public" api
   */
  void modperl_perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
  {
      STRLEN patlen;
      char *pat = SvPV(*sarg, patlen);
      bool do_taint = FALSE;
  
      sv_vsetpvfn(sv, pat, patlen, (va_list *)NULL, sarg + 1, len - 1, &do_taint);
      SvSETMAGIC(sv);
      if (do_taint) {
          SvTAINTED_on(sv);
      }
  }
  
  void modperl_perl_call_list(pTHX_ AV *subs, const char *name)
  {
      I32 i, oldscope = PL_scopestack_ix;
      SV **ary = AvARRAY(subs);
  
      MP_TRACE_g(MP_FUNC, MP_TRACEf_PERLID
                 " running %d %s subs", MP_TRACEv_PERLID_
                 AvFILLp(subs)+1, name);
  
      for (i=0; i<=AvFILLp(subs); i++) {
          CV *cv = (CV*)ary[i];
          SV *atsv = ERRSV;
  
          PUSHMARK(PL_stack_sp);
          call_sv((SV*)cv, G_EVAL|G_DISCARD);
  
          if (SvCUR(atsv)) {
              Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted",
                             name);
              while (PL_scopestack_ix > oldscope) {
                  LEAVE;
              }
              Perl_croak(aTHX_ "%s", SvPVX(atsv));
          }
      }
  }
  
  void modperl_perl_exit(pTHX_ int status)
  {
      ENTER;
      SAVESPTR(PL_diehook);
      PL_diehook = (SV *)NULL;
      modperl_croak(aTHX_ MODPERL_RC_EXIT, "ModPerl::Util::exit");
  }
  
  MP_INLINE SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
                                   char *key, SV *sv_val)
  {
      SV *retval = &PL_sv_undef;
  
      if (r && r->per_dir_config) {
          MP_dDCFG;
          retval = modperl_table_get_set(aTHX_ dcfg->configvars,
                                         key, sv_val, FALSE);
      }
  
      if (!SvOK(retval)) {
          if (s && s->module_config) {
              MP_dSCFG(s);
              SvREFCNT_dec(retval); /* in case above did newSV(0) */
              retval = modperl_table_get_set(aTHX_ scfg->configvars,
                                             key, sv_val, FALSE);
          }
          else {
              retval = &PL_sv_undef;
          }
      }
  
      return retval;
  }
  
  SV *modperl_table_get_set(pTHX_ apr_table_t *table, char *key,
                            SV *sv_val, int do_taint)
  {
      SV *retval = &PL_sv_undef;
  
      if (table == NULL) {
          /* do nothing */
      }
      else if (key == NULL) {
          retval = modperl_hash_tie(aTHX_ "APR::Table",
                                    (SV *)NULL, (void*)table);
      }
      else if (!sv_val) { /* no val was passed */
          char *val;
          if ((val = (char *)apr_table_get(table, key))) {
              retval = newSVpv(val, 0);
          }
          else {
              retval = newSV(0);
          }
          if (do_taint) {
              SvTAINTED_on(retval);
          }
      }
      else if (!SvOK(sv_val)) { /* val was passed in as undef */
          apr_table_unset(table, key);
      }
      else {
          apr_table_set(table, key, SvPV_nolen(sv_val));
      }
  
      return retval;
  }
  
  static char *package2filename(const char *package, int *len)
  {
      const char *s;
      char *d;
      char *filename;
  
      filename = malloc((strlen(package)+4)*sizeof(char));
  
      for (s = package, d = filename; *s; s++, d++) {
          if (*s == ':' && s[1] == ':') {
              *d = '/';
              s++;
          }
          else {
              *d = *s;
          }
      }
      *d++ = '.';
      *d++ = 'p';
      *d++ = 'm';
      *d   = '\0';
  
      *len = d - filename;
      return filename;
  }
  
  MP_INLINE int modperl_perl_module_loaded(pTHX_ const char *name)
  {
      SV **svp;
      int len;
      char *filename = package2filename(name, &len);
      svp = hv_fetch(GvHVn(PL_incgv), filename, len, 0);
      free(filename);
  
      return (svp && *svp != &PL_sv_undef) ? 1 : 0;
  }
  
  #define SLURP_SUCCESS(action)                                           \
      if (rc != APR_SUCCESS) {                                            \
          SvREFCNT_dec(sv);                                               \
          modperl_croak(aTHX_ rc,                                         \
                        apr_psprintf(r->pool,                             \
                                     "slurp_filename('%s') / " action,    \
                                     r->filename));                       \
      }
  
  MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
  {
      SV *sv;
      apr_status_t rc;
      apr_size_t size;
      apr_file_t *file;
  
      size = r->finfo.size;
      sv = newSV(size);
  
      /* XXX: could have checked whether r->finfo.filehand is valid and
       * save the apr_file_open call, but apache gives us no API to
       * check whether filehand is valid. we can't test whether it's
       * NULL or not, as it may contain garbagea
       */
      rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
                         APR_OS_DEFAULT, r->pool);
      SLURP_SUCCESS("opening");
  
      rc = apr_file_read(file, SvPVX(sv), &size);
      SLURP_SUCCESS("reading");
  
      MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'", size, r->filename);
  
      if (r->finfo.size != size) {
          SvREFCNT_dec(sv);
          Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
                     size, (apr_size_t)r->finfo.size, r->filename);
      }
  
      rc = apr_file_close(file);
      SLURP_SUCCESS("closing");
  
      SvPVX(sv)[size] = '\0';
      SvCUR_set(sv, size);
      SvPOK_on(sv);
  
      if (tainted) {
          SvTAINTED_on(sv);
      }
      else {
          SvTAINTED_off(sv);
      }
  
      return newRV_noinc(sv);
  }
  
  #define MP_VALID_PKG_CHAR(c) (isalnum(c) ||(c) == '_')
  #define MP_VALID_PATH_DELIM(c) ((c) == '/' || (c) =='\\')
  char *modperl_file2package(apr_pool_t *p, const char *file)
  {
      char *package;
      char *c;
      const char *f;
      int len = strlen(file)+1;
  
      /* First, skip invalid prefix characters */
      while (!MP_VALID_PKG_CHAR(*file)) {
          file++;
          len--;
      }
  
      /* Then figure out how big the package name will be like */
      for (f = file; *f; f++) {
          if (MP_VALID_PATH_DELIM(*f)) {
              len++;
          }
      }
  
      package = apr_pcalloc(p, len);
  
      /* Then, replace bad characters with '_' */
      for (c = package; *file; c++, file++) {
          if (MP_VALID_PKG_CHAR(*file)) {
              *c = *file;
          }
          else if (MP_VALID_PATH_DELIM(*file)) {
  
              /* Eliminate subsequent duplicate path delim */
              while (*(file+1) && MP_VALID_PATH_DELIM(*(file+1))) {
                  file++;
              }
  
              /* path delim not until end of line */
              if (*(file+1)) {
                  *c = *(c+1) = ':';
                  c++;
              }
          }
          else {
              *c = '_';
          }
      }
  
      return package;
  }
  
  SV *modperl_apr_array_header2avrv(pTHX_ apr_array_header_t *array)
  {
      AV *av = newAV();
  
      if (array) {
          int i;
          for (i = 0; i < array->nelts; i++) {
              av_push(av, newSVpv(((char **)array->elts)[i], 0));
          }
      }
      return newRV_noinc((SV*)av);
  }
  
  apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
                                                    SV *avrv)
  {
      AV *av;
      apr_array_header_t *array;
      int i, av_size;
  
      if (!(SvROK(avrv) && (SvTYPE(SvRV(avrv)) == SVt_PVAV))) {
          Perl_croak(aTHX_ "Not an array reference");
      }
  
      av = (AV*)SvRV(avrv);
      av_size = av_len(av);
      array = apr_array_make(p, av_size+1, sizeof(char *));
  
      for (i = 0; i <= av_size; i++) {
          SV *sv = *av_fetch(av, i, FALSE);
          char **entry = (char **)apr_array_push(array);
          *entry = apr_pstrdup(p, SvPV_nolen(sv));
      }
  
      return array;
  }
  
  /* Remove a package from %INC */
  static void modperl_package_delete_from_inc(pTHX_ const char *package)
  {
      int len;
      char *filename = package2filename(package, &len);
      (void)hv_delete(GvHVn(PL_incgv), filename, len, G_DISCARD);
      free(filename);
  }
  
  /* Destroy a package's stash */
  #define MP_STASH_SUBSTASH(key, len) ((len >= 2) &&                  \
                                       (key[len-1] == ':') &&         \
                                       (key[len-2] == ':'))
  #define MP_STASH_DEBUGGER(key, len) ((len >= 2) &&                  \
                                       (key[0] == '_') &&             \
                                       (key[1] == '<'))
  #define MP_SAFE_STASH(key, len)     (!(MP_STASH_SUBSTASH(key,len)|| \
                                        (MP_STASH_DEBUGGER(key, len))))
  static void modperl_package_clear_stash(pTHX_ const char *package)
  {
      HV *stash;
      if ((stash = gv_stashpv(package, FALSE))) {
          HE *he;
          I32 len;
          char *key;
          hv_iterinit(stash);
          while ((he = hv_iternext(stash))) {
              key = hv_iterkey(he, &len);
              if (MP_SAFE_STASH(key, len)) {
                  SV *val = hv_iterval(stash, he);
                  /* The safe thing to do is to skip over stash entries
                   * that don't come from the package we are trying to
                   * unload
                   */
                  if (GvSTASH(val) == stash) {
                      (void)hv_delete(stash, key, len, G_DISCARD);
                  }
              }
          }
      }
  }
  
  /* Unload a module as completely and cleanly as possible */
  void modperl_package_unload(pTHX_ const char *package)
  {
      I32 dl_index;
  
      modperl_package_clear_stash(aTHX_ package);
      modperl_package_delete_from_inc(aTHX_ package);
  
      if (modperl_package_is_dynamic(aTHX_ package, &dl_index)) {
          modperl_package_unload_dynamic(aTHX_ package, dl_index);
      }
  
  }
  
  #define MP_RESTART_COUNT_KEY "mod_perl_restart_count"
  
  /* passing the main server object here, just because we don't have the
   * modperl_server_pool available yet, later on we can access it
   * through the modperl_server_pool() call.
   */
  void modperl_restart_count_inc(server_rec *base_server)
  {
      void *data;
      int *counter;
      apr_pool_t *p = base_server->process->pool;
  
      apr_pool_userdata_get(&data, MP_RESTART_COUNT_KEY, p);
      if (data) {
          counter = data;
          (*counter)++;
      }
      else {
          counter = apr_palloc(p, sizeof *counter);
          *counter = 1;
          apr_pool_userdata_set(counter, MP_RESTART_COUNT_KEY,
                                apr_pool_cleanup_null, p);
      }
  }
  
  int modperl_restart_count(void)
  {
      void *data;
      apr_pool_userdata_get(&data, MP_RESTART_COUNT_KEY,
                            modperl_global_get_server_rec()->process->pool);
      return data ? *(int *)data : 0;
   }
  
  static MP_INLINE
  apr_status_t modperl_cleanup_pnotes(void *data) {
      modperl_pnotes_t *pnotes = data;
  
      dTHXa(pnotes->interp->perl);
      MP_ASSERT_CONTEXT(aTHX);
  
      SvREFCNT_dec(pnotes->pnotes);
      pnotes->pnotes = NULL;
      pnotes->pool = NULL;
  
      MP_INTERP_PUTBACK(pnotes->interp, aTHX);
      return APR_SUCCESS;
  }
  
  void modperl_pnotes_kill(void *data) {
      modperl_pnotes_t *pnotes = data;
  
      if( !pnotes->pnotes ) return;
  
      apr_pool_cleanup_kill(pnotes->pool, pnotes, modperl_cleanup_pnotes);
      modperl_cleanup_pnotes(pnotes);
  }
  
  SV *modperl_pnotes(pTHX_ modperl_pnotes_t *pnotes, SV *key, SV *val,
                     apr_pool_t *pool) {
      SV *retval = (SV *)NULL;
  
      if (!pnotes->pnotes) {
          pnotes->pool = pool;
  #ifdef USE_ITHREADS
          pnotes->interp = modperl_thx_interp_get(aTHX);
          pnotes->interp->refcnt++;
          MP_TRACE_i(MP_FUNC, "TO: (0x%lx)->refcnt incremented to %ld",
                     pnotes->interp, pnotes->interp->refcnt);
  #endif
          pnotes->pnotes = newHV();
          apr_pool_cleanup_register(pool, pnotes,
                                    modperl_cleanup_pnotes,
                                    apr_pool_cleanup_null);
      }
  
      if (key) {
          STRLEN len;
          char *k = SvPV(key, len);
  
          if (val) {
              retval = *hv_store(pnotes->pnotes, k, len, SvREFCNT_inc(val), 0);
          }
          else if (hv_exists(pnotes->pnotes, k, len)) {
              retval = *hv_fetch(pnotes->pnotes, k, len, FALSE);
          }
  
          return retval ? SvREFCNT_inc(retval) : &PL_sv_undef;
      }
      return newRV_inc((SV *)pnotes->pnotes);
  }
  
  U16 *modperl_code_attrs(pTHX_ CV *cv) {
      MAGIC *mg;    
  
      if (!SvMAGICAL(cv)) {
         sv_magic((SV*)cv, (SV *)NULL, PERL_MAGIC_ext, NULL, -1); 
      }
  
      mg = mg_find((SV*)cv, PERL_MAGIC_ext);
      return &(mg->mg_private);
  }
  
  #if AP_SERVER_MAJORVERSION_NUMBER>2 || \
      (AP_SERVER_MAJORVERSION_NUMBER == 2 && AP_SERVER_MINORVERSION_NUMBER>=3)
  
  static apr_hash_t *global_authz_providers = NULL;
  static apr_hash_t *global_authn_providers = NULL;
  
  typedef struct {
      SV *cb1;
      SV *cb2;
      modperl_handler_t *cb1_handler;
      modperl_handler_t *cb2_handler;
  } auth_callback;
  
  static apr_status_t cleanup_perl_global_providers(void *ctx)
  {
      global_authz_providers = NULL;
      global_authn_providers = NULL;
      return APR_SUCCESS;
  }
  
  static authz_status perl_check_authorization(request_rec *r,
                                               const char *require_args,
                                               const void *parsed_require_args)
  {
      authz_status ret = AUTHZ_DENIED;
      int count;
      AV *args = Nullav;
      const char *key;
      auth_callback *ab;
      MP_dINTERPa(r, NULL, NULL);
  
      if (global_authz_providers == NULL) {
          MP_INTERP_PUTBACK(interp, aTHX);
          return ret;
      }
  
      key = apr_table_get(r->notes, AUTHZ_PROVIDER_NAME_NOTE);
      ab = apr_hash_get(global_authz_providers, key, APR_HASH_KEY_STRING);
      if (ab == NULL) {
          MP_INTERP_PUTBACK(interp, aTHX);
          return ret;
      }
  
      if (ab->cb1 == NULL) {
          if (ab->cb1_handler == NULL) {
              MP_INTERP_PUTBACK(interp, aTHX);
              return ret;
          }
  
          modperl_handler_make_args(aTHX_ &args, "Apache2::RequestRec", r,
                                    "PV", require_args, NULL);
          ret = modperl_callback(aTHX_ ab->cb1_handler, r->pool, r, r->server,
                                 args);
          SvREFCNT_dec((SV*)args);
          MP_INTERP_PUTBACK(interp, aTHX);
          return ret;
      }
  
      {
          dSP;
          ENTER;
          SAVETMPS;
          PUSHMARK(SP);
          XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::RequestRec", r)));
          XPUSHs(sv_2mortal(newSVpv(require_args, 0)));
          PUTBACK;
          count = call_sv(ab->cb1, G_SCALAR);
          SPAGAIN;
  
          if (count == 1) {
              ret = (authz_status) POPi;
          }
  
          PUTBACK;
          FREETMPS;
          LEAVE;
      }
  
      MP_INTERP_PUTBACK(interp, aTHX);
      return ret;
  }
  
  static const char *perl_parse_require_line(cmd_parms *cmd,
                                             const char *require_line,
                                             const void **parsed_require_line)
  {
      char *ret = NULL;
      void *key;
      auth_callback *ab;
  
      if (global_authz_providers == NULL ||
          apr_hash_count(global_authz_providers) == 0)
      {
          return NULL;
      }
  
      apr_pool_userdata_get(&key, AUTHZ_PROVIDER_NAME_NOTE, cmd->temp_pool);
      ab = apr_hash_get(global_authz_providers, (char *) key, APR_HASH_KEY_STRING);
      if (ab == NULL || ab->cb2 == NULL) {
          return NULL;
      }
  
      {
          /* PerlAddAuthzProvider currently does not support an optional second
           * handler, so ab->cb2 should always be NULL above and we will never get
           * here. If such support is added in the future then this code will be
           * reached, but cannot succeed in the absence of an interpreter. The
           * second handler would be called at init to check a Require line for
           * errors, but in the current design there is no interpreter available
           * at that time.
           */
          MP_dINTERP_POOLa(cmd->pool, cmd->server);
          if (!MP_HAS_INTERP(interp)) {
  	    return "Require handler is not currently supported in this context";
  	}
  
          {
              SV *ret_sv;
              int count;
              dSP;
  
              ENTER;
              SAVETMPS;
              PUSHMARK(SP);
              XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::CmdParms", cmd)));
              XPUSHs(sv_2mortal(newSVpv(require_line, 0)));
              PUTBACK;
              count = call_sv(ab->cb2, G_SCALAR);
              SPAGAIN;
  
              if (count == 1) {
                  ret_sv = POPs;
                  if (SvOK(ret_sv)) {
                      char *tmp = SvPV_nolen(ret_sv);
                      if (*tmp != '\0') {
                          ret = apr_pstrdup(cmd->pool, tmp);
                      }
                  }
              }
  
              PUTBACK;
              FREETMPS;
              LEAVE;
          }
  
          MP_INTERP_PUTBACK(interp, aTHX);
      }
      return ret;
  }
  
  static authn_status perl_check_password(request_rec *r, const char *user,
                                          const char *password)
  {
      authn_status ret = AUTH_DENIED;
      int count;
      AV *args = Nullav;
      const char *key;
      auth_callback *ab;
      MP_dINTERPa(r, NULL, NULL);
  
      if (global_authn_providers == NULL) {
          MP_INTERP_PUTBACK(interp, aTHX);
          return ret;
      }
  
      key = apr_table_get(r->notes, AUTHN_PROVIDER_NAME_NOTE);
      ab = apr_hash_get(global_authn_providers, key,
                                       APR_HASH_KEY_STRING);
      if (ab == NULL || ab->cb1) {
          MP_INTERP_PUTBACK(interp, aTHX);
          return ret;
      }
  
      if (ab->cb1 == NULL) {
          if (ab->cb1_handler == NULL) {
              MP_INTERP_PUTBACK(interp, aTHX);
              return ret;
          }
  
          modperl_handler_make_args(aTHX_ &args, "Apache2::RequestRec", r,
                                    "PV", user,
                                    "PV", password, NULL);
          ret = modperl_callback(aTHX_ ab->cb1_handler, r->pool, r, r->server,
                                 args);
          SvREFCNT_dec((SV*)args);
          MP_INTERP_PUTBACK(interp, aTHX);
          return ret;
      }
  
      {
          dSP;
          ENTER;
          SAVETMPS;
          PUSHMARK(SP);
          XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::RequestRec", r)));
          XPUSHs(sv_2mortal(newSVpv(user, 0)));
          XPUSHs(sv_2mortal(newSVpv(password, 0)));
          PUTBACK;
          count = call_sv(ab->cb1, G_SCALAR);
          SPAGAIN;
  
          if (count == 1) {
              ret = (authn_status) POPi;
          }
  
          PUTBACK;
          FREETMPS;
          LEAVE;
      }
  
      MP_INTERP_PUTBACK(interp, aTHX);
      return ret;
  }
  
  static authn_status perl_get_realm_hash(request_rec *r, const char *user,
                                          const char *realm, char **rethash)
  {
      authn_status ret = AUTH_USER_NOT_FOUND;
      const char *key;
      auth_callback *ab;
  
      if (global_authn_providers == NULL ||
          apr_hash_count(global_authn_providers) == 0)
      {
          return AUTH_GENERAL_ERROR;
      }
  
      key = apr_table_get(r->notes, AUTHN_PROVIDER_NAME_NOTE);
      ab = apr_hash_get(global_authn_providers, key, APR_HASH_KEY_STRING);
      if (ab == NULL || ab->cb2 == NULL) {
          return AUTH_GENERAL_ERROR;
      }
  
      {
          /* PerlAddAuthnProvider currently does not support an optional second
           * handler, so ab->cb2 should always be NULL above and we will never get
           * here. If such support is added in the future then this code will be
           * reached. Unlike the PerlAddAuthzProvider case, the second handler here
           * would be called during request_rec processing to obtain a password hash
           * for the realm so there should be no problem grabbing an interpreter.
           */
          MP_dINTERPa(r, NULL, NULL);
  
          {
              SV* rh = sv_2mortal(newSVpv("", 0));
              int count;
              dSP;
  
              ENTER;
              SAVETMPS;
              PUSHMARK(SP);
              XPUSHs(sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::RequestRec", r)));
              XPUSHs(sv_2mortal(newSVpv(user, 0)));
              XPUSHs(sv_2mortal(newSVpv(realm, 0)));
              XPUSHs(newRV_noinc(rh));
              PUTBACK;
              count = call_sv(ab->cb2, G_SCALAR);
              SPAGAIN;
  
              if (count == 1) {
                  const char *tmp = SvPV_nolen(rh);
                  ret = (authn_status) POPi;
                  if (*tmp != '\0') {
                      *rethash = apr_pstrdup(r->pool, tmp);
                  }
              }
  
              PUTBACK;
              FREETMPS;
              LEAVE;
          }
  
          MP_INTERP_PUTBACK(interp, aTHX);
      }
  
      return ret;
  }
  
  static const authz_provider authz_perl_provider = { perl_check_authorization,
                                                      perl_parse_require_line };
  
  static const authn_provider authn_perl_provider = { perl_check_password,
                                                      perl_get_realm_hash };
  
  static apr_status_t register_auth_provider(apr_pool_t *pool,
                                             const char *provider_group,
                                             const char *provider_name,
                                             const char *provider_version,
                                             auth_callback *ab, int type)
  {
      void *provider_ = NULL;
  
      if (global_authz_providers == NULL) {
          global_authz_providers = apr_hash_make(pool);
          global_authn_providers = apr_hash_make(pool);
          /* We have to use pre_cleanup here, otherwise this cleanup method
           * would be called after another cleanup method which unloads
           * mod_perl module.
           */
          apr_pool_pre_cleanup_register(pool, NULL,
                                        cleanup_perl_global_providers);
      }
  
      if (strcmp(provider_group, AUTHZ_PROVIDER_GROUP) == 0) {
          provider_ = (void *) &authz_perl_provider;
          apr_hash_set(global_authz_providers, provider_name,
                       APR_HASH_KEY_STRING, ab);
      }
      else {
          provider_ = (void *) &authn_perl_provider;
          apr_hash_set(global_authn_providers, provider_name,
                       APR_HASH_KEY_STRING, ab);
      }
  
      return ap_register_auth_provider(pool, provider_group, provider_name,
                                       provider_version, provider_, type);
  
  }
  
  apr_status_t modperl_register_auth_provider(apr_pool_t *pool,
                                              const char *provider_group,
                                              const char *provider_name,
                                              const char *provider_version,
                                              SV *callback1, SV *callback2,
                                              int type)
  {
      char *provider_name_dup;
      auth_callback *ab = NULL;
  
      provider_name_dup = apr_pstrdup(pool, provider_name);
      ab = apr_pcalloc(pool, sizeof(auth_callback));
      ab->cb1 = callback1;
      ab->cb2 = callback2;
  
      return register_auth_provider(pool, provider_group, provider_name_dup,
                                    provider_version, ab, type);
  }
  
  apr_status_t modperl_register_auth_provider_name(apr_pool_t *pool,
                                                   const char *provider_group,
                                                   const char *provider_name,
                                                   const char *provider_version,
                                                   const char *callback1,
                                                   const char *callback2,
                                                   int type)
  {
      char *provider_name_dup;
      auth_callback *ab = NULL;
  
      provider_name_dup = apr_pstrdup(pool, provider_name);
      ab = apr_pcalloc(pool, sizeof(auth_callback));
      ab->cb1_handler = modperl_handler_new(pool, callback1);
      if (callback2) {
          ab->cb2_handler = modperl_handler_new(pool, callback2);
      }
  
      return register_auth_provider(pool, provider_group, provider_name_dup,
                                    provider_version, ab, type);
  }
  
  #endif /* httpd-2.4 */
  
  /*
   * Local Variables:
   * c-basic-offset: 4
   * indent-tabs-mode: nil
   * End:
   */
  