コード例 #1
0
ファイル: dimension.c プロジェクト: gitpan/Convert-Binary-C
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;
}
コード例 #2
0
ファイル: typemap_func.c プロジェクト: gitpan/XS-TCC
/* T_CVREF */
CV *
tm_input_cvref(pTHX_ SV * const arg)
{
    HV *st;
    GV *gvp;
    SvGETMAGIC(arg);
    return sv_2cv(arg, &st, &gvp, 0);
}
コード例 #3
0
ファイル: swiftperl.c プロジェクト: dankogai/swift-perl
// rv getters
char *swiftperl_reftype(void *vp) {
    SvGETMAGIC((SV *)vp);
    if (SvROK((SV *)vp)) {
        return (char *)sv_reftype(SvRV((SV *)vp), 0);
    } else {
        return "";
    }
}
コード例 #4
0
ファイル: typemap_func.c プロジェクト: gitpan/XS-TCC
/* T_HVREF */
HV *
tm_input_hvref(pTHX_ SV * const arg)
{
    SvGETMAGIC(arg);
    if (LIKELY( SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV ))
        return (HV *)SvRV(arg);
    else
        return NULL;
}
コード例 #5
0
ファイル: typemap_func.c プロジェクト: gitpan/XS-TCC
/* T_SVREF */
SV *
tm_input_svref(pTHX_ SV * const arg)
{
    SV *var;
    SvGETMAGIC(arg);
    if ( !SvROK(arg) )
        return NULL;
    var = SvRV(arg);
    return var;
}
コード例 #6
0
ファイル: ddl_enc.c プロジェクト: gitpan/Data-Dumper-Limited
/* Entry point for serialization. Dumps generic SVs and delegates
 * to more specialized functions for RVs, etc. */
