static void
Scalarize(pTHX_ SV *sv, AV *av)
{
int n = av_len(av)+1;
if (n == 0)
sv_setpvn(sv,"",0);
else
{
SV **svp;
if (n == 1 && (svp = av_fetch(av, 0, 0)))
{
STRLEN len = 0;
char *s = SvPV(*svp,len);
#ifdef SvUTF8
int utf8 = SvUTF8(*svp);
sv_setpvn(sv,s,len);
if (utf8)
SvUTF8_on(sv);
#else
sv_setpvn(sv,s,len);
#endif
}
else
{
Tcl_DString ds;
int i;
Tcl_DStringInit(&ds);
for (i=0; i < n; i++)
{
if ((svp = av_fetch(av, i, 0)))
{
SV *el = *svp;
int temp = 0;
if (SvROK(el) && !SvOBJECT(SvRV(el)) && SvTYPE(SvRV(el)) == SVt_PVAV)
{
el = newSVpv("",0);
temp = 1;
if ((AV *) SvRV(*svp) == av)
abort();
Scalarize(aTHX_ el,(AV *) SvRV(*svp));
}
Tcl_DStringAppendElement(&ds,Tcl_GetString(el));
if (temp)
SvREFCNT_dec(el);
}
}
sv_setpvn(sv,Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
sv_maybe_utf8(sv);
Tcl_DStringFree(&ds);
}
}
}
/* The newSVpvn function was introduced in perl5.004_05 */
static SV *
newSVpvn(char *s, STRLEN len)
{
register SV *sv = newSV(0);
sv_setpvn(sv,s,len);
return sv;
}
/* GDBM allocates the datum with system malloc() and expects the user
* to free() it. So we either have to free() it immediately, or have
* perl free() it when it deallocates the SV, depending on whether
* perl uses malloc()/free() or not. */
static void
output_datum(pTHX_ SV *arg, char *str, int size)
{
sv_setpvn(arg, str, size);
# undef free
free(str);
}
void
Tcl_SetStringObj (Tcl_Obj *objPtr, CONST char *bytes, int length)
{
dTHX;
if (length < 0)
length = strlen(bytes);
objPtr = ForceScalarLvalue(aTHX_ objPtr);
sv_setpvn(objPtr, bytes, length);
sv_maybe_utf8(objPtr);
}
int PtrToScalar(PERL_CALL SV *string, PVOID ptr, int len)
{
if(!string)
return 0;
if(ptr)
sv_setpvn(string, (PSTR)ptr, len);
return 1;
}
static void
my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
{
STRLEN len;
const char * const s = SvPV_const(ssv,len);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
else
SvUTF8_off(dsv);
}
Tcl_Obj *
Tcl_NewStringObj (CONST char *bytes, int length)
{
dTHX;
if (bytes)
{
SV *sv;
if (length < 0)
length = strlen(bytes);
sv = newSV(length);
sv_setpvn(sv,(char *)bytes,length);
return sv_maybe_utf8(sv);
}
else
return &PL_sv_undef;
}
void pdl_grow (pdl* a, int newsize) {
SV* foo;
HV* hash;
STRLEN nbytes;
STRLEN ncurr;
STRLEN len;
if(a->state & PDL_DONTTOUCHDATA) {
die("Trying to touch data of an untouchable (mmapped?) pdl");
}
if(a->datasv == NULL)
a->datasv = newSVpv("",0);
foo = a->datasv;
nbytes = ((STRLEN) newsize) * pdl_howbig(a->datatype);
ncurr = SvCUR( foo );
if (ncurr == nbytes)
return; /* Nothing to be done */
/* We don't want to do this: if someone is resizing it
* but wanting to preserve data.. */
#ifdef FEOIJFOESIJFOJE
if (ncurr>nbytes) /* Nuke back to zero */
sv_setpvn(foo,"",0);
#endif
if(nbytes > (1024*1024*1024)) {
SV *sv = get_sv("PDL::BIGPDL",0);
if(sv == NULL || !(SvTRUE(sv)))
die("Probably false alloc of over 1Gb PDL! (set $PDL::BIGPDL = 1 to enable)");
fflush(stdout);
}
{
void *p;
p = SvGROW ( foo, nbytes ); SvCUR_set( foo, nbytes );
}
a->data = (void *) SvPV( foo, len ); a->nvals = newsize;
}
static SV *
ForceScalar(pTHX_ SV *sv)
{
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTYPE(sv) == SVt_PVAV)
{
AV *av = (AV *) sv;
SV *newsv = newSVpv("",0);
Scalarize(aTHX_ newsv, (AV *) av);
av_clear(av);
av_store(av,0,newsv);
return newsv;
}
else
{
if (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV)
{
/* Callbacks and lists often get stringified by mistake due to
Tcl/Tk's string fixation - don't change the real value
*/
SV *newsv = newSVpv("",0);
Scalarize(aTHX_ newsv, (AV *) SvRV(sv));
return sv_2mortal(newsv);
}
else if (!SvOK(sv))
{
/* Map undef to null string */
if (SvREADONLY(sv))
{
SV *newsv = newSVpv("",0);
return sv_2mortal(newsv);
}
else
sv_setpvn(sv,"",0);
}
return sv;
}
}
/* SaveError() takes printf style args and saves the result in dl_last_error */
static void
SaveError(pTHX_ char* pat, ...)
{
dMY_CXT;
va_list args;
SV *msv;
char *message;
STRLEN len;
/* This code is based on croak/warn, see mess() in util.c */
va_start(args, pat);
msv = vmess(pat, &args);
va_end(args);
message = SvPV(msv,len);
len++; /* include terminating null char */
/* Copy message into dl_last_error (including terminating null char) */
sv_setpvn(MY_CXT.x_dl_last_error, message, len) ;
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error));
}
STDCHAR *
PerlIOEncode_get_base(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
if (!e->base.bufsiz)
e->base.bufsiz = 1024;
if (!e->bufsv) {
e->bufsv = newSV(e->base.bufsiz);
sv_setpvn(e->bufsv, "", 0);
}
e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
if (!e->base.ptr)
e->base.ptr = e->base.buf;
if (!e->base.end)
e->base.end = e->base.buf;
if (e->base.ptr < e->base.buf
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
e->base.buf + SvLEN(e->bufsv));
abort();
}
if (SvLEN(e->bufsv) < e->base.bufsiz) {
SSize_t poff = e->base.ptr - e->base.buf;
SSize_t eoff = e->base.end - e->base.buf;
e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
e->base.ptr = e->base.buf + poff;
e->base.end = e->base.buf + eoff;
}
if (e->base.ptr < e->base.buf
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
e->base.buf + SvLEN(e->bufsv));
abort();
}
return e->base.buf;
}
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;
}
void P_sv_setqvn(pTHX_ SV* m, int i, const char* s, STRLEN len){
sv_setpvn(m,s,len);
SvIV_set(m,i);
SvPOK_on(m);
}
START_MY_CXT
#define fdebug (MY_CXT.x_fdebug)
#define current_idx (MY_CXT.x_current_idx)
static I32
filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
{
dMY_CXT;
SV *my_sv = FILTER_DATA(idx);
char *nl = "\n";
char *p;
char *out_ptr;
int n;
if (fdebug)
warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n",
maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
while (1) {
/* anything left from last time */
if ((n = SvCUR(my_sv))) {
out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
if (maxlen) {
/* want a block */
if (fdebug)
warn("BLOCK(%d): size = %d, maxlen = %d\n",
idx, n, maxlen) ;
sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
if(n <= maxlen) {
BUF_OFFSET(my_sv) = 0 ;
SET_LEN(my_sv, 0) ;
}
else {
BUF_OFFSET(my_sv) += maxlen ;
SvCUR_set(my_sv, n - maxlen) ;
}
return SvCUR(buf_sv);
}
else {
/* want lines */
if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
n = n - (p - out_ptr + 1);
BUF_OFFSET(my_sv) += (p - out_ptr + 1);
SvCUR_set(my_sv, n) ;
if (fdebug)
warn("recycle %d - leaving %d, returning %d [%s]",
idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
return SvCUR(buf_sv);
}
else /* no EOL, so append the complete buffer */
sv_catpvn(buf_sv, out_ptr, n) ;
}
}
SET_LEN(my_sv, 0) ;
BUF_OFFSET(my_sv) = 0 ;
if (FILTER_ACTIVE(my_sv))
{
dSP ;
int count ;
if (fdebug)
warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
ENTER ;
SAVETMPS;
SAVEINT(current_idx) ; /* save current idx */
current_idx = idx ;
SAVESPTR(DEFSV) ; /* save $_ */
/* make $_ use our buffer */
DEFSV = sv_2mortal(newSVpv("", 0)) ;
PUSHMARK(sp) ;
if (CODE_REF(my_sv)) {
/* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
}
else {
XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
PUTBACK ;
count = perl_call_method("filter", G_SCALAR);
}
SPAGAIN ;
if (count != 1)
croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
PERL_MODULE(my_sv), count ) ;
n = POPi ;
if (fdebug)
warn("status = %d, length op buf = %d [%s]\n",
n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
if (SvCUR(DEFSV))
sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
PUTBACK ;
FREETMPS ;
LEAVE ;
}
else
n = FILTER_READ(idx + 1, my_sv, maxlen) ;
if (n <= 0)
{
/* Either EOF or an error */
if (fdebug)
warn ("filter_read %d returned %d , returning %d\n", idx, n,
(SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
/* PERL_MODULE(my_sv) ; */
/* PERL_OBJECT(my_sv) ; */
filter_del(filter_call);
/* If error, return the code */
if (n < 0)
return n ;
/* return what we have so far else signal eof */
return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
}
}
}
STATIC I32
S_do_trans_simple(pTHX_ SV * const sv)
{
dVAR;
I32 matches = 0;
STRLEN len;
U8 *s = (U8*)SvPV(sv,len);
U8 * const send = s+len;
const short * const tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
/* First, take care of non-UTF-8 input strings, because they're easy */
if (!SvUTF8(sv)) {
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
matches++;
*s = (U8)ch;
}
s++;
}
SvSETMAGIC(sv);
}
else {
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
U8 *d;
U8 *dstart;
/* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
if (grows)
Newx(d, len*2+1, U8);
else
d = s;
dstart = d;
while (s < send) {
STRLEN ulen;
I32 ch;
/* Need to check this, otherwise 128..255 won't match */
const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
if (c < 0x100 && (ch = tbl[c]) >= 0) {
matches++;
d = uvchr_to_utf8(d, ch);
s += ulen;
}
else { /* No match -> copy */
Move(s, d, ulen, U8);
d += ulen;
s += ulen;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
SvSETMAGIC(sv);
}
return matches;
}
STATIC I32
S_do_trans_complex(pTHX_ SV * const sv)
{
dVAR;
STRLEN len;
U8 *s = (U8*)SvPV(sv, len);
U8 * const send = s+len;
I32 matches = 0;
const short * const tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
if (!SvUTF8(sv)) {
U8 *d = s;
U8 * const dstart = d;
if (PL_op->op_private & OPpTRANS_SQUASH) {
const U8* p = send;
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
*d = (U8)ch;
matches++;
if (p != d - 1 || *p != *d)
p = d++;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
else {
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
matches++;
*d++ = (U8)ch;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
*d = '\0';
SvCUR_set(sv, d - dstart);
}
else { /* is utf8 */
const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
const I32 del = PL_op->op_private & OPpTRANS_DELETE;
U8 *d;
U8 *dstart;
STRLEN rlen = 0;
if (grows)
Newx(d, len*2+1, U8);
else
d = s;
dstart = d;
if (complement && !del)
rlen = tbl[0x100];
#ifdef MACOS_TRADITIONAL
#define comp CoMP /* "comp" is a keyword in some compilers ... */
#endif
if (PL_op->op_private & OPpTRANS_SQUASH) {
UV pch = 0xfeedface;
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
ch = (rlen == 0) ? (I32)comp :
(comp - 0x100 < rlen) ?
tbl[comp+1] : tbl[0x100+rlen];
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
}
}
else if ((ch = tbl[comp]) >= 0) {
matches++;
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
pch = 0xfeedface;
}
}
else {
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
if (comp - 0x100 < rlen)
d = uvchr_to_utf8(d, tbl[comp+1]);
else
d = uvchr_to_utf8(d, tbl[0x100+rlen]);
}
}
}
else if ((ch = tbl[comp]) >= 0) {
d = uvchr_to_utf8(d, ch);
matches++;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
}
SvSETMAGIC(sv);
return matches;
}
EXTERN SV*
decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
{
STRLEN len;
char *s = SvPV_force(sv, len);
char *t = s;
char *end = s + len;
char *ent_start;
char *repl;
STRLEN repl_len;
#ifdef UNICODE_HTML_PARSER
char buf[UTF8_MAXLEN];
int repl_utf8;
int high_surrogate = 0;
#else
char buf[1];
#endif
#if defined(__GNUC__) && defined(UNICODE_HTML_PARSER)
/* gcc -Wall reports this variable as possibly used uninitialized */
repl_utf8 = 0;
#endif
while (s < end) {
assert(t <= s);
if ((*t++ = *s++) != '&')
continue;
ent_start = s;
repl = 0;
if (s < end && *s == '#') {
UV num = 0;
int ok = 0;
s++;
if (s < end && (*s == 'x' || *s == 'X')) {
s++;
while (s < end) {
char *tmp = strchr(PL_hexdigit, *s);
if (!tmp)
break;
num = num << 4 | ((tmp - PL_hexdigit) & 15);
if (num > 0x10FFFF) {
/* overflow */
ok = 0;
break;
}
s++;
ok = 1;
}
}
else {
while (s < end && isDIGIT(*s)) {
num = num * 10 + (*s - '0');
if (num > 0x10FFFF) {
/* overflow */
ok = 0;
break;
}
s++;
ok = 1;
}
}
if (num && ok) {
#ifdef UNICODE_HTML_PARSER
if (!SvUTF8(sv) && num <= 255) {
buf[0] = (char) num;
repl = buf;
repl_len = 1;
repl_utf8 = 0;
}
else if (num == 0xFFFE || num == 0xFFFF) {
/* illegal */
}
else {
char *tmp;
if ((num & 0xFFFFFC00) == 0xDC00) { /* low-surrogate */
if (high_surrogate != 0) {
t -= 3; /* Back up past 0xFFFD */
num = ((high_surrogate - 0xD800) << 10) +
(num - 0xDC00) + 0x10000;
high_surrogate = 0;
} else {
num = 0xFFFD;
}
}
else if ((num & 0xFFFFFC00) == 0xD800) { /* high-surrogate */
high_surrogate = num;
num = 0xFFFD;
}
else {
high_surrogate = 0;
/* otherwise invalid? */
if ((num >= 0xFDD0 && num <= 0xFDEF) ||
((num & 0xFFFE) == 0xFFFE) ||
num > 0x10FFFF)
{
num = 0xFFFD;
}
}
tmp = (char*)uvuni_to_utf8((U8*)buf, num);
repl = buf;
repl_len = tmp - buf;
repl_utf8 = 1;
}
#else
if (num <= 255) {
buf[0] = (char) num & 0xFF;
repl = buf;
repl_len = 1;
}
#endif
}
}
else {
char *ent_name = s;
while (s < end && isALNUM(*s))
s++;
if (ent_name != s && entity2char) {
SV** svp;
if ( (svp = hv_fetch(entity2char, ent_name, s - ent_name, 0)) ||
(*s == ';' && (svp = hv_fetch(entity2char, ent_name, s - ent_name + 1, 0)))
)
{
repl = SvPV(*svp, repl_len);
#ifdef UNICODE_HTML_PARSER
repl_utf8 = SvUTF8(*svp);
#endif
}
else if (expand_prefix) {
char *ss = s - 1;
while (ss > ent_name) {
svp = hv_fetch(entity2char, ent_name, ss - ent_name, 0);
if (svp) {
repl = SvPV(*svp, repl_len);
#ifdef UNICODE_HTML_PARSER
repl_utf8 = SvUTF8(*svp);
#endif
s = ss;
break;
}
ss--;
}
}
}
#ifdef UNICODE_HTML_PARSER
high_surrogate = 0;
#endif
}
if (repl) {
char *repl_allocated = 0;
if (s < end && *s == ';')
s++;
t--; /* '&' already copied, undo it */
#ifdef UNICODE_HTML_PARSER
if (*s != '&') {
high_surrogate = 0;
}
if (!SvUTF8(sv) && repl_utf8) {
/* need to upgrade sv before we continue */
STRLEN before_gap_len = t - SvPVX(sv);
char *before_gap = (char*)bytes_to_utf8((U8*)SvPVX(sv), &before_gap_len);
STRLEN after_gap_len = end - s;
char *after_gap = (char*)bytes_to_utf8((U8*)s, &after_gap_len);
sv_setpvn(sv, before_gap, before_gap_len);
sv_catpvn(sv, after_gap, after_gap_len);
SvUTF8_on(sv);
Safefree(before_gap);
Safefree(after_gap);
s = t = SvPVX(sv) + before_gap_len;
end = SvPVX(sv) + before_gap_len + after_gap_len;
}
else if (SvUTF8(sv) && !repl_utf8) {
repl = (char*)bytes_to_utf8((U8*)repl, &repl_len);
repl_allocated = repl;
}
#endif
if (t + repl_len > s) {
/* need to grow the string */
grow_gap(aTHX_ sv, repl_len - (s - t), &t, &s, &end);
}
/* copy replacement string into string */
while (repl_len--)
*t++ = *repl++;
if (repl_allocated)
Safefree(repl_allocated);
}
else {
while (ent_start < s)
*t++ = *ent_start++;
}
}
*t = '\0';
SvCUR_set(sv, t - SvPVX(sv));
return sv;
}
void
Perl_set_caret_X(pTHX) {
GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
SV *const caret_x = GvSV(tmpgv);
#if defined(OS2)
sv_setpv(caret_x, os2_execname(aTHX));
#elif defined(USE_KERN_PROC_PATHNAME)
size_t size = 0;
int mib[4];
mib[0] = CTL_KERN;
mib[1] = KERN_PROC;
mib[2] = KERN_PROC_PATHNAME;
mib[3] = -1;
if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
&& size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
sv_grow(caret_x, size);
if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
&& size > 2) {
SvPOK_only(caret_x);
SvCUR_set(caret_x, size - 1);
SvTAINT(caret_x);
return;
}
}
#elif defined(USE_NSGETEXECUTABLEPATH)
char buf[1];
uint32_t size = sizeof(buf);
_NSGetExecutablePath(buf, &size);
if (size < MAXPATHLEN * MAXPATHLEN) {
sv_grow(caret_x, size);
if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
char *const tidied = realpath(SvPVX(caret_x), NULL);
if (tidied) {
sv_setpv(caret_x, tidied);
free(tidied);
} else {
SvPOK_only(caret_x);
SvCUR_set(caret_x, size);
}
return;
}
}
#elif defined(HAS_PROCSELFEXE)
char buf[MAXPATHLEN];
SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
/* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
* it is impossible to know whether the result was truncated. */
if (len != -1) {
buf[len] = '\0';
}
/* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
includes a spurious NUL which will cause $^X to fail in system
or backticks (this will prevent extensions from being built and
many tests from working). readlink is not meant to add a NUL.
Normal readlink works fine.
*/
if (len > 0 && buf[len-1] == '\0') {
len--;
}
/* FreeBSD's implementation is acknowledged to be imperfect, sometimes
returning the text "unknown" from the readlink rather than the path
to the executable (or returning an error from the readlink). Any
valid path has a '/' in it somewhere, so use that to validate the
result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
*/
if (len > 0 && memchr(buf, '/', len)) {
sv_setpvn(caret_x, buf, len);
return;
}
#elif defined(WIN32)
char *ansi;
WCHAR widename[MAX_PATH];
GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
ansi = win32_ansipath(widename);
sv_setpv(caret_x, ansi);
win32_free(ansi);
return;
#else
/* Fallback to this: */
sv_setpv(caret_x, PL_origargv[0]);
#endif
}
STATIC char *
S_skipspace(pTHX_ register char *s, int incline)
{
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
return s;
}
for (;;) {
STRLEN prevlen;
SSize_t oldprevlen, oldoldprevlen;
SSize_t oldloplen = 0, oldunilen = 0;
while (s < PL_bufend && isSPACE(*s)) {
if (*s++ == '\n' && ((incline == 2) || (PL_in_eval && !PL_rsfp && !incline)))
incline(s);
}
/* comment */
if (s < PL_bufend && *s == '#') {
while (s < PL_bufend && *s != '\n')
s++;
if (s < PL_bufend) {
s++;
if (PL_in_eval && !PL_rsfp && !incline) {
incline(s);
continue;
}
}
}
/* also skip leading whitespace on the beginning of a line before deciding
* whether or not to recharge the linestr. --rafl
*/
while (s < PL_bufend && isSPACE(*s)) {
if (*s++ == '\n' && PL_in_eval && !PL_rsfp && !incline)
incline(s);
}
/* only continue to recharge the buffer if we're at the end
* of the buffer, we're not reading from a source filter, and
* we're in normal lexing mode
*/
if (s < PL_bufend || !PL_rsfp || PL_lex_inwhat ||
PL_lex_state == LEX_FORMLINE)
return s;
/* try to recharge the buffer */
if ((s = filter_gets(PL_linestr, PL_rsfp,
(prevlen = SvCUR(PL_linestr)))) == Nullch)
{
/* end of file. Add on the -p or -n magic */
if (PL_minus_p) {
sv_setpv(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
PL_minus_n = PL_minus_p = 0;
}
else if (PL_minus_n) {
sv_setpvn(PL_linestr, ";}", 2);
PL_minus_n = 0;
}
else
sv_setpvn(PL_linestr,";", 1);
/* reset variables for next time we lex */
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
= SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = Nullch;
/* In perl versions previous to p4-rawid: //depot/perl@32954 -P
* preprocessors were supported here. We don't support -P at all, even
* on perls that support it, and use the following chunk from blead
* perl. (rafl)
*/
/* Close the filehandle. Could be from
* STDIN, or a regular file. If we were reading code from
* STDIN (because the commandline held no -e or filename)
* then we don't close it, we reset it so the code can
* read from STDIN too.
*/
if ((PerlIO*)PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
PL_rsfp = Nullfp;
return s;
}
/* not at end of file, so we only read another line */
/* make corresponding updates to old pointers, for yyerror() */
oldprevlen = PL_oldbufptr - PL_bufend;
oldoldprevlen = PL_oldoldbufptr - PL_bufend;
if (PL_last_uni)
oldunilen = PL_last_uni - PL_bufend;
if (PL_last_lop)
oldloplen = PL_last_lop - PL_bufend;
PL_linestart = PL_bufptr = s + prevlen;
PL_bufend = s + SvCUR(PL_linestr);
s = PL_bufptr;
PL_oldbufptr = s + oldprevlen;
PL_oldoldbufptr = s + oldoldprevlen;
if (PL_last_uni)
PL_last_uni = s + oldunilen;
if (PL_last_lop)
PL_last_lop = s + oldloplen;
if (!incline)
incline(s);
/* debugger active and we're not compiling the debugger code,
* so store the line into the debugger's array of lines
*/
if (PERLDB_LINE && PL_curstash != PL_debstash) {
AV *fileav = CopFILEAV(PL_curcop);
if (fileav) {
SV * const sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
(void)SvIOK_on(sv);
SvIV_set(sv, 0);
av_store(fileav,(I32)CopLINE(PL_curcop),sv);
}
}
}
}
void
ffi_pl_closure_call(ffi_cif *ffi_cif, void *result, void **arguments, void *user)
{
dSP;
ffi_pl_closure *closure = (ffi_pl_closure*) user;
ffi_pl_type_extra_closure *extra = &closure->type->extra[0].closure;
int flags = extra->flags;
int i;
int count;
SV *sv;
SV **svp;
if(!(flags & G_NOARGS))
{
ENTER;
SAVETMPS;
}
PUSHMARK(SP);
if(!(flags & G_NOARGS))
{
for(i=0; i< ffi_cif->nargs; i++)
{
if(extra->argument_types[i]->platypus_type == FFI_PL_NATIVE)
{
switch(extra->argument_types[i]->ffi_type->type)
{
case FFI_TYPE_VOID:
break;
case FFI_TYPE_UINT8:
sv = sv_newmortal();
sv_setuv(sv, *((uint8_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_SINT8:
sv = sv_newmortal();
sv_setiv(sv, *((int8_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_UINT16:
sv = sv_newmortal();
sv_setuv(sv, *((uint16_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_SINT16:
sv = sv_newmortal();
sv_setiv(sv, *((int16_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_UINT32:
sv = sv_newmortal();
sv_setuv(sv, *((uint32_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_SINT32:
sv = sv_newmortal();
sv_setiv(sv, *((int32_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_UINT64:
sv = sv_newmortal();
#ifdef HAVE_IV_IS_64
sv_setuv(sv, *((uint64_t*)arguments[i]));
#else
sv_setu64(sv, *((uint64_t*)arguments[i]));
#endif
XPUSHs(sv);
break;
case FFI_TYPE_SINT64:
sv = sv_newmortal();
#ifdef HAVE_IV_IS_64
sv_setiv(sv, *((int64_t*)arguments[i]));
#else
sv_seti64(sv, *((int64_t*)arguments[i]));
#endif
XPUSHs(sv);
break;
case FFI_TYPE_FLOAT:
sv = sv_newmortal();
sv_setnv(sv, *((float*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_DOUBLE:
sv = sv_newmortal();
sv_setnv(sv, *((double*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_POINTER:
sv = sv_newmortal();
if( *((void**)arguments[i]) != NULL)
sv_setiv(sv, PTR2IV( *((void**)arguments[i]) ));
XPUSHs(sv);
break;
}
}
else if(extra->argument_types[i]->platypus_type == FFI_PL_STRING)
{
sv = sv_newmortal();
if( *((char**)arguments[i]) != NULL)
{
if(extra->argument_types[i]->extra[0].string.platypus_string_type == FFI_PL_STRING_FIXED)
sv_setpvn(sv, *((char**)arguments[i]), extra->argument_types[i]->extra[0].string.size);
else
sv_setpv(sv, *((char**)arguments[i]));
}
XPUSHs(sv);
}
}
PUTBACK;
}
svp = hv_fetch((HV *)SvRV((SV *)closure->coderef), "code", 4, 0);
if (svp)
count = call_sv(*svp, flags | G_EVAL);
else
count = 0;
if(SvTRUE(ERRSV))
{
#ifdef warn_sv
warn_sv(ERRSV);
#else
warn("%s", SvPV_nolen(ERRSV));
#endif
}
if(!(flags & G_DISCARD))
{
SPAGAIN;
if(count != 1)
sv = &PL_sv_undef;
else
sv = POPs;
if(extra->return_type->platypus_type == FFI_PL_NATIVE)
{
switch(extra->return_type->ffi_type->type)
{
case FFI_TYPE_UINT8:
#ifdef FFI_PL_PROBE_BIGENDIAN
((uint8_t*)result)[3] = SvUV(sv);
#else
*((uint8_t*)result) = SvUV(sv);
#endif
break;
case FFI_TYPE_SINT8:
#ifdef FFI_PL_PROBE_BIGENDIAN
((int8_t*)result)[3] = SvIV(sv);
#else
*((int8_t*)result) = SvIV(sv);
#endif
break;
case FFI_TYPE_UINT16:
#ifdef FFI_PL_PROBE_BIGENDIAN
((uint16_t*)result)[1] = SvUV(sv);
#else
*((uint16_t*)result) = SvUV(sv);
#endif
break;
case FFI_TYPE_SINT16:
#ifdef FFI_PL_PROBE_BIGENDIAN
((int16_t*)result)[1] = SvIV(sv);
#else
*((int16_t*)result) = SvIV(sv);
#endif
break;
case FFI_TYPE_UINT32:
*((uint32_t*)result) = SvUV(sv);
break;
case FFI_TYPE_SINT32:
*((int32_t*)result) = SvIV(sv);
break;
case FFI_TYPE_UINT64:
#ifdef HAVE_IV_IS_64
*((uint64_t*)result) = SvUV(sv);
#else
*((uint64_t*)result) = SvU64(sv);
#endif
break;
case FFI_TYPE_SINT64:
#ifdef HAVE_IV_IS_64
*((int64_t*)result) = SvIV(sv);
#else
*((int64_t*)result) = SvI64(sv);
#endif
break;
case FFI_TYPE_FLOAT:
*((float*)result) = SvNV(sv);
break;
case FFI_TYPE_DOUBLE:
*((double*)result) = SvNV(sv);
break;
case FFI_TYPE_POINTER:
*((void**)result) = SvOK(sv) ? INT2PTR(void*, SvIV(sv)) : NULL;
break;
}
}
PUTBACK;
}
EXTERN void
parse(pTHX_
PSTATE* p_state,
SV* chunk,
SV* self)
{
char *s, *beg, *end;
U32 utf8 = 0;
STRLEN len;
if (!chunk) {
/* eof */
char empty[1];
if (p_state->buf && SvOK(p_state->buf)) {
/* flush it */
s = SvPV(p_state->buf, len);
end = s + len;
utf8 = SvUTF8(p_state->buf);
assert(len);
while (s < end) {
if (p_state->literal_mode) {
if (strEQ(p_state->literal_mode, "plaintext") && !p_state->closing_plaintext)
break;
p_state->pending_end_tag = p_state->literal_mode;
p_state->literal_mode = 0;
s = parse_buf(aTHX_ p_state, s, end, utf8, self);
continue;
}
if (!p_state->strict_comment && !p_state->no_dash_dash_comment_end && *s == '<') {
p_state->no_dash_dash_comment_end = 1;
s = parse_buf(aTHX_ p_state, s, end, utf8, self);
continue;
}
if (!p_state->strict_comment && *s == '<') {
/* some kind of unterminated markup. Report rest as as comment */
token_pos_t token;
token.beg = s + 1;
token.end = end;
report_event(p_state, E_COMMENT, s, end, utf8, &token, 1, self);
s = end;
}
break;
}
if (s < end) {
/* report rest as text */
report_event(p_state, E_TEXT, s, end, utf8, 0, 0, self);
}
SvREFCNT_dec(p_state->buf);
p_state->buf = 0;
}
if (p_state->pend_text && SvOK(p_state->pend_text))
flush_pending_text(p_state, self);
if (p_state->ignoring_element) {
/* document not balanced */
SvREFCNT_dec(p_state->ignoring_element);
p_state->ignoring_element = 0;
}
report_event(p_state, E_END_DOCUMENT, empty, empty, 0, 0, 0, self);
/* reset state */
p_state->offset = 0;
if (p_state->line)
p_state->line = 1;
p_state->column = 0;
p_state->literal_mode = 0;
p_state->is_cdata = 0;
return;
}
#ifdef UNICODE_HTML_PARSER
if (p_state->utf8_mode)
sv_utf8_downgrade(chunk, 0);
#endif
if (p_state->buf && SvOK(p_state->buf)) {
sv_catsv(p_state->buf, chunk);
beg = SvPV(p_state->buf, len);
utf8 = SvUTF8(p_state->buf);
}
else {
beg = SvPV(chunk, len);
utf8 = SvUTF8(chunk);
if (p_state->offset == 0) {
report_event(p_state, E_START_DOCUMENT, beg, beg, 0, 0, 0, self);
/* Print warnings if we find unexpected Unicode BOM forms */
#ifdef UNICODE_HTML_PARSER
if (DOWARN &&
p_state->argspec_entity_decode &&
!p_state->utf8_mode && (
(!utf8 && len >= 3 && strnEQ(beg, "\xEF\xBB\xBF", 3)) ||
(utf8 && len >= 6 && strnEQ(beg, "\xC3\xAF\xC2\xBB\xC2\xBF", 6)) ||
(!utf8 && probably_utf8_chunk(aTHX_ beg, len))
)
)
{
warn("Parsing of undecoded UTF-8 will give garbage when decoding entities");
}
if (DOWARN && utf8 && len >= 2 && strnEQ(beg, "\xFF\xFE", 2)) {
warn("Parsing string decoded with wrong endianess");
}
#endif
if (DOWARN) {
if (!utf8 && len >= 4 &&
(strnEQ(beg, "\x00\x00\xFE\xFF", 4) ||
strnEQ(beg, "\xFE\xFF\x00\x00", 4))
)
{
warn("Parsing of undecoded UTF-32");
}
else if (!utf8 && len >= 2 &&
(strnEQ(beg, "\xFE\xFF", 2) || strnEQ(beg, "\xFF\xFE", 2))
)
{
warn("Parsing of undecoded UTF-16");
}
}
}
}
if (!len)
return; /* nothing to do */
end = beg + len;
s = parse_buf(aTHX_ p_state, beg, end, utf8, self);
if (s == end || p_state->eof) {
if (p_state->buf) {
SvOK_off(p_state->buf);
}
}
else {
/* need to keep rest in buffer */
if (p_state->buf) {
/* chop off some chars at the beginning */
if (SvOK(p_state->buf)) {
sv_chop(p_state->buf, s);
}
else {
sv_setpvn(p_state->buf, s, end - s);
if (utf8)
SvUTF8_on(p_state->buf);
else
SvUTF8_off(p_state->buf);
}
}
else {
p_state->buf = newSVpv(s, end - s);
if (utf8)
SvUTF8_on(p_state->buf);
}
}
return;
}
/* helper for the default modify handler for builtin attributes */
static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
HV *typestash;
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
case 4:
if (memEQ(name, "pure", 4)) {
if (negated)
Perl_croak(aTHX_ "Illegal :-pure attribute");
CvPURE_on(sv);
goto next_attr;
}
break;
case 5:
if (memEQ(name, "const", 5)) {
if (negated)
CvCONST_off(sv);
else {
#ifndef USE_CPERL
const bool warn = (!CvANON(sv) || CvCLONED(sv))
&& !CvCONST(sv);
CvCONST_on(sv);
if (warn)
break;
#else
CvCONST_on(sv);
#endif
}
goto next_attr;
}
break;
case 6:
switch (name[3]) {
case 'l':
if (memEQ(name, "lvalue", 6)) {
bool warn =
!CvISXSUB(MUTABLE_CV(sv))
&& CvROOT(MUTABLE_CV(sv))
&& !CvLVALUE(MUTABLE_CV(sv)) != negated;
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
if (warn) break;
goto next_attr;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
goto next_attr;
}
break;
}
break;
default:
if (len > 10 && memEQ(name, "prototype(", 10)) {
SV * proto = newSVpvn(name+10,len-11);
HEK *const hek = CvNAME_HEK((CV *)sv);
SV *subname;
if (name[len-1] != ')')
Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
if (hek)
subname = sv_2mortal(newSVhek(hek));
else
subname=(SV *)CvGV((const CV *)sv);
if (ckWARN(WARN_ILLEGALPROTO))
Perl_validate_proto(aTHX_ subname, proto, TRUE);
Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
(const GV *)subname,
name+10,
len-11,
SvUTF8(attr));
sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
goto next_attr;
}
break;
}
if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) {
CvTYPED_on(sv);
CvTYPE_set((CV*)sv, typestash);
continue;
}
break;
case SVt_IV:
case SVt_PVIV:
case SVt_PVMG:
if (memEQ(name, "unsigned", 8)
&& (SvIOK(sv) || SvUOK(sv)))
{
if (negated) /* :-unsigned alias for :signed */
SvIsUV_off(sv);
else
SvIsUV_on(sv);
continue;
}
/* fallthru - all other data types */
default:
if (memEQ(name, "const", 5)
&& !(SvFLAGS(sv) & SVf_PROTECT))
{
if (negated)
SvREADONLY_off(sv);
else
SvREADONLY_on(sv);
continue;
}
if (memEQs(name, len, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
next_attr:
;
}
return nret;
}
IV
PerlIOEncode_fill(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = 0;
PerlIO *n;
SSize_t avail;
if (PerlIO_flush(f) != 0)
return -1;
n = PerlIONext(f);
if (!PerlIO_fast_gets(n)) {
/* Things get too messy if we don't have a buffer layer
push a :perlio to do the job */
char mode[8];
n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
if (!n) {
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
retry:
avail = PerlIO_get_cnt(n);
if (avail <= 0) {
avail = PerlIO_fill(n);
if (avail == 0) {
avail = PerlIO_get_cnt(n);
}
else {
if (!PerlIO_error(n) && PerlIO_eof(n))
avail = 0;
}
}
if (avail > 0 || (e->flags & NEEDS_LINES)) {
STDCHAR *ptr = PerlIO_get_ptr(n);
SSize_t use = (avail >= 0) ? avail : 0;
SV *uni;
char *s = NULL;
STRLEN len = 0;
e->base.ptr = e->base.end = (STDCHAR *) NULL;
(void) PerlIOEncode_get_base(aTHX_ f);
if (!e->dataSV)
e->dataSV = newSV(0);
if (SvTYPE(e->dataSV) < SVt_PV) {
sv_upgrade(e->dataSV,SVt_PV);
}
if (e->flags & NEEDS_LINES) {
/* Encoding needs whole lines (e.g. iso-2022-*)
search back from end of available data for
and line marker
*/
STDCHAR *nl = ptr+use-1;
while (nl >= ptr) {
if (*nl == '\n') {
break;
}
nl--;
}
if (nl >= ptr && *nl == '\n') {
/* found a line - take up to and including that */
use = (nl+1)-ptr;
}
else if (avail > 0) {
/* No line, but not EOF - append avail to the pending data */
sv_catpvn(e->dataSV, (char*)ptr, use);
PerlIO_set_ptrcnt(n, ptr+use, 0);
goto retry;
}
else if (!SvCUR(e->dataSV)) {
goto end_of_file;
}
}
if (SvCUR(e->dataSV)) {
/* something left over from last time - create a normal
SV with new data appended
*/
if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use + SvCUR(e->dataSV);
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz - SvCUR(e->dataSV);
}
}
sv_catpvn(e->dataSV,(char*)ptr,use);
}
else {
/* Create a "dummy" SV to represent the available data from layer below */
if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
Safefree(SvPVX_mutable(e->dataSV));
}
if (use > (SSize_t)e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use;
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz;
}
}
SvPV_set(e->dataSV, (char *) ptr);
SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
SvPOK_only(e->dataSV);
}
SvUTF8_off(e->dataSV);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(e->dataSV);
XPUSHs(e->chk);
PUTBACK;
if (call_method("decode", G_SCALAR) != 1) {
Perl_die(aTHX_ "panic: decode did not return a value");
}
SPAGAIN;
uni = POPs;
PUTBACK;
/* Now get translated string (forced to UTF-8) and use as buffer */
if (SvPOK(uni)) {
s = SvPVutf8(uni, len);
#ifdef PARANOID_ENCODE_CHECKS
if (len && !is_utf8_string((U8*)s,len)) {
Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
}
#endif
}
if (len > 0) {
/* Got _something */
/* if decode gave us back dataSV then data may vanish when
we do ptrcnt adjust - so take our copy now.
(The copy is a pain - need a put-it-here option for decode.)
*/
sv_setpvn(e->bufsv,s,len);
e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
e->base.end = e->base.ptr + SvCUR(e->bufsv);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
SvUTF8_on(e->bufsv);
/* Adjust ptr/cnt not taking anything which
did not translate - not clear this is a win */
/* compute amount we took */
use -= SvCUR(e->dataSV);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
/* and as we did not take it it isn't pending */
SvCUR_set(e->dataSV,0);
} else {
/* Got nothing - assume partial character so we need some more */
/* Make sure e->dataSV is a normal SV before re-filling as
buffer alias will change under us
*/
s = SvPV(e->dataSV,len);
sv_setpvn(e->dataSV,s,len);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
}
else {
end_of_file:
code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
FREETMPS;
LEAVE;
POPSTACK;
return code;
}
static void* run_thread(void* arg) {
mthread* thread = (mthread*) arg;
PerlInterpreter* my_perl = construct_perl();
const message *to_run, *modules, *message;
SV *call, *status;
perl_mutex* shutdown_mutex;
thread->interp = my_perl;
#ifndef WIN32
S_set_sigmask(&thread->initial_sigmask);
#endif
PERL_SET_CONTEXT(my_perl);
store_self(my_perl, thread);
{
dSP;
modules = queue_dequeue(thread->queue, NULL);
load_modules(my_perl, modules);
to_run = queue_dequeue(thread->queue, NULL);
ENTER;
SAVETMPS;
call = SvRV(message_load_value(to_run));
PUSHMARK(SP);
mXPUSHs(newSVpvn("exit", 4));
status = newSVpvn("normal", 6);
mXPUSHs(status);
mXPUSHs(newSViv(thread->id));
ENTER;
PUSHMARK(SP);
PUTBACK;
call_sv(call, G_SCALAR|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
sv_setpvn(status, "error", 5);
warn("Thread %"UVuf" got error %s\n", thread->id, SvPV_nolen(ERRSV));
PUSHs(ERRSV);
}
message_from_stack_pushed(message);
LEAVE;
send_listeners(thread, message);
destroy_message(message);
FREETMPS;
LEAVE;
}
shutdown_mutex = get_shutdown_mutex();
MUTEX_LOCK(shutdown_mutex);
perl_destruct(my_perl);
MUTEX_UNLOCK(shutdown_mutex);
mthread_destroy(thread);
PerlMemShared_free(thread);
perl_free(my_perl);
return NULL;
}
OP *
Perl_do_readline(pTHX_ GV* gv)
{
dVAR; dSP; dTARGETSTACKED;
register SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
register IO * const io = GvIO(gv);
register const I32 type = PL_op->op_type;
const I32 gimme = GIMME_V;
PERL_ARGS_ASSERT_DO_READLINE;
fp = NULL;
if (io) {
fp = IoIFP(io);
if (!fp) {
if (IoFLAGS(io) & IOf_ARGV) {
if (IoFLAGS(io) & IOf_START) {
IoLINES(io) = 0;
if (av_len(GvAVn(gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_openn(io,"-",1,FALSE,O_RDONLY,0,NULL,NULL,0);
sv_setpvn(GvSVn(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
fp = IoIFP(io);
goto have_fp;
}
}
fp = nextargv(gv);
if (!fp) { /* Note: fp != IoIFP(io) */
(void)do_close(gv, FALSE); /* now it does*/
}
}
}
else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
report_evil_fh(io, OP_phoney_OUTPUT_ONLY);
}
}
if (!fp) {
if ((!io || !(IoFLAGS(io) & IOf_START))
&& ckWARN2(WARN_GLOB, WARN_CLOSED))
{
if (type == OP_GLOB)
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
report_evil_fh(io, PL_op->op_type);
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
if ( ! SvPVOK(TARG) )
sv_upgrade(TARG, SVt_PV);
SvOK_off(TARG);
}
PUSHTARG;
}
RETURN;
}
have_fp:
if (gimme == G_SCALAR) {
sv = TARG;
if (type == OP_RCATLINE) {
NOOP;
}
else {
if ( SvOK(sv) && ! SvPVOK(sv) )
sv_clear_body(sv);
}
if (SvROK(sv)) {
if (type == OP_RCATLINE)
SvPV_force_nolen(sv);
else
sv_unref(sv);
}
else if (isGV_with_GP(sv)) {
SvPV_force_nolen(sv);
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
SvPV_force_nolen(sv);
}
offset = SvCUR(sv);
}
}
else {
sv = sv_2mortal(newSV(80));
offset = 0;
}
/* delay EOF state for a snarfed empty file */
#define SNARF_EOF(gimme,rs,io,sv) \
(gimme != G_SCALAR || SvCUR(sv) \
|| (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
for (;;) {
PUTBACK;
if (!sv_gets(sv, fp, offset)
&& (type == OP_GLOB
|| SNARF_EOF(gimme, PL_rs, io, sv)
|| PerlIO_error(fp)))
{
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
fp = nextargv(gv);
if (fp)
continue;
(void)do_close(gv, FALSE);
}
else if (type == OP_GLOB) {
if (!do_close(gv, FALSE) && ckWARN(WARN_GLOB)) {
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (child exited with status %d%s)",
(int)(STATUS_CURRENT >> 8),
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
}
if (gimme == G_SCALAR) {
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
SvOK_off(TARG);
}
SPAGAIN;
PUSHTARG;
}
RETURN;
}
void* pack1D_sz( SV* arg, char packtype, int * nelem) {
int iscalar;
float scalar;
double dscalar;
short sscalar;
unsigned char uscalar;
AV* array;
I32 i,n;
SV* work;
SV** work2;
double nval;
STRLEN len;
/* assume no size known */
if (nelem != NULL) *nelem = -1;
if (is_scalar_ref(arg)) /* Scalar ref */
return (void*) SvPV(SvRV(arg), len);
if (packtype!='f' && packtype!='i' && packtype!='d' && packtype!='s'
&& packtype != 'u')
Perl_croak(aTHX_ "Programming error: invalid type conversion specified to pack1D");
/*
Create a work char variable - be cunning and make it a mortal *SV
which will go away automagically when we leave the current
context, i.e. no need to malloc and worry about freeing - thus
we can use pack1D in a typemap!
*/
work = sv_2mortal(newSVpv("", 0));
/* Is arg a scalar? Return scalar*/
if (!SvROK(arg) && SvTYPE(arg)!=SVt_PVGV) {
if (packtype=='f') {
scalar = (float) SvNV(arg); /* Get the scalar value */
sv_setpvn(work, (char *) &scalar, sizeof(float)); /* Pack it in */
}
if (packtype=='i') {
iscalar = (int) SvNV(arg); /* Get the scalar value */
sv_setpvn(work, (char *) &iscalar, sizeof(int)); /* Pack it in */
}
if (packtype=='d') {
dscalar = (double) SvNV(arg); /*Get the scalar value */
sv_setpvn(work, (char *) &dscalar, sizeof(double)); /* Pack it in */
}
if (packtype=='s') {
sscalar = (short) SvNV(arg); /*Get the scalar value */
sv_setpvn(work, (char *) &sscalar, sizeof(short)); /* Pack it in */
}
if (packtype=='u') {
uscalar = (unsigned char) SvNV(arg); /*Get the scalar value */
sv_setpvn(work, (char *) &uscalar, sizeof(char)); /* Pack it in */
}
return (void *) SvPV(work, PL_na); /* Return the pointer */
}
/* Is it a glob or reference to an array? */
if (SvTYPE(arg)==SVt_PVGV || (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV)) {
if (SvTYPE(arg)==SVt_PVGV) {
array = (AV *) GvAVn((GV*) arg); /* glob */
}else{
array = (AV *) SvRV(arg); /* reference */
}
n = av_len(array);
if ( nelem != NULL )
*nelem = n + 1;
if (packtype=='f')
SvGROW( work, sizeof(float)*(n+1) ); /* Pregrow for efficiency */
if (packtype=='i')
SvGROW( work, sizeof(int)*(n+1) );
if (packtype=='d')
SvGROW( work, sizeof(double)*(n+1) );
if (packtype=='s')
SvGROW( work, sizeof(short)*(n+1) );
if (packtype=='u')
SvGROW( work, sizeof(char)*(n+1) );
/* Pack array into string */
for(i=0; i<=n; i++) {
work2 = av_fetch( array, i, 0 ); /* Fetch */
if (work2==NULL)
nval = 0.0; /* Undefined */
else {
if (SvROK(*work2))
goto errexit; /* Croak if reference [i.e. not 1D] */
nval = SvNV(*work2);
}
if (packtype=='f') {
scalar = (float) nval;
sv_catpvn( work, (char *) &scalar, sizeof(float));
}
if (packtype=='i') {
iscalar = (int) nval;
sv_catpvn( work, (char *) &iscalar, sizeof(int));
}
if (packtype=='d') {
dscalar = (double) nval;
sv_catpvn( work, (char *) &dscalar, sizeof(double));
}
if (packtype=='s') {
sscalar = (short) nval;
sv_catpvn( work, (char *) &sscalar, sizeof(short));
}
if (packtype=='u') {
uscalar = (unsigned char) nval;
sv_catpvn( work, (char *) &uscalar, sizeof(char));
}
}
/* Return a pointer to the byte array */
return (void *) SvPV(work, PL_na);
}
errexit:
Perl_croak(aTHX_ "Routine can only handle scalar values or refs to 1D arrays of scalars");
}
void decode_utf8(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
sv_setpvn(output, (char*)input, len);
SvUTF8_on(output);
}
