static SV *coroae_add_signal_watcher(const char *signame, CV *cb) {
SV *newobj;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
mXPUSHs(newSVpvs("AnyEvent"));
mXPUSHs(newSVpvs("signal"));
mXPUSHs(newSVpv(signame, 0));
mXPUSHs(newSVpvs("cb"));
mXPUSHs(newRV_noinc((SV *)cb));
PUTBACK;
call_method("signal", G_SCALAR|G_EVAL);
SPAGAIN;
if(SvTRUE(ERRSV)) {
// no need to continue...
uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV));
exit(1);
}
else {
newobj = SvREFCNT_inc(POPs);
}
PUTBACK;
FREETMPS;
LEAVE;
return newobj;
}
MAGIC *find_shadow_magic(SV *p6cb, SV *static_class, SV *obj) {
SV * const obj_deref = SvRV(obj);
MAGIC * mg = mg_find(obj_deref, '~');
if (mg == NULL || ((_perl6_magic*)(mg->mg_ptr))->key != PERL6_EXTENSION_MAGIC_KEY) {
/* need to create the shadow object here */
AV * method_args = newAV();
SV * method_args_rv = newRV_noinc((SV *) method_args);
av_extend(method_args, 1);
SvREFCNT_inc(obj);
av_store(method_args, 0, obj);
AV * args = newAV();
av_extend(args, 3);
SvREFCNT_inc(static_class);
av_store(args, 0, static_class);
av_store(args, 1, newSVpvs("new_shadow_of_p5_object"));
av_store(args, 2, method_args_rv);
MAGIC * const p6cb_mg = mg_find(SvRV(p6cb), '~');
_perl6_magic* const p6cb_p6mg = (_perl6_magic*)(p6cb_mg->mg_ptr);
SV *err = NULL;
SV * const args_rv = newRV_noinc((SV *) args);
declare_cbs;
cbs->call_p6_method(p6cb_p6mg->index, "invoke", 1, args_rv, &err);
SvREFCNT_dec(args_rv);
handle_p6_error(err);
mg = mg_find(obj_deref, '~');
}
return mg;
}
// create a new coro
SV * coroae_coro_new(CV *block) {
SV *newobj = NULL;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
mXPUSHs(newSVpvs("Coro"));
mXPUSHs(newRV_noinc((SV *)block));
PUTBACK;
call_method("new", G_SCALAR|G_EVAL);
SPAGAIN;
if(SvTRUE(ERRSV)) {
uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV));
(void)POPs; // we must pop undef from the stack in G_SCALAR context
}
else {
newobj = SvREFCNT_inc(POPs);
}
PUTBACK;
FREETMPS;
LEAVE;
return newobj;
}
void _parse_header(pTHX_ srl_splitter_t *splitter) {
int magic_string = 1;
int high_magic_string = 1;
U8 version_encoding;
U8 version;
U8 encoding_flags;
UV header_len;
int is_zlib_encoded = 0;
int is_snappy_encoded = 0;
int is_snappyincr_encoded = 0;
// SRL_MAGIC_STRLEN + PROTOCOL_LENGTH + OPTIONAL-HEADER-SIZE(at least 1 byte) + DATA(at least 1 byte)
if (splitter->input_len < SRL_MAGIC_STRLEN + 1 + 1 + 1){
croak("input Sereal string lacks data");
} else if ( (high_magic_string = strncmp(splitter->input_str, SRL_MAGIC_STRING, SRL_MAGIC_STRLEN))
&& (magic_string = strncmp(splitter->input_str, SRL_MAGIC_STRING_HIGHBIT, SRL_MAGIC_STRLEN)) ) {
croak("input Sereal string has wrong Sereal magic");
}
splitter->pos += SRL_MAGIC_STRLEN;
version_encoding = (U8)*(splitter->pos);
version = (U8)(version_encoding & SRL_PROTOCOL_VERSION_MASK);
encoding_flags = (U8)(version_encoding & SRL_PROTOCOL_ENCODING_MASK);
if ( version <= 0
|| ( version < 3 && high_magic_string )
|| ( version > 2 && magic_string ) ) {
croak("unsupported Sereal versions/protocol");
}
switch(encoding_flags) {
case SRL_PROTOCOL_ENCODING_RAW:
/* no op */
SRL_SPLITTER_TRACE("encoding is raw %s", "");
break;
case SRL_PROTOCOL_ENCODING_SNAPPY:
SRL_SPLITTER_TRACE("encoding is snappy %s", "");
is_snappy_encoded = 1;
break;
case SRL_PROTOCOL_ENCODING_SNAPPY_INCREMENTAL:
SRL_SPLITTER_TRACE("encoding is snappy incr %s", "");
is_snappy_encoded = is_snappyincr_encoded = 1;
break;
case SRL_PROTOCOL_ENCODING_ZLIB:
SRL_SPLITTER_TRACE("encoding is zlib %s", "");
is_zlib_encoded = 1;
break;
default:
croak("Sereal document encoded in an unknown format");
}
SRL_SPLITTER_TRACE("header version is %hhu", version);
// move after protocol version
splitter->pos += 1;
header_len= _read_varint_uv_nocheck(splitter);
SRL_SPLITTER_TRACE("header len is %lu", header_len);
//TODO: add code for processing the header
splitter->pos += header_len;
if (version < 2) {
splitter->input_body_pos = splitter->input_str;
} else {
splitter->input_body_pos = splitter->pos;
}
if (is_snappy_encoded) {
UV compressed_len;
uint32_t uncompressed_len;
int decompress_ok;
char * new_input_str;
if (is_snappyincr_encoded) {
compressed_len = _read_varint_uv_nocheck(splitter);
} else {
compressed_len = splitter->input_len - (splitter->pos - splitter->input_str);
}
SRL_SPLITTER_TRACE("snappy compressed len %"UVuf, compressed_len);
// splitter->pos is now at start of compressed payload
int snappy_header_len;
char *old_pos;
old_pos = splitter->pos;
snappy_header_len = csnappy_get_uncompressed_length(
(char *)old_pos,
compressed_len,
&uncompressed_len
);
if (snappy_header_len == CSNAPPY_E_HEADER_BAD) {
croak("invalid Snappy header in Snappy-compressed Sereal packet");
}
// allocate a new SV for uncompressed data
SvREFCNT_dec(splitter->input_sv);
splitter->input_sv = newSVpvs("");
new_input_str = SvGROW(splitter->input_sv, uncompressed_len);
decompress_ok = csnappy_decompress_noheader((char *) (old_pos + snappy_header_len),
compressed_len - snappy_header_len,
(char *) new_input_str,
&uncompressed_len);
if ( decompress_ok != 0 ) {
croak("Snappy decompression of Sereal packet payload failed");
}
splitter->input_str = new_input_str;
SRL_SPLITTER_TRACE(" decompress OK: uncompressed length: %d\n", uncompressed_len);
splitter->pos = splitter->input_str;;
splitter->input_len = uncompressed_len;
splitter->input_body_pos = splitter->pos;
} else if (is_zlib_encoded) {
UV uncompressed_len = _read_varint_uv_nocheck(splitter);
UV compressed_len = _read_varint_uv_nocheck(splitter);
char * new_input_str;
// splitter->pos is now at start of compressed payload
SRL_SPLITTER_TRACE("unzipping %s", "");
SRL_SPLITTER_TRACE("compressed_len : %" UVuf, compressed_len);
SRL_SPLITTER_TRACE("uncompressed_len : %" UVuf, uncompressed_len);
mz_ulong tmp = uncompressed_len;
// allocate a new SV for uncompressed data
SvREFCNT_dec(splitter->input_sv);
splitter->input_sv = newSVpvs("");
new_input_str = SvGROW(splitter->input_sv, uncompressed_len);
char *compressed = splitter->pos;
int decompress_ok = mz_uncompress( (unsigned char *) new_input_str,
&tmp,
(const unsigned char *) compressed,
compressed_len );
if (decompress_ok != Z_OK)
croak("ZLIB decompression of Sereal packet payload failed");
splitter->input_str = new_input_str;
SRL_SPLITTER_TRACE(" decompress OK: length %lu\n", uncompressed_len);
splitter->pos = splitter->input_str;
splitter->input_len = (STRLEN)tmp;
splitter->input_body_pos = splitter->pos;
}
}
/*
=for apidoc mro_package_moved
Call this function to signal to a stash that it has been assigned to
another spot in the stash hierarchy. C<stash> is the stash that has been
assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
that is actually being assigned to.
This can also be called with a null first argument to
indicate that C<oldstash> has been deleted.
This function invalidates isa caches on the old stash, on all subpackages
nested inside it, and on the subclasses of all those, including
non-existent packages that have corresponding entries in C<stash>.
It also sets the effective names (C<HvENAME>) on all the stashes as
appropriate.
If the C<gv> is present and is not in the symbol table, then this function
simply returns. This checked will be skipped if C<flags & 1>.
=cut
*/
void
Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
const GV * const gv, U32 flags)
{
SV *namesv;
HEK **namep;
I32 name_count;
HV *stashes;
HE* iter;
PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
assert(stash || oldstash);
/* Determine the name(s) of the location that stash was assigned to
* or from which oldstash was removed.
*
* We cannot reliably use the name in oldstash, because it may have
* been deleted from the location in the symbol table that its name
* suggests, as in this case:
*
* $globref = \*foo::bar::;
* Symbol::delete_package("foo");
* *$globref = \%baz::;
* *$globref = *frelp::;
* # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
*
* So we get it from the gv. But, since the gv may no longer be in the
* symbol table, we check that first. The only reliable way to tell is
* to see whether its stash has an effective name and whether the gv
* resides in that stash under its name. That effective name may be
* different from what gv_fullname4 would use.
* If flags & 1, the caller has asked us to skip the check.
*/
if(!(flags & 1)) {
SV **svp;
if(
!GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
!(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
*svp != (SV *)gv
) return;
}
assert(SvOOK(GvSTASH(gv)));
assert(GvNAMELEN(gv));
assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
if (!name_count) {
name_count = 1;
namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
}
else {
namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
if (name_count < 0) ++namep, name_count = -name_count - 1;
}
if (name_count == 1) {
if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
namesv = GvNAMELEN(gv) == 1
? newSVpvs_flags(":", SVs_TEMP)
: newSVpvs_flags("", SVs_TEMP);
}
else {
namesv = sv_2mortal(newSVhek(*namep));
if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
else sv_catpvs(namesv, "::");
}
if (GvNAMELEN(gv) != 1) {
sv_catpvn_flags(
namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
else {
SV *aname;
namesv = sv_2mortal((SV *)newAV());
while (name_count--) {
if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
aname = GvNAMELEN(gv) == 1
? newSVpvs(":")
: newSVpvs("");
namep++;
}
else {
aname = newSVhek(*namep++);
if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
else sv_catpvs(aname, "::");
}
if (GvNAMELEN(gv) != 1) {
sv_catpvn_flags(
aname, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
);
}
av_push((AV *)namesv, aname);
}
}
/* Get a list of all the affected classes. */
/* We cannot simply pass them all to mro_isa_changed_in to avoid
the list, as that function assumes that only one package has
changed. It does not work with:
@foo::ISA = qw( B B::B );
*B:: = delete $::{"A::"};
as neither B nor B::B can be updated before the other, since they
will reset caches on foo, which will see either B or B::B with the
wrong name. The names must be set on *all* affected stashes before
we do anything else. (And linearisations must be cleared, too.)
*/
stashes = (HV *) sv_2mortal((SV *)newHV());
mro_gather_and_rename(
stashes, (HV *) sv_2mortal((SV *)newHV()),
stash, oldstash, namesv
);
/* Once the caches have been wiped on all the classes, call
mro_isa_changed_in on each. */
hv_iterinit(stashes);
while((iter = hv_iternext(stashes))) {
HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
if(HvENAME(stash)) {
/* We have to restore the original meta->isa (that
mro_gather_and_rename set aside for us) this way, in case
one class in this list is a superclass of a another class
that we have already encountered. In such a case, meta->isa
from PL_isarev. */
struct mro_meta * const meta = HvMROMETA(stash);
if(meta->isa != (HV *)HeVAL(iter)) {
SvREFCNT_dec(meta->isa);
meta->isa
= HeVAL(iter) == &PL_sv_yes
? NULL
: (HV *)HeVAL(iter);
HeVAL(iter) = NULL; /* We donated our reference count. */
}
mro_isa_changed_in(stash);
}
}
}
void
my_xsinit(pTHX)
{
dVAR;
static const char file[] = __FILE__;
#ifdef USE_CTRLX
GV *ctrlXgv;
SV *ctrlX;
#endif
#ifdef USE_SUBFILE
if (PL_preprocess)
croak("Can't use -P with pl2exe");
#endif
#ifdef NEED_INIT_WIN32CORE
init_Win32CORE(aTHX);
#endif
#ifdef USE_ZIP
pl2exe_boot_zip(aTHX);
#endif
#ifdef NEED_PREAMBLE
newXS("ExtUtils::PerlToExe::preamble",
XS_ExtUtils_PerlToExe_preamble,
file);
if (!PL_preambleav)
PL_preambleav = newAV();
av_push(PL_preambleav,
newSVpvs("BEGIN { ExtUtils::PerlToExe::preamble() }"));
#endif
#ifdef NEED_TAINT
TAINT;
TAINT_PROPER("appended " TAINT_TYPE);
TAINT_NOT;
#endif
#ifdef USE_CTRLX
ctrlXgv = gv_fetchpvs("\030", GV_NOTQUAL, SVt_PV);
ctrlX = GvSV(ctrlXgv);
/*
* We can't reopen PL_rsfp yet as it hasn't been set (the file is
* open, it's just in an auto variable in S_parse_body). However,
* it's easier to fixup the name here, before gv_fetch_file gets
* called on it.
*/
PL_origfilename = savepv(SvPV_nolen(ctrlX));
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
sv_setpv(ctrlX, CTRL_X);
SvTAINTED_on(ctrlX);
#endif
#ifdef USE_ZIP
pl2exe_load_zip(aTHX_ PL_origfilename);
#endif
real_xsinit(aTHX);
}
