bool
Pointf::from_SV(SV* point_sv)
{
AV* point_av = (AV*)SvRV(point_sv);
SV* sv_x = *av_fetch(point_av, 0, 0);
SV* sv_y = *av_fetch(point_av, 1, 0);
if (!looks_like_number(sv_x) || !looks_like_number(sv_y)) return false;
this->x = SvNV(sv_x);
this->y = SvNV(sv_y);
return true;
}
static long sv_to_dimension(pTHX_ SV *sv, const char *member)
{
SV *warning;
const char *value = NULL;
assert(sv != NULL);
SvGETMAGIC(sv);
if (SvOK(sv) && !SvROK(sv))
{
if (looks_like_number(sv))
{
return SvIV(sv);
}
value = SvPV_nolen(sv);
}
warning = newSVpvn("", 0);
if (value) sv_catpvf(warning, " ('%s')", value);
if (member) sv_catpvf(warning, " in '%s'", member);
WARN((aTHX_ "Cannot use %s%s as dimension", identify_sv(sv), SvPV_nolen(warning)));
SvREFCNT_dec(warning);
return 0;
}
/* Load a YAML scalar into a Perl scalar */
SV *
load_scalar(perl_yaml_loader_t *loader)
{
SV *scalar;
char *string = (char *)loader->event.data.scalar.value;
STRLEN length = (STRLEN)loader->event.data.scalar.length;
char *anchor = (char *)loader->event.data.scalar.anchor;
char *tag = (char *)loader->event.data.scalar.tag;
if (tag) {
char *class;
char *prefix = TAG_PERL_PREFIX "regexp";
if (strnEQ(tag, prefix, strlen(prefix)))
return load_regexp(loader);
prefix = TAG_PERL_PREFIX "scalar:";
if (*tag == '!')
prefix = "!";
else if (strlen(tag) <= strlen(prefix) ||
! strnEQ(tag, prefix, strlen(prefix))
) croak(ERRMSG "bad tag found for scalar: '%s'", tag);
class = tag + strlen(prefix);
scalar = sv_setref_pvn(newSV(0), class, string, strlen(string));
SvUTF8_on(scalar);
return scalar;
}
if (loader->event.data.scalar.style == YAML_PLAIN_SCALAR_STYLE) {
if (strEQ(string, "~"))
return newSV(0);
else if (strEQ(string, ""))
return newSV(0);
else if (strEQ(string, "null"))
return newSV(0);
else if (strEQ(string, "true"))
return &PL_sv_yes;
else if (strEQ(string, "false"))
return &PL_sv_no;
}
scalar = newSVpvn(string, length);
if (loader->event.data.scalar.style == YAML_PLAIN_SCALAR_STYLE && looks_like_number(scalar) ) {
/* numify */
SvIV_please(scalar);
}
SvUTF8_on(scalar);
if (anchor)
hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
return scalar;
}
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;
}
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;
}
static SV *
newSVGtkIconSize (GtkIconSize size)
{
/* crap. there is no try. do, or do not. */
/* SV * sv = gperl_try_convert_back_enum (GTK_TYPE_ICON_SIZE, size); */
SV * sv = gperl_convert_back_enum_pass_unknown (GTK_TYPE_ICON_SIZE,
size);
if (looks_like_number (sv)) {
/* fall back... */
const char * name;
name = gtk_icon_size_get_name (size);
if (name)
sv_setpv (sv, name);
}
return sv;
}
static html_valid_status_t
html_valid_set_number_option (html_valid_t * htv, const char * coption,
TidyOptionId ti, SV * value)
{
int cvalue;
if (! SvOK (value)) {
warn ("cannot set option '%s' to undefined value",
coption);
return html_valid_undefined_option;
}
if (! looks_like_number (value)) {
warn ("option %s expects a numerical value, but you supplied %s",
coption, SvPV_nolen (value));
return html_valid_non_numerical_option;
}
cvalue = SvIV (value);
TIDY_CALL (tidyOptSetInt (htv->tdoc, ti, cvalue));
return html_valid_ok;
}
void _mpack_item(SV *res, SV *o)
{
size_t len, res_len, new_len;
char *s, *res_s;
res_s = SvPVbyte(res, res_len);
unsigned i;
if (!SvOK(o)) {
new_len = res_len + mp_sizeof_nil();
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_nil(res_s + res_len);
return;
}
if (SvROK(o)) {
o = SvRV(o);
if (SvOBJECT(o)) {
SvGETMAGIC(o);
HV *stash = SvSTASH(o);
GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0);
if (!mtd)
croak("Object has no method 'msgpack'");
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash));
PUTBACK;
call_sv((SV *)GvCV(mtd), G_SCALAR);
SPAGAIN;
SV *pkt = POPs;
if (!SvOK(pkt))
croak("O->msgpack returned undef");
s = SvPV(pkt, len);
new_len = res_len + len;
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
memcpy(res_s + res_len, s, len);
PUTBACK;
FREETMPS;
LEAVE;
return;
}
switch(SvTYPE(o)) {
case SVt_PVAV: {
AV *a = (AV *)o;
len = av_len(a) + 1;
new_len = res_len + mp_sizeof_array(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_array(res_s + res_len, len);
for (i = 0; i < len; i++) {
SV **item = av_fetch(a, i, 0);
if (!item)
_mpack_item(res, 0);
else
_mpack_item(res, *item);
}
break;
}
case SVt_PVHV: {
HV *h = (HV *)o;
len = hv_iterinit(h);
new_len = res_len + mp_sizeof_map(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_map(res_s + res_len, len);
for (;;) {
HE * iter = hv_iternext(h);
if (!iter)
break;
SV *k = hv_iterkeysv(iter);
SV *v = HeVAL(iter);
_mpack_item(res, k);
_mpack_item(res, v);
}
break;
}
default:
croak("Can't serialize reference");
}
return;
}
switch(SvTYPE(o)) {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVMG:
case SVt_REGEXP:
if (!looks_like_number(o)) {
s = SvPV(o, len);
new_len = res_len + mp_sizeof_str(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_str(res_s + res_len, s, len);
break;
}
case SVt_NV: {
NV v = SvNV(o);
IV iv = (IV)v;
if (v != iv) {
new_len = res_len + mp_sizeof_double(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_double(res_s + res_len, v);
break;
}
}
case SVt_IV: {
IV v = SvIV(o);
if (v >= 0) {
new_len = res_len + mp_sizeof_uint(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_uint(res_s + res_len, v);
} else {
new_len = res_len + mp_sizeof_int(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_int(res_s + res_len, v);
}
break;
}
default:
croak("Internal msgpack error %d", SvTYPE(o));
}
}
int dimtag_parse(pTHX_ const MemberInfo *pmi, const char *type, SV *tag, DimensionTag *dim)
{
enum dimension_tag_type tag_type = DTT_NONE;
assert(type != NULL);
assert(tag != NULL);
assert(dim != NULL);
assert(SvOK(tag));
if (SvROK(tag))
{
SV *sv = SvRV(tag);
switch (SvTYPE(sv))
{
case SVt_PVCV:
case SVt_PVAV:
tag_type = DTT_HOOK;
break;
default:
break;
}
}
else
{
if (SvPOK(tag))
{
STRLEN len;
const char *str = SvPV(tag, len);
if (len > 0)
{
if (strEQ(str, "*"))
{
tag_type = DTT_FLEXIBLE;
}
else if (looks_like_number(tag))
{
tag_type = DTT_FIXED;
}
else
{
tag_type = DTT_MEMBER;
}
}
}
else if (SvIOK(tag))
{
tag_type = DTT_FIXED;
}
}
switch (tag_type)
{
case DTT_NONE:
Perl_croak(aTHX_ "Invalid Dimension tag for '%s'", type);
break;
case DTT_FLEXIBLE:
break;
case DTT_FIXED:
{
IV value = SvIV(tag);
if (value < 0)
Perl_croak(aTHX_ "Cannot use negative value %" IVdf " in Dimension"
" tag for '%s'", value, type);
dim->u.fixed = value;
}
break;
case DTT_MEMBER:
{
STRLEN len;
const char *src = SvPV(tag, len);
validate_member_expression(aTHX_ pmi, src, type);
New(0, dim->u.member, len+1, char);
Copy(src, dim->u.member, len, char);
dim->u.member[len] = '\0';
}
break;
case DTT_HOOK:
{
SingleHook newhook;
U32 allowed = SHF_ALLOW_ARG_SELF
| SHF_ALLOW_ARG_HOOK;
if (pmi->parent)
allowed |= SHF_ALLOW_ARG_DATA;
single_hook_fill(aTHX_ "Dimension", type, &newhook, tag, allowed);
dim->u.hook = single_hook_new(&newhook);
}
break;
}
dim->type = tag_type;
return 1;
}
