| /* ==================================================================== |
| * The Apache Software License, Version 1.1 |
| * |
| * Copyright (c) 1996-2000 The Apache Software Foundation. All rights |
| * reserved. |
| * |
| * Redistribution and use in source and binary forms, with or without |
| * modification, are permitted provided that the following conditions |
| * are met: |
| * |
| * 1. Redistributions of source code must retain the above copyright |
| * notice, this list of conditions and the following disclaimer. |
| * |
| * 2. Redistributions in binary form must reproduce the above copyright |
| * notice, this list of conditions and the following disclaimer in |
| * the documentation and/or other materials provided with the |
| * distribution. |
| * |
| * 3. The end-user documentation included with the redistribution, |
| * if any, must include the following acknowledgment: |
| * "This product includes software developed by the |
| * Apache Software Foundation (http://www.apache.org/)." |
| * Alternately, this acknowledgment may appear in the software itself, |
| * if and wherever such third-party acknowledgments normally appear. |
| * |
| * 4. The names "Apache" and "Apache Software Foundation" must |
| * not be used to endorse or promote products derived from this |
| * software without prior written permission. For written |
| * permission, please contact apache@apache.org. |
| * |
| * 5. Products derived from this software may not be called "Apache", |
| * nor may "Apache" appear in their name, without prior written |
| * permission of the Apache Software Foundation. |
| * |
| * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED |
| * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES |
| * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE |
| * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR |
| * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
| * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT |
| * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF |
| * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND |
| * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, |
| * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT |
| * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF |
| * SUCH DAMAGE. |
| * ==================================================================== |
| */ |
| |
| #include "mod_perl.h" |
| |
| static HV *mod_perl_endhv = Nullhv; |
| static int set_ids = 0; |
| |
| void perl_util_cleanup(void) |
| { |
| hv_undef(mod_perl_endhv); |
| SvREFCNT_dec((SV*)mod_perl_endhv); |
| mod_perl_endhv = Nullhv; |
| |
| set_ids = 0; |
| } |
| |
| SV *array_header2avrv(array_header *arr) |
| { |
| AV *av; |
| int i; |
| dTHR; |
| |
| iniAV(av); |
| if(arr) { |
| for (i = 0; i < arr->nelts; i++) { |
| av_push(av, newSVpv(((char **) arr->elts)[i], 0)); |
| } |
| } |
| return newRV_noinc((SV*)av); |
| } |
| |
| array_header *avrv2array_header(SV *avrv, pool *p) |
| { |
| AV *av = (AV*)SvRV(avrv); |
| I32 i; |
| array_header *arr = make_array(p, AvFILL(av)-1, sizeof(char *)); |
| |
| for(i=0; i<=AvFILL(av); i++) { |
| SV *sv = *av_fetch(av, i, FALSE); |
| char **entry = (char **) push_array(arr); |
| *entry = pstrdup(p, SvPV(sv,na)); |
| } |
| |
| return arr; |
| } |
| |
| table *hvrv2table(SV *rv) |
| { |
| if(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV) { |
| SV *sv = perl_hvrv_magic_obj(rv); |
| if(!sv) croak("HV is not magic!"); |
| return (table *)SvIV((SV*)SvRV(sv)); |
| } |
| return (table *)SvIV((SV*)SvRV(rv)); |
| } |
| |
| static char *r_keys[] = { "_r", "r", NULL }; |
| |
| static request_rec *r_magic_get(SV *sv) |
| { |
| MAGIC *mg = mg_find(sv, '~'); |
| return mg ? (request_rec *)mg->mg_ptr : NULL; |
| } |
| |
| request_rec *sv2request_rec(SV *in, char *pclass, CV *cv) |
| { |
| request_rec *r = NULL; |
| SV *sv = Nullsv; |
| |
| if(in == &sv_undef) return NULL; |
| |
| if(SvROK(in) && (SvTYPE(SvRV(in)) == SVt_PVHV)) { |
| int i; |
| for (i=0; r_keys[i]; i++) { |
| int klen = strlen(r_keys[i]); |
| if(hv_exists((HV*)SvRV(in), r_keys[i], klen) && |
| (sv = *hv_fetch((HV*)SvRV(in), |
| r_keys[i], klen, FALSE))) { |
| if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) { |
| /* dig deeper */ |
| return sv2request_rec(sv, pclass, cv); |
| } |
| break; |
| } |
| } |
| if(!sv) |
| croak("method `%s' invoked by a `%s' object with no `r' key!", |
| GvNAME(CvGV(cv)), HvNAME(SvSTASH(SvRV(in)))); |
| } |
| |
| if(!sv) sv = in; |
| if(SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) { |
| if(sv_derived_from(sv, pclass)) { |
| if((r = r_magic_get(SvRV(sv)))) { |
| /* ~ magic */ |
| } |
| else { |
| r = (request_rec *) SvIV((SV*)SvRV(sv)); |
| } |
| } |
| else { |
| return NULL; |
| } |
| } |
| else if((r = perl_request_rec(NULL))) { |
| /*ok*/ |
| } |
| else { |
| croak("Apache->%s called without setting Apache->request!", |
| GvNAME(CvGV(cv))); |
| } |
| return r; |
| } |
| |
| pool *perl_get_util_pool(void) |
| { |
| request_rec *r = NULL; |
| |
| if((r = perl_request_rec(NULL))) |
| return r->pool; |
| else |
| return perl_get_startup_pool(); |
| return NULL; |
| } |
| |
| pool *perl_get_startup_pool(void) |
| { |
| SV *sv = perl_get_sv("Apache::__POOL", FALSE); |
| if(sv) { |
| IV tmp = SvIV((SV*)SvRV(sv)); |
| return (pool *)tmp; |
| } |
| return NULL; |
| } |
| |
| server_rec *perl_get_startup_server(void) |
| { |
| SV *sv = perl_get_sv("Apache::__SERVER", FALSE); |
| if(sv) { |
| IV tmp = SvIV((SV*)SvRV(sv)); |
| return (server_rec *)tmp; |
| } |
| return NULL; |
| } |
| |
| void mod_perl_untaint(SV *sv) |
| { |
| if(!tainting) return; |
| if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
| MAGIC *mg = mg_find(sv, 't'); |
| if (mg) |
| mg->mg_len &= ~1; |
| } |
| } |
| |
| /* same as Symbol::gensym() */ |
| SV *mod_perl_gensym (char *pack) |
| { |
| GV *gv = newGVgen(pack); |
| SV *rv = newRV((SV*)gv); |
| (void)hv_delete(gv_stashpv(pack, TRUE), |
| GvNAME(gv), GvNAMELEN(gv), G_DISCARD); |
| return rv; |
| } |
| |
| SV *mod_perl_slurp_filename(request_rec *r) |
| { |
| dTHR; |
| PerlIO *fp; |
| SV *insv; |
| |
| ENTER; |
| save_item(rs); |
| sv_setsv(rs, &sv_undef); |
| |
| fp = PerlIO_open(r->filename, "r"); |
| insv = newSV(r->finfo.st_size); |
| sv_gets(insv, fp, 0); /*slurp*/ |
| PerlIO_close(fp); |
| LEAVE; |
| return newRV_noinc(insv); |
| } |
| |
| SV *mod_perl_tie_table(table *t) |
| { |
| HV *hv = newHV(); |
| SV *sv = sv_newmortal(); |
| |
| sv_setref_pv(sv, "Apache::table", (void*)t); |
| perl_tie_hash(hv, "Apache::Table", sv); |
| return sv_bless(sv_2mortal(newRV_noinc((SV*)hv)), |
| gv_stashpv("Apache::Table", TRUE)); |
| } |
| |
| SV *perl_hvrv_magic_obj(SV *rv) |
| { |
| HV *hv = (HV*)SvRV(rv); |
| MAGIC *mg; |
| if(SvMAGICAL(hv) && (mg = mg_find((SV*)hv, 'P'))) |
| return mg->mg_obj; |
| else |
| return Nullsv; |
| } |
| |
| |
| void perl_tie_hash(HV *hv, char *pclass, SV *sv) |
| { |
| dSP; |
| SV *obj, *varsv = (SV*)hv; |
| char *methname = "TIEHASH"; |
| dTHRCTX; |
| |
| ENTER; |
| SAVETMPS; |
| PUSHMARK(sp); |
| XPUSHs(sv_2mortal(newSVpv(pclass,0))); |
| if(sv) XPUSHs(sv); |
| PUTBACK; |
| perl_call_method(methname, G_EVAL | G_SCALAR); |
| if(SvTRUE(ERRSV)) warn("perl_tie_hash: %s", SvPV(ERRSV,na)); |
| |
| SPAGAIN; |
| |
| obj = POPs; |
| sv_unmagic(varsv, 'P'); |
| sv_magic(varsv, obj, 'P', Nullch, 0); |
| |
| PUTBACK; |
| FREETMPS; |
| LEAVE; |
| } |
| |
| /* execute END blocks */ |
| |
| void perl_run_blocks(I32 oldscope, AV *subs) |
| { |
| STRLEN len; |
| I32 i; |
| dTHR; |
| dTHRCTX; |
| |
| for(i=0; i<=AvFILL(subs); i++) { |
| CV *cv = (CV*)*av_fetch(subs, i, FALSE); |
| SV* atsv = ERRSV; |
| |
| MARK_WHERE("END block", (SV*)cv); |
| PUSHMARK(stack_sp); |
| perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); |
| UNMARK_WHERE; |
| (void)SvPV(atsv, len); |
| if (len) { |
| if (subs == beginav) |
| sv_catpv(atsv, "BEGIN failed--compilation aborted"); |
| else |
| sv_catpv(atsv, "END failed--cleanup aborted"); |
| while (scopestack_ix > oldscope) |
| LEAVE; |
| } |
| } |
| } |
| |
| void mod_perl_clear_rgy_endav(request_rec *r, SV *sv) |
| { |
| STRLEN klen; |
| char *key; |
| |
| if(!mod_perl_endhv) return; |
| |
| key = SvPV(sv,klen); |
| if(hv_exists(mod_perl_endhv, key, klen)) { |
| SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); |
| AV *av; |
| if(!SvTRUE(entry) && !SvROK(entry)) { |
| MP_TRACE_g(fprintf(stderr, "endav is empty for %s\n", r->uri)); |
| return; |
| } |
| av = (AV*)SvRV(entry); |
| av_clear(av); |
| SvREFCNT_dec((SV*)av); |
| (void)hv_delete(mod_perl_endhv, key, klen, G_DISCARD); |
| MP_TRACE_g(fprintf(stderr, |
| "clearing END blocks for package `%s' (uri=%s)\n", |
| key, r->uri)); |
| } |
| } |
| |
| void perl_stash_rgy_endav(char *s, SV *rgystash) |
| { |
| AV *rgyendav = Nullav; |
| STRLEN klen; |
| char *key; |
| dTHR; |
| |
| if(!rgystash) |
| rgystash = perl_get_sv("Apache::Registry::curstash", FALSE); |
| |
| if(!rgystash || !SvTRUE(rgystash)) { |
| MP_TRACE_g(fprintf(stderr, |
| "Apache::Registry::curstash not set, can't stash END blocks for %s\n", |
| s)); |
| return; |
| } |
| |
| key = SvPV(rgystash,klen); |
| |
| if(mod_perl_endhv == Nullhv) |
| mod_perl_endhv = newHV(); |
| else if(hv_exists(mod_perl_endhv, key, klen)) { |
| SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); |
| if(SvTRUE(entry) && SvROK(entry)) |
| rgyendav = (AV*)SvRV(entry); |
| } |
| |
| if(endav) { |
| I32 i; |
| if(rgyendav == Nullav) |
| rgyendav = newAV(); |
| |
| if(AvFILL(rgyendav) > -1) |
| av_clear(rgyendav); |
| else |
| av_extend(rgyendav, AvFILL(endav)); |
| |
| for(i=0; i<=AvFILL(endav); i++) { |
| SV **svp = av_fetch(endav, i, FALSE); |
| av_store(rgyendav, i, (SV*)newRV((SV*)*svp)); |
| } |
| } |
| |
| if(rgyendav) |
| hv_store(mod_perl_endhv, key, klen, (SV*)newRV((SV*)rgyendav), FALSE); |
| } |
| |
| void perl_run_rgy_endav(char *s) |
| { |
| SV *rgystash = perl_get_sv("Apache::Registry::curstash", FALSE); |
| AV *rgyendav = Nullav; |
| STRLEN klen; |
| char *key; |
| dTHR; |
| |
| if(!rgystash || !SvTRUE(rgystash)) { |
| MP_TRACE_g(fprintf(stderr, |
| "Apache::Registry::curstash not set, can't run END blocks for %s\n", |
| s)); |
| return; |
| } |
| |
| key = SvPV(rgystash,klen); |
| |
| if(hv_exists(mod_perl_endhv, key, klen)) { |
| SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); |
| if(SvTRUE(entry) && SvROK(entry)) |
| rgyendav = (AV*)SvRV(entry); |
| } |
| |
| MP_TRACE_g(fprintf(stderr, |
| "running %d END blocks for %s\n", rgyendav ? (int)AvFILL(rgyendav)+1 : 0, s)); |
| ENTER; |
| save_aptr(&endav); |
| if((endav = rgyendav)) |
| perl_run_blocks(scopestack_ix, endav); |
| LEAVE; |
| sv_setpv(rgystash,""); |
| } |
| |
| void perl_run_endav(char *s) |
| { |
| dTHR; |
| I32 n = 0; |
| if(endav) |
| n = AvFILL(endav)+1; |
| |
| MP_TRACE_g(fprintf(stderr, "running %d END blocks for %s\n", |
| (int)n, s)); |
| if(endav) { |
| curstash = defstash; |
| call_list(scopestack_ix, endav); |
| } |
| } |
| |
| static PERL_MG_UFUNC(errgv_empty_set, ix, sv) |
| { |
| sv_setsv(sv, &sv_no); |
| return TRUE; |
| } |
| |
| void perl_call_halt(int status) |
| { |
| dTHR; |
| struct ufuncs umg; |
| int is_http_code = |
| ((status >= 100) && (status < 600) && ERRSV_CAN_BE_HTTP); |
| dTHRCTX; |
| |
| umg.uf_val = errgv_empty_set; |
| umg.uf_set = errgv_empty_set; |
| umg.uf_index = (IV)0; |
| |
| if(is_http_code) { |
| croak("%d\n", status); |
| } |
| else { |
| sv_magic(ERRSV, Nullsv, 'U', (char*) &umg, sizeof(umg)); |
| |
| ENTER; |
| SAVESPTR(diehook); |
| diehook = Nullsv; |
| croak(""); |
| LEAVE; /* we don't get this far, but croak() will rewind */ |
| |
| sv_unmagic(ERRSV, 'U'); |
| } |
| } |
| |
| /* |
| * reload %INC: cannot do so while iterating over %INC incase |
| * reloaded modules modify %INC at the file-scope |
| * this approach also preserves order for modules loaded via PerlModule |
| */ |
| void perl_reload_inc(server_rec *s, pool *sp) |
| { |
| dPSRV(s); |
| HV *hash = GvHV(incgv); |
| HE *entry; |
| U8 old_warn = dowarn; |
| pool *p = ap_make_sub_pool(sp); |
| table *reload = ap_make_table(p, HvKEYS(hash)); |
| char **entries; |
| int i = 0; |
| |
| dowarn = FALSE; |
| entries = (char **)cls->PerlModule->elts; |
| for (i=0; i < cls->PerlModule->nelts; i++) { |
| SV *file = perl_module2file(entries[i]); |
| ap_table_set(reload, SvPVX(file), "1"); |
| SvREFCNT_dec(file); |
| } |
| |
| hv_iterinit(hash); |
| while ((entry = hv_iternext(hash))) { |
| ap_table_set(reload, HeKEY(entry), "1"); |
| } |
| |
| { |
| array_header *arr = ap_table_elts(reload); |
| table_entry *elts = (table_entry *)arr->elts; |
| SV *keysv = newSV(0); |
| for (i=0; i < arr->nelts; i++) { |
| sv_setpv(keysv, elts[i].key); |
| if (!(entry = hv_fetch_ent(hash, keysv, FALSE, 0))) { |
| MP_TRACE_g(fprintf(stderr, |
| "%s not found in %%INC\n", elts[i].key)); |
| continue; |
| } |
| hv_delete_ent(hash, keysv, G_DISCARD, 0); |
| MP_TRACE_g(fprintf(stderr, "reloading %s\n", elts[i].key)); |
| perl_require_pv(elts[i].key); |
| } |
| SvREFCNT_dec(keysv); |
| } |
| |
| dowarn = old_warn; |
| ap_destroy_pool(p); |
| } |
| |
| I32 perl_module_is_loaded(char *name) |
| { |
| I32 retval = FALSE; |
| SV *key = perl_module2file(name); |
| if((key && hv_exists_ent(GvHV(incgv), key, FALSE))) |
| retval = TRUE; |
| if(key) |
| SvREFCNT_dec(key); |
| return retval; |
| } |
| |
| SV *perl_module2file(char *name) |
| { |
| SV *sv = newSVpv(name,0); |
| char *s; |
| for (s = SvPVX(sv); *s; s++) { |
| if (*s == ':' && s[1] == ':') { |
| *s = '/'; |
| Move(s+2, s+1, strlen(s+2)+1, char); |
| --SvCUR(sv); |
| } |
| } |
| sv_catpvn(sv, ".pm", 3); |
| return sv; |
| } |
| |
| int perl_require_module(char *name, server_rec *s) |
| { |
| dTHR; |
| SV *sv = sv_newmortal(); |
| dTHRCTX; |
| |
| sv_setpvn(sv, "require ", 8); |
| MP_TRACE_d(fprintf(stderr, "loading perl module '%s'...", name)); |
| sv_catpv(sv, name); |
| perl_eval_sv(sv, G_DISCARD); |
| if(s) { |
| if(perl_eval_ok(s) != OK) { |
| MP_TRACE_d(fprintf(stderr, "not ok\n")); |
| return -1; |
| } |
| } |
| else if(SvTRUE(ERRSV)) { |
| MP_TRACE_d(fprintf(stderr, "not ok\n")); |
| return -1; |
| } |
| |
| MP_TRACE_d(fprintf(stderr, "ok\n")); |
| return 0; |
| } |
| |
| void perl_do_file(char *pv) |
| { |
| SV* sv = sv_newmortal(); |
| sv_setpv(sv, "require '"); |
| sv_catpv(sv, pv); |
| sv_catpv(sv, "'"); |
| perl_eval_sv(sv, G_DISCARD); |
| /*(void)hv_delete(GvHV(incgv), pv, strlen(pv), G_DISCARD);*/ |
| } |
| |
| int perl_load_startup_script(server_rec *s, pool *p, char *script, U8 my_warn) |
| { |
| dTHR; |
| U8 old_warn = dowarn; |
| |
| if(!script) { |
| MP_TRACE_d(fprintf(stderr, "no Perl script to load\n")); |
| return OK; |
| } |
| |
| MP_TRACE_d(fprintf(stderr, "attempting to require `%s'\n", script)); |
| dowarn = my_warn; |
| curstash = defstash; |
| perl_do_file(script); |
| dowarn = old_warn; |
| return perl_eval_ok(s); |
| } |
| |
| void mp_magic_setenv(char *key, char *val, int is_tainted) |
| { |
| int klen = strlen(key); |
| SV **ptr = hv_fetch(GvHV(envgv), key, klen, TRUE); |
| if (ptr) { |
| SvSetMagicSV(*ptr, newSVpv(val,0)); |
| if (is_tainted) { |
| SvTAINTED_on(*ptr); |
| } |
| } |
| } |
| |
| array_header *perl_cgi_env_init(request_rec *r) |
| { |
| table *envtab = r->subprocess_env; |
| char *tz = NULL; |
| |
| add_common_vars(r); |
| add_cgi_vars(r); |
| /* resetup global request rec, because it may set to an (invalid) subrequest by ap_add_cgi_vars */ |
| perl_request_rec(r); |
| |
| if (!table_get(envtab, "TZ")) { |
| if ((tz = getenv("TZ")) != NULL) { |
| table_set(envtab, "TZ", tz); |
| } |
| } |
| if (!table_get(envtab, "PATH")) { |
| table_set(envtab, "PATH", DEFAULT_PATH); |
| } |
| table_set(envtab, "GATEWAY_INTERFACE", PERL_GATEWAY_INTERFACE); |
| |
| return table_elts(envtab); |
| } |
| |
| #define untie_env sv_unmagic((SV*)GvHV(envgv), 'E') |
| #define tie_env sv_magic((SV*)GvHV(envgv), (SV*)envgv, 'E', Nullch, 0) |
| #define delete_env(ken, klen) \ |
| (void)hv_delete(GvHV(envgv), key, klen, G_DISCARD) |
| |
| void perl_clear_env(void) |
| { |
| char *key; |
| I32 klen; |
| SV *val; |
| HV *hv = (HV*)GvHV(envgv); |
| |
| untie_env; |
| if(!hv_exists(hv, "MOD_PERL", 8)) { |
| hv_store(hv, "MOD_PERL", 8, |
| newSVpv(MOD_PERL_STRING_VERSION,0), FALSE); |
| hv_store(hv, "GATEWAY_INTERFACE", 17, |
| newSVpv("CGI-Perl/1.1",0), FALSE); |
| } |
| (void)hv_iterinit(hv); |
| while ((val = hv_iternextsv(hv, (char **) &key, &klen))) { |
| if((*key == 'G') && strEQ(key, "GATEWAY_INTERFACE")) |
| continue; |
| else if((*key == 'M') && strnEQ(key, "MOD_PERL", 8)) |
| continue; |
| else if((*key == 'T') && strnEQ(key, "TZ", 2)) |
| continue; |
| else if((*key == 'P') && strEQ(key, "PATH")) |
| continue; |
| else if((*key == 'H') && strnEQ(key, "HTTP_", 5)) { |
| tie_env; |
| delete_env(key, klen); |
| untie_env; |
| continue; |
| } |
| delete_env(key, klen); |
| } |
| tie_env; |
| } |
| |
| void mod_perl_init_ids(void) /* $$, $>, $), etc */ |
| { |
| if(set_ids++) return; |
| sv_setiv(GvSV(gv_fetchpv("$", TRUE, SVt_PV)), (I32)getpid()); |
| #ifndef WIN32 |
| uid = (int)getuid(); |
| euid = (int)geteuid(); |
| gid = (int)getgid(); |
| egid = (int)getegid(); |
| MP_TRACE_g(fprintf(stderr, |
| "perl_init_ids: uid=%d, euid=%d, gid=%d, egid=%d\n", |
| uid, euid, gid, egid)); |
| #endif |
| } |
| |
| int perl_eval_ok(server_rec *s) |
| { |
| int status; |
| SV *sv; |
| dTHR; |
| dTHRCTX; |
| |
| sv = ERRSV; |
| if (SvTRUE(sv)) { |
| if (SvMAGICAL(sv) && (SvCUR(sv) > 4) && |
| strnEQ(SvPVX(sv), " at ", 4)) |
| { |
| /* Apache::exit was called */ |
| return DECLINED; |
| } |
| if (perl_sv_is_http_code(ERRSV, &status)) { |
| return status; |
| } |
| MP_TRACE_g(fprintf(stderr, "perl_eval error: %s\n", SvPV(sv,na))); |
| mod_perl_error(s, SvPV(sv, na)); |
| return SERVER_ERROR; |
| } |
| return OK; |
| } |
| |
| int perl_sv_is_http_code(SV *errsv, int *status) |
| { |
| int retval = FALSE; |
| STRLEN i=0, http_code=0; |
| char *errpv; |
| char cpcode[4]; |
| dTHR; |
| |
| if(!SvTRUE(errsv) || !ERRSV_CAN_BE_HTTP) |
| return FALSE; |
| |
| errpv = SvPVX(errsv); |
| |
| for(i=0;i<=2;i++) { |
| if(i >= SvCUR(errsv)) |
| break; |
| if(isDIGIT(SvPVX(errsv)[i])) |
| http_code++; |
| else |
| http_code--; |
| } |
| |
| /* we've looked at the first 3 characters of $@ |
| * if they're not all digits, $@ is not an HTTP code |
| */ |
| if(http_code != 3) { |
| MP_TRACE_g(fprintf(stderr, |
| "mod_perl: $@ doesn't look like an HTTP code `%s'\n", |
| errpv)); |
| return FALSE; |
| } |
| |
| /* nothin but 3 digits */ |
| if(SvCUR(errsv) == http_code) |
| return TRUE; |
| |
| ap_cpystrn((char *)cpcode, errpv, 4); |
| |
| MP_TRACE_g(fprintf(stderr, |
| "mod_perl: possible $@ HTTP code `%s' (cp=`%s')\n", |
| errpv,cpcode)); |
| |
| if((SvCUR(errsv) == 4) && (*(SvEND(errsv) - 1) == '\n')) { |
| /* nothin but 3 digit code and \n */ |
| retval = TRUE; |
| } |
| else { |
| char *tmp = errpv; |
| tmp += 3; |
| #ifndef PERL_MARK_WHERE |
| if(strNE(SvPVX(GvSV(CopFILEGV(curcop))), "-e")) { |
| SV *fake = newSV(0); |
| sv_setpv(fake, ""); /* avoid -w warning */ |
| sv_catpvf(fake, " at %_ line ", GvSV(CopFILEGV(curcop))); |
| |
| if(strnEQ(SvPVX(fake), tmp, SvCUR(fake))) |
| /* $@ is nothing but 3 digit code and the mess die tacks on */ |
| retval = TRUE; |
| |
| SvREFCNT_dec(fake); |
| } |
| #endif |
| if(!retval && strnEQ(tmp, " at ", 4) && instr(errpv, " line ")) |
| /* well, close enough */ |
| retval = TRUE; |
| } |
| |
| if(retval == TRUE) { |
| *status = atoi(cpcode); |
| MP_TRACE_g(fprintf(stderr, |
| "mod_perl: $@ is an HTTP code `%d'\n", *status)); |
| } |
| |
| return retval; |
| } |
| |
| #ifndef PERLLIB_SEP |
| #define PERLLIB_SEP ':' |
| #endif |
| |
| void perl_inc_unshift(char *p) |
| { |
| if(!p) return; |
| |
| while(p && *p) { |
| SV *libdir = newSV(0); |
| char *s; |
| |
| while(*p == PERLLIB_SEP) p++; |
| |
| if((s = strchr(p, PERLLIB_SEP)) != Nullch) { |
| sv_setpvn(libdir, p, (STRLEN)(s - p)); |
| p = s + 1; |
| } |
| else { |
| sv_setpv(libdir, p); |
| p = Nullch; |
| } |
| av_unshift(GvAV(incgv), 1); |
| av_store(GvAV(incgv), 0, libdir); |
| } |
| } |
| |
| #ifdef PERL_MARK_WHERE |
| /* XXX find the right place for this! */ |
| static SV *perl_sv_name(SV *svp) |
| { |
| SV *sv = Nullsv; |
| SV *RETVAL = Nullsv; |
| |
| if(svp && SvROK(svp) && (sv = SvRV(svp))) { |
| switch(SvTYPE(sv)) { |
| case SVt_PVCV: |
| RETVAL = newSV(0); |
| gv_fullname(RETVAL, CvGV(sv)); |
| break; |
| |
| default: |
| break; |
| } |
| } |
| else if(svp && SvPOK(svp)) { |
| RETVAL = newSVsv(svp); |
| } |
| |
| return RETVAL; |
| } |
| |
| void mod_perl_mark_where(char *where, SV *sub) |
| { |
| dTHR; |
| SV *name = Nullsv; |
| if(CopLINE(curcop)) { |
| #if 0 |
| fprintf(stderr, "already know where: %s line %d\n", |
| SvPV(GvSV(CopFILEGV(curcop)),na), CopFILEGV(curcop)); |
| #endif |
| return; |
| } |
| |
| SAVECOPFILE(curcop); |
| SAVECOPLINE(curcop); |
| |
| if(sub) |
| name = perl_sv_name(sub); |
| |
| sv_setpv(GvSV(CopFILEGV(curcop)), ""); |
| if (name) { |
| sv_catpvf(GvSV(CopFILEGV(curcop)), "%s subroutine `%_'", where, name); |
| SvREFCNT_dec(name); |
| } |
| else { |
| sv_catpvf(GvSV(CopFILEGV(curcop)), "%s subroutine <unknown>", where); |
| } |
| |
| CopLINE_set(curcop, 1); |
| |
| } |
| #endif |
| |
| #if MODULE_MAGIC_NUMBER < 19971226 |
| char *ap_cpystrn(char *dst, const char *src, size_t dst_size) |
| { |
| |
| char *d, *end; |
| |
| if (!dst_size) |
| return (dst); |
| |
| d = dst; |
| end = dst + dst_size - 1; |
| |
| for (; d < end; ++d, ++src) { |
| if (!(*d = *src)) { |
| return (d); |
| } |
| } |
| |
| *d = '\0'; /* always null terminate */ |
| |
| return (d); |
| } |
| |
| #endif |
| |
| #if defined(WIN32) && defined(PERL_IS_5_6) |
| void |
| Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp) |
| { |
| SV **oldmark = mark; |
| register I32 items = sp - mark; |
| register STRLEN len; |
| STRLEN delimlen; |
| register char *delim = SvPV(del, delimlen); |
| STRLEN tmplen; |
| |
| mark++; |
| len = (items > 0 ? (delimlen * (items - 1) ) : 0); |
| (void)SvUPGRADE(sv, SVt_PV); |
| if (SvLEN(sv) < len + items) { /* current length is way too short */ |
| while (items-- > 0) { |
| if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) { |
| SvPV(*mark, tmplen); |
| len += tmplen; |
| } |
| mark++; |
| } |
| SvGROW(sv, len + 1); /* so try to pre-extend */ |
| |
| mark = oldmark; |
| items = sp - mark; |
| ++mark; |
| } |
| |
| if (items-- > 0) { |
| char *s; |
| |
| if (*mark) { |
| s = SvPV(*mark, tmplen); |
| sv_setpvn(sv, s, tmplen); |
| } |
| else |
| sv_setpv(sv, ""); |
| mark++; |
| } |
| else |
| sv_setpv(sv,""); |
| len = delimlen; |
| if (len) { |
| for (; items > 0; items--,mark++) { |
| sv_catpvn(sv,delim,len); |
| sv_catsv(sv,*mark); |
| } |
| } |
| else { |
| for (; items > 0; items--,mark++) |
| sv_catsv(sv,*mark); |
| } |
| SvSETMAGIC(sv); |
| } |
| #endif |