PApp
view release on metacpan or search on metacpan
}
else
{
elem = find_path (arg, &hash);
sv = *hv_fetch (hash, elem, SvEND (arg) - elem, 1);
}
return sv;
}
/* do path resolution. not much yet. */
static SV *
expand_path (char *path, STRLEN pathlen, char *cwd, STRLEN cwdlen)
{
SV *res = newSV (0);
if (*path == '-')
{
sv_catpvn (res, path, 1);
path++; pathlen--;
}
if (*path != '/')
croak ("relative state paths no longer supported, downgrade to PApp 1.x");
sv_catpvn (res, path, pathlen);
return res;
}
#define surl_expand_path(path,pathlen) expand_path ((path), (pathlen), 0, 0)
/* checks wether this surl argument is a single arg (1) or key->value (0) */
/* should be completely pluggable, i.e. by subclassing/calling PApp::SURL->gen */
#define SURL_NOARG(sv) (SvROK (sv) && (sv_isa (sv, "PApp::Callback::Function") \
|| sv_isa (sv, "Agni::Callback")))
/*****************************************************************************/
MODULE = PApp PACKAGE = PApp
BOOT:
{
cipher_e = gv_fetchpv ("PApp::cipher_e" , TRUE, SVt_PV);
location = gv_fetchpv ("PApp::location" , TRUE, SVt_PV);
big_p = gv_fetchpv ("PApp::P" , TRUE, SVt_PV);
state = gv_fetchpv ("PApp::state" , TRUE, SVt_PV);
arguments = gv_fetchpv ("PApp::arguments" , TRUE, SVt_PV);
userid = gv_fetchpv ("PApp::userid" , TRUE, SVt_IV);
stateid = gv_fetchpv ("PApp::stateid" , TRUE, SVt_IV);
sessionid = gv_fetchpv ("PApp::sessionid" , TRUE, SVt_IV);
surlstyle = gv_fetchpv ("PApp::surlstyle" , TRUE, SVt_IV);
}
# the most complex piece of shit
void
surl(...)
PROTOTYPE: @
ALIAS:
salternative = 1
PPCODE:
{
int i;
UV xalternative;
SV *surl;
AV *args = newAV ();
SV *path = 0;
char *svp; STRLEN svl;
int style = 1;
if (SvIOK (GvSV (surlstyle)))
style = SvIV (GvSV (surlstyle));
{
int has_module = items;
int j;
for (j = 0; j < items; j++)
if (SURL_NOARG (ST(j)))
has_module++;
has_module &= 1;
if (has_module)
croak ("surl no longer supports module arguments, downgrade to PApp 1.x");
}
for (; i < items; i++)
{
SV *arg = ST(i);
if (SURL_NOARG (arg))
{
/* SURL_EXEC() */
av_push (args, newSVpvn ("\x00\x01", 2));
av_push (args, NEWSV (0,0));
av_push (args, newSVpv ("/papp_execonce", 0));
av_push (args, SvREFCNT_inc (arg));
}
else
{
SV *val = ST(i+1);
i++;
if (SvROK (arg))
{
if (!sv_is_scalar_type (SvRV (arg)))
croak ("surl: tried to assign scalar to non-scalar reference (e.g. 'surl \\@x => 5')");
arg = newSVsv (arg);
val = newSVsv (val);
}
else if (SvPOK (arg) && SvCUR (arg) == 2 && !*SvPV_nolen (arg))
/* do not expand SURL_xxx constants */
{
int surlmod = (unsigned char)SvPV_nolen (arg)[1];
if (surlmod == SURL_STYLE)
{
style = SvIV (val);
continue;
}
if (surlmod == SURL_POP || surlmod == SURL_SHIFT)
{
AV *av = rv2av (find_keysv (val, 0));
if (av && av_len (av) >= 0)
{
if (surlmod == SURL_POP)
SvREFCNT_dec (av_pop (av));
else
SvREFCNT_dec (av_shift (av));
}
}
else if (surlmod == SURL_EXEC_IMMED)
{
PUSHMARK (SP); PUTBACK;
call_sv (val, G_VOID | G_DISCARD);
SPAGAIN;
}
else
croak ("set_alternative: unsupported surlmod (%02x)", surlmod);
}
else
flags |= surlmod;
}
else
{
SV *sv = find_keysv (arg, !flags && !SvOK (val));
if (sv)
{
int arrayop = flags & 3;
if (arrayop)
{
AV *av = rv2av (sv);
if (arrayop == SURL_PUSH)
av_push (av, SvREFCNT_inc (val));
else if (arrayop == SURL_UNSHIFT)
{
av_unshift (av, 1);
if (!av_store (av, 0, SvREFCNT_inc (val)))
SvREFCNT_dec (val);
}
else
croak ("illegal arrayop in set_alternative");
}
else
sv_setsv_mg (sv, val);
}
flags = 0;
}
}
}
void
find_path (path)
SV * path
PROTOTYPE: $
PPCODE:
HV *hash;
char *elem = find_path (path, &hash);
EXTEND (SP, 2);
PUSHs (sv_2mortal (newRV_inc ((SV *)hash)));
PUSHs (sv_2mortal (newSVpv (elem, 0)));
SV *
modpath_freeze(modules)
SV * modules
PROTOTYPE: $
CODE:
RETVAL = modpath_freeze (modules);
OUTPUT:
RETVAL
SV *
modpath_thaw(modulepath)
SV * modulepath
PROTOTYPE: $
CODE:
char *src, *end;
STRLEN dc;
src = SvPV (modulepath, dc);
end = src + dc;
RETVAL = newRV_noinc ((SV *)modpath_thaw (&src, end));
OUTPUT:
RETVAL
# destroy %P, %S and %state, but do not call DESTROY
# TODO: why %P here and not in update_state?
void
_destroy_state()
CODE:
HV *hv = PL_defstash;
PL_defstash = 0;
hv_clear (GvHV (state));
PL_defstash = hv;
hv_clear (GvHV (big_p));
void
_set_params(...)
CODE:
int i;
HV *hv = GvHV (big_p);
for (i = 1; i < items; i += 2)
{
STRLEN klen;
char *key = SvPV (ST(i-1), klen);
SV *val = SvREFCNT_inc (ST(i));
SV **ent = hv_fetch (hv, key, klen, 0);
if (ent)
{
if (SvROK (*ent))
av_push ((AV *)SvRV (*ent), val);
else
uchar buf[8];
pack64 (buf, v, ix);
RETVAL = newSVpvn(buf, 8);
OUTPUT:
RETVAL
BOOT:
compute_hash (CACHEp , CACHEl , &CACHEs , &CACHEh);
compute_hash (TYPEp , TYPEl , &TYPEs , &TYPEh);
compute_hash (ATTRp , ATTRl , &ATTRs , &ATTRh);
compute_hash (PATHp , PATHl , &PATHs , &PATHh);
compute_hash (GIDp , GIDl , &GIDs , &GIDh);
compute_hash (INSTANCEp, INSTANCEl, &INSTANCEs, &INSTANCEh);
SV *
agnibless(SV *rv, char *classname)
CODE:
HV *hv = (HV *)SvRV (rv);
sv_unmagic ((SV *)hv, PERL_MAGIC_tied);
RETVAL = newSVsv (sv_bless (rv, gv_stashpv(classname, TRUE)));
if (!hv_fetch_ent (hv, ATTRs, 0, ATTRh))
hv_store_ent (hv, ATTRs, newRV_noinc ((SV *)newHV ()), ATTRh);
if (!hv_fetch_ent (hv, TYPEs, 0, TYPEh))
hv_store_ent (hv, TYPEs, newRV_noinc ((SV *)newHV ()), TYPEh);
if (!hv_fetch_ent (hv, CACHEs, 0, CACHEh))
hv_store_ent (hv, CACHEs, newRV_noinc ((SV *)newHV ()), CACHEh);
sv_magicext ((SV *)hv, Nullsv, PERL_MAGIC_tied, &vtbl_agni_object, Nullch, 0);
OUTPUT:
RETVAL
void
rmagical_off(SV *rv)
ALIAS:
rmagical_on = 1
CODE:
if (ix)
SvRMAGICAL_on (SvRV (rv));
else
SvRMAGICAL_off (SvRV (rv));
void
isobject(SV *rv)
CODE:
if (sv_isobject (rv))
XSRETURN_YES;
else
XSRETURN_NO;
void
obj_of (SV *ref)
PROTOTYPE: $
PPCODE:
if (SvROK (ref) && SvMAGICAL (SvRV (ref)))
{
MAGIC *mg = mg_find (SvRV (ref), PERL_MAGIC_tiedelem);
if (mg && mg->mg_obj)
{
XPUSHs (newSVsv (mg->mg_obj));
XSRETURN (1);
}
}
XPUSHs (&PL_sv_undef);
XSRETURN (1);
SV *
_data_special_key (SV *self, SV *obj)
CODE:
if (sv_isobject (self) && sv_isobject (obj))
{
uchar k[8+8];
HV *shv = (HV *)SvRV (self);
SvRMAGICAL_off (shv);
pack64_be (k, SvUV (HeVAL (hv_fetch_ent (shv, GIDs, 0, GIDh))));
SvRMAGICAL_on (shv);
if (SvTRUE (HeVAL (hv_fetch_ent (shv, INSTANCEs, 0, INSTANCEh))))
{
HV *ohv = (HV *)SvRV (obj);
SvRMAGICAL_off (ohv);
pack64_be (k + 8, SvUV (HeVAL (hv_fetch_ent (ohv, GIDs, 0, GIDh))));
SvRMAGICAL_on (ohv);
RETVAL = newSVpvn (k, 16);
}
else
{
RETVAL = newSVpvn (k, 8);
}
}
else
croak ("_data_special_key must be called with two references");
OUTPUT:
RETVAL
MODULE = PApp PACKAGE = agni::object
void
DESTROY(SV *rv)
CODE:
/* turn magic off before destruction, to ease perls job */
SvRMAGICAL_off (SvRV (rv));
void
FETCH(SV *self, SV *key)
PPCODE:
agni_try_patch (Perl_pp_helem, agni_fetch_op);
{
SV *ret;
PUTBACK;
ret = agni_fetch (self, key);
SPAGAIN;
if (ret)
XPUSHs (ret);
}
void
STORE(SV *self, SV *key, SV *value)
PPCODE:
/*agni_try_patch (Perl_pp_helem, agni_store_op);*/
PUTBACK;
agni_store (self, key, value);
SPAGAIN;
void
EXISTS(SV *self, SV *key)
PPCODE:
HV *hv = (HV*) SvRV (self);
HV *hvt;
char *key_ = SvPV_nolen (key);
SvRMAGICAL_off (hv);
/* check _-keys in $self and non-_-keys in $self->{_type} */
if (key_[0] == '_')
hvt = hv;
else if (key_[0] >= '1' && key_[0] <= '9')
hvt = (HV *)SvRV (*(hv_fetch (hv, ATTRp, ATTRl, 0)));
else
hvt = (HV *)SvRV (*(hv_fetch (hv, TYPEp, TYPEl, 0)));
XPUSHs (sv_2mortal (newSViv (hv_exists_ent (hvt, key, 0))));
SvRMAGICAL_on (hv);
void
DELETE(SV *self, SV *key)
PPCODE:
HV *hv = (HV*) SvRV (self);
char *key_ = SvPV_nolen (key);
SV *value;
SvRMAGICAL_off (hv);
if (key_[0] != '_' || 1)
{
value = hv_delete_ent (hv, key, 0, 0);
if (value)
XPUSHs (value);
}
SvRMAGICAL_on (hv);
void
NEXTKEY(self, ...)
SV * self
ALIAS:
FIRSTKEY = 1
PPCODE:
HV *hv = (HV*) SvRV (self);
HV *hvt;
HE *he;
SvRMAGICAL_off (hv);
hvt = (HV *)SvRV (*(hv_fetch (hv, TYPEp, TYPEl, 0)));
if (ix)
hv_iterinit (hvt);
he = hv_iternext (hvt);
if (he)
XPUSHs (hv_iterkeysv (he));
SvRMAGICAL_on (hv);
( run in 0.914 second using v1.01-cache-2.11-cpan-5511b514fd6 )