C++ SvPVX函数代码示例

static int
image_gif_read_buf(GifFileType *gif, GifByteType *data, int len)
{
  image *im = (image *)gif->UserData;

  //DEBUG_TRACE("GIF read_buf wants %d bytes, %d in buffer\n", len, buffer_len(im->buf));

  if (im->fh != NULL) {
    if ( !_check_buf(im->fh, im->buf, len, MAX(len, BUFFER_SIZE)) ) {
      warn("Image::Scale not enough GIF data (%s)\n", SvPVX(im->path));
      return 0;
    }
  }
  else {
    if (len > buffer_len(im->buf)) {
      // read from SV into buffer
      int sv_readlen = len - buffer_len(im->buf);

      if (sv_readlen > sv_len(im->sv_data) - im->sv_offset) {
        warn("Image::Scale not enough GIF data (%s)\n", SvPVX(im->path));
        return 0;
      }

      DEBUG_TRACE("  Reading %d bytes of SV data @ %d\n", sv_readlen, im->sv_offset);
      buffer_append(im->buf, SvPVX(im->sv_data) + im->sv_offset, sv_readlen);
      im->sv_offset += sv_readlen;
     }
  }

  memcpy(data, buffer_ptr(im->buf), len);
  buffer_consume(im->buf, len);

  return len;
}

void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
    register GP *gp;
    bool doproto = SvTYPE(gv) > SVt_NULL;
    char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;

    sv_upgrade((SV*)gv, SVt_PVGV);
    if (SvLEN(gv)) {
	if (proto) {
	    SvPVX(gv) = NULL;
	    SvLEN(gv) = 0;
	    SvPOK_off(gv);
	} else
	    Safefree(SvPVX(gv));
    }
    Newz(602, gp, 1, GP);
    GvGP(gv) = gp_ref(gp);
    GvSV(gv) = NEWSV(72,0);
    GvLINE(gv) = CopLINE(PL_curcop);
    GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
    GvCVGEN(gv) = 0;
    GvEGV(gv) = gv;
    sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
    GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
    GvNAME(gv) = savepvn(name, len);
    GvNAMELEN(gv) = len;
    if (multi || doproto)              /* doproto means it _was_ mentioned */
	GvMULTI_on(gv);
    if (doproto) {			/* Replicate part of newSUB here. */
	SvIOK_off(gv);
	ENTER;
	/* XXX unsafe for threads if eval_owner isn't held */
	start_subparse(0,0);		/* Create CV in compcv. */
	GvCV(gv) = PL_compcv;
	LEAVE;

	PL_sub_generation++;
	CvGV(GvCV(gv)) = gv;
	CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
	CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
	CvOWNER(GvCV(gv)) = 0;
	if (!CvMUTEXP(GvCV(gv))) {
	    New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
	    MUTEX_INIT(CvMUTEXP(GvCV(gv)));
	}
#endif /* USE_THREADS */
	if (proto) {
	    sv_setpv((SV*)GvCV(gv), proto);
	    Safefree(proto);
	}
    }
}

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();
}

void modperl_perl_call_list(pTHX_ AV *subs, const char *name)
{
    I32 i, oldscope = PL_scopestack_ix;
    SV **ary = AvARRAY(subs);

    MP_TRACE_g(MP_FUNC, "pid %lu" MP_TRACEf_TID MP_TRACEf_PERLID
               " running %d %s subs",
               (unsigned long)getpid(), MP_TRACEv_TID_ MP_TRACEv_PERLID_
               AvFILLp(subs)+1, name);

    for (i=0; i<=AvFILLp(subs); i++) {
        CV *cv = (CV*)ary[i];
        SV *atsv = ERRSV;

        PUSHMARK(PL_stack_sp);
        call_sv((SV*)cv, G_EVAL|G_DISCARD);

        if (SvCUR(atsv)) {
            Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted",
                           name);
            while (PL_scopestack_ix > oldscope) {
                LEAVE;
            }
            Perl_croak(aTHX_ "%s", SvPVX(atsv));
        }
    }
}

modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv)
{
    char *name = NULL;
    GV *gv;

    if (SvROK(sv)) {
        sv = SvRV(sv);
    }

    switch (SvTYPE(sv)) {
      case SVt_PV:
        name = SvPVX(sv);
        return modperl_handler_new(p, apr_pstrdup(p, name));
        break;
      case SVt_PVCV:
        if (CvANON((CV*)sv)) {
            return modperl_handler_new_anon(aTHX_ p, (CV*)sv);
        }
        if (!(gv = CvGV((CV*)sv))) {
            Perl_croak(aTHX_ "can't resolve the code reference");
        }
        name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL);
        return modperl_handler_new(p, name);
      default:
        break;
    };

    return NULL;
}