void
ddl_dump_sv(pTHX_ ddl_encoder_t *enc, SV *src)
{
  SvGETMAGIC(src);

  /* dump strings */
  if (SvPOKp(src)) {
    STRLEN len;
    char *str = SvPV(src, len);
    BUF_SIZE_ASSERT(enc, 2 + len);
    ddl_dump_pv(aTHX_ enc, str, len, SvUTF8(src));
  }
  /* dump floats */
  else if (SvNOKp(src)) {
    BUF_SIZE_ASSERT(enc, NV_DIG + 32);
    Gconvert(SvNVX(src), NV_DIG, 0, enc->pos);
    enc->pos += strlen(enc->pos);
  }
  /* dump ints */
  else if (SvIOKp(src)) {
    /* we assume we can always read an IV as a UV and vice versa
     * we assume two's complement
     * we assume no aliasing issues in the union */
    if (SvIsUV(src) ? SvUVX(src) <= 59000
                    : SvIVX(src) <= 59000 && SvIVX(src) >= -59000)
    {
      /* optimise the "small number case"
       * code will likely be branchless and use only a single multiplication
       * works for numbers up to 59074 */
      I32 i = SvIVX(src);
      U32 u;
      char digit, nz = 0;

      BUF_SIZE_ASSERT(enc, 6);

      *enc->pos = '-'; enc->pos += i < 0 ? 1 : 0;
      u = i < 0 ? -i : i;

      /* convert to 4.28 fixed-point representation */
      u *= ((0xfffffff + 10000) / 10000); /* 10**5, 5 fractional digits */

      /* now output digit by digit, each time masking out the integer part
       * and multiplying by 5 while moving the decimal point one to the right,
       * resulting in a net multiplication by 10.
       * we always write the digit to memory but conditionally increment
       * the pointer, to enable the use of conditional move instructions. */
      digit = u >> 28; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0xfffffffUL) * 5;
      digit = u >> 27; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0x7ffffffUL) * 5;
      digit = u >> 26; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0x3ffffffUL) * 5;
      digit = u >> 25; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0x1ffffffUL) * 5;
      digit = u >> 24; *enc->pos = digit + '0'; enc->pos += 1; /* correctly generate '0' */
    }
    else {
コード例 #7
0
ファイル: net_getdns.c プロジェクト: DNS-OARC/p5-Net-GetDNS
getdns_return_t net_getdns_hostname(Net__GetDNS__XS__Context * context, Net__GetDNS__XS__Dict * address, Net__GetDNS__XS__Dict * extensions, SV * userarg, getdns_transaction_t * transaction_id, SV * callbackfn)
{
    struct __callback * cb = 0;

    if (!callbackfn) {
        return GETDNS_RETURN_GENERIC_ERROR;
    }
    if (!SvOK(callbackfn)) {
        return GETDNS_RETURN_GENERIC_ERROR;
    }

    Newxz(cb, 1, struct __callback);
    if (!cb) return GETDNS_RETURN_MEMORY_ERROR;

    if (SvOK(userarg)) {
        SvGETMAGIC(userarg);
        cb->userarg = userarg;
    }
    SvGETMAGIC(callbackfn);
    cb->callbackfn = SvREFCNT_inc(newSVsv(callbackfn));

    return getdns_hostname(context, address, extensions, cb, transaction_id, __getdns_callback);
}
コード例 #8
0
ファイル: option.c プロジェクト: mhx/Convert-Binary-C
void handle_string_list(pTHX_ const char *option, LinkedList list, SV *sv, SV **rval)
{
  const char *str;

  if (sv)
  {
    LL_flush(list, (LLDestroyFunc) string_delete); 

    if (SvROK(sv))
    {
      sv = SvRV(sv);

      if (SvTYPE(sv) == SVt_PVAV)
      {
        AV *av = (AV *) sv;
        SV **pSV;
        int i, max = av_len(av);

        for (i = 0; i <= max; i++)
        {
          if ((pSV = av_fetch(av, i, 0)) != NULL)
          {
            SvGETMAGIC(*pSV);
            LL_push(list, string_new_fromSV(aTHX_ *pSV));
          }
          else
            fatal("NULL returned by av_fetch() in handle_string_list()");
        }
      }
      else
        Perl_croak(aTHX_ "%s wants an array reference", option);
    }
    else
      Perl_croak(aTHX_ "%s wants a reference to an array of strings", option);
  }

  if (rval)
  {
    ListIterator li;
    AV *av = newAV();

    LL_foreach(str, li, list)
      av_push(av, newSVpv(CONST_CHAR(str), 0));

    *rval = newRV_noinc((SV *) av);
  }
}
コード例 #9
0
/*
    NOTE: mouse_tc_check() handles GETMAGIC
*/
int
mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
    CV* const cv = (CV*)SvRV(tc_code);
    assert(SvTYPE(cv) == SVt_PVCV);

    if(CvXSUB(cv) == XS_Mouse_constraint_check){ /* built-in type constraints */
        MAGIC* const mg = (MAGIC*)CvXSUBANY(cv).any_ptr;

        assert(CvXSUBANY(cv).any_ptr != NULL);
        assert(mg->mg_ptr            != NULL);

        SvGETMAGIC(sv);
        /* call the check function directly, skipping call_sv() */
        return CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv);
    }
    else { /* custom */
        int ok;
        dSP;
        dMY_CXT;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        XPUSHs(sv);
        if( MY_CXT.tc_extra_args ) {
            AV* const av  = MY_CXT.tc_extra_args;
            I32 const len = AvFILLp(av) + 1;
            int i;
            for(i = 0; i < len; i++) {
                XPUSHs( AvARRAY(av)[i] );
            }
        }
        PUTBACK;

        call_sv(tc_code, G_SCALAR);

        SPAGAIN;
        ok = sv_true(POPs);
        PUTBACK;

        FREETMPS;
        LEAVE;

        return ok;
    }
}
コード例 #10
0
ファイル: mathoms.c プロジェクト: evalEmpire/piledriver
void
Perl_save_list(pTHX_ SV **sarg, I32 maxsarg)
{
    I32 i;

    PERL_ARGS_ASSERT_SAVE_LIST;

    for (i = 1; i <= maxsarg; i++) {
        SV *sv;
        SvGETMAGIC(sarg[i]);
        sv = newSV(0);
        sv_setsv_nomg(sv,sarg[i]);
        SSCHECK(3);
        SSPUSHPTR(sarg[i]);		/* remember the pointer */
        SSPUSHPTR(sv);			/* remember the value */
        SSPUSHUV(SAVEt_ITEM);
    }
}
コード例 #11
0
ファイル: scalar.c プロジェクト: Cui-Research-RIT/NucPipeline
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
		    PerlIO_funcs * tab)
{
    IV code;
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    /* If called (normally) via open() then arg is ref to scalar we are
     * using, otherwise arg (from binmode presumably) is either NULL
     * or the _name_ of the scalar
     */
    if (arg) {
	if (SvROK(arg)) {
	    if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
		if (ckWARN(WARN_LAYER))
		    Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
		SETERRNO(EINVAL, SS_IVCHAN);
		return -1;
	    }
	    s->var = SvREFCNT_inc(SvRV(arg));
	    SvGETMAGIC(s->var);
	    if (!SvPOK(s->var) && SvOK(s->var))
		(void)SvPV_nomg_const_nolen(s->var);
	}
	else {
	    s->var =
		SvREFCNT_inc(perl_get_sv
			     (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
	}
    }
    else {
	s->var = newSVpvn("", 0);
    }
    SvUPGRADE(s->var, SVt_PV);
    code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
    if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
	SvCUR_set(s->var, 0);
    if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
	s->posn = SvCUR(s->var);
    else
	s->posn = 0;
    return code;
}
コード例 #12
0
ファイル: Socket.c プロジェクト: macholic/perl5
static void xs_getaddrinfo(pTHX_ CV *cv)
{
	dVAR;
	dXSARGS;

	SV   *host;
	SV   *service;
	SV   *hints;

	char *hostname = NULL;
	char *servicename = NULL;
	STRLEN len;
	struct addrinfo hints_s;
	struct addrinfo *res;
	struct addrinfo *res_iter;
	int err;
	int n_res;

	if(items > 3)
		croak_xs_usage(cv, "host, service, hints");

	SP -= items;

	if(items < 1)
		host = &PL_sv_undef;
	else
		host = ST(0);

	if(items < 2)
		service = &PL_sv_undef;
	else
		service = ST(1);

	if(items < 3)
		hints = NULL;
	else
		hints = ST(2);

	SvGETMAGIC(host);
	if(SvOK(host)) {
		hostname = SvPV_nomg(host, len);
		if (!len)
			hostname = NULL;
	}

	SvGETMAGIC(service);
	if(SvOK(service)) {
		servicename = SvPV_nomg(service, len);
		if (!len)
			servicename = NULL;
	}

	Zero(&hints_s, sizeof hints_s, char);
	hints_s.ai_family = PF_UNSPEC;

	if(hints && SvOK(hints)) {
		HV *hintshash;
		SV **valp;

		if(!SvROK(hints) || SvTYPE(SvRV(hints)) != SVt_PVHV)
			croak("hints is not a HASH reference");

		hintshash = (HV*)SvRV(hints);

		if((valp = hv_fetch(hintshash, "flags", 5, 0)) != NULL)
			hints_s.ai_flags = SvIV(*valp);
		if((valp = hv_fetch(hintshash, "family", 6, 0)) != NULL)
			hints_s.ai_family = SvIV(*valp);
		if((valp = hv_fetch(hintshash, "socktype", 8, 0)) != NULL)
			hints_s.ai_socktype = SvIV(*valp);
		if((valp = hv_fetch(hintshash, "protocol", 8, 0)) != NULL)
			hints_s.ai_protocol = SvIV(*valp);
	}

	err = getaddrinfo(hostname, servicename, &hints_s, &res);

	XPUSHs(err_to_SV(aTHX_ err));

	if(err)
		XSRETURN(1);

	n_res = 0;
	for(res_iter = res; res_iter; res_iter = res_iter->ai_next) {
		HV *res_hv = newHV();

		(void)hv_stores(res_hv, "family",   newSViv(res_iter->ai_family));
		(void)hv_stores(res_hv, "socktype", newSViv(res_iter->ai_socktype));
		(void)hv_stores(res_hv, "protocol", newSViv(res_iter->ai_protocol));

		(void)hv_stores(res_hv, "addr",     newSVpvn((char*)res_iter->ai_addr, res_iter->ai_addrlen));

		if(res_iter->ai_canonname)
			(void)hv_stores(res_hv, "canonname", newSVpv(res_iter->ai_canonname, 0));
		else
			(void)hv_stores(res_hv, "canonname", newSV(0));

		XPUSHs(sv_2mortal(newRV_noinc((SV*)res_hv)));
		n_res++;
	}

	freeaddrinfo(res);

	XSRETURN(1 + n_res);
}
コード例 #13
0
ファイル: interpreter.C プロジェクト: Leont/libperl--
	Hash::Temp Interpreter::hash(const char* name) const {
		HV* const ret = get_hv(name, true);
		SvGETMAGIC(reinterpret_cast<SV*>(ret));
		return Hash::Temp(raw_interp.get(), ret, false);
	}
コード例 #14
0
ファイル: option.c プロジェクト: mhx/Convert-Binary-C
static void disabled_keywords(pTHX_ LinkedList *current, SV *sv, SV **rval,
                              u_32 *pKeywordMask)
{
  const char *str;
  LinkedList keyword_list = NULL;

  if (sv)
  {
    if (SvROK(sv))
    {
      sv = SvRV(sv);

      if (SvTYPE(sv) == SVt_PVAV)
      {
        AV *av = (AV *) sv;
        SV **pSV;
        int i, max = av_len(av);
        u_32 keywords = HAS_ALL_KEYWORDS;

        keyword_list = LL_new();

        for (i = 0; i <= max; i++)
        {
          if ((pSV = av_fetch(av, i, 0)) != NULL)
          {
            SvGETMAGIC(*pSV);
            str = SvPV_nolen(*pSV);

#include "token/t_keywords.c"

            success:
            LL_push(keyword_list, string_new(str));
          }
          else
            fatal("NULL returned by av_fetch() in disabled_keywords()");
        }

        if (pKeywordMask != NULL)
          *pKeywordMask = keywords;

        if (current != NULL)
        {
          LL_destroy(*current, (LLDestroyFunc) string_delete); 
          *current = keyword_list;
        }
      }
      else
        Perl_croak(aTHX_ "DisabledKeywords wants an array reference");
    }
    else
      Perl_croak(aTHX_ "DisabledKeywords wants a reference to "
                       "an array of strings");
  }

  if (rval)
  {
    ListIterator li;
    AV *av = newAV();

    LL_foreach (str, li, *current)
      av_push(av, newSVpv(CONST_CHAR(str), 0));

    *rval = newRV_noinc((SV *) av);
  }

  return;

unknown:
  LL_destroy(keyword_list, (LLDestroyFunc) string_delete);
  Perl_croak(aTHX_ "Cannot disable unknown keyword '%s'", str);
}
コード例 #15
0
ファイル: interpreter.C プロジェクト: Leont/libperl--
	Array::Temp Interpreter::array(const char* name) const {
		AV* const ret = get_av(name, true);
		SvGETMAGIC(reinterpret_cast<SV*>(ret));
		return Array::Temp(raw_interp.get(), ret, false);
	}
コード例 #16
0
ファイル: msgpack.c プロジェクト: dr-co/dr-tarantool
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));
	}
}
コード例 #17
0
ファイル: JavaBin.c プロジェクト: JRaspass/JavaBin
// This function reads the various JavaBin datatypes and returns a Perl SV.
// Different datatypes are jumped to view a lookup in an array of computed gotos.
//
// The first group (undef to enum) use the entire tag for the index of the type.
//
// The second are matched by taking the tag byte, shifting it by 5 so to only read
// the first 3 bits of the tag byte, giving it a range or 0-7 inclusive.
//
// To store both in one array the second group have 18 added to them. See DISPATCH.
//
// The remaining 5 bits can then be used to store the size of the datatype, e.g. how
// many chars in a string, this therefore has a range of 0-31, if the size exceeds or
// matches this then an additional vint is added.
//
// The overview of the tag byte is therefore TTTSSSSS with T and S being type and size.
static SV* read_sv(pTHX) {
    void* dispatch[] = {
        &&read_undef,
        &&read_bool,
        &&read_bool,
        &&read_byte,
        &&read_short,
        &&read_double,
        &&read_int,
        &&read_long,
        &&read_float,
        &&read_date,
        &&read_map,
        &&read_solr_doc,
        &&read_solr_doc_list,
        &&read_byte_array,
        &&read_iterator,
        NULL,
        NULL,
        NULL,
        &&read_enum,
        &&read_string,
        &&read_small_int,
        &&read_small_long,
        &&read_array,
        &&read_map,
        &&read_map,
    };

    in++;

    goto *dispatch[in[-1] >> 5 ? (in[-1] >> 5) + 18 : in[-1]];

read_undef:
    return &PL_sv_undef;
read_bool: {
        SV *rv = newSV_type(SVt_IV), *sv = in[-1] == 1 ? bool_true : bool_false;

        SvREFCNT(sv)++;
        SvROK_on(rv);
        SvRV_set(rv, sv);

        return rv;
    }
read_byte:
    return newSViv((int8_t) *in++);
read_short: {
        const int16_t s = in[0] << 8 | in[1];

        in += 2;

        return newSViv(s);
    }
read_double: {
        // For perls with double length NVs this conversion is simple.
        // Read 8 bytes, cast to double, return. For long double perls
        // more magic is used, see read_float for more details.

        const int_double u = { (uint64_t) in[0] << 56 |
                               (uint64_t) in[1] << 48 |
                               (uint64_t) in[2] << 40 |
                               (uint64_t) in[3] << 32 |
                               (uint64_t) in[4] << 24 |
                               (uint64_t) in[5] << 16 |
                               (uint64_t) in[6] << 8  |
                               (uint64_t) in[7] };

        in += 8;

    #ifdef USE_LONG_DOUBLE
        char *str = alloca(snprintf(NULL, 0, "%.14f", u.d));

        sprintf(str, "%.14f", u.d);

        return newSVnv(strtold(str, NULL));
    #else
        return newSVnv(u.d);
    #endif
    }
read_int: {
        const int32_t i = in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3];

        in += 4;

        return newSViv(i);
    }
