C++ SvROK函数代码示例

VAstEnt* VAstEnt::findSym (const string& name) {
    HV* hvp = subhash();  assert(hvp);
    // $svpp = $table{$name}
    SV** svpp = hv_fetch(hvp, name.c_str(), name.length(), 0/*no-change*/);
    if (!svpp) return NULL;
    SV* svp = *svpp;
    if (!svp || !SvROK(svp) || SvTYPE(SvRV(svp)) != SVt_PVAV) return NULL;
    // $sub_avp = @{$table{$name}}
    AV* sub_avp = (AV*)(SvRV(svp));
    VAstEnt* entp = avToSymEnt(sub_avp);
    if (debug()) cout<<"VAstEnt::find found under="<<this<<" "<<entp->ascii(name)<<"\n";
    return entp;
}

std::vector<T> toMsgVec(SV* sv)
{
    std::vector<T> return_vec;
    if (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)
        Perl_croak(aTHX_ "Expected an array ref of messages");
    AV* msg_av = (AV*) SvRV(sv);
    int length = AvFILL(msg_av) + 1;
    for (int i = 0; i < length; i++) {
        SV* el = *(av_fetch(msg_av, i, 0));
        return_vec.push_back(toMsg<T>(el));
    }
    return return_vec;
}

USER_OBJECT_
RS_PerlLength(USER_OBJECT_ obj)
{
 SV *sv;
 int n;
 USER_OBJECT_ ans;
 dTHX;

 sv = RS_PerlGetSV(obj);
 if(!sv) {
   PROBLEM "Can't get Perl object from S object"
   ERROR;
 }

 /*
   Check for 
     a) objects,
     b) references 
   here.
  */

#if 0
 if(sv_isobject(sv)) {
/*XXX What are we warning here. Is it debugging? */
    PROBLEM "Calling length on a Perl object"
    WARN;
 }
#endif

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

 switch(SvTYPE(sv)) {
    case SVt_PVHV:
       n = hv_iterinit((HV*) sv);
     break;
    case SVt_PVAV:
       n = av_len((AV*) sv) + 1; 
     break;
    default:
      n = 0;
      break;
 }

  ans = NEW_INTEGER(1);
  INTEGER_DATA(ans)[0] = n;

 return(ans);
}

/*
 * convert perl HV to partition_info_t
 */
int
hv_to_partition_info(HV *hv, partition_info_t *part_info)
{
    SV **svp;
    AV *av;
    int i, n;

    memset(part_info, 0, sizeof(partition_info_t));

    FETCH_FIELD(hv, part_info, allow_alloc_nodes, charp, FALSE);
    FETCH_FIELD(hv, part_info, allow_accounts, charp, FALSE);
    FETCH_FIELD(hv, part_info, allow_groups, charp, FALSE);
    FETCH_FIELD(hv, part_info, allow_qos, charp, FALSE);
    FETCH_FIELD(hv, part_info, alternate, charp, FALSE);
    FETCH_FIELD(hv, part_info, cr_type, uint16_t, FALSE);
    FETCH_FIELD(hv, part_info, def_mem_per_cpu, uint32_t, FALSE);
    FETCH_FIELD(hv, part_info, default_time, uint32_t, TRUE);
    FETCH_FIELD(hv, part_info, deny_accounts, charp, FALSE);
    FETCH_FIELD(hv, part_info, deny_qos, charp, FALSE);
    FETCH_FIELD(hv, part_info, flags, uint16_t, TRUE);
    FETCH_FIELD(hv, part_info, grace_time, uint32_t, FALSE);
    FETCH_FIELD(hv, part_info, max_cpus_per_node, uint32_t, FALSE);
    FETCH_FIELD(hv, part_info, max_mem_per_cpu, uint32_t, FALSE);
    FETCH_FIELD(hv, part_info, max_nodes, uint32_t, TRUE);
    FETCH_FIELD(hv, part_info, max_share, uint16_t, TRUE);
    FETCH_FIELD(hv, part_info, max_time, uint32_t, TRUE);
    FETCH_FIELD(hv, part_info, min_nodes, uint32_t, TRUE);
    FETCH_FIELD(hv, part_info, name, charp, TRUE);
    svp = hv_fetch(hv, "node_inx", 8, FALSE);
    if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
        av = (AV*)SvRV(*svp);
        n = av_len(av) + 2; /* for trailing -1 */
        part_info->node_inx = xmalloc(n * sizeof(int));
        for (i = 0 ; i < n-1; i += 2) {
            part_info->node_inx[i] = (int)SvIV(*(av_fetch(av, i, FALSE)));
            part_info->node_inx[i+1] = (int)SvIV(*(av_fetch(av, i+1 ,FALSE)));
        }
        part_info->node_inx[n-1] = -1;
    } else {
        /* nothing to do */
    }
    FETCH_FIELD(hv, part_info, nodes, charp, FALSE);
    FETCH_FIELD(hv, part_info, preempt_mode, uint16_t, TRUE);
    FETCH_FIELD(hv, part_info, priority, uint16_t, TRUE);
    FETCH_FIELD(hv, part_info, qos_char, charp, TRUE);
    FETCH_FIELD(hv, part_info, state_up, uint16_t, TRUE);
    FETCH_FIELD(hv, part_info, total_cpus, uint32_t, TRUE);
    FETCH_FIELD(hv, part_info, total_nodes, uint32_t, TRUE);
    return 0;
}

