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?*/
}
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);
}
}
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);
}
}
/* 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));
}
NV
Perl_sv_nv(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_NV;
if (SvNOK(sv))
return SvNVX(sv);
return sv_2nv(sv);
}
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;
}
}
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;
}
U32 p5_SvNOK(PerlInterpreter *my_perl, SV* sv) {
return SvNOK(sv);
}
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;
}
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);
}
/* 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;
}