read_long: {
        const int64_t l = (uint64_t) in[0] << 56 |
                          (uint64_t) in[1] << 48 |
                          (uint64_t) in[2] << 40 |
                          (uint64_t) in[3] << 32 |
                          (uint64_t) in[4] << 24 |
                          (uint64_t) in[5] << 16 |
                          (uint64_t) in[6] << 8  |
                          (uint64_t) in[7];

        in += 8;

        return newSViv(l);
    }
read_float: {
        // JavaBin has a 4byte float format, NVs in perl are double or long double,
        // therefore a little magic is required. Read the 4 bytes into an int in the
        // correct endian order. Re-read these bits as a float, stringify this float,
        // then finally numify the string into a double or long double.
        const int_float u = { in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3] };

        in += 4;

        char *str = alloca(snprintf(NULL, 0, "%f", u.f));

        sprintf(str, "%f", u.f);

    #ifdef USE_LONG_DOUBLE
        return newSVnv(strtold(str, NULL));
    #else
        return newSVnv(strtod(str, NULL));
    #endif
    }
read_date: {
        const int64_t date_ms = (uint64_t) in[0] << 56 |
                                (uint64_t) in[1] << 48 |
                                (uint64_t) in[2] << 40 |
                                (uint64_t) in[3] << 32 |
                                (uint64_t) in[4] << 24 |
                                (uint64_t) in[5] << 16 |
                                (uint64_t) in[6] << 8  |
                                (uint64_t) in[7];

        in += 8;

        const time_t date = date_ms / 1000;

        const struct tm *t = gmtime(&date);

        char date_str[25];

        sprintf(date_str, "%u-%02u-%02uT%02u:%02u:%02u.%03uZ", t->tm_year + 1900,
                t->tm_mon + 1,
                t->tm_mday,
                t->tm_hour,
                t->tm_min,
                t->tm_sec,
                (uint32_t) (date_ms % 1000));

        return newSVpvn(date_str, 24);
    }
