src/modules/perl/PerlRunXS.xs

/* ====================================================================
 * Copyright (c) 1995-1998 The Apache Group.  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. All advertising materials mentioning features or use of this
 *    software must display the following acknowledgment:
 *    "This product includes software developed by the Apache Group
 *    for use in the Apache HTTP server project (http://www.apache.org/)."
 *
 * 4. The names "Apache Server" and "Apache Group" 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 names without prior written
 *    permission of the Apache Group.
 *
 * 6. Redistributions of any form whatsoever must retain the following
 *    acknowledgment:
 *    "This product includes software developed by the Apache Group
 *    for use in the Apache HTTP server project (http://www.apache.org/)."
 *
 * THIS SOFTWARE IS PROVIDED BY THE APACHE GROUP ``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 GROUP 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.
 * ====================================================================
 *
 * This software consists of voluntary contributions made by many
 * individuals on behalf of the Apache Group and was originally based
 * on public domain software written at the National Center for
 * Supercomputing Applications, University of Illinois, Urbana-Champaign.
 * For more information on the Apache Group and the Apache HTTP server
 * project, please see <http://www.apache.org/>.
 *
 */

#include "mod_perl.h"

static const char c2x_table[] = "0123456789abcdef";

static unsigned char *c2x(unsigned what, unsigned char *where)
{
    *where++ = '_';
    *where++ = c2x_table[what >> 4];
    *where++ = c2x_table[what & 0xf];
    return where;
}

/*
 * s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
 */
static char *uri2perlish(char *segment, int slen) {
    register int x,y;
    char *copy = (char *)safemalloc(3 * slen + 1);

    for(x=0,y=0; segment[x]; x++,y++) {
	char c = segment[x];
	if((c < 'A' || c > 'Z') && (c < 'a' || c > 'z') && (c < '0' || c >'9')
	   && c != '/')
        {
	    c2x(c, &copy[y]);
	    y += 2;
        }
	else
	    copy[y] = c;
    }
    copy[y] = '\0';
    return copy;
}

/*
 * s{
 *   (/+)       # directory
 *   (\d?)      # package's first character
 *  }[
 *   "::" . ($2 ? sprintf("_%2x",unpack("C",$2)) : "")
 *   ]egx;
 */
static SV *slash2stash(const char *segment) {
    register int x,y;
    SV *sv = newSV(3 * strlen(segment));

    for(x=0,y=0; segment[x]; x++,y++) {
	char c=segment[x];
	if(c == '/') {
	    SvPVX(sv)[y] = ':';
	    SvPVX(sv)[++y] = ':';
	    if(isDIGIT(segment[x+1])) {
		char d = segment[++x];
		c2x(d, &SvPVX(sv)[++y]);
		y += 2;
	    }
        }
	else
	    SvPVX(sv)[y] = c;
    }
    SvPVX(sv)[y] = '\0';
    SvCUR_set(sv, y);
    SvPOK_on(sv);
    return sv;
}

#define ApachePerlRun_import_exit() \
    "use Apache 'exit';\n"

#define ApachePerlRun_chdir_scwd() \
    chdir(SvPV(perl_get_sv("Apache::Server::CWD", TRUE),na))

#ifndef ApachePerlRun_name_with_virtualhost
#define ApachePerlRun_name_with_virtualhost() \
    perl_get_sv("Apache::Registry::NameWithVirtualHost", FALSE)
#endif

SV *ApachePerlRun_namespace(request_rec *r, char *root)
{
    char *copy, *uri;
    int uri_len;
    SV *esc, *RETVAL;

    uri = (char *)pstrdup(r->pool, r->uri);
    uri_len = strlen(uri);  
    if(r->path_info) {
	int n = strlen(r->path_info);
	int chop = (uri_len - n);
	uri[chop] = '\0';
    }
    if(r->server->is_virtual && ApachePerlRun_name_with_virtualhost()) {
	uri = pstrcat(r->pool, r->server->server_hostname, uri, NULL);
	uri_len += strlen(r->server->server_hostname);
    }
    copy = uri2perlish(uri, uri_len);
    RETVAL = newSVpv(root ? root : "Apache::ROOT",0);
    esc = slash2stash(copy);	
    sv_setsv(perl_get_sv("Apache::Registry::curstash", TRUE), esc);
    sv_catsv(RETVAL, esc);
    safefree(copy);
    SvREFCNT_dec(esc);
    return RETVAL;
}

#define log_scripterror(r, rc, msg) \
    aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, r->server, \
		"%s: %s", msg, r->filename); \
    return rc

