void av_to_arrays (AV* points,
double** xp,
double** yp,
int* npointsp) {
int prev_exists;
int i;
int j;
double prev_x;
double prev_y;
double x;
double y;
*npointsp = 0;
*xp = (double *)malloc(sizeof(double) * (av_len(points) + 1));
*yp = (double *)malloc(sizeof(double) * (av_len(points) + 1));
for (i = 0, j = 0; i <= av_len(points); i += 1) {
SV** pointp = av_fetch(points, i, 0);
if (!pointp || !*pointp) continue;
SV* point = *pointp;
if (!IS_ARRAY_REF(point)) continue;
AV* xy = (AV*)SvRV(point);
if (av_len(xy) < 1) continue;
x = SvNV(*(av_fetch(xy, 0, 0)));
y = SvNV(*(av_fetch(xy, 1, 0)));
if (prev_exists && x == prev_x && y == prev_y) continue;
(*xp)[j] = x;
(*yp)[j] = y;
j += 1;
prev_x = x;
prev_y = y;
prev_exists = 1;
}
*npointsp = j;
}
void TriangleMesh::ReadFromPerl(SV* vertices, SV* facets)
{
stl.stats.type = inmemory;
// count facets and allocate memory
AV* facets_av = (AV*)SvRV(facets);
stl.stats.number_of_facets = av_len(facets_av)+1;
stl.stats.original_num_facets = stl.stats.number_of_facets;
stl_allocate(&stl);
// read geometry
AV* vertices_av = (AV*)SvRV(vertices);
for (unsigned int i = 0; i < stl.stats.number_of_facets; i++) {
AV* facet_av = (AV*)SvRV(*av_fetch(facets_av, i, 0));
stl_facet facet;
facet.normal.x = 0;
facet.normal.y = 0;
facet.normal.z = 0;
for (unsigned int v = 0; v <= 2; v++) {
AV* vertex_av = (AV*)SvRV(*av_fetch(vertices_av, SvIV(*av_fetch(facet_av, v, 0)), 0));
facet.vertex[v].x = SvNV(*av_fetch(vertex_av, 0, 0));
facet.vertex[v].y = SvNV(*av_fetch(vertex_av, 1, 0));
facet.vertex[v].z = SvNV(*av_fetch(vertex_av, 2, 0));
}
facet.extra[0] = 0;
facet.extra[1] = 0;
stl.facet_start[i] = facet;
}
stl_get_size(&(this->stl));
}
void
Pointf::from_SV(SV* point_sv)
{
AV* point_av = (AV*)SvRV(point_sv);
this->x = SvNV(*av_fetch(point_av, 0, 0));
this->y = SvNV(*av_fetch(point_av, 1, 0));
}
void
ffi_pl_perl_to_complex_float(SV *sv, float *ptr)
{
if(sv_isobject(sv) && sv_derived_from(sv, "Math::Complex"))
{
ptr[0] = decompose(sv, 0);
ptr[1] = decompose(sv, 1);
}
else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)
{
AV *av = (AV*) SvRV(sv);
SV **real_sv, **imag_sv;
real_sv = av_fetch(av, 0, 0);
imag_sv = av_fetch(av, 1, 0);
ptr[0] = real_sv != NULL ? SvNV(*real_sv) : 0.0;
ptr[1]= imag_sv != NULL ? SvNV(*imag_sv) : 0.0;
}
else if(SvOK(sv))
{
ptr[0] = SvNV(sv);
ptr[1] = 0.0;
}
else
{
ptr[0] = 0.0;
ptr[1] = 0.0;
}
}
void
Point::from_SV(SV* point_sv)
{
AV* point_av = (AV*)SvRV(point_sv);
// get a double from Perl and round it, otherwise
// it would get truncated
this->x = lrint(SvNV(*av_fetch(point_av, 0, 0)));
this->y = lrint(SvNV(*av_fetch(point_av, 1, 0)));
}
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;
}
main (int argc, char **argv, char **env)
{
STRLEN n_a;
char *embedding[] = { "", "-e", "0" };
my_perl = perl_alloc();
perl_construct( my_perl );
perl_parse(my_perl, NULL, 3, embedding, NULL);
perl_run(my_perl);
/** Treat $a as an integer **/
perl_eval_pv("$a = 3; $a **= 2", TRUE);
printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
/** Treat $a as a float **/
perl_eval_pv("$a = 3.14; $a **= 2", TRUE);
printf("a = %f\n", SvNV(perl_get_sv("a", FALSE)));
/** Treat $a as a string **/
perl_eval_pv("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a);", TRUE);
printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), n_a));
perl_destruct(my_perl);
perl_free(my_perl);
}
int64_t
kino_Host_callback_i64(void *vobj, char *method, uint32_t num_args, ...)
{
va_list args;
SV *return_sv;
int64_t retval;
va_start(args, num_args);
return_sv = S_do_callback_sv(vobj, method, num_args, args);
va_end(args);
if (sizeof(IV) == 8) {
retval = (int64_t)SvIV(return_sv);
}
else {
if (SvIOK(return_sv)) {
// It's already no more than 32 bits, so don't convert.
retval = SvIV(return_sv);
}
else {
// Maybe lossy.
double temp = SvNV(return_sv);
retval = (int64_t)temp;
}
}
FREETMPS;
LEAVE;
return retval;
}
static void
plperl_safe_init(void)
{
SV *res;
double safe_version;
res = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */
safe_version = SvNV(res);
/*
* We actually want to reject safe_version < 2.09, but it's risky to
* assume that floating-point comparisons are exact, so use a slightly
* smaller comparison value.
*/
if (safe_version < 2.0899)
{
/* not safe, so disallow all trusted funcs */
eval_pv(SAFE_BAD, FALSE);
}
else
{
eval_pv(SAFE_OK, FALSE);
}
plperl_safe_init_done = true;
}
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);
}
}
SEXP
GetRScalar(SV *val)
{
dTHX;
SEXP ans = NULL_USER_OBJECT;
if(SvIOKp(val)) {
PROTECT(ans = NEW_INTEGER(1));
INTEGER_DATA(ans)[0] = SvIV(val);
UNPROTECT(1);
} else if(SvNOKp(val)) {
PROTECT(ans = NEW_NUMERIC(1));
NUMERIC_DATA(ans)[0] = SvNV(val);
UNPROTECT(1);
} else if(SvPOK(val)) {
PROTECT(ans = NEW_CHARACTER(1));
SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(SvPV(val, PL_na)));
UNPROTECT(1);
} else if(SvROK(val)) {
fprintf(stderr, "Not handling nested references in conversion from Perl to R at present. Suggestions for semantics welcome!\n");fflush(stderr);
} else if(SvTYPE(val) == SVt_PVMG) {
/*XXX get more info about the type of the magic object.
struct magic *mg = SvMAGIC(val);
*/
PROTECT(ans = createPerlReference(val));
UNPROTECT(1);
} else {
fprintf(stderr, "Cannot deal currently with Perl types %d\n", SvTYPE(val));fflush(stderr);
}
return(ans);
}
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);
}
}
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?*/
}
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);
}
}
}
static CORBA_boolean
put_double (GIOPSendBuffer *buf, SV *sv)
{
CORBA_double v = SvNV(sv);
buf_putn (buf, &v, sizeof (v));
return CORBA_TRUE;
}
/* 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));
}
/*
Converts and inserts the Perl primitive value `val'
into the R/S object `ans' in position `i'.
It knows the type of the Perl object and hence the
S object type.
See PerlAllocHomogeneousVector() above.
*/
void
PerlAddHomogeneousElement(SV *val, int i, USER_OBJECT_ ans, svtype elementType)
{
dTHX;
switch(elementType) {
case SVt_IV:
INTEGER_DATA(ans)[i] = SvIV(val);
break;
case SVt_PVIV:
INTEGER_DATA(ans)[i] = SvIV(val);
break;
case SVt_NV:
NUMERIC_DATA(ans)[i] = SvNV(val);
break;
case SVt_PVNV:
NUMERIC_DATA(ans)[i] = SvNV(val);
break;
case SVt_PV:
SET_STRING_ELT(ans, i, COPY_TO_USER_STRING(SvPV(val, PL_na)));
break;
#if 0
case SVt_RV:
SET_VECTOR_ELT(ans, i, fromPerl(sv_isobject(val) ? val : val/*XXX SvRV(val)*/, 1));
break;
#endif
case SVt_PVMG: /* magic variable */
/*XXX */ SET_VECTOR_ELT(ans, i, fromPerl(val, 0));
break;
case SVt_PVGV: /* glob value*/
SET_VECTOR_ELT(ans, i, fromPerl(val, 1));
break;
case SVt_NULL:
if(TYPEOF(ans) == VECSXP)
SET_VECTOR_ELT(ans, i, R_NilValue);
else
fprintf(stderr, "Unhandled NULL object at position %d in array conversion into R object of type %d\n", i, TYPEOF(ans));
break;
default:
fprintf(stderr, "Unhandled type %d at position %d in array conversion\n", elementType, i);
break;
}
}
/* Code for serializing floats */
static SRL_INLINE void
srl_dump_nv(pTHX_ srl_encoder_t *enc, SV *src)
{
NV nv= SvNV(src);
float f= nv;
double d= nv;
if ( f == nv || nv != nv ) {
BUF_SIZE_ASSERT(enc, 1 + sizeof(f)); /* heuristic: header + string + simple value */
srl_buf_cat_char_nocheck(enc,SRL_HDR_FLOAT);
Copy((char *)&f, enc->pos, sizeof(f), char);
enc->pos += sizeof(f);
} else if (d == nv) {
static void perl_variable_to_json_internal( SV *input, json_writer_t *writer )
{
char *val;
int ival;
STRLEN len;
double number;
int type = -1;
if ( SvOK( input ) && SvROK( input ) ) {
type = SvTYPE( SvRV( input ) );
}
else if ( SvOK( input ) ) {
type = SvTYPE( input );
}
switch ( type ) {
case SVt_IV:
ival = SvIV( input );
json_writer_write_integer( writer, ival );
break;
case SVt_NV:
number = SvNV( input );
json_writer_write_number( writer, number );
break;
case SVt_PV:
val = SvPV( input, len );
json_writer_write_strn( writer, val, len );
break;
case SVt_PVNV:
if ( input == &PL_sv_yes ) {
json_writer_write_boolean( writer, TRUE );
}
else if ( input == &PL_sv_no ) {
json_writer_write_boolean( writer, FALSE );
}
break;
case SVt_PVAV:
perl_array_to_json( input, writer );
break;
case SVt_PVHV:
perl_hash_to_json( input, writer );
break;
default:
break;
}
}
static void
print_var(char *var_name, char *var)
{
HV *h_var;
h_var = get_hv(var_name, 0);
if(!h_var) error_tmpl("Vars hash not exist");
SV **sr_var = hv_fetch(h_var, var, (int)strlen(var), 0);
if(!sr_var){ error_tmpl("Var not exist");};
if(SvTYPE(*sr_var) == SVt_IV || SvTYPE(*sr_var) == SVt_PVIV){ printf( "%li", SvIV(*sr_var)); }
else if(SvTYPE(*sr_var) == SVt_NV || SvTYPE(*sr_var) == SVt_PVNV){ printf("%f", SvNV(*sr_var)); }
else if(SvTYPE(*sr_var) == SVt_PV){ printf("%s", SvPV_nolen(*sr_var)); }
else { error_tmpl("Incompatible type of var"); }
}
/* Code for serializing floats */
SRL_STATIC_INLINE void
srl_dump_nv(pTHX_ srl_encoder_t *enc, SV *src)
{
NV nv= SvNV(src);
MS_VC6_WORKAROUND_VOLATILE float f= (float)nv;
MS_VC6_WORKAROUND_VOLATILE double d= (double)nv;
/* TODO: this logic could be reworked to not duplicate so much code, which will help on win32 */
if ( f == nv || nv != nv ) {
BUF_SIZE_ASSERT(enc, 1 + sizeof(f)); /* heuristic: header + string + simple value */
srl_buf_cat_char_nocheck(enc,SRL_HDR_FLOAT);
Copy((char *)&f, enc->pos, sizeof(f), char);
enc->pos += sizeof(f);
} else if (d == nv) {
void sv2idcval(SV *sv, idc_value_t *val)
{
switch(val->vtype)
{
// note: idc_value_t calls qfree in it's destructor.
// problem: if ST is '$1' this somehow does not work.
case VT_STR: val->str= qstrdup(SvPV_nolen_const(sv)); break;
case VT_LONG: val->num= SvIV(sv); break;
case VT_FLOAT: double nv= SvNV(sv);
ph.realcvt(&nv, val->e, 3);
break;
}
}
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;
}
static CORBA_boolean
put_float (GIOPSendBuffer *buf, SV *sv)
{
double nv = SvNV(sv);
CORBA_float v = nv;
/* FIXME: add a correct warning */
/* if ((CORBA::Float)v != v) {
warn ("CORBA::Float out of range");
return CORBA_FALSE;
}*/
buf_putn (buf, &v, sizeof (v));
return CORBA_TRUE;
}
double
kino_Host_callback_f64(void *vobj, char *method, uint32_t num_args, ...)
{
va_list args;
SV *return_sv;
double retval;
va_start(args, num_args);
return_sv = S_do_callback_sv(vobj, method, num_args, args);
va_end(args);
retval = SvNV(return_sv);
FREETMPS;
LEAVE;
return retval;
}
float
kino_Host_callback_f(void *vobj, char *method, chy_u32_t num_args, ...)
{
kino_Obj *obj = (kino_Obj*)vobj;
va_list args;
SV *return_sv;
float retval;
va_start(args, num_args);
return_sv = do_callback_sv(obj, method, num_args, args);
va_end(args);
retval = (float)SvNV(return_sv);
FREETMPS;
LEAVE;
return retval;
}
/* transfer and may_be_null can be gotten from arg_info, but sv_to_arg is also
* called from places which don't have access to a GIArgInfo. */
static void
sv_to_arg (SV * sv,
GIArgument * arg,
GIArgInfo * arg_info,
GITypeInfo * type_info,
GITransfer transfer,
gboolean may_be_null,
GPerlI11nInvocationInfo * invocation_info)
{
GITypeTag tag = g_type_info_get_tag (type_info);
if (!gperl_sv_is_defined (sv))
/* Interfaces and void types need to be able to handle undef
* separately. */
if (!may_be_null && tag != GI_TYPE_TAG_INTERFACE
&& tag != GI_TYPE_TAG_VOID) {
if (arg_info) {
ccroak ("undefined value for mandatory argument '%s' encountered",
g_base_info_get_name ((GIBaseInfo *) arg_info));
} else {
ccroak ("undefined value encountered");
}
}
switch (tag) {
case GI_TYPE_TAG_VOID:
/* returns NULL if no match is found */
arg->v_pointer = sv_to_callback_data (sv, invocation_info);
break;
case GI_TYPE_TAG_BOOLEAN:
arg->v_boolean = SvTRUE (sv);
break;
case GI_TYPE_TAG_INT8:
arg->v_int8 = (gint8) SvIV (sv);
break;
case GI_TYPE_TAG_UINT8:
arg->v_uint8 = (guint8) SvUV (sv);
break;
case GI_TYPE_TAG_INT16:
arg->v_int16 = (gint16) SvIV (sv);
break;
case GI_TYPE_TAG_UINT16:
arg->v_uint16 = (guint16) SvUV (sv);
break;
case GI_TYPE_TAG_INT32:
arg->v_int32 = (gint32) SvIV (sv);
break;
case GI_TYPE_TAG_UINT32:
arg->v_uint32 = (guint32) SvUV (sv);
break;
case GI_TYPE_TAG_INT64:
arg->v_int64 = SvGInt64 (sv);
break;
case GI_TYPE_TAG_UINT64:
arg->v_uint64 = SvGUInt64 (sv);
break;
case GI_TYPE_TAG_FLOAT:
arg->v_float = (gfloat) SvNV (sv);
break;
case GI_TYPE_TAG_DOUBLE:
arg->v_double = SvNV (sv);
break;
case GI_TYPE_TAG_UNICHAR:
arg->v_uint32 = g_utf8_get_char (SvGChar (sv));
break;
case GI_TYPE_TAG_GTYPE:
/* GType == gsize */
arg->v_size = gperl_type_from_package (SvPV_nolen (sv));
if (!arg->v_size)
arg->v_size = g_type_from_name (SvPV_nolen (sv));
break;
case GI_TYPE_TAG_ARRAY:
arg->v_pointer = sv_to_array (transfer, type_info, sv, invocation_info);
break;
case GI_TYPE_TAG_INTERFACE:
dwarn (" type %p -> interface\n", type_info);
sv_to_interface (arg_info, type_info, transfer, may_be_null,
sv, arg, invocation_info);
break;
case GI_TYPE_TAG_GLIST:
case GI_TYPE_TAG_GSLIST:
arg->v_pointer = sv_to_glist (transfer, type_info, sv);
break;
case GI_TYPE_TAG_GHASH:
arg->v_pointer = sv_to_ghash (transfer, type_info, sv);
break;
case GI_TYPE_TAG_ERROR:
ccroak ("FIXME - A GError as an in/inout arg? Should never happen!");
break;
case GI_TYPE_TAG_UTF8:
arg->v_string = gperl_sv_is_defined (sv) ? SvGChar (sv) : NULL;
if (transfer >= GI_TRANSFER_CONTAINER)
arg->v_string = g_strdup (arg->v_string);
break;
case GI_TYPE_TAG_FILENAME:
/* FIXME: Should we use SvPVbyte_nolen here? */
arg->v_string = gperl_sv_is_defined (sv) ? SvPV_nolen (sv) : NULL;
if (transfer >= GI_TRANSFER_CONTAINER)
arg->v_string = g_strdup (arg->v_string);
break;
default:
ccroak ("Unhandled info tag %d in sv_to_arg", tag);
}
}
OP *
Perl_scalarvoid(pTHX_ OP *o)
{
dVAR;
OP *kid;
const char* useless = NULL;
SV* sv;
U8 want;
PERL_ARGS_ASSERT_SCALARVOID;
/* trailing mad null ops don't count as "there" for void processing */
if (PL_madskills &&
o->op_type != OP_NULL &&
o->op_sibling &&
o->op_sibling->op_type == OP_NULL)
{
OP *sib;
for (sib = o->op_sibling;
sib && sib->op_type == OP_NULL;
sib = sib->op_sibling) ;
if (!sib)
return o;
}
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_DBSTATE
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
|| o->op_targ == OP_DBSTATE)))
PL_curcop = (COP*)o; /* for warning below */
/* assumes no premature commitment */
want = o->op_flags & OPf_WANT;
if ((want && want != OPf_WANT_SCALAR)
|| (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN)
{
return o;
}
if ((o->op_flags & OPf_TARGET_MY)
&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
{
return scalar(o); /* As if inside SASSIGN */
}
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
switch (o->op_type) {
default:
if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
break;
/* FALL THROUGH */
case OP_REPEAT:
if (o->op_flags & OPf_STACKED)
break;
goto func_ops;
case OP_SUBSTR:
case OP_VEC:
if (o->op_private == 4)
break;
/* FALL THROUGH */
case OP_GVSV:
case OP_GV:
case OP_PADSV:
case OP_REF:
case OP_SREFGEN:
case OP_DEFINED:
case OP_HEX:
case OP_OCT:
case OP_LENGTH:
case OP_INDEX:
case OP_RINDEX:
case OP_SPRINTF:
case OP_ASLICE:
case OP_HSLICE:
case OP_UNPACK:
case OP_PACK:
case OP_JOIN:
case OP_LSLICE:
case OP_SORT:
case OP_REVERSE:
case OP_RANGE:
case OP_CALLER:
case OP_FILENO:
case OP_EOF:
case OP_TELL:
case OP_GETSOCKNAME:
case OP_GETPEERNAME:
case OP_READLINK:
case OP_TELLDIR:
case OP_GETPPID:
case OP_GETPGRP:
case OP_GETPRIORITY:
case OP_TIME:
case OP_TMS:
case OP_LOCALTIME:
case OP_GMTIME:
case OP_GHBYNAME:
case OP_GHBYADDR:
case OP_GHOSTENT:
case OP_GNBYNAME:
case OP_GNBYADDR:
case OP_GNETENT:
case OP_GPBYNAME:
case OP_GPBYNUMBER:
case OP_GPROTOENT:
case OP_GSBYNAME:
case OP_GSBYPORT:
case OP_GSERVENT:
case OP_GPWNAM:
case OP_GPWUID:
case OP_GGRNAM:
case OP_GGRGID:
case OP_GETLOGIN:
case OP_PROTOTYPE:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
/* Otherwise it's "Useless use of grep iterator" */
useless = OP_DESC(o);
break;
case OP_HELEM:
case OP_AELEM:
case OP_AELEMFAST:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO|OPpELEM_ADD)))
/* Otherwise it's "Useless use of grep iterator" */
useless = OP_DESC(o);
break;
case OP_ANONARRAY:
case OP_ANONHASH:
useless = OP_DESC(o);
break;
case OP_NOT:
kid = cUNOPo->op_first;
if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST) {
goto func_ops;
}
useless = "negative pattern binding (!~)";
break;
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
case OP_RV2HV:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
(!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
useless = "a variable";
break;
case OP_CONST:
sv = cSVOPo_sv;
if (cSVOPo->op_private & OPpCONST_STRICT)
Perl_croak_at(aTHX_
o->op_location,
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
SVfARG(cSVOPo_sv));
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
useless = NULL;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = NULL;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
(before the invention of POD) was based on a
trick to mix nroff and perl code. The trick was
built upon these three nroff macros being used in
void context. The pink camel has the details in
the script wrapman near page 319. */
const char * const maybe_macro = SvPVX_const(sv);
if (strnEQ(maybe_macro, "di", 2) ||
strnEQ(maybe_macro, "ds", 2) ||
strnEQ(maybe_macro, "ig", 2))
useless = NULL;
}
}
}
op_null(o); /* don't execute or even remember it */
break;
#ifndef PERL_MAD
case OP_POSTINC:
o->op_type = OP_PREINC; /* pre-increment is faster */
o->op_ppaddr = PL_ppaddr[OP_PREINC];
break;
case OP_POSTDEC:
o->op_type = OP_PREDEC; /* pre-decrement is faster */
o->op_ppaddr = PL_ppaddr[OP_PREDEC];
break;
case OP_I_POSTINC:
o->op_type = OP_I_PREINC; /* pre-increment is faster */
o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
break;
case OP_I_POSTDEC:
o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
break;
#endif /* MAD */
case OP_OR:
case OP_AND:
case OP_DOR:
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
case OP_NULL:
if (o->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
case OP_ENTERTRY:
case OP_ENTER:
if (!(o->op_flags & OPf_KIDS))
break;
/* FALL THROUGH */
case OP_SCOPE:
case OP_LEAVE:
case OP_LEAVETRY:
case OP_LEAVELOOP:
case OP_LINESEQ:
case OP_LIST:
case OP_LISTLAST:
case OP_LISTFIRST:
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
case OP_SASSIGN:
scalarvoid(cBINOPo->op_last);
break;
case OP_ENTEREVAL:
scalarkids(o);
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
o->op_flags &= ~OPf_WANT;
/* FALL THROUGH */
case OP_SCALAR:
return scalar(o);
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplrootu.op_pmreplroot)
deprecate_old("implicit split to @_");
}
break;
}
if (useless && !(o->op_flags & OPf_ASSIGN)
&& ckWARN(WARN_VOID))
Perl_warner_at(aTHX_ o->op_location, packWARN(WARN_VOID), "Useless use of %s in void context", useless);
return o;
}
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));
}
}
SV * call_dubd ( SV* in ) {
double ret = dubd((double)SvNV(in));
return newSVuv(ret);
}