read_solr_doc:
    in++;     // Assume a solr doc is a map.
read_map: {
        HV *hv = (HV*)newSV_type(SVt_PVHV);

        uint32_t len = in[-1] >> 5 ? READ_LEN : read_v_int();

        while (len--) {
            cached_key key;

            in++;

            const uint32_t i = READ_LEN;

            if (i)
                key = cached_keys[i];
            else {
                in++;

                cached_keys[++cache_pos] = key = (cached_key){ (char*)in, 0, READ_LEN };

                uint8_t *key_str = in;

                in += key.len;

                // Set the UTF8 flag if we hit a high byte.
                while (key_str != in) {
                    if (*key_str++ & 128) {
                        key.flags = HVhek_UTF8;
                        break;
                    }
                }
            }

            hv_common(hv, NULL, key.key, key.len, key.flags, HV_FETCH_ISSTORE, read_sv(aTHX), 0);
        }

        SV *rv = newSV_type(SVt_IV);

        SvROK_on(rv);
        SvRV_set(rv, (SV*)hv);

        return rv;
    }
read_solr_doc_list: {
        HV *hv = (HV*)newSV_type(SVt_PVHV);

        // Assume values are in an array, skip tag & read_sv.
        in++;

        hv_set(hv, "numFound", read_sv(aTHX), numFound);
        hv_set(hv, "start",    read_sv(aTHX), start);
        hv_set(hv, "maxScore", read_sv(aTHX), maxScore);
        hv_set(hv, "docs",     read_sv(aTHX), docs);

        SV *rv = newSV_type(SVt_IV);

        SvROK_on(rv);
        SvRV_set(rv, (SV*)hv);

        return rv;
    }