request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
{
    SV *sv = (SV *)NULL;
    MAGIC *mg;

    if (SvROK(in)) {
        SV *rv = (SV*)SvRV(in);

        switch (SvTYPE(rv)) {
          case SVt_PVMG:
            sv = rv;
            break;
          case SVt_PVHV:
            sv = modperl_hv_request_find(aTHX_ in, classname, cv);
            break;
          default:
            Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
                       (int)SvTYPE(rv));
        }
    }

    /* might be Apache2::ServerRec::warn method */
    if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) {
        request_rec *r = NULL;
        (void)modperl_tls_get_request_rec(&r);

        if (!r) {
            Perl_croak(aTHX_
                       "Apache2->%s called without setting Apache2->request!",
                       cv ? GvNAME(CvGV(cv)) : "unknown");
        }

        return r;
    }

    /* there could be pool magic attached to custom $r object, so make
     * sure that mg->mg_ptr is set */
    if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) {
        return (request_rec *)mg->mg_ptr;
    }
    else {
        if (classname && !sv_derived_from(in, classname)) {
            /* XXX: find something faster than sv_derived_from */
            return NULL;
        }
        return INT2PTR(request_rec *, SvIV(sv));
    }

    return NULL;
}

static CORBA_boolean
put_union (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv)
{
    SV **discriminator;
    SV **value;
    AV *av;
    CORBA_long arm;
    
    if (sv == &PL_sv_undef) {
	if (PL_dowarn & G_WARN_ON)
	    warn ("Uninitialized union");
	if (!porbit_put_sv (buf, tc->discriminator, &PL_sv_undef))
	    return CORBA_FALSE;
	arm = porbit_union_find_arm (tc, &PL_sv_undef);
	if (arm < 0) {
	    warn("union discriminator branch does not match any arm, and no default arm");
	    return CORBA_FALSE;
	}
	return porbit_put_sv (buf, tc->subtypes[arm], &PL_sv_undef);
    }

    if (!SvROK(sv) || 
	(SvTYPE(SvRV(sv)) != SVt_PVAV)) {
	warn("Union must be array reference");
	return CORBA_FALSE;
    }

    av = (AV *)SvRV(sv);
    discriminator = av_fetch(av, 0, 0);

    if (!discriminator && (PL_dowarn & G_WARN_ON))
	warn ("Uninitialized union discriminator");

    if (!porbit_put_sv (buf, tc->discriminator,
	discriminator ? *discriminator : &PL_sv_undef))
	return CORBA_FALSE;
    
    arm = porbit_union_find_arm (tc,
	discriminator ? *discriminator : &PL_sv_undef);
    if (arm < 0) {
	warn("union discriminator branch does not match any arm, and no default arm");
	return CORBA_FALSE;
    }

    value = av_fetch(av, 1, 0);

    return porbit_put_sv (buf, tc->subtypes[arm],
	value ? *value : &PL_sv_undef);
}

USER_OBJECT_
RS_PerlNames(USER_OBJECT_ obj)
{

 HV* hv;
 SV *el;
 int n, i; 
 USER_OBJECT_ names;
 char *key;
 I32 len;
 dTHX;

 if(IS_CHARACTER(obj)) {
   hv = get_hv(CHAR_DEREF(STRING_ELT(obj,0)), FALSE);
 } else
  hv = (HV *) RS_PerlGetSV(obj);  

  if(hv == NULL) {
    PROBLEM "identifier does not refer to a Perl hashtable object"
    ERROR;
  }


 if(SvTYPE(hv) != SVt_PVHV) {
      if(SvROK(hv) && SvTYPE(SvRV(hv)) == SVt_PVHV) {
         hv = (HV *) SvRV(hv);
      } else {
	  PROBLEM "identifier is not a Perl hashtable object, but some other type %s", getPerlType((SV*)hv)
	  ERROR;
      }
  }

 n = hv_iterinit(hv);   
 if(n == 0)
   return(NULL_USER_OBJECT);

 PROTECT(names = NEW_CHARACTER(n));
 i = 0;
 while(i < n) {
  el = hv_iternextsv(hv, &key, &len);
  if(key == NULL)
    break;
  SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key));
  i++;
 }

 UNPROTECT(1);
 return(names);
}