int ApachePerlRun_can_compile(request_rec *r)
{
    if (!(allow_options(r) & OPT_EXECCGI)) {
	log_scripterror(r, FORBIDDEN, 
			"Options ExecCGI is off in this directory");
    }
    if (r->finfo.st_mode == 0) {
	log_scripterror(r, NOT_FOUND,
			"script not found or unable to stat");
    }
    if (S_ISDIR(r->finfo.st_mode)) {
	return DECLINED;
    }
    if (!can_exec(&r->finfo)) {
	log_scripterror(r, FORBIDDEN,
			"file permissions deny server execution");
    }
    return OK;
}

void ApachePerlRun_compile(request_rec *r, SV *code_ref)
{
     SV *code;

     if(SvROK(code_ref))
	code = (SV*)SvRV(code_ref);
     else
        code = code_ref;

     perl_eval_sv(code, G_DISCARD|G_KEEPERR);
}

/*
 * {
 *   local $/ = undef;
 *   my $fh = gensym;
 *   open $fh, $r->filename;
 *   my $code = <$fh>;
 *   close $fh;
 *   return \$code;
 * }
 */

#define ApachePerlRun_readscript mod_perl_slurp_filename

SV *ApachePerlRun_parse_cmdline(request_rec *r, SV *code)
{
    char *pos = (char *)strstr(SvPVX(code), "\n"), *shebang;
    int plen = pos - SvPVX(code);
    SV *sv;

    if(!pos) return Nullsv;
    sv = newSVpv("",0);
    shebang = (char*)safemalloc(sizeof(char)+plen);
    strncpy(shebang, SvPVX(code), plen);  
    
    if(*shebang == '#') {
	if(strstr(shebang, "-w")) {
	    sv_catpv(sv, "BEGIN {$^W = 1;}; $^W = 1;\n");
	}
    }

    safefree(shebang);
    return sv;
}

int ApachePerlRun_error_check(request_rec *r)
{
    dTHR;
    if((perl_eval_ok(r->server) != 0) && !strnEQ(SvPVX(ERRSV), " at ", 4)) {
	hv_store(ERRHV, r->uri, strlen(r->uri), ERRSV, FALSE);
	sv_setpv(ERRSV, "");
	return SERVER_ERROR;
    }
    else
	return OK;
}

void ApachePerlRun_set_scriptname(request_rec *r)
{
    SV *script_name = perl_get_sv("0", TRUE);
    /*save_item(script_name);*/
    sv_setpv(script_name, r->filename);
}

int handler(request_rec *r)
{
    dTHR;
    int rc = ApachePerlRun_can_compile(r);
    SV *package, *code, *eval, *cmdline;
    if(rc != OK)
	return rc;

    ENTER;
    package = ApachePerlRun_namespace(r, NULL);
    SAVEFREESV(package);
    code = ApachePerlRun_readscript(r);
    SAVEFREESV(code);
    eval = newSV(0);
    SAVEFREESV(eval);
    if((cmdline = ApachePerlRun_parse_cmdline(r, (SV*)SvRV(code)))) {
	sv_catsv(eval, cmdline);
	SvREFCNT_dec(cmdline);
    }
    ApachePerlRun_set_scriptname(r);
    chdir_file(r->filename);

    SAVEI32(hints);
    hints = 0; 

    sv_setpvf(eval, "package %_;\n", package);
    sv_catpv(eval, ApachePerlRun_import_exit());
    sv_catpvf(eval, "#line 1 %s\n", r->filename);
    sv_catsv(eval, (SV*)SvRV(code));
    sv_catpvn(eval, "\n", 1);
    ApachePerlRun_compile(r, eval);

    /*flush the namespace*/
    hv_clear(gv_stashpv(SvPVX(package), TRUE));

    ApachePerlRun_chdir_scwd();
    LEAVE;
    return ApachePerlRun_error_check(r);
}