read_byte_array: {
        AV *av = (AV*)newSV_type(SVt_PVAV);

        SSize_t len = read_v_int();

        SV **ary = safemalloc(len * sizeof(SV*));

        AvALLOC(av) = AvARRAY(av) = ary;
        AvFILLp(av) = AvMAX(av) = len - 1;

        while (len--)
            *ary++ = newSViv((int8_t) *in++);

        SV *rv = newSV_type(SVt_IV);

        SvROK_on(rv);
        SvRV_set(rv, (SV*)av);

        return rv;
    }
read_iterator: {
        AV *av = (AV*)newSV_type(SVt_PVAV);

        uint32_t len = 0;

        while (*in != 15)
            av_store(av, len++, read_sv(aTHX));

        in++;

        SV *rv = newSV_type(SVt_IV);

        SvROK_on(rv);
        SvRV_set(rv, (SV*)av);

        return rv;
    }
read_enum: {
        SV *sv = read_sv(aTHX); // small_int if +ve, int otherwise.

        sv_upgrade(sv, SVt_PVMG);

        in++;

        const STRLEN len = READ_LEN;

        char *str = sv_grow(sv, len + 1);

        memcpy(str, in, len);

        in += len;

        str[len] = '\0';

        SvCUR(sv) = len;

        SvFLAGS(sv) = SVf_IOK | SVp_IOK | SVs_OBJECT | SVf_POK | SVp_POK | SVt_PVMG | SVf_UTF8;

        HV *stash = CALL(gv_stashpvn, STR_WITH_LEN("JavaBin::Enum"), 0);

        SvREFCNT(stash)++;
        SvSTASH_set(sv, stash);

        SV *rv = newSV_type(SVt_IV);

        SvROK_on(rv);
        SvRV_set(rv, sv);

        return rv;
    }
