Beispiel #1
0
void dump_value(pTHX_ SV* val, Buffer* buf)
{
    if (!val) {
      return;
    }

    if (SvIOK(val)) {
        char str[50];
        int len = sprintf(str, "%ld", (long) SvIV(val));
        buffer_append(buf, str, len);
    } else if (SvNOK(val)) {
        char str[50];
        int len = sprintf(str, "%lf", (double) SvNV(val));
        buffer_append(buf, str, len);
    } else if (SvPOK(val)) {
        STRLEN len;
        char* str = SvPV(val, len);
        buffer_append(buf, "\"", 1);
        buffer_append(buf, str, len);
        buffer_append(buf, "\"", 1);
    } else if (SvROK(val)) {
        SV* rv = SvRV(val);
        if (SvTYPE(rv) == SVt_PVAV) {
            dump_array(aTHX_ (AV*) rv, buf);
        } else if (SvTYPE(rv) == SVt_PVHV) {
            dump_hash(aTHX_ (HV*) rv, buf);
        }
    }
}
void plcb_ctor_init_common(PLCB_t *object, libcouchbase_t instance,
                           AV *options)
{
    NV timeout_value;
    SV **tmpsv;
    
    object->instance = instance;
    object->errors = newAV();
    if(! (object->ret_stash = gv_stashpv(PLCB_RET_CLASSNAME, 0)) ) {
        die("Could not load '%s'", PLCB_RET_CLASSNAME);
    }
    
    /*gather instance-related options from the constructor*/
    if( (tmpsv = av_fetch(options, PLCB_CTORIDX_TIMEOUT, 0))  && 
            (SvIOK(*tmpsv) || SvNOK(*tmpsv))) {
        timeout_value = SvNV(*tmpsv);
        if(!timeout_value) {
            warn("Cannot use 0 for timeout");
        } else {
            libcouchbase_set_timeout(instance,
                timeout_value * (1000*1000));
        }
    }
    
    if((tmpsv = av_fetch(options, PLCB_CTORIDX_NO_CONNECT, 0)) &&
       SvTRUE(*tmpsv)) {
        object->my_flags |= PLCBf_NO_CONNECT;
    }
    /*maybe more stuff here?*/
}
Beispiel #3
0
guint64 amglue_SvU64(SV *sv)
{
    if (SvIOK(sv)) {
	if (SvIsUV(sv)) {
	    return SvUV(sv);
	} else if (SvIV(sv) < 0) {
	    croak("Expected an unsigned value, got a negative integer");
	    return 0;
	} else {
	    return (guint64)SvIV(sv);
	}
    } else if (SvNOK(sv)) {
	double dv = SvNV(sv);
	if (dv < 0.0) {
	    croak("Expected an unsigned value, got a negative integer");
	    return 0;
	} else if (dv > (double)G_MAXUINT64) {
	    croak("Expected an unsigned 64-bit value or smaller; value out of range");
	    return 0;
	} else {
	    return (guint64)dv;
	}
    } else {
	return bigint2uint64(sv);
    }
}
Beispiel #4
0
gint64 amglue_SvI64(SV *sv)
{
    if (SvIOK(sv)) {
	if (SvIsUV(sv)) {
	    return SvUV(sv);
	} else {
	    return SvIV(sv);
	}
    } else if (SvNOK(sv)) {
	double dv = SvNV(sv);

	/* preprocessor constants seem to have trouble here, so we convert to gint64 and
	 * back, and if the result differs, then we have lost something.  Note that this will
	 * also error out on integer truncation .. which is probably OK */
	gint64 iv = (gint64)dv;
	if (dv != (double)iv) {
	    croak("Expected a signed 64-bit value or smaller; value '%.0f' out of range", (float)dv);
	    return 0;
	} else {
	    return iv;
	}
    } else {
	return bigint2int64(sv);
    }
}
Beispiel #5
0
/* Returns perl value as a scheme one */
VCSI_OBJECT perl_return(VCSI_CONTEXT vc,
			SV* val) {
  if(SvIOK(val))
    return make_long(vc,SvIV(val));
  else if(SvNOK(val))
    return make_float(vc,SvNV(val));
  else     
    return make_string(vc,SvPV_nolen(val));
}
Beispiel #6
0
NV
Perl_sv_nv(pTHX_ SV *sv)
{
    PERL_ARGS_ASSERT_SV_NV;

    if (SvNOK(sv))
        return SvNVX(sv);
    return sv_2nv(sv);
}
Beispiel #7
0
char sv2idctype(const SV *sv)
{
    if (SvIOK(sv)) return VT_LONG;
    else if (SvNOK(sv)) return VT_FLOAT;
    else if (SvPOK(sv)) return VT_STR;
    else {
        // otherwise, probably an object -> stringify
        return VT_STR;
    }
}
Beispiel #8
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;
}
Beispiel #9
0
U32 p5_SvNOK(PerlInterpreter *my_perl, SV* sv) {
    return SvNOK(sv);
}
Beispiel #10
0
static int Encode(csv_t* csv, SV* dst, AV* fields, SV* eol) {
  int i;
  for (i = 0;  i <= av_len(fields);  i++) {
    SV** svp;
    if (i > 0) {
      CSV_PUT(csv, dst, csv->sepChar);
    }
    if ((svp = av_fetch(fields, i, 0))  &&  *svp  &&  SvOK(*svp)) {
      STRLEN len;
      char* ptr = SvPV(*svp, len);
      int quoteMe = csv->alwaysQuote;
      /*
       *  Do we need quoting? We do quote, if the user requested
       *  (alwaysQuote), if binary or blank characters are found
       *  and if the string contains quote or escape characters.
       */
      if (!quoteMe  &&
	  (quoteMe = (!SvIOK(*svp)  &&  !SvNOK(*svp)  &&
		      csv->quoteChar))) {
	char* ptr2, *ptr3;
	STRLEN l;
	for (ptr2 = ptr, l = len;  l;  ++ptr2, --l) {
	  unsigned char c = *ptr2;
	  if (c <= 0x20  ||  (c >= 0x7f  &&  c <= 0xa0)  ||
	      (csv->quoteChar && c == csv->quoteChar)  ||
	      (csv->sepChar && c == csv->sepChar)  ||
	      (csv->escapeChar  &&  c == csv->escapeChar)) {
	    /* Binary character */
	    break;
	  }
	}
	quoteMe = (l>0);
      }
      if (quoteMe) {
	CSV_PUT(csv, dst, csv->quoteChar);
      }
      while (len-- > 0) {
	char c = *ptr++;
	int e = 0;
	if (!csv->binary  &&
	    (c != '\t'  &&  (c < '\040'  ||  c > '\176'))) {
	  SvREFCNT_inc(*svp);
	  if (!hv_store(csv->self, "_ERROR_INPUT", 12, *svp, 0)) {
	    SvREFCNT_dec(*svp);
	  }
	  return FALSE;
	}
	if (csv->quoteChar  &&  c == csv->quoteChar) {
	  e = 1;
	} else if (csv->escapeChar  &&  c == csv->escapeChar) {
	  e = 1;
	} else if (c == '\0') {
	  e = 1;
	  c = '0';
	}
	if (e  &&  csv->escapeChar) {
	  CSV_PUT(csv, dst, csv->escapeChar);
	}
	CSV_PUT(csv, dst, c);
      }
      if (quoteMe) {
	CSV_PUT(csv, dst, csv->quoteChar);
      }
    }
  }
  if (eol && SvOK(eol)) {
    STRLEN len;
    char* ptr = SvPV(eol, len);
    while (len--) {
      CSV_PUT(csv, dst, *ptr++);
    }
  }
  if (csv->used) {
    Print(csv, dst);
  }
  return TRUE;
}
Beispiel #11
0
static void
tn_encode(SV *data, struct tn_buffer *buf)
{
	size_t init_length = tn_buffer_length(buf) + 1;

	/* Null */
	if(!SvOK(data)) {
		tn_buffer_puts(buf, "0:~", 3);
		return;
	}
	/* Boolean */
	else if(sv_isobject(data) && sv_derived_from(data, "boolean")) {
		tn_buffer_putc(buf, tn_type_bool);
		if(SvTRUE(data)) {
			tn_buffer_puts(buf, "4:true", 6);
		} else {
			tn_buffer_puts(buf, "5:false", 7);
		}
		return;
	}
	/* Integer */
	else if(SvIOK(data)) {
		/* The evaluatioin order of arguments isn't defined, so
		 * stringify before calling tn_buffer_puts(). */
		SvPV_nolen(data);
		tn_buffer_putc(buf, tn_type_integer);
		tn_buffer_puts(buf, SvPVX(data), SvCUR(data));
	}
	/* Floating point */
	else if(SvNOK(data)) {
		/* The evaluatioin order of arguments isn't defined, so
		 * stringify before calling tn_buffer_puts(). */
		SvPV_nolen(data);
		tn_buffer_putc(buf, tn_type_float);
		tn_buffer_puts(buf, SvPVX(data), SvCUR(data));
	}
	/* String */
	else if(SvPOK(data)) {
		tn_buffer_putc(buf, tn_type_bytestring);
		tn_buffer_puts(buf, SvPVX(data), SvCUR(data));
	}
	/* Reference (Hash/Array) */
	else if(SvROK(data)) {
		data = SvRV(data);
		switch(SvTYPE(data)) {
			case SVt_PVAV:
				tn_buffer_putc(buf, tn_type_array);
				tn_encode_array(data, buf);
				break;
			case SVt_PVHV:
				tn_buffer_putc(buf, tn_type_hash);
				tn_encode_hash(data, buf);
				break;
			default:
				croak("encountered %s (%s), but TNetstrings can only represent references to arrays or hashes",
					SvPV_nolen(data), sv_reftype(data, 0));
		}
	} else {
		croak("support for type (%s, %s) not implemented, please file a bug",
			sv_reftype(data, 0), SvPV_nolen(data));
	}
	tn_buffer_putc(buf, ':');
	tn_buffer_puti(buf, tn_buffer_length(buf) - init_length - 1);
}
Beispiel #12
0
/* 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;
}