static HV*
S_thaw_fields(lucy_InStream *instream) {
    // Read frozen data into an SV buffer.
    size_t len = (size_t)LUCY_InStream_Read_C64(instream);
    SV *buf_sv = newSV(len + 1);
    SvPOK_on(buf_sv);
    SvCUR_set(buf_sv, len);
    char *buf = SvPVX(buf_sv);
    LUCY_InStream_Read_Bytes(instream, buf, len);

    // Call back to Storable to thaw the frozen hash.
    dSP;
    ENTER;
    SAVETMPS;
    EXTEND(SP, 1);
    PUSHMARK(SP);
    mPUSHs(buf_sv);
    PUTBACK;
    call_pv("Storable::thaw", G_SCALAR);
    SPAGAIN;
    SV *frozen = POPs;
    if (frozen && !SvROK(frozen)) {
        CFISH_THROW(CFISH_ERR, "thaw failed");
    }
    HV *fields = (HV*)SvRV(frozen);
    (void)SvREFCNT_inc((SV*)fields);
    PUTBACK;
    FREETMPS;
    LEAVE;

    return fields;
}

IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    STRLEN oldcur = SvCUR(s->var);
    STRLEN newlen;
    switch (whence) {
    case SEEK_SET:
	s->posn = offset;
	break;
    case SEEK_CUR:
	s->posn = offset + s->posn;
	break;
    case SEEK_END:
	s->posn = offset + SvCUR(s->var);
	break;
    }
    if (s->posn < 0) {
        if (ckWARN(WARN_LAYER))
	    Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
	SETERRNO(EINVAL, SS_IVCHAN);
	return -1;
    }
    newlen = (STRLEN) s->posn;
    if (newlen > oldcur) {
	(void) SvGROW(s->var, newlen);
	Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
	/* No SvCUR_set(), though.  This is just a seek, not a write. */
    }

bool EQWParser::dosub(const char * subname, const std::vector<std::string> &args, std::string &error, int mode) {
	bool err = false;
	dSP;				// initialize stack pointer
	ENTER;				// everything created after here
	SAVETMPS;			// ...is a temporary variable
	PUSHMARK(SP);		// remember the stack pointer
	if(!args.empty())
	{
		for (auto i = args.begin(); i != args.end(); ++i) { /* push the arguments onto the perl stack */
			XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
		}
	}
	PUTBACK;					// make local stack pointer global
	call_pv(subname, mode);		/*eval our code*/
	SPAGAIN;					// refresh stack pointer
	if(SvTRUE(ERRSV)) {
		err = true;
	}
	FREETMPS;		// free temp values
	LEAVE;			// ...and the XPUSHed "mortal" args.

	if(err) {
		error = "Perl runtime error: ";
		error += SvPVX(ERRSV);
		return(false);
	}
	return(true);
}

GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
    register const char *nend;
    const char *nsplit = 0;
    GV* gv;

    for (nend = name; *nend; nend++) {
	if (*nend == '\'')
	    nsplit = nend;
	else if (*nend == ':' && *(nend + 1) == ':')
	    nsplit = ++nend;
    }
    if (nsplit) {
	const char *origname = name;
	name = nsplit + 1;
	if (*nsplit == ':')
	    --nsplit;
	if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
	    /* ->SUPER::method should really be looked up in original stash */
	    SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
						  CopSTASHPV(PL_curcop)));
	    stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
			 origname, HvNAME(stash), name) );
	}
	else
	    stash = gv_stashpvn(origname, nsplit - origname, TRUE);
    }

    gv = gv_fetchmeth(stash, name, nend - name, 0);
    if (!gv) {
	if (strEQ(name,"import") || strEQ(name,"unimport"))
	    gv = (GV*)&PL_sv_yes;
	else if (autoload)
	    gv = gv_autoload4(stash, name, nend - name, TRUE);
    }
    else if (autoload) {
	CV* cv = GvCV(gv);
	if (!CvROOT(cv) && !CvXSUB(cv)) {
	    GV* stubgv;
	    GV* autogv;

	    if (CvANON(cv))
		stubgv = gv;
	    else {
		stubgv = CvGV(cv);
		if (GvCV(stubgv) != cv)		/* orphaned import */
		    stubgv = gv;
	    }
	    autogv = gv_autoload4(GvSTASH(stubgv),
				  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
	    if (autogv)
		gv = autogv;
	}
    }

    return gv;
}

MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
{
    SV *sv;
    apr_status_t rc;
    apr_size_t size;
    apr_file_t *file;

    size = r->finfo.size;
    sv = newSV(size);

    /* XXX: could have checked whether r->finfo.filehand is valid and
     * save the apr_file_open call, but apache gives us no API to
     * check whether filehand is valid. we can't test whether it's
     * NULL or not, as it may contain garbagea
     */
    rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
                       APR_OS_DEFAULT, r->pool);
    SLURP_SUCCESS("opening");

    rc = apr_file_read(file, SvPVX(sv), &size);
    SLURP_SUCCESS("reading");

    MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'", size, r->filename);

    if (r->finfo.size != size) {
        SvREFCNT_dec(sv);
        Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
                   size, (apr_size_t)r->finfo.size, r->filename);
    }

    rc = apr_file_close(file);
    SLURP_SUCCESS("closing");

    SvPVX(sv)[size] = '\0';
    SvCUR_set(sv, size);
    SvPOK_on(sv);

    if (tainted) {
        SvTAINTED_on(sv);
    }
    else {
        SvTAINTED_off(sv);
    }

    return newRV_noinc(sv);
}