read_string: {
        const STRLEN len = READ_LEN;

        SV *sv = newSV_type(SVt_PV);

        char *str = SvPVX(sv) = (char*)safemalloc(len);

        memcpy(str, in, len);

        SvCUR(sv) = SvLEN(sv) = len;
        SvFLAGS(sv) |= SVf_POK | SVp_POK | SVf_UTF8;

        in += len;

        return sv;
    }
read_small_int: {
        uint32_t result = in[-1] & 15;

        if (in[-1] & 16)
            result |= read_v_int() << 4;

        return newSViv(result);
    }
read_small_long: {
        uint64_t result = in[-1] & 15;

        // Inlined variable-length +ve long code, see read_v_int().
        if (in[-1] & 16) {
            uint8_t shift = 4;

            do result |= (*in++ & 127) << shift;
            while (in[-1] & 128 && (shift += 7));
        }

        return newSViv(result);
    }
read_array: {
        AV *av = (AV*)newSV_type(SVt_PVAV);

        SSize_t len = READ_LEN;

        SV **ary = safemalloc(len * sizeof(SV*));

        AvALLOC(av) = AvARRAY(av) = ary;
        AvFILLp(av) = AvMAX(av) = len - 1;

        while (len--)
            *ary++ = read_sv(aTHX);

        SV *rv = newSV_type(SVt_IV);

        SvROK_on(rv);
        SvRV(rv) = (SV*)av;

        return rv;
    }
}

static void grow_out(pTHX_ const STRLEN want) {
    const STRLEN len = out_buf - (uint8_t *)SvPVX(out_sv);

    // If we want more than we have, realloc the string.
    if (len + want >= SvLEN(out_sv)) {
        sv_grow(out_sv, len + want);

        out_buf = (uint8_t *)SvPVX(out_sv) + len;
    }
}

static void write_v_int(uint32_t i) {
    while (i & ~127) {
        *out_buf++ = (i & 127) | 128;

        i >>= 7;
    }

    *out_buf++ = i;
}

static void write_shifted_tag(uint8_t tag, uint32_t len) {
    if (len < 31)
        *out_buf++ = tag | len;
    else {
        *out_buf++ = tag | 31;

        write_v_int(len - 31);
    }
}

