SV* newPerlPyObject_noinc(PyObject *pyo) { SV* rv; SV* sv; MAGIC *mg; dCTXP; ASSERT_LOCK_PERL; if (!pyo) croak("Missing pyo reference argument"); rv = newSV(0); sv = newSVrv(rv, "Python::Object"); sv_setiv(sv, (IV)pyo); sv_magic(sv, 0, '~', 0, 0); mg = mg_find(sv, '~'); if (!mg) { SvREFCNT_dec(rv); croak("Can't assign magic to Python::Object"); } mg->mg_virtual = &vtbl_free_pyo; SvREADONLY(sv); #ifdef REF_TRACE printf("Bind pyo %p\n", pyo); #endif ASSERT_LOCK_PERL; return rv; }
GLvoid * EL(SV * sv, int needlen) { STRLEN skip = 0; SV * svref; if (SvREADONLY(sv)) croak("Readonly value for buffer"); if(SvROK(sv)) { svref = SvRV(sv); sv = svref; } else { #ifdef USE_STRICT_UNGLOB if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); #endif SvUPGRADE(sv, SVt_PV); SvGROW(sv, (unsigned int)(needlen + 1)); SvPOK_on(sv); SvCUR_set(sv, needlen); *SvEND(sv) = '\0'; /* Why is this here? -chm */ } return SvPV_force(sv, skip); }
static ngx_int_t ngx_http_perl_sv2str(pTHX_ ngx_http_request_t *r, ngx_str_t *s, SV *sv) { u_char *p; STRLEN len; if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PV) { sv = SvRV(sv); } p = (u_char *) SvPV(sv, len); s->len = len; if (SvREADONLY(sv) && SvPOK(sv)) { s->data = p; ngx_log_debug2(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "perl sv2str: %08XD \"%V\"", sv->sv_flags, s); return NGX_OK; } s->data = ngx_pnalloc(r->pool, len); if (s->data == NULL) { return NGX_ERROR; } ngx_memcpy(s->data, p, len); ngx_log_debug2(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "perl sv2str: %08XD \"%V\"", sv->sv_flags, s); return NGX_OK; }
static char *pe_var_start(pe_watcher *_ev, int repeat) { STRLEN n_a; struct ufuncs *ufp; MAGIC **mgp; MAGIC *mg; pe_var *ev = (pe_var*) _ev; SV *sv = ev->variable; if (!_ev->callback) return "without callback"; if (!sv || !SvOK(sv)) return "watching what?"; if (!ev->events) return "without poll events specified"; sv = SvRV(sv); if (SvREADONLY(sv)) return "cannot trace read-only variable"; (void)SvUPGRADE(sv, SVt_PVMG); mgp = &SvMAGIC(sv); while ((mg = *mgp)) { mgp = &mg->mg_moremagic; } EvNew(11, mg, 1, MAGIC); Zero(mg, 1, MAGIC); mg->mg_type = 'U'; mg->mg_virtual = &PL_vtbl_uvar; *mgp = mg; EvNew(8, ufp, 1, struct ufuncs); ufp->uf_val = ev->events & PE_R? tracevar_r : 0; ufp->uf_set = ev->events & PE_W? tracevar_w : 0; ufp->uf_index = PTR2IV(ev); mg->mg_ptr = (char *) ufp; mg->mg_obj = (SV*) ev; mg_magical(sv); if (!SvMAGICAL(sv)) return "mg_magical didn't"; return 0; }
IV PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * tab) { IV code; PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); /* If called (normally) via open() then arg is ref to scalar we are * using, otherwise arg (from binmode presumably) is either NULL * or the _name_ of the scalar */ if (arg) { if (SvROK(arg)) { if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') { if (ckWARN(WARN_LAYER)) Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify); SETERRNO(EINVAL, SS_IVCHAN); return -1; } s->var = SvREFCNT_inc(SvRV(arg)); SvGETMAGIC(s->var); if (!SvPOK(s->var) && SvOK(s->var)) (void)SvPV_nomg_const_nolen(s->var); } else { s->var = SvREFCNT_inc(perl_get_sv (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI)); } } else { s->var = newSVpvn("", 0); } SvUPGRADE(s->var, SVt_PV); code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab); if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE) SvCUR_set(s->var, 0); if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) s->posn = SvCUR(s->var); else s->posn = 0; return code; }
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; } }
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; }
/* Converts perl values to equivalent JS values */ JSBool PJS_ReflectPerl2JS( pTHX_ JSContext *cx, JSObject *pobj, SV *ref, jsval *rval ) { PJS_Context *pcx = PJS_GET_CONTEXT(cx); JSObject *newobj = NULL; if(++pcx->svconv % 2000 == 0) { JSErrorReporter older; ENTER; SAVETMPS; /* Scope for finalizers */ older = JS_SetErrorReporter(cx, NULL); if(pcx->svconv > 10000) { JS_GC(cx); pcx->svconv = 0; } else JS_MaybeGC(cx); JS_SetErrorReporter(cx, older); FREETMPS; LEAVE; } if(SvROK(ref)) { MAGIC *mg; /* First check old jsvisitors */ if((newobj = PJS_IsPerlVisitor(aTHX_ pcx, SvRV(ref)))) { PJS_DEBUG("Old jsvisitor returns\n"); *rval = OBJECT_TO_JSVAL(newobj); return JS_TRUE; } if(SvMAGICAL(SvRV(ref)) && (mg = mg_find(SvRV(ref), PERL_MAGIC_tied)) && mg->mg_obj && sv_derived_from(mg->mg_obj, PJS_BOXED_PACKAGE)) { PJS_DEBUG1("A magical ref %s, shortcircuit!\n", SvPV_nolen((SV*)mg->mg_obj)); ref = mg->mg_obj; } if(sv_derived_from(ref, PJS_BOXED_PACKAGE)) { SV **fref = av_fetch((AV *)SvRV(SvRV(ref)), 2, 0); assert(sv_derived_from(*fref, PJS_RAW_JSVAL)); *rval = (jsval)SvIV(SvRV(*fref)); return JS_TRUE; } if(sv_derived_from(ref, PJS_BOOLEAN)) { *rval = SvTRUE(SvRV(ref)) ? JSVAL_TRUE : JSVAL_FALSE; return JS_TRUE; } if(sv_isobject(ref)) { newobj = PJS_NewPerlObject(aTHX_ cx, pobj, ref); if(newobj) { *rval = OBJECT_TO_JSVAL(newobj); return JS_TRUE; } return JS_FALSE; } } SvGETMAGIC(ref); if(!SvOK(ref)) /* undef */ *rval = JSVAL_VOID; else if(SvIOK(ref) || SvIOKp(ref)) { if(SvIV(ref) <= JSVAL_INT_MAX) *rval = INT_TO_JSVAL(SvIV(ref)); else JS_NewDoubleValue(cx, (double) SvIV(ref), rval); } else if(SvNOK(ref)) JS_NewDoubleValue(cx, SvNV(ref), rval); else if(SvPOK(ref) || SvPOKp(ref)) { STRLEN len; char *str; SV *temp=NULL; if(SvREADONLY(ref)) { temp = newSVsv(ref); str = PJS_SvPV(temp, len); } else str = PJS_SvPV(ref, len); JSString *jstr = ((int)len >= 0) ? JS_NewStringCopyN(cx, str, len) : JS_NewUCStringCopyN(cx, (jschar *)str, -(int)len); sv_free(temp); if(!jstr) return JS_FALSE; *rval = STRING_TO_JSVAL(jstr); } else if(SvROK(ref)) { /* Plain reference */ I32 type = SvTYPE(SvRV(ref)); if(type == SVt_PVHV) newobj = PJS_NewPerlHash(aTHX_ cx, pobj, ref); else if(type == SVt_PVAV) newobj = PJS_NewPerlArray(aTHX_ cx, pobj, ref); else if(type == SVt_PVCV) newobj = PJS_NewPerlSub(aTHX_ cx, pobj, ref); else newobj = PJS_NewPerlScalar(aTHX_ cx, pobj, ref); if(!newobj) return JS_FALSE; *rval = OBJECT_TO_JSVAL(newobj); } else { warn("I have no idea what perl send us (it's of type %i), I'll pretend it's undef", SvTYPE(ref)); *rval = JSVAL_VOID; } return JS_TRUE; }