lucy_RegexTokenizer*
lucy_RegexTokenizer_init(lucy_RegexTokenizer *self,
                         cfish_String *pattern) {
    lucy_Analyzer_init((lucy_Analyzer*)self);
    lucy_RegexTokenizerIVARS *const ivars = lucy_RegexTokenizer_IVARS(self);
    #define DEFAULT_PATTERN "\\w+(?:['\\x{2019}]\\w+)*"
    if (pattern) {
        if (CFISH_Str_Contains_Utf8(pattern, "\\p", 2)
            || CFISH_Str_Contains_Utf8(pattern, "\\P", 2)
           ) {
            CFISH_DECREF(self);
            THROW(CFISH_ERR, "\\p and \\P constructs forbidden");
        }
        ivars->pattern = CFISH_Str_Clone(pattern);
    }
    else {
        ivars->pattern = cfish_Str_new_from_trusted_utf8(
                            DEFAULT_PATTERN, sizeof(DEFAULT_PATTERN) - 1);
    }

    // Acquire a compiled regex engine for matching one token.
    dTHX;
    SV *token_re = S_compile_token_re(aTHX_ ivars->pattern);
#if (PERL_VERSION > 10)
    REGEXP *rx = SvRX((SV*)token_re);
#else
    if (!SvROK(token_re)) {
        THROW(CFISH_ERR, "token_re is not a qr// entity");
    }
    SV *inner = SvRV(token_re);
    MAGIC *magic = NULL;
    if (SvMAGICAL((SV*)inner)) {
        magic = mg_find((SV*)inner, PERL_MAGIC_qr);
    }
    if (!magic) {
        THROW(CFISH_ERR, "token_re is not a qr// entity");
    }
    REGEXP *rx = (REGEXP*)magic->mg_obj;
#endif
    if (rx == NULL) {
        THROW(CFISH_ERR, "Failed to extract REGEXP from token_re '%s'",
              SvPV_nolen((SV*)token_re));
    }
    ivars->token_re = rx;
    (void)ReREFCNT_inc(((REGEXP*)ivars->token_re));
    SvREFCNT_dec(token_re);

    return self;
}

static JSBool
perlsub_construct(
    JSContext *cx,
    DEFJSFSARGS_
) {
    dTHX;
    DECJSFSARGS;
    JSObject *func = JSVAL_TO_OBJECT(JS_ARGV_CALLEE(argv));
    SV *callee = (SV *)JS_GetPrivate(cx, func);
    SV *caller = NULL;
#if JS_VERSION < 185
    JSObject *This = JSVAL_TO_OBJECT(argv[-1]);
#else
    JSObject *This = JS_NewObjectForConstructor(cx, vp);
#endif
    JSObject *proto = JS_GetPrototype(cx, This);

    PJS_DEBUG1("Want construct, This is a %s", PJS_GET_CLASS(cx, This)->name);
    if(PJS_GET_CLASS(cx, proto) == &perlpackage_class ||
       ( JS_LookupProperty(cx, func, "prototype", &argv[-1])
         && JSVAL_IS_OBJECT(argv[-1]) && !JSVAL_IS_NULL(argv[-1])
         && (proto = JS_GetPrototype(cx, JSVAL_TO_OBJECT(argv[-1]))) 
         && strEQ(PJS_GET_CLASS(cx, proto)->name, PJS_PACKAGE_CLASS_NAME))
    ) {
	SV *rsv = NULL;
	char *pkgname = PJS_GetPackageName(aTHX_ cx, proto);
#if JS_VERSION >= 185
	JSAutoByteString bytes;
	bytes.initBytes(pkgname);
#endif
	caller = newSVpv(pkgname, 0);

	argv[-1] = OBJECT_TO_JSVAL(This);
	if(!PJS_Call_sv_with_jsvals_rsv(aTHX_ cx, obj, callee, caller,
	                                argc, argv, &rsv, G_SCALAR))
	    return JS_FALSE;

	if(SvROK(rsv) && sv_derived_from(rsv, pkgname)) {
	    JSObject *newobj = PJS_NewPerlObject(aTHX_ cx, JS_GetParent(cx, func), rsv);
	    *rval = OBJECT_TO_JSVAL(newobj);
	    return JS_TRUE;
	}
	JS_ReportError(cx, "%s's constructor don't return an object",
	               SvPV_nolen(caller));
    }
    else JS_ReportError(cx, "Can't use as a constructor"); // Yet! ;-)

    return JS_FALSE;
}