static void write_sv(pTHX_ SV *sv) {
    SvGETMAGIC(sv);

    if (SvPOKp(sv)) {
        const STRLEN len = SvCUR(sv);

        grow_out(aTHX_ len + 5);

        write_shifted_tag(32, len);

        memcpy(out_buf, SvPVX(sv), len);

        out_buf += len;
    }
    else if (SvNOKp(sv)) {
        const int_double u = { .d = SvNV(sv) };

        grow_out(aTHX_ 9);

        *out_buf++ = 5;
        *out_buf++ = u.i >> 56;
        *out_buf++ = u.i >> 48;
        *out_buf++ = u.i >> 40;
        *out_buf++ = u.i >> 32;
        *out_buf++ = u.i >> 24;
        *out_buf++ = u.i >> 16;
        *out_buf++ = u.i >> 8;
        *out_buf++ = u.i;
    }
    else if (SvIOKp(sv)) {
コード例 #18
0
ファイル: PJS_Reflection.c プロジェクト: gitpan/JSP
/* 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;
}
コード例 #19
0
ファイル: dimension.c プロジェクト: gitpan/Convert-Binary-C
static long dimension_from_member(pTHX_ const char *member, HV *parent)
{
  MemberExprWalker walker;
  int success = 1;
  SV *sv = NULL;
  dTHR;
  dXCPT;

  assert(member != NULL);

  if (parent == NULL)
  {
    WARN((aTHX_ "Missing parent to look up '%s'", member));
    return 0;
  }

  CT_DEBUG(MAIN, ("trying to get dimension from member, walking \"%s\"", member));

  walker = member_expr_walker_new(aTHX_ member, 0);

  XCPT_TRY_START
  {
    for (;;)
    {
      struct me_walk_info mei;

      member_expr_walker_walk(aTHX_ walker, &mei);

      if (mei.retval == MERV_END)
      {
        break;

lookup_failed:
        success = 0;
        break;
      }

      switch (mei.retval)
      {
        case MERV_COMPOUND_MEMBER:
          {
            const char *name = mei.u.compound_member.name;
            HV *hv = parent;
            SV **psv;

            CT_DEBUG(MAIN, ("found compound member \"%s\"", name));

            if (sv)
            {
              SV *hash;

              if (SvROK(sv) && SvTYPE(hash = SvRV(sv)) == SVt_PVHV)
              {
                hv = (HV *) hash;
              }
              else
              {
                WARN((aTHX_ "Expected a hash reference to look up member '%s'"
                            " in '%s', not %s", name, member, identify_sv(sv)));
                goto lookup_failed;
              }
            }

            psv = hv_fetch(hv, name, mei.u.compound_member.name_length, 0);

            if (psv)
            {
              SvGETMAGIC(*psv);
              sv = *psv;
            }
            else
            {
              WARN((aTHX_ "Cannot find member '%s' in hash (in '%s')", name, member));
              goto lookup_failed;
            }
          }
          break;

        case MERV_ARRAY_INDEX:
          {
            long last, index = mei.u.array_index;
            AV *av;
            SV *array;
            SV **psv;

            assert(sv != NULL);

            CT_DEBUG(MAIN, ("found array index \"%ld\"", index));

            if (SvROK(sv) && SvTYPE(array = SvRV(sv)) == SVt_PVAV)
            {
              av = (AV *) array;
            }
            else
            {
              WARN((aTHX_ "Expected an array reference to look up index '%ld'"
                          " in '%s', not %s", index, member, identify_sv(sv)));
              goto lookup_failed;
            }

            last = (long) av_len(av);

            if (index > last)
            {
              WARN((aTHX_ "Cannot lookup index '%ld' in array of size"
                          " '%ld' (in '%s')", index, last + 1, member));
              goto lookup_failed;
            }

            psv = av_fetch(av, index, 0);

            if (psv == NULL)
            {
              fatal("cannot find index '%ld' in array of size '%ld' (in '%s')",
                    index, last + 1, member);
            }

            SvGETMAGIC(*psv);
            sv = *psv;
          }
          break;

        default:
          fatal("unexpected return value (%d) in dimension_from_member('%s')",
                (int) mei.retval, member);
          break;
      }
    }
  }
  XCPT_TRY_END

  member_expr_walker_delete(aTHX_ walker);

  XCPT_CATCH
  {
    XCPT_RETHROW;
  }

  if (success)
  {
    assert(sv != NULL);

    return sv_to_dimension(aTHX_ sv, member);
  }

  return 0;
}