void fatal(const char *f, ...)
{
dTHX;
va_list l;
SV *sv = newSVpvn("", 0);
va_start(l, f);
sv_catpv(sv,
"============================================\n"
" FATAL ERROR in " XSCLASS "!\n"
"--------------------------------------------\n"
);
sv_vcatpvf(sv, f, &l);
sv_catpv(sv,
"\n"
"--------------------------------------------\n"
" please report this error to [email protected]\n"
"============================================\n"
);
va_end(l);
fprintf(stderr, "%s", SvPVX(sv));
SvREFCNT_dec(sv);
abort();
}
static const StringOption *get_string_option(pTHX_ const StringOption *options,
int count, int value, SV *sv, const char *name)
{
char *string = NULL;
if (sv)
{
if (SvROK(sv))
Perl_croak(aTHX_ "%s must be a string value, not a reference", name);
else
string = SvPV_nolen(sv);
}
if (string)
{
const StringOption *opt = options;
int n = count;
while (n--)
{
if (strEQ(string, opt->string))
return opt;
opt++;
}
if (name)
{
SV *str = sv_2mortal(newSVpvn("", 0));
for (n = 0; n < count; n++)
{
sv_catpv(str, CONST_CHAR((options++)->string));
if (n < count-2)
sv_catpv(str, "', '");
else if (n == count-2)
sv_catpv(str, "' or '");
}
Perl_croak(aTHX_ "%s must be '%s', not '%s'", name, SvPV_nolen(str), string);
}
}
else
{
while (count--)
{
if (value == options->value)
return options;
options++;
}
fatal("Inconsistent data detected in get_string_option()!");
}
return NULL;
}
void CroakOptsHash(char * name, char * value, HV * o)
{
dTHR;
SV * result = sv_newmortal();
HE * he;
int i=0;
sv_catpv(result, "invalid ");
sv_catpv(result, name);
sv_catpv(result, " ");
sv_catpv(result, value);
sv_catpv(result, ", expecting");
hv_iterinit(o);
he = hv_iternext(o);
while(he) {
I32 len;
char * key = hv_iterkey(he, &len);
he = hv_iternext(o);
if (i==0)
sv_catpv(result," '");
else if (he)
sv_catpv(result,"', '");
else
sv_catpv(result,"', or '");
i=1;
sv_catpvn(result, key, len);
}
sv_catpv(result,"'");
croak(SvPV(result, PL_na));
}
int modperl_require_module(pTHX_ const char *pv, int logfailure)
{
SV *sv;
dSP;
PUSHSTACKi(PERLSI_REQUIRE);
ENTER;SAVETMPS;
PUTBACK;
sv = sv_newmortal();
sv_setpv(sv, "require ");
sv_catpv(sv, pv);
eval_sv(sv, G_DISCARD);
SPAGAIN;
POPSTACK;
FREETMPS;LEAVE;
if (SvTRUE(ERRSV)) {
if (logfailure) {
(void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
NULL, NULL);
}
return FALSE;
}
return TRUE;
}
void CroakOpts(char * name, char * value, struct opts * o)
{
dTHR;
SV * result = sv_newmortal();
int i;
sv_catpv(result, "invalid ");
sv_catpv(result, name);
sv_catpv(result, " ");
sv_catpv(result, value);
sv_catpv(result, ", expecting");
for(i=0;o[i].name;i++) {
if (i==0)
sv_catpv(result," '");
else if (o[i+1].name)
sv_catpv(result,"', '");
else
sv_catpv(result,"', or '");
sv_catpv(result, o[i].name);
}
sv_catpv(result,"'");
croak(SvPV(result, PL_na));
}
static
SV* truststring(unsigned long siglvl)
{
SV *str;
if(!(siglvl & MASK_ENABLE)){
return newSVpv("never", 0);
}else if(!(~siglvl & MASK_OPT)){
str = newSVpv("optional", 0);
}else{
str = newSVpv("required", 0);
}
if(!(~siglvl & MASK_TRUSTALL)){
sv_catpv(str, " trustall");
}
return str;
}
long SvEFValueLookup (GtkEnumValue * vals, char* name, GtkType type) {
GtkEnumValue *v;
dTHR;
if (!name)
croak("Need a value in lookup");
if (*name == '-')
name++;
v = vals;
while (v && v->value_nick) {
if (hystrEQ(name, v->value_nick))
return v->value;
v++;
}
{
SV * r;
char * endc=NULL;
long val;
/* last chanche: integer value... */
val = strtol(name, &endc, 0);
if (*name && endc && *endc == '\0')
return val;
v = vals;
r = sv_newmortal();
sv_catpv(r, "invalid ");
sv_catpv(r, gtk_type_name(type));
sv_catpv(r, " value ");
sv_catpv(r, name);
sv_catpv(r, ", expecting: ");
while (v && v->value_nick) {
sv_catpv(r, v->value_nick);
if (++v)
sv_catpv(r, ", ");
}
croak(SvPV(r, PL_na));
return 0;
}
}
SV *single_hook_call(pTHX_ SV *self, const char *hook_id_str, const char *id_pre,
const char *id, const SingleHook *hook, SV *in, int mortal)
{
dSP;
int count;
SV *out;
CT_DEBUG(MAIN, ("single_hook_call(hid='%s', id='%s%s', hook=%p, in=%p(%d), mortal=%d)",
hook_id_str, id_pre, id, hook, in, in ? (int) SvREFCNT(in) : 0, mortal));
assert(self != NULL);
assert(hook != NULL);
if (hook->sub == NULL)
return in;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (hook->arg)
{
I32 ix, len;
len = av_len(hook->arg);
for (ix = 0; ix <= len; ++ix)
{
SV **pSV = av_fetch(hook->arg, ix, 0);
SV *sv;
if (pSV == NULL)
fatal("NULL returned by av_fetch() in single_hook_call()");
if (SvROK(*pSV) && sv_isa(*pSV, ARGTYPE_PACKAGE))
{
HookArgType type = (HookArgType) SvIV(SvRV(*pSV));
switch (type)
{
case HOOK_ARG_SELF:
sv = sv_mortalcopy(self);
break;
case HOOK_ARG_DATA:
assert(in != NULL);
sv = sv_mortalcopy(in);
break;
case HOOK_ARG_TYPE:
assert(id != NULL);
sv = sv_newmortal();
if (id_pre)
{
sv_setpv(sv, id_pre);
sv_catpv(sv, CONST_CHAR(id));
}
else
sv_setpv(sv, id);
break;
case HOOK_ARG_HOOK:
if (hook_id_str)
{
sv = sv_newmortal();
sv_setpv(sv, hook_id_str);
}
else
{
sv = &PL_sv_undef;
}
break;
default:
fatal("Invalid hook argument type (%d) in single_hook_call()", type);
break;
}
}
else
sv = sv_mortalcopy(*pSV);
XPUSHs(sv);
}
}
else
{
if (in)
{
/* only push the data argument */
XPUSHs(in);
}
}
PUTBACK;
count = call_sv(hook->sub, G_SCALAR);
SPAGAIN;
if (count != 1)
fatal("Hook returned %d elements instead of 1", count);
out = POPs;
CT_DEBUG(MAIN, ("single_hook_call: in=%p(%d), out=%p(%d)",
in, in ? (int) SvREFCNT(in) : 0, out, (int) SvREFCNT(out)));
if (!mortal && in != NULL)
SvREFCNT_dec(in);
SvREFCNT_inc(out);
PUTBACK;
FREETMPS;
LEAVE;
if (mortal)
sv_2mortal(out);
CT_DEBUG(MAIN, ("single_hook_call: out=%p(%d)", out, (int) SvREFCNT(out)));
return out;
}
static int load_indexed_hash_module_ex(pTHX_ CBC *THIS, const char **modlist, int num)
{
const char *p = NULL;
int i;
if (THIS->ixhash != NULL)
{
/* a module has already been loaded */
return 1;
}
for (i = 0; i < num; i++)
{
if (modlist[i])
{
SV *sv = newSVpvn("require ", 8);
sv_catpv(sv, CONST_CHAR(modlist[i]));
CT_DEBUG(MAIN, ("trying to require \"%s\"", modlist[i]));
(void) eval_sv(sv, G_DISCARD);
SvREFCNT_dec(sv);
if ((sv = get_sv("@", 0)) != NULL && strEQ(SvPV_nolen(sv), ""))
{
p = modlist[i];
break;
}
if (i == 0)
{
Perl_warn(aTHX_ "Couldn't load %s for member ordering, "
"trying default modules", modlist[i]);
}
CT_DEBUG(MAIN, ("failed: \"%s\"", sv ? SvPV_nolen(sv) : "[NULL]"));
}
}
if (p == NULL)
{
SV *sv = newSVpvn("", 0);
for (i = 1; i < num; i++)
{
if (i > 1)
{
if (i == num-1)
sv_catpvn(sv, " or ", 4);
else
sv_catpvn(sv, ", ", 2);
}
sv_catpv(sv, CONST_CHAR(modlist[i]));
}
Perl_warn(aTHX_ "Couldn't load a module for member ordering "
"(consider installing %s)", SvPV_nolen(sv));
return 0;
}
CT_DEBUG(MAIN, ("using \"%s\" for member ordering", p));
THIS->ixhash = p;
return 1;
}