/*
 * convert perl HV to node_info_msg_t
 */
int
hv_to_node_info_msg(HV *hv, node_info_msg_t *node_info_msg)
{
	SV **svp;
	AV *av;
	int i, n;

	memset(node_info_msg, 0, sizeof(node_info_msg_t));

	FETCH_FIELD(hv, node_info_msg, last_update, time_t, TRUE);
	FETCH_FIELD(hv, node_info_msg, node_scaling, uint16_t, TRUE);

	svp = hv_fetch(hv, "node_array", 10, FALSE);
	if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) {
		Perl_warn (aTHX_ "node_array is not an array reference in HV for node_info_msg_t");
		return -1;
	}

	av = (AV*)SvRV(*svp);
	n = av_len(av) + 1;
	node_info_msg->record_count = n;

	node_info_msg->node_array = xmalloc(n * sizeof(node_info_t));
	for (i = 0; i < n; i ++) {
		svp = av_fetch(av, i, FALSE);
		if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV)) {
			Perl_warn (aTHX_ "element %d in node_array is not valid", i);
			return -1;
		}
		if (hv_to_node_info((HV*)SvRV(*svp), &node_info_msg->node_array[i]) < 0) {
			Perl_warn (aTHX_ "failed to convert element %d in node_array", i);
			return -1;
		}
	}
	return 0;
}

/* 
 * convert perl HV to job_step_info_response_msg_t
 */
int
hv_to_job_step_info_response_msg(HV *hv,
		job_step_info_response_msg_t *step_info_msg)
{
	int i, n;
	SV **svp;
	AV *av;

	memset(step_info_msg, 0, sizeof(job_step_info_response_msg_t));

	FETCH_FIELD(hv, step_info_msg, last_update, time_t, TRUE);

	svp = hv_fetch(hv, "job_steps", 9, FALSE);
	if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) {
		Perl_warn (aTHX_ "job_steps is not an array reference in HV for job_step_info_response_msg_t");
		return -1;
	}

	av = (AV*)SvRV(*svp);
	n = av_len(av) + 1;
	step_info_msg->job_step_count = n;

	step_info_msg->job_steps = xmalloc(n * sizeof(job_step_info_t));
	for (i = 0; i < n; i ++) {
		svp = av_fetch(av, i, FALSE);
		if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV)) {
			Perl_warn (aTHX_ "element %d in job_steps is not valid", i);
			return -1;
		}
		if (hv_to_job_step_info((HV*)SvRV(*svp), &step_info_msg->job_steps[i]) < 0) {
			Perl_warn (aTHX_ "failed to convert element %d in job_steps", i);
			return -1;
		}
	}
	return 0;
}

PWSTR NonEmptyWStrFromScalar(PERL_CALL SV *string, BOOL isRef)
{
	if(!string)
		return NULL;

	if(isRef && !(string = SvROK(string) ? SvRV(string) : NULL))
			return NULL;

	PSTR str = SvPV(string, PL_na);
	
	if(str && *str)
		return S2W(str);

	return NULL;
}

SV *ScalarFromArray(PERL_CALL AV *array, int idx, BOOL isRef)
{
	if(isRef && array)
	{
		if(!(array = SvROK(array) ? (AV*)SvRV(array) : NULL))
			return NULL;

		if(SvTYPE(array) != SVt_PVAV)
			return NULL;
	}

	SV **item = array ? av_fetch(array, idx, 0) : NULL;

	return item ? *item : NULL;
}

SV* ScalarFromHash(PERL_CALL HV *hash, PSTR idx, BOOL isRef)
{
	if(isRef && hash)
	{
		if(!(hash = SvROK(hash) ? (HV*)SvRV(hash) : NULL))
			return NULL;

		if(SvTYPE(hash) != SVt_PVHV)
			return NULL;
	}

	SV **item = hash ? hv_fetch(hash, idx, strlen(idx), 0) : NULL;

	return item ? *item : NULL;
}

PyObject*
PerlPyObject_pyo_or_null(SV* sv)
{
    MAGIC *mg;
    dCTXP;

    ASSERT_LOCK_PERL;

    if (SvROK(sv) && sv_derived_from(sv, "Python::Object")) {
        sv = SvRV(sv);
        mg = mg_find(sv, '~');
        if (SvIOK(sv) && mg && mg->mg_virtual == &vtbl_free_pyo) {
	    IV ival = SvIV(sv);
	    return INT2PTR(PyObject *, ival);
        }