int execute_perl( const char *function, char **args, char *data ) {
    int count = 0, i, ret_value = 1;
    STRLEN na;
    SV *sv_args[0];
    dSP;
    PERL_SET_CONTEXT( my_perl );
    /*
     * Set up the perl environment, push arguments onto the perl stack, then
     * call the given function
     */
    SPAGAIN;
    ENTER;
    SAVETMPS;
    PUSHMARK( sp );
    for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
        if ( args[i] != NULL ) {
            sv_args[i] = sv_2mortal( newSVpv( args[i], 0 ) );
            XPUSHs( sv_args[i] );
        }
    }
    PUTBACK;
    PERL_SET_CONTEXT( my_perl );
    count = call_pv( function, G_EVAL | G_SCALAR );
    SPAGAIN;
    /*
     * Check for "die," make sure we have 1 argument, and set our return value
     */
    if ( SvTRUE( ERRSV ) ) {
        sprintf( data,
                 "%sPerl function (%s) exited abnormally: %s",
                 ( loaded ? "ERR " : "" ), function, SvPV( ERRSV, na ) );
        ( void )POPs;
    }
    else if ( count != 1 ) {
        /*
         * This should NEVER happen. G_SCALAR ensures that we WILL have 1
         * parameter
         */
        sprintf( data,
                 "%sPerl error executing '%s': expected 1 return value; received %s",
                 ( loaded ? "ERR " : "" ), function, count );
    }
    else {
        sprintf( data, "%s%s", ( loaded ? "OK " : "" ), POPpx );
    }
    /* Check for changed arguments */
    for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
        if ( args[i] && strcmp( args[i], SvPVX( sv_args[i] ) ) ) {
            args[i] = strdup( SvPV( sv_args[i], na ) );
        }
    }
    PUTBACK;
    FREETMPS;
    LEAVE;
    return ret_value;
}

PERL_STATIC_INLINE UV*
S__get_invlist_len_addr(pTHX_ SV* invlist)
{
 /* Return the address of the UV that contains the current number
 * of used elements in the inversion list */

 PERL_ARGS_ASSERT__GET_INVLIST_LEN_ADDR;

 return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
}

char *
Perl_sv_pv(pTHX_ SV *sv)
{
    PERL_ARGS_ASSERT_SV_PV;

    if (SvPOK(sv))
        return SvPVX(sv);

    return sv_2pv(sv, NULL);
}

/* maxlen 0 = read one text line */
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
    filter_t funcp;
    SV *datasv = NULL;

    if (!PL_rsfp_filters)
	return -1;
    if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?	*/
	/* Provide a default input filter to make life easy.	*/
	/* Note that we append to the line. This is handy.	*/
	DEBUG_P(PerlIO_printf(Perl_debug_log,
			      "filter_read %d: from rsfp\n", idx));
	if (maxlen) {
 	    /* Want a block */
	    int len ;
	    const int old_len = SvCUR(buf_sv);

	    /* ensure buf_sv is large enough */
	    SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
	    if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
		if (PerlIO_error(PL_rsfp))
	            return -1;		/* error */
	        else
		    return 0 ;		/* end of file */
	    }
	    SvCUR_set(buf_sv, old_len + len) ;
	} else {
	    /* Want a line */
            if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
		if (PerlIO_error(PL_rsfp))
	            return -1;		/* error */
	        else
		    return 0 ;		/* end of file */
	    }
	}
	return SvCUR(buf_sv);
    }
    /* Skip this filter slot if filter has been deleted	*/
    if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
	DEBUG_P(PerlIO_printf(Perl_debug_log,
			      "filter_read %d: skipped (filter deleted)\n",
			      idx));
	return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
    }
    /* Get function pointer hidden within datasv	*/
    funcp = DPTR2FPTR(filter_t, IoANY(datasv));
    DEBUG_P(PerlIO_printf(Perl_debug_log,
			  "filter_read %d: via function %p (%s)\n",
			  idx, datasv, SvPV_nolen_const(datasv)));
    /* Call function. The function is expected to 	*/
    /* call "FILTER_READ(idx+1, buf_sv)" first.		*/
    /* Return: <0:error, =0:eof, >0:not eof 		*/
    return (*funcp)(aTHX_ idx, buf_sv, maxlen);
}

char *
Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
{
    PERL_ARGS_ASSERT_SV_PVN;

    if (SvPOK(sv)) {
        *lp = SvCUR(sv);
        return SvPVX(sv);
    }
    return sv_2pv(sv, lp);
}