Esempio n. 1
0
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;
}
Esempio n. 2
0
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);
	}
    }
}
Esempio n. 3
0
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();
}
Esempio n. 4
0
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));
        }
    }
}
Esempio n. 5
0
static void
flush_pending_text(PSTATE* p_state, SV* self)
{
    dTHX;
    bool   old_unbroken_text = p_state->unbroken_text;
    SV*    old_pend_text     = p_state->pend_text;
    bool   old_is_cdata      = p_state->is_cdata;
    STRLEN old_offset        = p_state->offset;
    STRLEN old_line          = p_state->line;
    STRLEN old_column        = p_state->column;

    assert(p_state->pend_text && SvOK(p_state->pend_text));

    p_state->unbroken_text = 0;
    p_state->pend_text     = 0;
    p_state->is_cdata      = p_state->pend_text_is_cdata;
    p_state->offset        = p_state->pend_text_offset;
    p_state->line          = p_state->pend_text_line;
    p_state->column        = p_state->pend_text_column;

    report_event(p_state, E_TEXT,
		 SvPVX(old_pend_text), SvEND(old_pend_text), 
		 SvUTF8(old_pend_text), 0, 0, self);
    SvOK_off(old_pend_text);

    p_state->unbroken_text = old_unbroken_text;
    p_state->pend_text     = old_pend_text;
    p_state->is_cdata      = old_is_cdata;
    p_state->offset        = old_offset;
    p_state->line          = old_line;
    p_state->column        = old_column;
}
Esempio n. 6
0
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;
}
Esempio n. 7
0
File: Doc.c Progetto: gitpan/Lucy
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;
}
Esempio n. 8
0
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. */
    }
