SV *p5_call_method(PerlInterpreter *my_perl, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
int i;
SV * retval = NULL;
int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;
ENTER;
SAVETMPS;
HV * const pkg = SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv)) {
PUSHMARK(SP);
if (len > 1) {
XPUSHs(args[0]);
for (i = 1; i < len; i++) {
if (args[i] != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(sv_2mortal(args[i]));
}
}
else if (len > 0)
if (args != NULL) /* skip Nil which gets turned into NULL */
XPUSHs((SV*)args);
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, flags);
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
SPAGAIN;
}
else {
ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
}
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}
AV *p5_call_method(PerlInterpreter *my_perl, char *package, SV *obj, char *name, int len, SV *args[]) {
dSP;
int i;
AV * const retval = newAV();
int flags = G_ARRAY | G_EVAL;
PERL_SET_CONTEXT(my_perl);
ENTER;
SAVETMPS;
HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv)) {
I32 count;
PUSHMARK(SP);
for (i = 0; i < len; i++) {
XPUSHs(sv_2mortal(args[i]));
}
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
count = call_sv(rv, flags);
SPAGAIN;
if (count > 0)
av_extend(retval, count - 1);
for (i = count - 1; i >= 0; i--) {
SV * const next = POPs;
SvREFCNT_inc(next);
if (av_store(retval, i, next) == NULL)
SvREFCNT_dec(next); /* see perlguts Working with AVs */
}
}
else {
ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
}
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
static void
fmm_append_mime(PerlFMM *state, char **buf, union VALUETYPE *p, fmmagic *m)
{
char *pp;
unsigned long v;
char *time_str;
SV *err;
#ifdef FMM_DEBUG
PerlIO_printf(PerlIO_stderr(), "fmm_append_mime: buf = %s\n", buf);
#endif
switch (m->type) {
case BYTE:
v = p->b;
break;
case SHORT:
case BESHORT:
case LESHORT:
v = p->h;
break;
case STRING:
if (m->reln == '=') {
fmm_append_buf(state, buf, m->desc, m->value.s );
} else {
fmm_append_buf(state, buf, m->desc, p->s);
}
return;
case DATE:
case BEDATE:
case LEDATE:
Newz(1234, time_str, CTIME_LEN, char);
strftime(time_str, CTIME_LEN, CTIME_FMT,
localtime((const time_t *) &p->l));
pp = time_str;
fmm_append_buf(state, buf, m->desc, pp);
Safefree(time_str);
return;
default:
err = newSVpvf(
"fmm_append_mime: invalud m->type (%d) in fmm_append_mime().\n", m->type);
FMM_SET_ERROR(state, err);
return;
}
v = fmm_signextend(state, m, v) & m->mask;
fmm_append_buf(state, buf, m->desc, (unsigned long) v);
}
/*
* Convert the byte order of the data we are looking at
*/
static int
fmm_mconvert(PerlFMM *state, union VALUETYPE *p, fmmagic *m)
{
char *rt;
SV *err;
switch (m->type) {
case BYTE:
case SHORT:
case LONG:
case DATE:
return 1;
case STRING:
/* Null terminate and eat the return */
p->s[sizeof(p->s) - 1] = '\0';
if ((rt = strchr(p->s, '\n')) != NULL)
*rt = '\0';
return 1;
case BESHORT:
p->h = (short) ((p->hs[0] << 8) | (p->hs[1]));
return 1;
case BELONG:
case BEDATE:
p->l = (long)
((p->hl[0] << 24) | (p->hl[1] << 16) | (p->hl[2] << 8) | (p->hl[3]));
return 1;
case LESHORT:
p->h = (short) ((p->hs[1] << 8) | (p->hs[0]));
return 1;
case LELONG:
case LEDATE:
p->l = (long)
((p->hl[3] << 24) | (p->hl[2] << 16) | (p->hl[1] << 8) | (p->hl[0]));
return 1;
default:
err = newSVpvf(
"fmm_mconvert : invalid type %d in mconvert().",
m->type
);
FMM_SET_ERROR(state, err);
return 0;
}
}
static int
fmm_fsmagic(PerlFMM *state, char *filename, char **mime_type)
{
struct stat sb;
SV *err;
if (stat(filename, &sb) == -1) {
err = newSVpvf(
"Failed to stat file %s: %s", filename, strerror(errno));
FMM_SET_ERROR(state, err);
return -1;
}
if (fmm_fsmagic_stat(state, &sb, mime_type) == 0) {
return 0;
}
return 1;
}
static int
fmm_fhmagic(PerlFMM *state, PerlIO *fhandle, char **mime_type)
{
SV *err;
unsigned char *data;
int ret = -1;
Newz(1234, data, HOWMANY + 1, unsigned char);
if (! PerlIO_read(fhandle, data, HOWMANY)) {
err = newSVpvf(
"Failed to read from handle: %s",
strerror(errno)
);
FMM_SET_ERROR(state, err);
Safefree(data);
return -1;
}
ret = fmm_bufmagic(state, &data, mime_type);
Safefree(data);
return ret;
}
/*
* extend the sign bit if the comparison is to be signed
*/
static unsigned long
fmm_signextend(PerlFMM *state, fmmagic *m, unsigned long v)
{
SV *err;
if (!(m->flag & UNSIGNED))
switch (m->type) {
/*
* Do not remove the casts below. They are vital. When later
* compared with the data, the sign extension must have happened.
*/
case BYTE:
v = (char) v;
break;
case SHORT:
case BESHORT:
case LESHORT:
v = (short) v;
break;
case DATE:
case BEDATE:
case LEDATE:
case LONG:
case BELONG:
case LELONG:
v = (long) v;
break;
case STRING:
break;
default:
err = newSVpvf(
"fmm_signextend: can't happen: m->type=%d\n", m->type);
FMM_SET_ERROR(state, err);
return -1;
}
return v;
}
static int proxenet_perl_load_file(plugin_t* plugin)
{
char *pathname = NULL;
size_t pathlen = 0;
SV* sv = NULL;
int nb_res = -1;
SV* package_sv = NULL;
char *required = NULL;
char *package_name = NULL;
size_t package_len, len = 0;
int ret = -1;
pathlen = strlen(cfg->plugins_path) + 1 + strlen(plugin->filename) + 1;
pathname = (char*) alloca(pathlen+1);
proxenet_xzero(pathname, pathlen+1);
snprintf(pathname, pathlen, "%s/%s", cfg->plugins_path, plugin->filename);
#ifdef DEBUG
xlog(LOG_DEBUG, "[Perl] Loading '%s'\n", pathname);
#endif
/* Load the file through perl's require mechanism */
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUTBACK;
sv = newSVpvf("$package = require q%c%s%c", 0, pathname, 0);
nb_res = eval_sv(sv_2mortal(sv), G_EVAL);
if (nb_res != 1) {
xlog(LOG_ERROR,
"[Perl] Invalid number of response returned while loading '%s' (got %d, expected 1)\n",
pathname,
nb_res);
} else if (SvTRUE(ERRSV)) {
xlog(LOG_ERROR, "[Perl] Eval error for '%s': %s\n", pathname, SvPV_nolen(ERRSV));
} else {
/* Get the package name from the package (which should follow the convention...) */
package_sv = get_sv("package", 0);
/* Check if the SV* stores a string */
if (!SvPOK(package_sv)) {
xlog(LOG_ERROR, "[Perl] Invalid convention for '%s': the package should return a string\n", pathname);
} else {
required = (char*) SvPV_nolen(package_sv);
package_len = strlen(required);
package_name = (char*) alloca(package_len+1);
proxenet_xzero(package_name, package_len+1);
memcpy(package_name, required, package_len);
#ifdef DEBUG
xlog(LOG_DEBUG, "[Perl] Package of name '%s' loaded\n", package_name);
#endif
/* Save the functions' full name to call them later */
len = package_len + 2 + strlen(CFG_REQUEST_PLUGIN_FUNCTION);
plugin->pre_function = proxenet_xmalloc(len + 1);
snprintf(plugin->pre_function, len+1, "%s::%s", package_name, CFG_REQUEST_PLUGIN_FUNCTION);
len = package_len + 2 + strlen(CFG_RESPONSE_PLUGIN_FUNCTION);
plugin->post_function = proxenet_xmalloc(len + 1);
snprintf(plugin->post_function, len+1, "%s::%s", package_name, CFG_RESPONSE_PLUGIN_FUNCTION);
ret = 0;
}
}
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
static AV*
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* isa;
const HEK* stashhek;
struct mro_meta* meta;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = meta->mro_linear_c3)) {
return retval;
}
/* not in cache, make a new one */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
if ( isa && ! SvAVOK(isa) ) {
Perl_croak(aTHX_ "@ISA is not an array but %s", Ddesc((SV*)isa));
}
/* For a better idea how the rest of this works, see the much clearer
pure perl version in Algorithm::C3 0.01:
http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
(later versions go about it differently than this code for speed reasons)
*/
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
I32* heads;
/* This builds @seqs, which is an array of arrays.
The members of @seqs are the MROs of
the members of @ISA, followed by @ISA itself.
*/
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
SV* const isa_item = *isa_ptr++;
if ( ! SvPVOK(isa_item) ) {
Perl_croak(aTHX_ "@ISA element which is not an plain value");
}
{
HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
/* if no stash, make a temporary fake MRO
containing just itself */
AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
av_push(seqs, (SV*)isa_lin);
}
else {
/* recursion */
AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
av_push(seqs, SvREFCNT_inc_NN((SV*)isa_lin));
}
}
}
av_push(seqs, SvREFCNT_inc_NN((SV*)isa));
/* This builds "heads", which as an array of integer array
indices, one per seq, which point at the virtual "head"
of the seq (initially zero) */
Newxz(heads, AvFILLp(seqs)+1, I32);
/* This builds %tails, which has one key for every class
mentioned in the tail of any sequence in @seqs (tail meaning
everything after the first class, the "head"). The value
is how many times this key appears in the tails of @seqs.
*/
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
AV *const seq = MUTABLE_AV(*seqs_ptr++);
I32 seq_items = AvFILLp(seq);
if(seq_items > 0) {
SV** seq_ptr = AvARRAY(seq) + 1;
while(seq_items--) {
SV* const seqitem = *seq_ptr++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
if(he) {
SV* const val = HeVAL(he);
/* This will increment undef to 1, which is what we
want for a newly created entry. */
sv_inc(val);
}
}
}
}
/* Initialize retval to build the return value in */
retval = newAV();
av_push(retval, newSVhek(stashhek)); /* us first */
/* This loop won't terminate until we either finish building
the MRO, or get an exception. */
while(1) {
SV* cand = NULL;
SV* winner = NULL;
int s;
/* "foreach $seq (@seqs)" */
SV** const avptr = AvARRAY(seqs);
for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
AV * const seq = MUTABLE_AV(avptr[s]);
SV* seqhead;
if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
seqhead = *svp; /* seqhead = head of this seq */
if(!winner) {
HE* tail_entry;
SV* val;
/* if we haven't found a winner for this round yet,
and this seqhead is not in tails (or the count
for it in tails has dropped to zero), then this
seqhead is our new winner, and is added to the
final MRO immediately */
cand = seqhead;
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
&& (val = HeVAL(tail_entry))
&& (SvIV(val) > 0))
continue;
winner = newSVsv(cand);
av_push(retval, winner);
/* note however that even when we find a winner,
we continue looping over @seqs to do housekeeping */
}
if(!sv_cmp(seqhead, winner)) {
/* Once we have a winner (including the iteration
where we first found him), inc the head ptr
for any seq which had the winner as a head,
NULL out any seq which is now empty,
and adjust tails for consistency */
const int new_head = ++heads[s];
if(new_head > AvFILLp(seq)) {
SvREFCNT_dec(avptr[s]);
avptr[s] = NULL;
}
else {
HE* tail_entry;
SV* val;
/* Because we know this new seqhead used to be
a tail, we can assume it is in tails and has
a positive value, which we need to dec */
svp = av_fetch(seq, new_head, 0);
seqhead = *svp;
tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
val = HeVAL(tail_entry);
sv_dec(val);
}
}
}
/* if we found no candidates, we are done building the MRO.
!cand means no seqs have any entries left to check */
if(!cand) {
Safefree(heads);
break;
}
/* If we had candidates, but nobody won, then the @ISA
hierarchy is not C3-incompatible */
if(!winner) {
SV *errmsg;
I32 i;
errmsg = newSVpvf(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s':\n\t"
"current merge results [\n", HEK_KEY(stashhek));
for (i = 0; i <= av_len(retval); i++) {
SV **elem = av_fetch(retval, i, 0);
sv_catpvf(aTHX_ errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
}
sv_catpvf(aTHX_ errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
/* we have to do some cleanup before we croak */
AvREFCNT_dec(retval);
Safefree(heads);
croak(aTHX_ "%"SVf, SVfARG(errmsg));
}
}
}
else { /* @ISA was undefined or empty */
/* build a retval containing only ourselves */
retval = newAV();
av_push(retval, newSVhek(stashhek));
}
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
meta->mro_linear_c3 = retval;
return retval;
}
static void
report_event(PSTATE* p_state,
event_id_t event,
char *beg, char *end, U32 utf8,
token_pos_t *tokens, int num_tokens,
SV* self
)
{
struct p_handler *h;
dTHX;
dSP;
AV *array;
STRLEN my_na;
char *argspec;
char *s;
#ifdef UNICODE_HTML_PARSER
#define CHR_DIST(a,b) (utf8 ? utf8_distance((U8*)(a),(U8*)(b)) : (a) - (b))
#else
#define CHR_DIST(a,b) ((a) - (b))
#endif
/* capture offsets */
STRLEN offset = p_state->offset;
STRLEN line = p_state->line;
STRLEN column = p_state->column;
#if 0
{ /* used for debugging at some point */
char *s = beg;
int i;
/* print debug output */
switch(event) {
case E_DECLARATION: printf("DECLARATION"); break;
case E_COMMENT: printf("COMMENT"); break;
case E_START: printf("START"); break;
case E_END: printf("END"); break;
case E_TEXT: printf("TEXT"); break;
case E_PROCESS: printf("PROCESS"); break;
case E_NONE: printf("NONE"); break;
default: printf("EVENT #%d", event); break;
}
printf(" [");
while (s < end) {
if (*s == '\n') {
putchar('\\'); putchar('n');
}
else
putchar(*s);
s++;
}
printf("] %d\n", end - beg);
for (i = 0; i < num_tokens; i++) {
printf(" token %d: %d %d\n",
i,
tokens[i].beg - beg,
tokens[i].end - tokens[i].beg);
}
}
#endif
if (p_state->pending_end_tag && event != E_TEXT && event != E_COMMENT) {
token_pos_t t;
char dummy;
t.beg = p_state->pending_end_tag;
t.end = p_state->pending_end_tag + strlen(p_state->pending_end_tag);
p_state->pending_end_tag = 0;
report_event(p_state, E_END, &dummy, &dummy, 0, &t, 1, self);
SPAGAIN;
}
/* update offsets */
p_state->offset += CHR_DIST(end, beg);
if (line) {
char *s = beg;
char *nl = NULL;
while (s < end) {
if (*s == '\n') {
p_state->line++;
nl = s;
}
s++;
}
if (nl)
p_state->column = CHR_DIST(end, nl) - 1;
else
p_state->column += CHR_DIST(end, beg);
}
if (event == E_NONE)
goto IGNORE_EVENT;
#ifdef MARKED_SECTION
if (p_state->ms == MS_IGNORE)
goto IGNORE_EVENT;
#endif
/* tag filters */
if (p_state->ignore_tags || p_state->report_tags || p_state->ignore_elements) {
if (event == E_START || event == E_END) {
SV* tagname = p_state->tmp;
assert(num_tokens >= 1);
sv_setpvn(tagname, tokens[0].beg, tokens[0].end - tokens[0].beg);
if (utf8)
SvUTF8_on(tagname);
else
SvUTF8_off(tagname);
if (!CASE_SENSITIVE(p_state))
sv_lower(aTHX_ tagname);
if (p_state->ignoring_element) {
if (sv_eq(p_state->ignoring_element, tagname)) {
if (event == E_START)
p_state->ignore_depth++;
else if (--p_state->ignore_depth == 0) {
SvREFCNT_dec(p_state->ignoring_element);
p_state->ignoring_element = 0;
}
}
goto IGNORE_EVENT;
}
if (p_state->ignore_elements &&
hv_fetch_ent(p_state->ignore_elements, tagname, 0, 0))
{
p_state->ignoring_element = newSVsv(tagname);
p_state->ignore_depth = 1;
goto IGNORE_EVENT;
}
if (p_state->ignore_tags &&
hv_fetch_ent(p_state->ignore_tags, tagname, 0, 0))
{
goto IGNORE_EVENT;
}
if (p_state->report_tags &&
!hv_fetch_ent(p_state->report_tags, tagname, 0, 0))
{
goto IGNORE_EVENT;
}
}
else if (p_state->ignoring_element) {
goto IGNORE_EVENT;
}
}
h = &p_state->handlers[event];
if (!h->cb) {
/* event = E_DEFAULT; */
h = &p_state->handlers[E_DEFAULT];
if (!h->cb)
goto IGNORE_EVENT;
}
if (SvTYPE(h->cb) != SVt_PVAV && !SvTRUE(h->cb)) {
/* FALSE scalar ('' or 0) means IGNORE this event */
return;
}
if (p_state->unbroken_text && event == E_TEXT) {
/* should buffer text */
if (!p_state->pend_text)
p_state->pend_text = newSV(256);
if (SvOK(p_state->pend_text)) {
if (p_state->is_cdata != p_state->pend_text_is_cdata) {
flush_pending_text(p_state, self);
SPAGAIN;
goto INIT_PEND_TEXT;
}
}
else {
INIT_PEND_TEXT:
p_state->pend_text_offset = offset;
p_state->pend_text_line = line;
p_state->pend_text_column = column;
p_state->pend_text_is_cdata = p_state->is_cdata;
sv_setpvn(p_state->pend_text, "", 0);
if (!utf8)
SvUTF8_off(p_state->pend_text);
}
#ifdef UNICODE_HTML_PARSER
if (utf8 && !SvUTF8(p_state->pend_text))
sv_utf8_upgrade(p_state->pend_text);
if (utf8 || !SvUTF8(p_state->pend_text)) {
sv_catpvn(p_state->pend_text, beg, end - beg);
}
else {
SV *tmp = newSVpvn(beg, end - beg);
sv_utf8_upgrade(tmp);
sv_catsv(p_state->pend_text, tmp);
SvREFCNT_dec(tmp);
}
#else
sv_catpvn(p_state->pend_text, beg, end - beg);
#endif
return;
}
else if (p_state->pend_text && SvOK(p_state->pend_text)) {
flush_pending_text(p_state, self);
SPAGAIN;
}
/* At this point we have decided to generate an event callback */
argspec = h->argspec ? SvPV(h->argspec, my_na) : "";
if (SvTYPE(h->cb) == SVt_PVAV) {
if (*argspec == ARG_FLAG_FLAT_ARRAY) {
argspec++;
array = (AV*)h->cb;
}
else {
/* start sub-array for accumulator array */
array = newAV();
}
}
else {
array = 0;
if (*argspec == ARG_FLAG_FLAT_ARRAY)
argspec++;
/* start argument stack for callback */
ENTER;
SAVETMPS;
PUSHMARK(SP);
}
for (s = argspec; *s; s++) {
SV* arg = 0;
int push_arg = 1;
enum argcode argcode = (enum argcode)*s;
switch( argcode ) {
case ARG_SELF:
arg = sv_mortalcopy(self);
break;
case ARG_TOKENS:
if (num_tokens >= 1) {
AV* av = newAV();
SV* prev_token = &PL_sv_undef;
int i;
av_extend(av, num_tokens);
for (i = 0; i < num_tokens; i++) {
if (tokens[i].beg) {
prev_token = newSVpvn(tokens[i].beg, tokens[i].end-tokens[i].beg);
if (utf8)
SvUTF8_on(prev_token);
av_push(av, prev_token);
}
else { /* boolean */
av_push(av, p_state->bool_attr_val
? newSVsv(p_state->bool_attr_val)
: newSVsv(prev_token));
}
}
arg = sv_2mortal(newRV_noinc((SV*)av));
}
break;
case ARG_TOKENPOS:
if (num_tokens >= 1 && tokens[0].beg >= beg) {
AV* av = newAV();
int i;
av_extend(av, num_tokens*2);
for (i = 0; i < num_tokens; i++) {
if (tokens[i].beg) {
av_push(av, newSViv(CHR_DIST(tokens[i].beg, beg)));
av_push(av, newSViv(CHR_DIST(tokens[i].end, tokens[i].beg)));
}
else { /* boolean tag value */
av_push(av, newSViv(0));
av_push(av, newSViv(0));
}
}
arg = sv_2mortal(newRV_noinc((SV*)av));
}
break;
case ARG_TOKEN0:
case ARG_TAGNAME:
/* fall through */
case ARG_TAG:
if (num_tokens >= 1) {
arg = sv_2mortal(newSVpvn(tokens[0].beg,
tokens[0].end - tokens[0].beg));
if (utf8)
SvUTF8_on(arg);
if (!CASE_SENSITIVE(p_state) && argcode != ARG_TOKEN0)
sv_lower(aTHX_ arg);
if (argcode == ARG_TAG && event != E_START) {
char *e_type = "!##/#?#";
sv_insert(arg, 0, 0, &e_type[event], 1);
}
}
break;
case ARG_ATTR:
case ARG_ATTRARR:
if (event == E_START) {
HV* hv;
int i;
if (argcode == ARG_ATTR) {
hv = newHV();
arg = sv_2mortal(newRV_noinc((SV*)hv));
}
else {
#ifdef __GNUC__
/* gcc -Wall reports this variable as possibly used uninitialized */
hv = 0;
#endif
push_arg = 0; /* deal with argument pushing here */
}
for (i = 1; i < num_tokens; i += 2) {
SV* attrname = newSVpvn(tokens[i].beg,
tokens[i].end-tokens[i].beg);
SV* attrval;
if (utf8)
SvUTF8_on(attrname);
if (tokens[i+1].beg) {
char *beg = tokens[i+1].beg;
STRLEN len = tokens[i+1].end - beg;
if (*beg == '"' || *beg == '\'') {
assert(len >= 2 && *beg == beg[len-1]);
beg++; len -= 2;
}
attrval = newSVpvn(beg, len);
if (utf8)
SvUTF8_on(attrval);
if (!p_state->attr_encoded) {
#ifdef UNICODE_HTML_PARSER
if (p_state->utf8_mode)
sv_utf8_decode(attrval);
#endif
decode_entities(aTHX_ attrval, p_state->entity2char, 0);
if (p_state->utf8_mode)
SvUTF8_off(attrval);
}
}
else { /* boolean */
if (p_state->bool_attr_val)
attrval = newSVsv(p_state->bool_attr_val);
else
attrval = newSVsv(attrname);
}
if (!CASE_SENSITIVE(p_state))
sv_lower(aTHX_ attrname);
if (argcode == ARG_ATTR) {
if (hv_exists_ent(hv, attrname, 0) ||
!hv_store_ent(hv, attrname, attrval, 0)) {
SvREFCNT_dec(attrval);
}
SvREFCNT_dec(attrname);
}
else { /* ARG_ATTRARR */
if (array) {
av_push(array, attrname);
av_push(array, attrval);
}
else {
XPUSHs(sv_2mortal(attrname));
XPUSHs(sv_2mortal(attrval));
}
}
}
}
else if (argcode == ARG_ATTRARR) {
push_arg = 0;
}
break;
case ARG_ATTRSEQ: /* (v2 compatibility stuff) */
if (event == E_START) {
AV* av = newAV();
int i;
for (i = 1; i < num_tokens; i += 2) {
SV* attrname = newSVpvn(tokens[i].beg,
tokens[i].end-tokens[i].beg);
if (utf8)
SvUTF8_on(attrname);
if (!CASE_SENSITIVE(p_state))
sv_lower(aTHX_ attrname);
av_push(av, attrname);
}
arg = sv_2mortal(newRV_noinc((SV*)av));
}
break;
case ARG_TEXT:
arg = sv_2mortal(newSVpvn(beg, end - beg));
if (utf8)
SvUTF8_on(arg);
break;
case ARG_DTEXT:
if (event == E_TEXT) {
arg = sv_2mortal(newSVpvn(beg, end - beg));
if (utf8)
SvUTF8_on(arg);
if (!p_state->is_cdata) {
#ifdef UNICODE_HTML_PARSER
if (p_state->utf8_mode)
sv_utf8_decode(arg);
#endif
decode_entities(aTHX_ arg, p_state->entity2char, 1);
if (p_state->utf8_mode)
SvUTF8_off(arg);
}
}
break;
case ARG_IS_CDATA:
if (event == E_TEXT) {
arg = boolSV(p_state->is_cdata);
}
break;
case ARG_SKIPPED_TEXT:
arg = sv_2mortal(p_state->skipped_text);
p_state->skipped_text = newSVpvn("", 0);
break;
case ARG_OFFSET:
arg = sv_2mortal(newSViv(offset));
break;
case ARG_OFFSET_END:
arg = sv_2mortal(newSViv(offset + CHR_DIST(end, beg)));
break;
case ARG_LENGTH:
arg = sv_2mortal(newSViv(CHR_DIST(end, beg)));
break;
case ARG_LINE:
arg = sv_2mortal(newSViv(line));
break;
case ARG_COLUMN:
arg = sv_2mortal(newSViv(column));
break;
case ARG_EVENT:
assert(event >= 0 && event < EVENT_COUNT);
arg = sv_2mortal(newSVpv(event_id_str[event], 0));
break;
case ARG_LITERAL:
{
int len = (unsigned char)s[1];
arg = sv_2mortal(newSVpvn(s+2, len));
if (SvUTF8(h->argspec))
SvUTF8_on(arg);
s += len + 1;
}
break;
case ARG_UNDEF:
arg = sv_mortalcopy(&PL_sv_undef);
break;
default:
arg = sv_2mortal(newSVpvf("Bad argspec %d", *s));
break;
}
if (push_arg) {
if (!arg)
arg = sv_mortalcopy(&PL_sv_undef);
if (array) {
/* have to fix mortality here or add mortality to
* XPUSHs after removing it from the switch cases.
*/
av_push(array, SvREFCNT_inc(arg));
}
else {
XPUSHs(arg);
}
}
}
if (array) {
if (array != (AV*)h->cb)
av_push((AV*)h->cb, newRV_noinc((SV*)array));
}
else {
PUTBACK;
if ((enum argcode)*argspec == ARG_SELF && !SvROK(h->cb)) {
char *method = SvPV(h->cb, my_na);
perl_call_method(method, G_DISCARD | G_EVAL | G_VOID);
}
else {
perl_call_sv(h->cb, G_DISCARD | G_EVAL | G_VOID);
}
if (SvTRUE(ERRSV)) {
RETHROW;
}
FREETMPS;
LEAVE;
}
if (p_state->skipped_text)
SvCUR_set(p_state->skipped_text, 0);
return;
IGNORE_EVENT:
if (p_state->skipped_text) {
if (event != E_TEXT && p_state->pend_text && SvOK(p_state->pend_text))
flush_pending_text(p_state, self);
#ifdef UNICODE_HTML_PARSER
if (utf8 && !SvUTF8(p_state->skipped_text))
sv_utf8_upgrade(p_state->skipped_text);
if (utf8 || !SvUTF8(p_state->skipped_text)) {
#endif
sv_catpvn(p_state->skipped_text, beg, end - beg);
#ifdef UNICODE_HTML_PARSER
}
else {
SV *tmp = newSVpvn(beg, end - beg);
sv_utf8_upgrade(tmp);
sv_catsv(p_state->pend_text, tmp);
SvREFCNT_dec(tmp);
}
#endif
}
#undef CHR_DIST
return;
}
SV *ngx_http_psgi_create_env(pTHX_ ngx_http_request_t *r, char *app)
{
ngx_list_part_t *part;
ngx_table_elt_t *h;
ngx_uint_t i, c, x;
SV *_version[2];
AV *version;
HV* env = newHV();
/* PSGI version 1.0, arrayref [1,0] */
_version[0] = newSViv(1);
_version[1] = newSViv(0);
version = av_make(2, _version);
SvREFCNT_dec(_version[0]);
SvREFCNT_dec(_version[1]);
hv_store(env, "psgi.version", sizeof("psgi.version")-1, newRV_noinc((SV*)version), 0);
/* FIXME: after any of this two operations $! is set to 'Inappropriate ioctl for device' */
SV *errors_h = PerlIONginxError_newhandle(aTHX_ r);
if (errors_h == NULL)
return NULL;
hv_store(env, "psgi.errors", sizeof("psgi.errors")-1, errors_h, 0);
SV *input_h = PerlIONginxInput_newhandle(aTHX_ r);
if (input_h == NULL)
return NULL;
hv_store(env, "psgi.input", sizeof("psgi.input")-1, input_h, 0);
/* Detect scheme.
* TODO: Check if only http and https schemes allowed here. What about ws and others?
* FIXME: mb nginx should parse scheme in safe way: [a-z][a-z0-9\=\0\.]* allowed to be valid scheme (rfc3986)
* but nginx allows only [a-z]+
*/
#if (NGX_HTTP_SSL)
char *scheme;
if (r->connection->ssl) {
scheme = "https";
} else {
scheme = "http";
}
hv_store(env, "psgi.url_scheme", sizeof("psgi.url_scheme")-1, newSVpv(scheme, 0), 0);
#else
hv_store(env, "psgi.url_scheme", sizeof("psgi.url_scheme")-1, newSVpv("http", 0), 0);
#endif
// Buffered body in file
if (r->request_body != NULL && r->request_body->temp_file != NULL) {
hv_store(env, "psgix.input.buffered", sizeof("psgix.input.buffered")-1, newSViv(1), 0);
}
/* port defined in first line of HTTP request and parsed by nginx */
if (r->port_start) {
STRLEN port_len = r->port_end - r->port_start;
hv_store(env, "SERVER_PORT", sizeof("SERVER_PORT")-1, newSVpv((char *)r->port_start, port_len), 0);
} else {
/* copypasted from ngx_http_variables.c: get port from nginx conf */
/* TODO: Maybe reuse code from ngx_http_variables.c is a good idea? */
ngx_uint_t port;
struct sockaddr_in *sin;
#if (NGX_HAVE_INET6)
struct sockaddr_in6 *sin6;
#endif
u_char *strport;
if (ngx_connection_local_sockaddr(r->connection, NULL, 0) != NGX_OK) {
// TODO: Throw error
return NULL;
}
strport = ngx_pnalloc(r->pool, sizeof("65535") - 1);
if (strport == NULL) {
return NULL;
}
switch (r->connection->local_sockaddr->sa_family) {
#if (NGX_HAVE_INET6)
case AF_INET6:
sin6 = (struct sockaddr_in6 *) r->connection->local_sockaddr;
port = ntohs(sin6->sin6_port);
break;
#endif
default: /* AF_INET */
sin = (struct sockaddr_in *) r->connection->local_sockaddr;
port = ntohs(sin->sin_port);
break;
}
if (port > 0 && port < 65536) {
hv_store(env, "SERVER_PORT", sizeof("SERVER_PORT")-1, newSVuv(port), 0);
} else {
hv_store(env, "SERVER_PORT", sizeof("SERVER_PORT")-1, newSVpv("", 0), 0);
}
}
hv_store(env, "SERVER_PROTOCOL", sizeof("SERVER_PROTOCOL")-1, newSVpv((char *)r->http_protocol.data, r->http_protocol.len), 0);
if (r->headers_in.content_length_n != -1) {
hv_store(env, "CONTENT_LENGTH", sizeof("CONTENT_LENGTH")-1, newSViv(r->headers_in.content_length_n), 0);
}
if (r->headers_in.content_type != NULL) {
hv_store(env, "CONTENT_TYPE", sizeof("CONTENT_TYPE")-1,
newSVpv((char*)r->headers_in.content_type->value.data, r->headers_in.content_type->value.len), 0);
}
hv_store(env, "REQUEST_URI", sizeof("REQUEST_URI")-1, newSVpv((char *)r->unparsed_uri.data, r->unparsed_uri.len), 0);
/* TODO: SCRIPT_NAME should be string matched by 'location' value in nginx.conf */
hv_store(env, "SCRIPT_NAME", sizeof("SCRIPT_NAME")-1, newSVpv("", 0), 0);
/* FIXME:
* PATH_INFO should be relative to SCRIPT_NAME (current 'location') path in nginx.conf
* How to achieve this? Should I allow psgi only in 'exact match' locations?
* It would be hard to find PATH_INFO for locations like "location ~ /(foo|bar)/.* { }". Or it wouldn't?
*/
hv_store(env, "PATH_INFO", sizeof("PATH_INFO")-1, newSVpv((char *)r->uri.data, r->uri.len), 0);
hv_store(env, "REQUEST_METHOD", sizeof("REQUEST_METHOD")-1, newSVpv((char *)r->method_name.data, r->method_name.len), 0);
if (r->args.len > 0) {
hv_store(env, "QUERY_STRING", sizeof("QUERY_STRING")-1, newSVpv((char *)r->args.data, r->args.len), 0);
} else {
hv_store(env, "QUERY_STRING", sizeof("QUERY_STRING")-1, newSVpv("", 0), 0);
}
if (r->host_start && r->host_end) {
hv_store(env, "SERVER_NAME", sizeof("SERVER_NAME")-1, newSVpv((char *)r->host_start, r->host_end - r->host_start), 0);
} else {
ngx_http_core_srv_conf_t *cscf = ngx_http_get_module_srv_conf(r, ngx_http_core_module);
hv_store(env, "SERVER_NAME", sizeof("SERVER_NAME")-1, newSVpv((char *)cscf->server_name.data, cscf->server_name.len), 0);
}
hv_store(env, "REMOTE_ADDR", sizeof("REMOTE_ADDR")-1, newSVpv((char *)r->connection->addr_text.data, r->connection->addr_text.len), 0);
/* TODO
*
* psgi.multithread
* psgi.multiprocess
*/
part = &r->headers_in.headers.part;
h = part->elts;
c = 0;
for (i = 0; /* void */ ; i++) {
ngx_str_t name;
u_char *p;
if (i >= part->nelts) {
if (part->next == NULL) {
break;
}
part = part->next;
h = part->elts;
i = 0;
}
/* The environment MUST NOT contain keys named HTTP_CONTENT_TYPE or HTTP_CONTENT_LENGTH.
* PSGI 1.09_3
*/
if (ngx_strncasecmp(h[i].key.data, (u_char*)"CONTENT-LENGTH", h[i].key.len) == 0) {
continue;
}
if (ngx_strncasecmp(h[i].key.data, (u_char*)"CONTENT-TYPE", h[i].key.len) == 0) {
continue;
}
p = ngx_pnalloc(r->pool, sizeof("HTTP_") - 1 + h[i].key.len);
if (p == NULL) {
return NULL;
}
name.data = p;
name.len = sizeof("HTTP_") + h[i].key.len -1 ;
p = ngx_copy(p, (u_char*)"HTTP_", sizeof("HTTP_")-1);
p = ngx_copy(p, h[i].key.data, h[i].key.len );
ngx_log_debug2(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"Set env header: '%s' => '%s'",
h[i].key.data, h[i].value.data);
x = h[i].key.len + sizeof("HTTP_");
while (x > 0) {
if (name.data[x] == '-') {
name.data[x] = '_';
} else {
name.data[x] = ngx_toupper(name.data[x]);
}
x--;
}
SV **exists = hv_fetch(env, (char*)name.data, name.len, 0);
if (exists == NULL) {
hv_store(env, (char *)name.data, name.len, newSVpv((char *)h[i].value.data, h[i].value.len), 0);
} else {
/* join ',', @values;
* FIXME: Can I do this better
*/
SV *newval = newSVpvf("%s,%s", SvPV_nolen(*exists), h[i].value.data);
hv_store(env, (char *)name.data, name.len, newval, 0);
}
c += 2;
}
return newRV_noinc((SV*)env);
}
ngx_int_t
ngx_http_psgi_init_app(pTHX_ ngx_http_psgi_loc_conf_t *psgilcf, ngx_log_t *log)
{
ngx_int_t retval = NGX_ERROR;
/* Check if we have Perl interpreter */
if (psgilcf->perl == NULL) {
ngx_log_error(NGX_LOG_ERR, log, 0,
"Panic: NULL Perl interpreter");
return retval;
}
/* Already have PSGI app */
if (psgilcf->sub != NULL) {
return NGX_OK;
}
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0,
"Loading app \"%s\"", psgilcf->app);
/* Init PSGI application */
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
/* FIXME: This should be written way cleaner! */
SV *call = newSVpvf("sub { return do '%s' }", psgilcf->app);
SV *cvrv = eval_pv(SvPV_nolen(call), FALSE);
int count = call_sv(cvrv, G_EVAL|G_SCALAR);
if (SvTRUE(ERRSV))
{
ngx_log_error(NGX_LOG_ERR, log, 0,
"Failed to initialize psgi app \"%s\": %s", psgilcf->app, SvPV_nolen(ERRSV));
} else if (count < 1) {
ngx_log_error(NGX_LOG_ERR, log, 0,
"Application '%s' returned empty list", psgilcf->app);
} else {
SPAGAIN;
psgilcf->sub = (SV*)POPs;
PUTBACK;
/* Dereference */
if (SvROK(psgilcf->sub)) {
psgilcf->sub = SvRV(psgilcf->sub);
}
if (SvTYPE(psgilcf->sub) == SVt_PVCV || SvTYPE(psgilcf->sub) == SVt_PVMG) {
SvREFCNT_inc(psgilcf->sub);
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0,
"Application successfully initialized: %s", SvPV_nolen(psgilcf->sub));
retval = NGX_OK;
} else {
ngx_log_error(NGX_LOG_ERR, log, 0,
"psgi app \"%s\" returned something that is not a code reference: '%s'",
psgilcf->app, SvPV_nolen(psgilcf->sub));
}
}
FREETMPS;
LEAVE;
}
return retval;
}
/* maps to mod_mime_magic::parse */
static int
fmm_parse_magic_line(PerlFMM *state, char *l, int lineno)
{
char *t;
char *s;
fmmagic *m;
SV *err;
Newz(1234, m, 1, fmmagic);
m->next = NULL;
m->flag = 0;
m->cont_level = 0;
m->lineno = lineno;
if (! state->magic || !state->last) {
state->magic = state->last = m;
} else {
state->last->next = m;
state->last = m;
}
while (*l == '>') {
l++; /* step over */
m->cont_level++;
}
if (m->cont_level != 0 && *l == '(') {
l++; /* step over */
m->flag |= INDIR;
}
/* get offset, then skip over it */
m->offset = (int) strtol(l, &t, 0);
if (l == t) {
err = newSVpvf("Invalid offset in mime magic file, line %d: %s", lineno, l);
goto error;
}
l = t;
if (m->flag & INDIR) {
m->in.type = LONG;
m->in.offset = 0;
/* read [.lbs][+=]nnnnn) */
if (*l == '.') {
switch (*++l) {
case 'l':
m->in.type = LONG;
break;
case 's':
m->in.type = SHORT;
break;
case 'b':
m->in.type = BYTE;
break;
default:
err = newSVpvf(
"Invalid indirect offset type in mime magic file, line %d: %c", lineno, *l);
goto error;
}
l++;
}
s = l;
if (*l == '+' || *l == '-') {
l++;
}
if (isdigit((unsigned char) *l)) {
m->in.offset = strtol(l, &t, 0);
if (*s == '-') {
m->in.offset = -(m->in.offset);
}
} else {
t = l;
}
if (*t++ != ')') {
err = newSVpvf(
"Missing ')' in indirect offset in mime magic file, line %d", lineno);
goto error;
}
l = t;
}
while (isdigit((unsigned char) *l)) {
++l;
}
EATAB(l);
#define NBYTE 4
#define NSHORT 5
#define NLONG 4
#define NSTRING 6
#define NDATE 4
#define NBESHORT 7
#define NBELONG 6
#define NBEDATE 6
#define NLESHORT 7
#define NLELONG 6
#define NLEDATE 6
if (*l == 'u') {
++l;
m->flag |= UNSIGNED;
}
/* get type, skip it */
if (strncmp(l, "byte", NBYTE) == 0) {
m->type = BYTE;
l += NBYTE;
}
else if (strncmp(l, "short", NSHORT) == 0) {
m->type = SHORT;
l += NSHORT;
}
else if (strncmp(l, "long", NLONG) == 0) {
m->type = LONG;
l += NLONG;
}
else if (strncmp(l, "string", NSTRING) == 0) {
m->type = STRING;
l += NSTRING;
}
else if (strncmp(l, "date", NDATE) == 0) {
m->type = DATE;
l += NDATE;
}
else if (strncmp(l, "beshort", NBESHORT) == 0) {
m->type = BESHORT;
l += NBESHORT;
}
else if (strncmp(l, "belong", NBELONG) == 0) {
m->type = BELONG;
l += NBELONG;
}
else if (strncmp(l, "bedate", NBEDATE) == 0) {
m->type = BEDATE;
l += NBEDATE;
}
else if (strncmp(l, "leshort", NLESHORT) == 0) {
m->type = LESHORT;
l += NLESHORT;
}
else if (strncmp(l, "lelong", NLELONG) == 0) {
m->type = LELONG;
l += NLELONG;
}
else if (strncmp(l, "ledate", NLEDATE) == 0) {
m->type = LEDATE;
l += NLEDATE;
}
else {
err = newSVpvf("Invalid type in mime magic file, line %d: %s", lineno, l);
goto error;
}
/* New-style anding: "0 byte&0x80 =0x80 dynamically linked" */
if (*l == '&') {
++l;
m->mask = fmm_signextend(state, m, strtol(l, &l, 0));
}
else {
m->mask = ~0L;
}
EATAB(l);
switch (*l) {
case '>':
case '<':
/* Old-style anding: "0 byte &0x80 dynamically linked" */
case '&':
case '^':
case '=':
m->reln = *l;
++l;
break;
case '!':
if (m->type != STRING) {
m->reln = *l;
++l;
break;
}
/* FALL THROUGH */
default:
if (*l == 'x' && isSPACE(l[1])) {
m->reln = *l;
++l;
goto GetDesc; /* Bill The Cat */
}
m->reln = '=';
break;
}
EATAB(l);
if (fmm_getvalue(state, m, &l))
return -1;
/*
* now get last part - the description
*/
GetDesc:
EATAB(l);
if (l[0] == '\b') {
++l;
m->nospflag = 1;
}
else if ((l[0] == '\\') && (l[1] == 'b')) {
++l;
++l;
m->nospflag = 1;
}
else {
m->nospflag = 0;
}
strncpy(m->desc, l, sizeof(m->desc) - 1);
m->desc[sizeof(m->desc) - 1] = '\0';
return 0;
error:
FMM_SET_ERROR(state, err);
croak(SvPV_nolen(err));
}
/*
* Convert a string containing C character escapes. Stop at an unescaped
* space or tab. Copy the converted version to "p", returning its length in
* *slen. Return updated scan pointer as function result.
*/
static char *
fmm_getstr(PerlFMM *state, register char *s, register char *p, int plen, int *slen)
{
char *origs = s, *origp = p;
char *pmax = p + plen - 1;
register int c;
register int val;
SV *err;
while ((c = *s++) != '\0') {
if (isSPACE(c))
break;
if (p >= pmax) {
err = newSVpvf(
"fmm_getstr: string too long: %s", origs);
FMM_SET_ERROR(state, err);
break;
}
if (c == '\\') {
switch (c = *s++) {
case '\0':
goto out;
default:
*p++ = (char) c;
break;
case 'n':
*p++ = '\n';
break;
case 'r':
*p++ = '\r';
break;
case 'b':
*p++ = '\b';
break;
case 't':
*p++ = '\t';
break;
case 'f':
*p++ = '\f';
break;
case 'v':
*p++ = '\v';
break;
/* \ and up to 3 octal digits */
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
val = c - '0';
c = *s++; /* try for 2 */
if (c >= '0' && c <= '7') {
val = (val << 3) | (c - '0');
c = *s++; /* try for 3 */
if (c >= '0' && c <= '7')
val = (val << 3) | (c - '0');
else
--s;
}
else
--s;
*p++ = (char) val;
break;
/* \x and up to 3 hex digits */
case 'x':
val = 'x'; /* Default if no digits */
c = fmm_hextoint(*s++); /* Get next char */
if (c >= 0) {
val = c;
c = fmm_hextoint(*s++);
if (c >= 0) {
val = (val << 4) + c;
c = fmm_hextoint(*s++);
if (c >= 0) {
val = (val << 4) + c;
}
else
--s;
}
else
--s;
}
else
--s;
*p++ = (char) val;
break;
}
}
else
*p++ = (char) c;
}
out:
*p = '\0';
*slen = p - origp;
return s;
}
static int
fmm_mcheck(PerlFMM *state, union VALUETYPE *p, fmmagic *m)
{
register unsigned long l = m->value.l;
register unsigned long v;
register unsigned char *a;
register unsigned char *b;
register int len;
int matched;
SV *err;
if ((m->value.s[0] == 'x') && (m->value.s[1] == '\0')) {
/* XXX - WTF does this mean?? */
PerlIO_printf(PerlIO_stderr(), "fmm_mcheck: BOINK\n");
return 1;
}
switch (m->type) {
case BYTE:
v = p->b;
break;
case SHORT:
case BESHORT:
case LESHORT:
v = p->h;
break;
case LONG:
case BELONG:
case LELONG:
case DATE:
case BEDATE:
case LEDATE:
v = p->l;
break;
case STRING:
l = 0;
/* What we want here is: v = strncmp(m->value.s, p->s, m->vallen)
* but ignoring any nulls. bcmp doesn't give -/+/0 and isn't
* universally available anyway
*/
v = 0;
{
a = (unsigned char *) m->value.s;
b = (unsigned char *) p->s;
len = m->vallen;
while (--len >= 0) {
if ((v = *b++ - *a++) != 0) {
break;
}
}
}
break;
default:
/* bogosity, pretend that it just wan't a match*/
err = newSVpvf(
"fmm_mcheck: invalid type %d in mcheck().\n", m->type);
FMM_SET_ERROR(state, err);
return 0;
}
v = fmm_signextend(state, m, v) & m->mask;
switch (m->reln) {
case 'x':
matched = 1;
break;
case '!':
matched = v != l;
break;
case '=':
matched = v == l;
break;
case '>':
if (m->flag & UNSIGNED) {
matched = v > l;
} else {
matched = (long) v > (long) l;
}
break;
case '<':
if (m->flag & UNSIGNED) {
matched = v < l;
} else {
matched = (long) v < (long) l;
}
break;
case '&':
matched = (v & l) == l;
break;
case '^':
matched = (v & l) != l;
break;
default:
/* bogosity, pretend it didn't match */
matched = 0;
err = newSVpvf(
"fmm_mcheck: Can't happen: invalid relation %d.\n", m->reln);
FMM_SET_ERROR(state, err);
}
return matched;
}
/* Wrap a JS value to export into perl
* Returns a new SV, REFCNT_dec is caller's responsability
*/
JSBool
PJS_ReflectJS2Perl(
pTHX_
JSContext *cx,
jsval value,
SV** sv,
int full
) {
if(JSVAL_IS_PRIMITIVE(value)) {
*sv = PrimJSVALToSV(aTHX_ cx, value);
if(*sv) return JS_TRUE;
}
else if(JSVAL_IS_OBJECT(value)) {
PJS_Context *pcx = PJS_GET_CONTEXT(cx);
JSObject *object = JSVAL_TO_OBJECT(value);
JSClass *clasp = PJS_GET_CLASS(cx, object);
const char *classname = clasp->name;
JSObject *passport;
SV *wrapper;
SV *box;
char hkey[32];
jsval temp = JSVAL_VOID;
snprintf(hkey, 32, "%p", (void *)object);
PJS_DEBUG2("Wrapping a %s(%s)\n", classname, hkey);
if(PJS_getFlag(pcx, "ConvertRegExp") && strEQ(classname, "RegExp")) {
jsval src;
char *str;
if(JS_CallFunctionName(cx, object, "toSource", 0, NULL, &src) &&
(str = JS_GetStringBytes(JS_ValueToString(cx, src))) )
{
dSP;
SV *tmp = newSVpvf("qr%s", str);
eval_sv(tmp, G_SCALAR);
sv_free(tmp); // Don't leak
SPAGAIN;
tmp = POPs;
PUTBACK;
if(!SvTRUE(ERRSV)) {
*sv = SvREFCNT_inc_simple_NN(tmp);
return JS_TRUE;
}
}
return JS_FALSE;
}
if(IS_PERL_CLASS(clasp)) {
/* IS_PERL_CLASS means actual perl object is there */
SV *priv = (SV *)JS_GetPrivate(cx, object);
if(priv && SvOK(priv) && SvROK(priv)) {
*sv = SvREFCNT_inc_simple_NN(priv);
return JS_TRUE;
}
croak("A private %s?!\n", classname);
return JS_FALSE;
}
/* Common JSObject case */
/* Check registered perl visitors */
JS_LookupProperty(cx, pcx->pvisitors, hkey, &temp);
if(temp != JSVAL_VOID) {
/* Already registered, so exits a reference in perl space
* _must_ hold a PASSPORT */
assert(JSVAL_TO_OBJECT(temp) == object);
box = PJS_GetPassport(aTHX_ cx, object);
SvREFCNT_inc_void_NN(box); /* In perl should be one more */
PJS_DEBUG1("Cached!: %s\n", hkey);
} else {
/* Check if with a PASSPORT */
JS_LookupPropertyWithFlags(cx, object, PJS_PASSPORT_PROP, 0, &temp);
if(JSVAL_IS_OBJECT(temp) && (passport = JSVAL_TO_OBJECT(temp)) &&
PJS_GET_CLASS(cx, passport) == &passport_class &&
JS_GetReservedSlot(cx, passport, 0, &temp) &&
object == (JSObject *)JSVAL_TO_PRIVATE(temp)
) { /* Yes, reentering perl */
box = (SV *)JS_GetPrivate(cx, passport);
/* Here we don't increment refcount, the ownership in passport is
* transferred to perl land.
*/
PJS_DEBUG1("Reenter: %s\n", hkey);
}
else { /* No, first time, must wrap the object */
SV *boxref;
const char *package;
SV *robj = newSV(0);
SV *rjsv = newSV(0);
if (JS_ObjectIsFunction(cx, object))
package = PJS_FUNCTION_PACKAGE;
else if(JS_IsArrayObject(cx, object))
package = PJS_ARRAY_PACKAGE;
else if(strEQ(classname, PJS_PACKAGE_CLASS_NAME))
package = PJS_STASH_PACKAGE;
#if JS_HAS_XML_SUPPORT
else if(strEQ(classname, "XML"))
package = PJS_XMLOBJ_PACKAGE;
#endif
else if(strEQ(classname, "Error"))
package = PJS_ERROR_PACKAGE;
else {
SV **sv = hv_fetch(get_hv(NAMESPACE"ClassMap", 1), classname,
strlen(classname), 0);
if(sv) package = SvPV_nolen(*sv);
else package = PJS_OBJECT_PACKAGE;
}
sv_setref_pv(robj, PJS_RAW_OBJECT, (void*)object);
sv_setref_iv(rjsv, PJS_RAW_JSVAL, (IV)value);
boxref = PJS_CallPerlMethod(aTHX_ cx,
"__new",
sv_2mortal(newSVpv(package, 0)), // package
sv_2mortal(robj), // content
sv_2mortal(rjsv), // jsval
NULL
);
if(!boxref) return JS_FALSE;
if(!SvOK(boxref) || !sv_derived_from(boxref, PJS_BOXED_PACKAGE))
croak("PJS_Assert: Contructor must return a "NAMESPACE"Boxed");
/* Create a new PASSPORT */
passport = JS_NewObject(cx, &passport_class, NULL, object);
if(!passport ||
!JS_DefineProperty(cx, object, PJS_PASSPORT_PROP,
OBJECT_TO_JSVAL(passport),
NULL, NULL, JSPROP_READONLY | JSPROP_PERMANENT))
return JS_FALSE;
box = SvRV(boxref);
/* boxref is mortal, so we need to increment its rc, at end of
* scope, PASSPORT owns created box */
JS_SetPrivate(cx, passport, (void *)SvREFCNT_inc_simple_NN(box));
JS_SetReservedSlot(cx, passport, 0, PRIVATE_TO_JSVAL(object));
PJS_DEBUG2("New boxed: %s brc: %d\n", hkey, SvREFCNT(box));
}
/* Root object adding it to pvisitors list, will be unrooted by
* jsc_free_root at Boxed DESTROY time
*/
JS_DefineProperty(cx, pcx->pvisitors, hkey, value, NULL, NULL, 0);
}
/* Here the RC of box in PASSPORT reflects wrapper's ownership */
if(full && PJS_getFlag(pcx, "AutoTie") &&
(strEQ(classname, "Object") || strEQ(classname, "Array"))
) {
/* Return tied */
AV *avbox = (AV *)SvRV(box);
SV **last;
SV *tied;
SV *tier;
if(strEQ(classname, "Array")) {
last = av_fetch(avbox, 6, 1);
if(last && SvOK(*last) && SvROK(*last)) { // Cached
*sv = newSVsv(*last);
sv_free(box); /* Hard copy 'sv' owns the reference */
return JS_TRUE;
}
tied = (SV *)newAV();
} else { // Object
last = av_fetch(avbox, 5, 1);
if(last && SvOK(*last) && SvROK(*last)) { // Cached
*sv = newSVsv(*last);
sv_free(box); /* Hard copy 'sv' owns the reference */
return JS_TRUE;
}
tied = (SV *)newHV();
}
/* hv_magic below own a reference to box, we use an explicit path,
* to make clear that to perl land only one reference is given
*/
tier = newRV_inc(box);
hv_magic((HV *)tied, (GV *)tier, PERL_MAGIC_tied);
sv_free(tier);
wrapper = newRV_noinc(tied); /* Don't leak the hidden tied variable */
/* Save in cache a weaken copy, the cache itself dosn't hold a reference */
sv_setsv(*last, wrapper);
sv_rvweaken(*last);
PJS_DEBUG1("Return tied for %s\n", SvPV_nolen(tier));
}
else {
wrapper = newRV_noinc(box); /* Transfer ownership to wrapper */
#if PERL_VERSION < 9
sv_bless(wrapper, SvSTASH(box));
#endif
}
*sv = wrapper;
return JS_TRUE;
}
return JS_FALSE;
}