static int registry_handler(request_rec *r)
{
    dTHR;
    int rc = ApachePerlRun_can_compile(r);
    SV *code, *package;
    SV *rgy_cache_rv = perl_get_sv("Apache::Registry", TRUE);
    HV *rgy_cache, *pkg_ent = Nullhv;
    bool do_compile = FALSE;
    if(rc != OK)
	return rc;

    if(!SvTRUE(rgy_cache_rv))
	sv_setsv(rgy_cache_rv, newRV((SV*)newHV()));

    rgy_cache = (HV*)SvRV(rgy_cache_rv);

    ENTER;
    package = ApachePerlRun_namespace(r, NULL);
    SAVEFREESV(package);

    ApachePerlRun_set_scriptname(r);
    chdir_file(r->filename);
    
    SAVEI32(hints);
    hints = FALSE;
    SAVEI32(dowarn);
    dowarn = FALSE;

    chdir(SvPV(perl_get_sv("Apache::Server::CWD", TRUE),na));
    if(hv_exists(rgy_cache, SvPVX(package), SvCUR(package))) {
	SV **rv = hv_fetch(rgy_cache, SvPVX(package), SvCUR(package), FALSE);
	SV *mtime;
	pkg_ent = (HV*)SvRV(*rv);
	mtime = *hv_fetch(pkg_ent, "mtime", 5, FALSE);
	if(SvTRUE(mtime) && ((int)SvIV(mtime) <= r->finfo.st_mtime)) {
	    /*we have compiled this subroutine already, nothing left to do*/
	}
	else 
	    do_compile = TRUE;
    }
    else
	do_compile = TRUE;

    if(do_compile) {
	int i = 0;
	SV *eval = newSVpv("",0), *cmdline;
	code = ApachePerlRun_readscript(r);
	SAVEFREESV(code);

	if((cmdline = ApachePerlRun_parse_cmdline(r, (SV*)SvRV(code)))) {
	    sv_catsv(eval, cmdline);
	    SvREFCNT_dec(cmdline);
	}

	sv_catpvf(eval, "package %_;\n", package);
	sv_catpv(eval, ApachePerlRun_import_exit());
	sv_catpv(eval, "sub handler {\n");
	sv_catpvf(eval, "#line 1 %s\n", r->filename);
	sv_catsv(eval, (SV*)SvRV(code));
	sv_catpvn(eval, "\n}", 2);
	ApachePerlRun_compile(r, eval);
	perl_stash_rgy_endav(r->uri, 
			     perl_get_sv("Apache::Registry::curstash", TRUE));
	SvREFCNT_dec(eval);
	rc = ApachePerlRun_error_check(r); 
	if(rc != OK) {
	    LEAVE;
	    return rc;
	}
	mod_perl_clear_rgy_endav(r, package);
	while (!pkg_ent) {
	    SV **svp = hv_fetch(rgy_cache, 
				SvPVX(package), SvCUR(package), FALSE);
	    if(svp) {
		pkg_ent = (HV*)SvRV(*svp);
		break;
	    }
	    hv_store(rgy_cache, SvPVX(package), SvCUR(package), 
		     newRV((SV*)newHV()), FALSE);
	    if(++i > 10) {
		fprintf(stderr, "STUCK\n");
		break;
	    }
	}

	hv_store(pkg_ent, "mtime", 5, newSViv(r->finfo.st_mtime), FALSE);
    }

    {
	dSP;
	int count;
	SV *sub = newSVsv(package);
	sv_catpvn(sub, "::handler", 9);
	ENTER;SAVETMPS;PUSHMARK(sp);
	XPUSHs((SV*)perl_bless_request_rec(r)); 
	PUTBACK;
	count = perl_call_sv(sub, G_EVAL | G_SCALAR);
	SvREFCNT_dec(sub);
	FREETMPS;LEAVE;
    }

    ApachePerlRun_chdir_scwd();
    LEAVE;
    if((rc = ApachePerlRun_error_check(r)) != OK)
	return rc;

    return r->status;
}

MODULE = Apache::PerlRunXS PACKAGE = Apache::RegistryXS PREFIX = registry_

int
registry_handler(r)
    Apache r

MODULE = Apache::PerlRunXS PACKAGE = Apache::PerlRunXS PREFIX = ApachePerlRun_

PROTOTYPES: DISABLE

BOOT:
    items = items; /*avoid warning*/ 

int
handler(r)
    Apache r

SV *
ApachePerlRun_namespace(r, root="Apache::ROOT")
    Apache r
    char *root

void
ApachePerlRun_can_compile(r)
    Apache r

    PREINIT:
    int retval = OK;

    PPCODE:
    retval = ApachePerlRun_can_compile(r);
    XPUSHs(sv_2mortal(newSViv(retval)));
    if(GIMME == G_ARRAY) {
	XPUSHs(sv_2mortal(newSViv(r->finfo.st_mtime)));
    }

void
ApachePerlRun_compile(r, code_ref)
     Apache r
     SV *code_ref

SV *
ApachePerlRun_readscript(r)
    Apache r

int
ApachePerlRun_error_check(r)
    Apache r