/*=====================================================================
*
* Template::Stash::XS (Stash.xs)
*
* DESCRIPTION
* This is an XS implementation of the Template::Stash module.
* It is an alternative version of the core Template::Stash methods
* ''get'' and ''set'' (the ones that should benefit most from a
* speedy C implementation), along with some virtual methods (like
* first, last, reverse, etc.)
*
* AUTHORS
* Andy Wardley <abw@kfs.org>
* Doug Steinwand <dsteinwand@citysearch.com>
*
* COPYRIGHT
* Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved.
* Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
*
* This module is free software; you can redistribute it and/or
* modify it under the same terms as Perl itself.
*
* NOTE
* Be very familiar with the perlguts, perlxs, perlxstut and
* perlapi manpages before digging through this code.
*
*---------------------------------------------------------------------
*
* $Id: Stash.xs,v 1.14 2003/03/17 23:05:27 abw Exp $
*
*=====================================================================*/
/* #define TT_PERF_ENABLE <--- enables profiling code,
but hurts performance some. */
#ifdef __cplusplus
extern "C" {
#endif
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "ppport.h"
#include "XSUB.h"
#ifdef TT_PERF_ENABLE
#include <sys/types.h>
#include <sys/time.h>
#include <sys/resource.h>
#include <unistd.h>
#endif /* TT_PERF_ENABLE */
#ifdef __cplusplus
}
#endif
#define TT_STASH_PKG "Template::Stash::XS"
#define TT_LIST_OPS "Template::Stash::LIST_OPS"
#define TT_HASH_OPS "Template::Stash::HASH_OPS"
#define TT_SCALAR_OPS "Template::Stash::SCALAR_OPS"
#define TT_LVALUE_FLAG 1
#define TT_DEBUG_FLAG 2
#define TT_DEFAULT_FLAG 4
typedef enum tt_ret { TT_RET_UNDEF, TT_RET_OK, TT_RET_CODEREF } TT_RET;
static TT_RET hash_op(pTHX_ SV*, char*, AV*, SV**);
static TT_RET list_op(pTHX_ SV*, char*, AV*, SV**);
static TT_RET scalar_op(pTHX_ SV*, char*, AV*, SV**, int);
static TT_RET tt_fetch_item(pTHX_ SV*, SV*, AV*, SV**);
static SV* dotop(pTHX_ SV*, SV*, AV*, int);
static SV* call_coderef(pTHX_ SV*, AV*);
static SV* fold_results(pTHX_ I32);
static SV* find_perl_op(pTHX_ char*, char*);
static AV* mk_mortal_av(pTHX_ SV*, AV*, SV*);
static SV* do_getset(pTHX_ SV*, AV*, SV*, int);
static AV* convert_dotted_string(pTHX_ const char*, I32);
static int get_debug_flag(pTHX_ SV*);
static int cmp_arg(const void *, const void *);
static void die_object(pTHX_ SV *);
static struct xs_arg *find_xs_op(char *);
static SV* list_dot_first(pTHX_ AV*, AV*);
static SV* list_dot_join(pTHX_ AV*, AV*);
static SV* list_dot_last(pTHX_ AV*, AV*);
static SV* list_dot_max(pTHX_ AV*, AV*);
static SV* list_dot_reverse(pTHX_ AV*, AV*);
static SV* list_dot_size(pTHX_ AV*, AV*);
static SV* hash_dot_each(pTHX_ HV*, AV*);
static SV* hash_dot_keys(pTHX_ HV*, AV*);
static SV* hash_dot_values(pTHX_ HV*, AV*);
static SV* scalar_dot_defined(pTHX_ SV*, AV*);
static SV* scalar_dot_length(pTHX_ SV*, AV*);
static char rcsid[] =
"$Id: Stash.xs,v 1.14 2003/03/17 23:05:27 abw Exp $";
/* dispatch table for XS versions of special "virtual methods",
* names must be in alphabetical order
*/
static const struct xs_arg {
const char *name;
SV* (*list_f) (pTHX_ AV*, AV*);
SV* (*hash_f) (pTHX_ HV*, AV*);
SV* (*scalar_f) (pTHX_ SV*, AV*);
} xs_args[] = {
/* name list (AV) ops. hash (HV) ops. scalar (SV) ops.
-------- ---------------- --------------- ------------------ */
{ "defined", NULL, NULL, scalar_dot_defined },
{ "each", NULL, hash_dot_each, NULL },
/* { "first", list_dot_first, NULL, NULL }, */
{ "join", list_dot_join, NULL, NULL },
{ "keys", NULL, hash_dot_keys, NULL },
/* { "last", list_dot_last, NULL, NULL }, */
{ "length", NULL, NULL, scalar_dot_length },
{ "max", list_dot_max, NULL, NULL },
{ "reverse", list_dot_reverse, NULL, NULL },
{ "size", list_dot_size, NULL, NULL },
{ "values", NULL, hash_dot_values, NULL },
};
#ifdef TT_PERF_ENABLE
/* performance data gathering structures and code */
int hv_op_cnt, hv_op_cnt_xs, hv_op_cnt_pl,
av_op_cnt, av_op_cnt_xs, av_op_cnt_pl,
sv_op_cnt, sv_op_cnt_xs, sv_op_cnt_pl = 0;
typedef enum perf_status_type {
perf_av_hit_xs, perf_av_hit_pl, perf_av_miss,
perf_hv_hit_xs, perf_hv_hit_pl, perf_hv_miss,
perf_sv_hit_xs, perf_sv_hit_pl, perf_sv_miss,
perf_func, perf_method, max_perf_status_type }
perf_status_type;
/* Note:
* vrt = virtual: in ''foo.bar.last'', ''last'' is a virtual method
*/
char *perf_status_string[] = {
"vrt XS AV", "vrt PL AV", "vrt ?? AV",
"vrt XS HV", "vrt PL HV", "vrt ?? HV",
"vrt XS SV", "vrt PL SV", "vrt ?? SV",
"*Function", "Method " };
struct perf_rec {
char key[24];
int count[max_perf_status_type];
double cpu_time[max_perf_status_type];
struct perf_rec *next_lt;
struct perf_rec *next_gr;
} *perf_hist = NULL;
struct perf_out_rec {
SV *outsv;
double cpu_time;
} perf_out;
/* returns user CPU time and optionally
* system CPU time and max rss for this process
* time measured in seconds, rss in kilobytes */
static double get_cpu_usage (double *sys_time, long *max_rss) {
struct rusage rusage;
getrusage(RUSAGE_SELF, &rusage);
if (sys_time)
*sys_time = (double) rusage.ru_stime.tv_sec +
(double) rusage.ru_stime.tv_usec / 1000000.0;
if (max_rss)
*max_rss = rusage.ru_maxrss;
return (double) rusage.ru_utime.tv_sec +
(double) rusage.ru_utime.tv_usec / 1000000.0;
}
/* stores performance data (key, status) in a binary tree */
static double *record_key_perf(char *key, perf_status_type status) {
struct perf_rec *p = perf_hist;
struct perf_rec **lp = &perf_hist;
int i;
/* look for existing node */
while (p) {
i = strcmp(key, p->key);
if (i < 0) {
/* left branch */
lp = &(p->next_lt);
p = p->next_lt;
} else if (i > 0) {
/* right branch */
lp = &(p->next_gr);
p = p->next_gr;
} else {
/* found matching key */
p->count[status]++;
p->cpu_time[status] -= get_cpu_usage(NULL, NULL);
return &(p->cpu_time[status]);
}
}
/* create new node */
Newz(0, p, 1, struct perf_rec);
if (p) {
p->count[status] = 1;
strncpy(p->key, key, sizeof(p->key));
*lp = p;
p->cpu_time[status] -= get_cpu_usage(NULL, NULL);
return &(p->cpu_time[status]);
} else {
croak(TT_STASH_PKG ": Newz() failed for %s in record_key_perf\n", key);
}
return NULL;
}
/* dumps one row of performance data */
static void dump_perf_rec(p, out, status)
struct perf_rec *p;
struct perf_out_rec *out;
perf_status_type status;
{
sv_catpvf(out->outsv,
"%-24s %s%9d", p->key, perf_status_string[status], p->count[status]);
if (p->count[status] && p->cpu_time[status] && out->cpu_time > 0.0)
sv_catpvf(out->outsv,
"%10.3f%9.6f %4.1f\n",
p->cpu_time[status],
p->cpu_time[status] / (double) p->count[status],
100.0 * p->cpu_time[status] / out->cpu_time);
else
sv_catpvf(out->outsv, " - - -\n");
}
/* recursively dumps entire performance table ''p'' */
static void dump_all_perf(p, out)
struct perf_rec *p;
struct perf_out_rec *out;
{
perf_status_type i;
if (!p)
return;
/* left branch */
if (p->next_lt)
dump_all_perf(p->next_lt, out);
/* this node */
for(i = 0; i < max_perf_status_type; i++)
if(p->count[i])
dump_perf_rec(p, out, i);
/* right branch */
if (p->next_gr)
dump_all_perf(p->next_gr, out);
return;
}
#define TT_PERF_INIT \
double *tt_perf_tmr
#define TT_PERF_START(x, y, key, status_type) \
(x)++; \
(y)++; \
tt_perf_tmr = record_key_perf((key), (status_type))
#define TT_PERF_START_FUNC(key) \
tt_perf_tmr = record_key_perf((key), perf_func)
#define TT_PERF_START_METHOD(key) \
tt_perf_tmr = record_key_perf((key), perf_method)
#define TT_PERF_END \
*tt_perf_tmr += get_cpu_usage(NULL, NULL)
#define TT_PERF_MISS(x, key, status_type) \
(x)++; \
tt_perf_tmr = record_key_perf("*", status_type); \
*tt_perf_tmr += get_cpu_usage(NULL, NULL)
#else
/* no-ops when no performance code is wanted */
#define TT_PERF_INIT
#define TT_PERF_START(w,x,y,z)
#define TT_PERF_START_FUNC(x)
#define TT_PERF_START_METHOD(x)
#define TT_PERF_END
#define TT_PERF_MISS(x,y,z)
#endif /* TT_PERF_ENABLE */
/*------------------------------------------------------------------------
* tt_fetch_item(pTHX_ SV *root, SV *key_sv, AV *args, SV **result)
*
* Retrieves an item from the given hash or array ref. If item is found
* and a coderef then the coderef will be called and passed args. Returns
* TT_RET_CODEREF or TT_RET_OK and sets result. If not found, returns
* TT_RET_UNDEF and result is undefined.
*------------------------------------------------------------------------*/
static TT_RET tt_fetch_item(pTHX_ SV *root, SV *key_sv, AV *args, SV **result) {
STRLEN key_len;
char *key = SvPV(key_sv, key_len);
SV **value = NULL;
if (!SvROK(root))
return TT_RET_UNDEF;
switch (SvTYPE(SvRV(root))) {
case SVt_PVHV:
value = hv_fetch((HV *) SvRV(root), key, key_len, FALSE);
break;
case SVt_PVAV:
if (looks_like_number(key_sv)) {
value = av_fetch((AV *) SvRV(root), SvIV(key_sv), FALSE);
}
break;
}
if (value) {
/* trigger any tied magic to FETCH value */
SvGETMAGIC(*value);
/* call if a coderef */
if (SvROK(*value)
&& (SvTYPE(SvRV(*value)) == SVt_PVCV)
&& !sv_isobject(*value)) {
*result = call_coderef(aTHX_ *value, args);
return TT_RET_CODEREF;
}
else if (*value != &PL_sv_undef) {
*result = *value;
return TT_RET_OK;
}
}
*result = &PL_sv_undef;
return TT_RET_UNDEF;
}
/*------------------------------------------------------------------------
* dotop(pTHX_ SV *root, SV *key_sv, AV *args, int flags)
*
* Resolves dot operations of the form root.key, where 'root' is a
* reference to the root item, 'key_sv' is an SV containing the
* operation key (e.g. hash key, list index, first, last, each, etc),
* 'args' is a list of additional arguments and 'TT_LVALUE_FLAG' is a
* flag to indicate if, for certain operations (e.g. hash key), the item
* should be created if it doesn't exist. Also, 'TT_DEBUG_FLAG' is the
* debug flag.
*------------------------------------------------------------------------*/
static SV *dotop(pTHX_ SV *root, SV *key_sv, AV *args, int flags) {
dSP;
STRLEN item_len;
char *item = SvPV(key_sv, item_len);
SV *result = &PL_sv_undef;
I32 atroot;
TT_PERF_INIT;
/* ignore _private or .private members */
if (!root || *item == '_' || *item == '.') {
return &PL_sv_undef;
}
if (SvROK(root)) {
atroot = sv_derived_from(root, TT_STASH_PKG);
if (atroot
|| ((SvTYPE(SvRV(root)) == SVt_PVHV) && !sv_isobject(root))) {
/* root is a HASH or Template::Stash */
switch(tt_fetch_item(aTHX_ root, key_sv, args, &result)) {
case TT_RET_OK:
/* return immediately */
return result;
break;
case TT_RET_CODEREF:
/* fall through */
break;
default:
/* for lvalue, create an intermediate hash */
if (flags & TT_LVALUE_FLAG) {
SV *newhash;
HV *roothv = (HV *) SvRV(root);
newhash = SvREFCNT_inc((SV *) newRV_noinc((SV *) newHV()));
if (! hv_store(roothv, item, item_len, newhash, 0)) {
/* trigger any tied magic to STORE value */
SvSETMAGIC(newhash);
SvREFCNT_dec(newhash);
}
return sv_2mortal(newhash);
}
/* try hash pseudo-method (not at stash root, except import) */
if ((! atroot || (strcmp(item, "import") == 0))
&& hash_op(aTHX_ root, item, args, &result) == TT_RET_UNDEF) {
/* try hash slice */
if (SvROK(key_sv) && SvTYPE(SvRV(key_sv)) == SVt_PVAV) {
AV *a_av = newAV();
AV *k_av = (AV *) SvRV(key_sv);
HV *r_hv = (HV *) SvRV(root);
char *t;
I32 i;
STRLEN tlen;
SV **svp;
/* TODO: SvGETMAGIC x 2 below */
for (i = 0; i <= av_len(k_av); i++) {
if ((svp = av_fetch(k_av, i, 0))) {
t = SvPV(*svp, tlen);
if((svp = hv_fetch(r_hv, t, tlen, FALSE)))
av_push(a_av, SvREFCNT_inc(*svp));
}
}
return sv_2mortal(newRV_noinc((SV *) a_av));
}
}
}
}
else if ((SvTYPE(SvRV(root)) == SVt_PVAV) && !sv_isobject(root)) {
/* root is an ARRAY */
/* try list pseudo-method, but not for lvalues */
if ((flags & TT_LVALUE_FLAG) ||
(list_op(aTHX_ root, item, args, &result) == TT_RET_UNDEF)) {
switch (tt_fetch_item(aTHX_ root, key_sv, args, &result)) {
case TT_RET_OK:
return result;
break;
case TT_RET_CODEREF:
break;
default:
/* try array slice */
if (SvROK(key_sv) && SvTYPE(SvRV(key_sv)) == SVt_PVAV) {
AV *a_av = newAV();
AV *k_av = (AV *) SvRV(key_sv);
AV *r_av = (AV *) SvRV(root);
I32 i;
SV **svp;
/* TODO: SvGETMAGIC x 2 below */
for (i = 0; i <= av_len(k_av); i++) {
if ((svp = av_fetch(k_av, i, FALSE))) {
if (looks_like_number(*svp) &&
(svp = av_fetch(r_av, SvIV(*svp), FALSE)))
av_push(a_av, SvREFCNT_inc(*svp));
}
}
return sv_2mortal(newRV_noinc((SV *) a_av));
}
}
}
}
else if (sv_isobject(root)) {
/* root is an object */
I32 n, i;
SV **svp;
HV *stash = SvSTASH((SV *) SvRV(root));
GV *gv;
result = NULL;
if ((gv = gv_fetchmethod_autoload(stash, item, 1))) {
/* eval { @result = $root->$item(@$args); }; */
TT_PERF_START_METHOD(item);
PUSHMARK(SP);
XPUSHs(root);
n = (args && args != Nullav) ? av_len(args) : -1;
for (i = 0; i <= n; i++)
if ((svp = av_fetch(args, i, 0))) XPUSHs(*svp);
PUTBACK;
n = perl_call_method(item, G_ARRAY | G_EVAL);
TT_PERF_END;
SPAGAIN;
if (SvTRUE(ERRSV)) {
(void) POPs; /* remove undef from stack */
PUTBACK;
result = NULL;
/* temporary hack - required to propogate errors thrown
by views; if $@ is a ref (e.g. Template::Exception)
object then we assume it's a real error that needs
real throwing */
if (SvROK(ERRSV) || !strstr(SvPV(ERRSV, PL_na),
"Can't locate object method")) {
die_object(aTHX_ ERRSV);
}
} else {
result = fold_results(aTHX_ n);
}
}
if (!result) {
/* failed to call object method, so try some fallbacks */
if ((SvTYPE(SvRV(root)) == SVt_PVHV)
&& ((n = tt_fetch_item(aTHX_ root, key_sv, args, &result)) != TT_RET_UNDEF)) {
if (n == TT_RET_OK) {
return result;
}
}
else if (SvTYPE(SvRV(root)) == SVt_PVAV) {
if ((list_op(aTHX_ root, item, args, &result) == TT_RET_UNDEF)
&& (flags & TT_DEBUG_FLAG))
result = (SV *) mk_mortal_av(aTHX_ &PL_sv_undef, NULL, ERRSV);
}
else
scalar_op(aTHX_ root, item, args, &result, flags);
}
}
}
/* it doesn't look like we've got a reference to anything we know about,
* so let's try the SCALAR_OPS pseudo-methods (but not for l-values)
*/
else if (!(flags & TT_LVALUE_FLAG)
&& (scalar_op(aTHX_ root, item, args, &result, flags)
== TT_RET_UNDEF)) {
if (flags & TT_DEBUG_FLAG)
croak("don't know how to access [ %s ].%s\n",
SvPV(root, PL_na), item);
}
/* if we have an arrayref and the first element is defined then
* everything is peachy, otherwise some ugliness may have occurred
*/
if (SvROK(result) && SvTYPE(SvRV(result)) == SVt_PVAV) {
SV **svp;
AV *array = (AV *) SvRV(result);
I32 len = (array == Nullav) ? 0 : (av_len(array) + 1);
if (len) {
svp = av_fetch(array, 0, FALSE);
if (svp && (*svp != &PL_sv_undef)) {
return result;
}
}
}
if ((flags & TT_DEBUG_FLAG)
&& (!result || !SvOK(result) || (result == &PL_sv_undef))) {
croak("%s is undefined\n", item);
}
return result;
}
/*------------------------------------------------------------------------
* assign(pTHX_ SV *root, SV *key_sv, AV *args, SV *value, int flags)
*
* Resolves the final assignment element of a dotted compound variable
* of the form "root.key(args) = value". 'root' is a reference to
* the root item, 'key_sv' is an SV containing the operation key
* (e.g. hash key, list item, object method), 'args' is a list of user
* provided arguments (passed only to object methods), 'value' is the
* assignment value to be set (appended to args) and 'deflt' (default)
* is a flag to indicate that the assignment should only be performed
* if the item is currently undefined/false.
*------------------------------------------------------------------------*/
static SV *assign(pTHX_ SV *root, SV *key_sv, AV *args, SV *value, int flags) {
dSP;
SV **svp, *newsv;
HV *roothv;
AV *rootav;
STRLEN key_len;
char *key = SvPV(key_sv, key_len);
TT_PERF_INIT;
if (!root || !key_len || *key == '_' || *key == '.') {
/* ignore _private or .private members */
return &PL_sv_undef;
} else if (SvROK(root)) {
/* see if root is an object (but not Template::Stash) */
if (sv_isobject(root) && !sv_derived_from(root, TT_STASH_PKG)) {
HV *stash = SvSTASH((SV *) SvRV(root));
GV *gv;
/* look for the named method, or an AUTOLOAD method */
if ((gv = gv_fetchmethod_autoload(stash, key, 1))) {
I32 count = (args && args != Nullav) ? av_len(args) : -1;
I32 i;
/* push args and value onto stack, then call method */
TT_PERF_START_METHOD(key);
PUSHMARK(SP);
XPUSHs(root);
for (i = 0; i <= count; i++) {
if ((svp = av_fetch(args, i, FALSE)))
XPUSHs(*svp);
}
XPUSHs(value);
PUTBACK;
count = perl_call_method(key, G_ARRAY);
TT_PERF_END;
SPAGAIN;
return fold_results(aTHX_ count);
}
}
/* drop-through if not an object or method not found */
switch SvTYPE(SvRV(root)) {
case SVt_PVHV: /* HASH */
roothv = (HV *) SvRV(root);
/* check for any existing value if ''default'' flag set */
if ((flags & TT_DEFAULT_FLAG)
&& (svp = hv_fetch(roothv, key, key_len, FALSE))) {
/* invoke any tied magical FETCH method */
SvGETMAGIC(*svp);
if (SvTRUE(*svp))
return &PL_sv_undef;
}
/* avoid 'modification of read-only value' error */
newsv = newSVsv(value);
if (! hv_store(roothv, key, key_len, newsv, 0)) {
/* invoke any tied magical STORE method */
SvSETMAGIC(newsv);
SvREFCNT_dec(newsv);
}
return value;
break;
case SVt_PVAV: /* ARRAY */
rootav = (AV *) SvRV(root);
/* check for any existing value if default flag set */
if ((flags & TT_DEFAULT_FLAG)
&& looks_like_number(key_sv)
&& (svp = av_fetch(rootav, SvIV(key_sv), FALSE))) {
/* invoke any tied magical FETCH method */
SvGETMAGIC(*svp);
if (SvTRUE(*svp))
return &PL_sv_undef;
}
newsv = newSVsv(value);
if (looks_like_number(key_sv)) {
if (av_store(rootav, SvIV(key_sv), newsv))
SvREFCNT_inc(newsv);
else
SvSETMAGIC(newsv);
return value;
}
else
return &PL_sv_undef;
break;
default: /* BARF */
/* TODO: fix [ %s ] */
croak("don't know how to assign to [ %s ].%s",
SvPV(SvRV(root), PL_na), key);
}
}
else { /* SCALAR */
/* TODO: fix [ %s ] */
croak("don't know how to assign to [ %s ].%s",
SvPV(SvRV(root), PL_na), key);
}
/* not reached */
return &PL_sv_undef; /* just in case */
}
/* dies and passes back a blessed object,
* or just a string if it's not blessed
*/
static void die_object (pTHX_ SV *err) {
if (sv_isobject(err)) {
/* throw object via ERRSV ($@) */
SV *errsv = perl_get_sv("@", TRUE);
sv_setsv(errsv, err);
(void) die(Nullch);
}
/* error string sent back via croak() */
croak("%s", SvPV(err, PL_na));
}
/* pushes any arguments in 'args' onto the stack then calls the code ref
* in 'code'. Calls fold_results() to return a listref or die.
*/
static SV *call_coderef(pTHX_ SV *code, AV *args) {
dSP;
SV **svp;
I32 count = (args && args != Nullav) ? av_len(args) : -1;
I32 i;
PUSHMARK(SP);
for (i = 0; i <= count; i++)
if ((svp = av_fetch(args, i, FALSE)))
XPUSHs(*svp);
PUTBACK;
count = perl_call_sv(code, G_ARRAY);
SPAGAIN;
return fold_results(aTHX_ count);
}
/* pops 'count' items off the stack, folding them into a list reference
* if count > 1, or returning the sole item if count == 1.
* Returns undef if count == 0.
* Dies if first value of list is undef
*/
static SV* fold_results(pTHX_ I32 count) {
dSP;
SV *retval = &PL_sv_undef;
if (count > 1) {
/* convert multiple return items into a list reference */
AV *av = newAV();
SV *last_sv = &PL_sv_undef;
SV *sv = &PL_sv_undef;
I32 i;
av_extend(av, count - 1);
for(i = 1; i <= count; i++) {
last_sv = sv;
sv = POPs;
if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv)))
SvREFCNT_dec(sv);
}
PUTBACK;
retval = sv_2mortal((SV *) newRV_noinc((SV *) av));
if (!SvOK(sv) || sv == &PL_sv_undef) {
/* if first element was undef, die */
die_object(aTHX_ last_sv);
}
return retval;
} else {
if (count)
retval = POPs;
PUTBACK;
return retval;
}
}
/* Iterates through array calling dotop() to resolve all items
* Skips the last if ''value'' is non-NULL.
* If ''value'' is non-NULL, calls assign() to do the assignment.
*
* SV *root; AV *ident_av; SV *value; int flags;
*
*/
static SV* do_getset(pTHX_ SV *root, AV *ident_av, SV *value, int flags) {
AV *key_args;
SV *key;
SV **svp;
I32 end_loop, i, size = av_len(ident_av);
if (value) {
/* make some adjustments for assign mode */
end_loop = size - 1;
flags |= TT_LVALUE_FLAG;
} else {
end_loop = size;
}
for(i = 0; i < end_loop; i += 2) {
if (!(svp = av_fetch(ident_av, i, FALSE)))
croak(TT_STASH_PKG " %cet: bad element %d", value ? 's' : 'g', i);
key = *svp;
if (!(svp = av_fetch(ident_av, i + 1, FALSE)))
croak(TT_STASH_PKG " %cet: bad arg. %d", value ? 's' : 'g', i + 1);
if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)
key_args = (AV *) SvRV(*svp);
else
key_args = Nullav;
root = dotop(aTHX_ root, key, key_args, flags);
if (!root || !SvOK(root))
return root;
}
if (value && SvROK(root)) {
/* call assign() to resolve the last item */
if (!(svp = av_fetch(ident_av, size - 1, FALSE)))
croak(TT_STASH_PKG ": set bad ident element at %d", i);
key = *svp;
if (!(svp = av_fetch(ident_av, size, FALSE)))
croak(TT_STASH_PKG ": set bad ident argument at %d", i + 1);
if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)
key_args = (AV *) SvRV(*svp);
else
key_args = Nullav;
return assign(aTHX_ root, key, key_args, value, flags);
}
return root;
}
/* return [ map { s/\(.*$//; ($_, 0) } split(/\./, $str) ];
*/
static AV *convert_dotted_string(pTHX_ const char *str, I32 len) {
AV *av = newAV();
char *buf, *b;
int b_len = 0;
New(0, buf, len + 1, char);
if (!buf)
croak(TT_STASH_PKG ": New() failed for convert_dotted_string");
for(b = buf; len >= 0; str++, len--) {
if (*str == '(') {
for(; (len > 0) && (*str != '.'); str++, len--) ;
}
if ((len < 1) || (*str == '.')) {
*b = '\0';
av_push(av, newSVpv(buf, b_len));
av_push(av, newSViv((IV) 0));
b = buf;
b_len = 0;
} else {
*b++ = *str;
b_len++;
}
}
Safefree(buf);
return (AV *) sv_2mortal((SV *) av);
}
/* performs a generic hash operation identified by 'key'
* (e.g. keys, * values, each) on 'hash'.
* returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise.
*/
static TT_RET hash_op(pTHX_ SV *root, char *key, AV *args, SV **result) {
struct xs_arg *a;
SV *code;
TT_PERF_INIT;
/* look for XS version first */
if ((a = find_xs_op(key)) && a->hash_f) {
TT_PERF_START(hv_op_cnt, hv_op_cnt_xs, key, perf_hv_hit_xs);
*result = a->hash_f(aTHX_ (HV *) SvRV(root), args);
TT_PERF_END;
return TT_RET_CODEREF;
}
/* look for perl version in Template::Stash module */
if ((code = find_perl_op(aTHX_ key, TT_HASH_OPS))) {
TT_PERF_START(hv_op_cnt, hv_op_cnt_pl, key, perf_hv_hit_pl);
*result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ root, args, NULL));
TT_PERF_END;
return TT_RET_CODEREF;
}
/* not found */
TT_PERF_MISS(hv_op_cnt, key, perf_hv_miss);
*result = &PL_sv_undef;
return TT_RET_UNDEF;
}
/* performs a generic list operation identified by 'key' on 'list'.
* Additional arguments may be passed in 'args'.
* returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise.
*/
static TT_RET list_op(pTHX_ SV *root, char *key, AV *args, SV **result) {
struct xs_arg *a;
SV *code;
TT_PERF_INIT;
/* look for and execute XS version first */
if ((a = find_xs_op(key)) && a->list_f) {
TT_PERF_START(av_op_cnt, av_op_cnt_xs, key, perf_av_hit_xs);
*result = a->list_f(aTHX_ (AV *) SvRV(root), args);
TT_PERF_END;
return TT_RET_CODEREF;
}
/* look for and execute perl version in Template::Stash module */
if ((code = find_perl_op(aTHX_ key, TT_LIST_OPS))) {
TT_PERF_START(av_op_cnt, av_op_cnt_pl, key, perf_av_hit_pl);
*result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ root, args, NULL));
TT_PERF_END;
return TT_RET_CODEREF;
}
/* not found */
TT_PERF_MISS(av_op_cnt, key, perf_av_miss);
*result = &PL_sv_undef;
return TT_RET_UNDEF;
}
/* Performs a generic scalar operation identified by 'key'
* on 'sv'. Additional arguments may be passed in 'args'.
* returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise.
*/
static TT_RET scalar_op(pTHX_ SV *sv, char *key, AV *args, SV **result, int flags) {
struct xs_arg *a;
SV *code;
TT_RET retval;
TT_PERF_INIT;
/* look for a XS version first */
if ((a = find_xs_op(key)) && a->scalar_f) {
TT_PERF_START(sv_op_cnt, sv_op_cnt_xs, key, perf_sv_hit_xs);
*result = a->scalar_f(aTHX_ sv, args);
TT_PERF_END;
return TT_RET_CODEREF;
}
/* look for perl version in Template::Stash module */
if ((code = find_perl_op(aTHX_ key, TT_SCALAR_OPS))) {
TT_PERF_START(sv_op_cnt, sv_op_cnt_pl, key, perf_sv_hit_pl);
*result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ sv, args, NULL));
TT_PERF_END;
return TT_RET_CODEREF;
}
/* try upgrading item to a list and look for a list op */
if (!(flags & TT_LVALUE_FLAG)) {
AV *newlist;
SV *listref;
newlist = newAV();
av_push(newlist, sv);
SvREFCNT_inc(sv);
listref = (SV *) newRV_noinc((SV *) newlist);
if ((retval = list_op(aTHX_ listref, key, args, result)) == TT_RET_UNDEF) {
av_undef(newlist);
}
return retval;
}
/* not found */
TT_PERF_MISS(sv_op_cnt, key, perf_sv_miss);
*result = &PL_sv_undef;
return TT_RET_UNDEF;
}
/* xs_arg comparison function */
static int cmp_arg(const void *a, const void *b) {
return (strcmp(((const struct xs_arg *)a)->name,
((const struct xs_arg *)b)->name));
}
/* Searches the xs_arg table for key */
static struct xs_arg *find_xs_op(char *key) {
struct xs_arg *ap, tmp;
tmp.name = key;
if ((ap = (struct xs_arg *)
bsearch(&tmp,
xs_args,
sizeof(xs_args)/sizeof(struct xs_arg),
sizeof(struct xs_arg),
cmp_arg)))
return ap;
return NULL;
}
/* Searches the perl Template::Stash.pm module for ''key'' in the
* hashref named ''perl_var''. Returns SV if found, NULL otherwise.
*/
static SV *find_perl_op(pTHX_ char *key, char *perl_var) {
SV *tt_ops;
SV **svp;
if ((tt_ops = perl_get_sv(perl_var, FALSE))
&& SvROK(tt_ops)
&& (svp = hv_fetch((HV *) SvRV(tt_ops), key, strlen(key), FALSE))
&& SvROK(*svp)
&& SvTYPE(SvRV(*svp)) == SVt_PVCV)
return *svp;
return NULL;
}
/* Returns: @a = ($sv, @av, $more) */
static AV *mk_mortal_av(pTHX_ SV *sv, AV *av, SV *more) {
SV **svp;
AV *a;
I32 i = 0, size;
a = newAV();
av_push(a, SvREFCNT_inc(sv));
if (av && (size = av_len(av)) > -1) {
av_extend(a, size + 1);
for (i = 0; i <= size; i++)
if ((svp = av_fetch(av, i, FALSE)))
if(!av_store(a, i + 1, SvREFCNT_inc(*svp)))
SvREFCNT_dec(*svp);
}
if (more && SvOK(more))
if (!av_store(a, i + 1, SvREFCNT_inc(more)))
SvREFCNT_dec(more);
return (AV *) sv_2mortal((SV *) a);
}
/* Returns TT_DEBUG_FLAG if _DEBUG key is true in hashref ''sv''. */
static int get_debug_flag (pTHX_ SV *sv) {
const char *key = "_DEBUG";
const I32 len = 6;
SV **debug;
if (SvROK(sv)
&& (SvTYPE(SvRV(sv)) == SVt_PVHV)
&& (debug = hv_fetch((HV *) SvRV(sv), (char *) key, len, FALSE))
&& SvOK(*debug)
&& SvTRUE(*debug))
return TT_DEBUG_FLAG;
return 0;
}
/* XS versions of some common dot operations
* ----------------------------------------- */
/* list.first */
static SV *list_dot_first(pTHX_ AV *list, AV *args) {
SV **svp;
if ((svp = av_fetch(list, 0, FALSE))) {
/* entry fetched from arry may be code ref */
if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) {
return call_coderef(aTHX_ *svp, args);
} else {
return *svp;
}
}
return &PL_sv_undef;
}
/* list.join */
static SV *list_dot_join(pTHX_ AV *list, AV *args) {
SV **svp;
SV *item, *retval;
I32 size, i;
STRLEN jlen;
char *joint;
if ((svp = av_fetch(args, 0, FALSE)) != NULL) {
joint = SvPV(*svp, jlen);
} else {
joint = " ";
jlen = 1;
}
retval = newSVpvn("", 0);
size = av_len(list);
for (i = 0; i <= size; i++) {
if ((svp = av_fetch(list, i, FALSE)) != NULL) {
item = *svp;
if (SvROK(item) && SvTYPE(SvRV(item)) == SVt_PVCV) {
item = call_coderef(aTHX_ *svp, args);
sv_catsv(retval, item);
} else {
sv_catsv(retval, item);
}
if (i != size)
sv_catpvn(retval, joint, jlen);
}
}
return sv_2mortal(retval);
}
/* list.last */
static SV *list_dot_last(pTHX_ AV *list, AV *args) {
SV **svp;
if ((av_len(list) > -1)
&& (svp = av_fetch(list, av_len(list), FALSE))) {
/* entry fetched from arry may be code ref */
if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) {
return call_coderef(aTHX_ *svp, args);
} else {
return *svp;
}
}
return &PL_sv_undef;
}
/* list.max */
static SV *list_dot_max(pTHX_ AV *list, AV *args) {
return sv_2mortal(newSViv((IV) av_len(list)));
}
/* list.reverse */
static SV *list_dot_reverse(pTHX_ AV *list, AV *args) {
SV **svp;
AV *result = newAV();
I32 size, i;
if ((size = av_len(list)) >= 0) {
av_extend(result, size + 1);
for (i = 0; i <= size; i++) {
if ((svp = av_fetch(list, i, FALSE)) != NULL)
if (!av_store(result, size - i, SvREFCNT_inc(*svp)))
SvREFCNT_dec(*svp);
}
}
return sv_2mortal((SV *) newRV_noinc((SV *) result));
}
/* list.size */
static SV *list_dot_size(pTHX_ AV *list, AV *args) {
return sv_2mortal(newSViv((IV) av_len(list) + 1));
}
/* hash.each */
static SV *hash_dot_each(pTHX_ HV *hash, AV *args) {
AV *result = newAV();
HE *he;
hv_iterinit(hash);
while ((he = hv_iternext(hash))) {
av_push(result, SvREFCNT_inc((SV *) hv_iterkeysv(he)));
av_push(result, SvREFCNT_inc((SV *) hv_iterval(hash, he)));
}
return sv_2mortal((SV *) newRV_noinc((SV *) result));
}
/* hash.keys */
static SV *hash_dot_keys(pTHX_ HV *hash, AV *args) {
AV *result = newAV();
HE *he;
hv_iterinit(hash);
while ((he = hv_iternext(hash)))
av_push(result, SvREFCNT_inc((SV *) hv_iterkeysv(he)));
return sv_2mortal((SV *) newRV_noinc((SV *) result));
}
/* hash.values */
static SV *hash_dot_values(pTHX_ HV *hash, AV *args) {
AV *result = newAV();
HE *he;
hv_iterinit(hash);
while ((he = hv_iternext(hash)))
av_push(result, SvREFCNT_inc((SV *) hv_iterval(hash, he)));
return sv_2mortal((SV *) newRV_noinc((SV *) result));
}
/* scalar.defined */
static SV *scalar_dot_defined(pTHX_ SV *sv, AV *args) {
return &PL_sv_yes;
}
/* scalar.length */
static SV *scalar_dot_length(pTHX_ SV *sv, AV *args) {
STRLEN length;
SvPV(sv, length);
return sv_2mortal(newSViv((IV) length));
}
/*====================================================================
* XS SECTION
*====================================================================*/
MODULE = Template::Stash::XS PACKAGE = Template::Stash::XS
PROTOTYPES: DISABLED
#-----------------------------------------------------------------------
# get(SV *root, SV *ident, SV *args)
#-----------------------------------------------------------------------
SV *
get(root, ident, ...)
SV *root
SV *ident
CODE:
AV *args;
int flags = get_debug_flag(aTHX_ root);
STRLEN len;
char *str;
/* look for a list ref of arguments, passed as third argument */
args =
(items > 2 && SvROK(ST(2)) && SvTYPE(SvRV(ST(2))) == SVt_PVAV)
? (AV *) SvRV(ST(2)) : Nullav;
if (SvROK(ident) && (SvTYPE(SvRV(ident)) == SVt_PVAV)) {
RETVAL = do_getset(aTHX_ root, (AV *) SvRV(ident), NULL, flags);
} else if (SvROK(ident)) {
croak(TT_STASH_PKG ": get (arg 2) must be a scalar or listref");
} else if ((str = SvPV(ident, len)) && memchr(str, '.', len)) {
/* convert dotted string into an array */
AV *av = convert_dotted_string(aTHX_ str, len);
RETVAL = do_getset(aTHX_ root, av, NULL, flags);
av_undef(av);
} else {
/* otherwise ident is a scalar so we call dotop() just once */
RETVAL = dotop(aTHX_ root, ident, args, flags);
}
if (!SvOK(RETVAL))
RETVAL = newSVpvn("", 0); /* new empty string */
else
RETVAL = SvREFCNT_inc(RETVAL);
OUTPUT:
RETVAL
#-----------------------------------------------------------------------
# set(SV *root, SV *ident, SV *value, SV *deflt)
#-----------------------------------------------------------------------
SV *
set(root, ident, value, ...)
SV *root
SV *ident
SV *value
CODE:
int flags = get_debug_flag(aTHX_ root);
STRLEN len;
char *str;
/* check default flag passed as fourth argument */
flags |= ((items > 3) && SvTRUE(ST(3))) ? TT_DEFAULT_FLAG : 0;
if (SvROK(ident) && (SvTYPE(SvRV(ident)) == SVt_PVAV)) {
RETVAL = do_getset(aTHX_ root, (AV *) SvRV(ident), value, flags);
} else if (SvROK(ident)) {
croak(TT_STASH_PKG ": set (arg 2) must be a scalar or listref");
} else if ((str = SvPV(ident, len)) && memchr(str, '.', len)) {
/* convert dotted string into a temporary array */
AV *av = convert_dotted_string(aTHX_ str, len);
RETVAL = do_getset(aTHX_ root, av, value, flags);
av_undef(av);
} else {
/* otherwise a simple scalar so call assign() just once */
RETVAL = assign(aTHX_ root, ident, Nullav, value, flags);
}
if (!SvOK(RETVAL))
RETVAL = newSVpvn("", 0); /* new empty string */
else
RETVAL = SvREFCNT_inc(RETVAL);
OUTPUT:
RETVAL
#-----------------------------------------------------------------------
# performance() - returns a summary of Stash & method call performance
#-----------------------------------------------------------------------
SV *
performance(verbose)
SV *verbose
CODE:
#ifdef TT_PERF_ENABLE
I32 a, b, c;
double total_time, sys_time;
long max_rss;
perf_out.cpu_time = get_cpu_usage(&sys_time, &max_rss);
total_time = sys_time + perf_out.cpu_time;
perf_out.outsv = newSVpvf(
TT_STASH_PKG " " XS_VERSION " - Performance Summary for PID %d\n"
"===================================================================\n"
"CPU: User: %.2fs + System: %.2fs = Total: %.2fs, RSS: %ldKB\n\n",
(int) getpid(), perf_out.cpu_time, sys_time, total_time, max_rss);
if (SvTRUE(verbose)) {
sv_catpvf(perf_out.outsv,
"Method/Virtual Method Type # Calls User CPU sec/Call %CPU\n"
"------------------------ --------- -------- --------- -------- ----\n"
);
/* avoid division by 0 */
if (perf_out.cpu_time < 0.0001) perf_out.cpu_time = 1.0;
dump_all_perf(perf_hist, &perf_out);
sv_catpvf(perf_out.outsv, "\n\n");
}
a = hv_op_cnt + av_op_cnt + sv_op_cnt;
b = hv_op_cnt_xs + av_op_cnt_xs + sv_op_cnt_xs;
c = hv_op_cnt_pl + av_op_cnt_pl + sv_op_cnt_pl;
sv_catpvf(perf_out.outsv,
"Virtual Method XS + PL + Missing = Total Calls\n"
"-------------- -------- -------- -------- -----------\n"
"Array (AV) %10d %10d %10d %12d\n"
"Hash (HV) %10d %10d %10d %12d\n"
"Scalar (SV) %10d %10d %10d %12d\n"
"TOTAL %10d %10d %10d %12d\n\n",
av_op_cnt_xs,
av_op_cnt_pl,
av_op_cnt - (av_op_cnt_xs + av_op_cnt_pl),
av_op_cnt,
hv_op_cnt_xs,
hv_op_cnt_pl,
hv_op_cnt - (hv_op_cnt_xs + hv_op_cnt_pl),
hv_op_cnt,
sv_op_cnt_xs,
sv_op_cnt_pl,
sv_op_cnt - (sv_op_cnt_xs + sv_op_cnt_pl),
sv_op_cnt,
b,
c,
a - (b + c),
a);
RETVAL = perf_out.outsv;
#else
char *msg = "Profiling was not enabled in " TT_STASH_PKG
"(Stash.xs)\n#define TT_PERF_ENABLE and rebuild.\n";
verbose = verbose; /* avoid compiler warning */
RETVAL = newSVpvn(msg, strlen(msg));
#endif /* TT_PERF_ENABLE */
OUTPUT:
RETVAL
#-----------------------------------------------------------------------
# cvsid() - returns cvs id tag for this file
#-----------------------------------------------------------------------
SV *
cvsid()
CODE:
RETVAL = newSVpvn(rcsid, strlen(rcsid));
OUTPUT:
RETVAL