Esempio n. 9
0
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);
}
Esempio n. 10
0
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;
}
Esempio n. 11
0
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);
}
Esempio n. 12
0
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;
}
Esempio n. 13
0
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)));
}
Esempio n. 14
0
char *
Perl_sv_pv(pTHX_ SV *sv)
{
    PERL_ARGS_ASSERT_SV_PV;

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

    return sv_2pv(sv, NULL);
}
Esempio n. 15
0
/* 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);
}
Esempio n. 16
0
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);
}
Esempio n. 17
0
char *
Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp)
{
    PERL_ARGS_ASSERT_SV_PVN_NOMG;

    if (SvPOK(sv)) {
        *lp = SvCUR(sv);
        return SvPVX(sv);
    }
    return sv_2pv_flags(sv, lp, 0);
}
Esempio n. 18
0
static SV *sv_soundex_utf8 (SV* source)
{
  U8 *source_p;
  U8 *source_end;

  {
    STRLEN source_len;
    source_p = (U8 *) SvPV(source, source_len);
    source_end = &source_p[source_len];
  }

  while (source_p < source_end)
    {
      STRLEN offset;
      UV c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
      char codepart_last = (c <= 0xFF) ? sv_soundex_table[c] : '\0';
      source_p = (offset >= 1) ? &source_p[offset] : source_end;

      if (codepart_last != '\0')
        {
          SV   *code     = newSV(SOUNDEX_ACCURACY);
          char *code_p   = SvPVX(code);
          char *code_end = &code_p[SOUNDEX_ACCURACY];

          SvCUR_set(code, SOUNDEX_ACCURACY);
          SvPOK_only(code);

          *code_p++ = toupper(c);

          while (source_p != source_end && code_p != code_end)
            {
              char codepart;
              c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
              codepart = (c <= 0xFF) ? sv_soundex_table[c] : '\0';
              source_p = (offset >= 1) ? &source_p[offset] : source_end;

              if (codepart != '\0')
                if (codepart != codepart_last && (codepart_last = codepart) != '0')
                  *code_p++ = codepart;
            }

          while (code_p != code_end)
            *code_p++ = '0';

          *code_end = '\0';

          return code;
        }

      source_p++;
    }

  return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
}
Esempio n. 19
0
SV *
sv_maybe_utf8(SV *sv)
{
#ifdef SvUTF8_on
 if (SvPOK(sv))
  {
   if (has_highbit(SvPVX(sv),SvCUR(sv)))
    SvUTF8_on(sv);
  }
#endif
 return sv;
}
Esempio n. 20
0
char * get_command_line(void) {

										/* debug 
										 * printf("%s\n", INIT_TERM_READLINE) ;
										 */
	SV *cmd_line ;
	char *command_line ;

	cmd_line	= my_eval_pv(DO_READLINE) ;
	command_line	= SvPVX(cmd_line) ;
	/* command_line	= SvPV(cmd_line, n_a) ; */
	return command_line ;
}
Esempio n. 21
0
static
int
nkf_putchar_grow(unsigned int c) 
{
    /* extends string length */
    o_len += incsize;
    SvGROW(result, o_len);
    /* to avoid linear growing, increase extension size */
    incsize *= 2;
    output = SvPVX(result);
    /* SvPV(result,o_len) breaks o_len */
    return output[output_ctr++] = c;
}
Esempio n. 22
0
void Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{//as seen in perlembed docs
#if EQDEBUG >= 5
	if(InUse()) {
		LogFile->write(EQCLog::Debug, "Warning: Perl dosub called for %s when perl is allready in use.\n", subname);
	}
#endif
	in_use = true;
	bool err = false;
	try {
		SV **sp = PL_stack_sp;
	       /* initialize stack pointer      */
	} catch(const char *err)
			{//this should never happen, so if it does, it is something really serious (like a bad perl install), so we'll shutdown.
				EQC::Common::Log(EQCLog::Error,CP_ZONESERVER, "Fatal error initializing perl: %s", err);
				
			}

	dSP;                     
	ENTER;                          /* everything created after here */
	SAVETMPS;                       /* ...is a temporary variable.   */
	PUSHMARK(SP);                   /* remember the stack pointer    */
	if(args && args->size())
	{
		for(std::vector<std::string>::const_iterator 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 */
	int result = 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.*/
	
	in_use = false;
	if(err)
	{
		errmsg = "Perl runtime error: ";
		errmsg += SvPVX(ERRSV);
		throw errmsg.c_str();
	}
}
Esempio n. 23
0
int Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{
	dSP;
	int ret_value = 0;
	int count;
	std::string error;

	ENTER;
	SAVETMPS;
	PUSHMARK(SP);
	if(args && args->size())
	{
		for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)
		{
			XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
		}
	}
	PUTBACK;

	count = call_pv(subname, mode);
	SPAGAIN;

	if(SvTRUE(ERRSV))
	{
		error = SvPV_nolen(ERRSV);
		POPs;
	}
	else
	{
		if(count == 1) {
			SV *ret = POPs;
			if(SvTYPE(ret) == SVt_IV) {
				IV v = SvIV(ret);
				ret_value = v;
			}
			PUTBACK;
		}
	}

	FREETMPS;
	LEAVE;

	if(error.length() > 0)
	{
		std::string errmsg = "Perl runtime error: ";
		errmsg += SvPVX(ERRSV);
		throw errmsg.c_str();
	}

	return ret_value;
}
Esempio n. 24
0
request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
{
    SV *sv = (SV *)NULL;
    MAGIC *mg;

    if (SvROK(in)) {
        SV *rv = (SV*)SvRV(in);

        switch (SvTYPE(rv)) {
          case SVt_PVMG:
            sv = rv;
            break;
          case SVt_PVHV:
            sv = modperl_hv_request_find(aTHX_ in, classname, cv);
            break;
          default:
            Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
                       (int)SvTYPE(rv));
        }
    }

    /* might be Apache2::ServerRec::warn method */
    if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) {
        request_rec *r = NULL;
        (void)modperl_tls_get_request_rec(&r);

        if (!r) {
            Perl_croak(aTHX_
                       "Apache2->%s called without setting Apache2->request!",
                       cv ? GvNAME(CvGV(cv)) : "unknown");
        }

        return r;
    }

    /* there could be pool magic attached to custom $r object, so make
     * sure that mg->mg_ptr is set */
    if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) {
        return (request_rec *)mg->mg_ptr;
    }
    else {
        if (classname && !sv_derived_from(in, classname)) {
            /* XXX: find something faster than sv_derived_from */
            return NULL;
        }
        return INT2PTR(request_rec *, SvIV(sv));
    }

    return NULL;
}
Esempio n. 25
0
int
Tcl_GetLongFromObj (Tcl_Interp *interp, Tcl_Obj *obj, long *longPtr)
{
 dTHX;
 SV *sv = ForceScalar(aTHX_ obj);
 if (SvIOK(sv) || looks_like_number(sv))
  *longPtr = SvIV(sv);
 else
  {
   *longPtr = 0;
   return EXPIRE((interp, "'%s' isn't numeric", SvPVX(sv)));
  }
 return TCL_OK;
}
Esempio n. 26
0
int
Tcl_GetDoubleFromObj (Tcl_Interp *interp, Tcl_Obj *obj, double *doublePtr)
{
 dTHX;
 SV *sv = ForceScalar(aTHX_ obj);
 if (SvNOK(sv) || looks_like_number(sv))
  *doublePtr = SvNV(sv);
 else
  {
   *doublePtr = 0;
   return EXPIRE((interp, "'%s' isn't numeric", SvPVX(sv)));
  }
 return TCL_OK;
}
Esempio n. 27
0
static SV *sv_soundex (SV *source)
{
  char *source_p;
  char *source_end;

  {
    STRLEN source_len;
    source_p = SvPV(source, source_len);
    source_end = &source_p[source_len];
  }

  while (source_p != source_end)
    {
      char codepart_last = sv_soundex_table[(unsigned char) *source_p];

      if (codepart_last != '\0')
        {
          SV   *code     = newSV(SOUNDEX_ACCURACY);
          char *code_p   = SvPVX(code);
          char *code_end = &code_p[SOUNDEX_ACCURACY];

          SvCUR_set(code, SOUNDEX_ACCURACY);
          SvPOK_only(code);

          *code_p++ = toupper(*source_p++);

          while (source_p != source_end && code_p != code_end)
            {
              char c = *source_p++;
              char codepart = sv_soundex_table[(unsigned char) c];

              if (codepart != '\0')
                if (codepart != codepart_last && (codepart_last = codepart) != '0')
                  *code_p++ = codepart;
            }

          while (code_p != code_end)
            *code_p++ = '0';

          *code_end = '\0';

          return code;
        }

      source_p++;
    }

  return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
}
Esempio n. 28
0
static int modperl_package_is_dynamic(pTHX_ const char *package,
                                      I32 *dl_index)
{
   I32 i;
   AV *modules = get_av(dl_modules, FALSE);

   for (i=0; i<av_len(modules); i++) {
        SV *module = *av_fetch(modules, i, 0);
        if (strEQ(package, SvPVX(module))) {
            *dl_index = i;
            return TRUE;
        }
    }
    return FALSE;
}
Esempio n. 29
0
static int
tn_buffer_init(struct tn_buffer *buf, size_t size)
{
	assert(buf);
	buf->sv = newSV(size);
	if(!buf->sv) {
		return 0;
	}
	SvPOK_only(buf->sv);
	buf->start = SvPVX(buf->sv);
	buf->cursor = buf->start + size;
	*buf->cursor = '\0';
	buf->size = size;
	return 1;
}
Esempio n. 30
0
void
Perl_set_version(pTHX_ const char *name, STRLEN nlen, const char *strval, STRLEN plen, NV nvval)
{
    SV* ver = GvSV(gv_add_by_type(gv_fetchpvn(name, nlen, GV_ADD, SVt_PVNV),
                                  SVt_PVNV));
    PERL_ARGS_ASSERT_SET_VERSION;
    SvREADONLY_off(ver);
    SvUPGRADE(ver, SVt_PVNV);
    SvPVX(ver) = SvGROW(ver, plen+1);
    Move(strval, SvPVX(ver), plen, char);
    SvCUR_set(ver, plen);
    SvNVX(ver) = nvval;
    /* not the PROTECT bit */
    SvFLAGS(ver) |= (SVf_NOK|SVp_NOK|SVf_POK|SVp_POK|SVf_READONLY);
}