C++ SvTYPE函数代码示例

struct t_hashtable *
weechat_perl_hash_to_hashtable (SV *hash, int size, const char *type_keys,
                                const char *type_values)
{
    struct t_hashtable *hashtable;
    HV *hash2;
    SV *value;
    char *str_key;
    I32 retlen;

    hashtable = weechat_hashtable_new (size, type_keys, type_values,
                                       NULL, NULL);
    if (!hashtable)
        return NULL;

    if ((hash) && SvROK(hash) && SvRV(hash)
        && (SvTYPE(SvRV(hash)) == SVt_PVHV))
    {
        hash2 = (HV *)SvRV(hash);
        hv_iterinit (hash2);
        while ((value = hv_iternextsv (hash2, &str_key, &retlen)))
        {
            if (strcmp (type_values, WEECHAT_HASHTABLE_STRING) == 0)
            {
                weechat_hashtable_set (hashtable, str_key,
                                       SvPV (value, PL_na));
            }
            else if (strcmp (type_values, WEECHAT_HASHTABLE_POINTER) == 0)
            {
                weechat_hashtable_set (hashtable, str_key,
                                       plugin_script_str2ptr (
                                           weechat_perl_plugin,
                                           NULL, NULL,
                                           SvPV (value, PL_na)));
            }
        }
    }

    return hashtable;
}

static void perl_hash_to_json( SV *input, json_writer_t *writer )
{
  HV *h;
  char *prop;
  I32 cnt, retlen;
  SV *item;

  json_writer_start_object( writer );

  if ( ( SvROK( input ) && SvTYPE( SvRV( input ) ) == SVt_PVHV ) ) {
    h = (HV *) SvRV( input );
    cnt = hv_iterinit( h );
    while ( cnt-- ) {
      item = hv_iternextsv( h, &prop, &retlen );
      json_writer_start_property( writer, prop );
      perl_variable_to_json_internal( item, writer );
      json_writer_end_property( writer );
    }
  }

  json_writer_end_object( writer );
}

SV *
Window_menuItems( Handle self, Bool set, SV * menuItems)
{
   dPROFILE;
   if ( var-> stage > csFrozen) return nilSV;

   if ( !set)
      return var-> menu ? CMenu( var-> menu)-> get_items( var-> menu, "") : nilSV;

   if ( var-> menu == nilHandle) {
     if ( SvTYPE( menuItems)) {
         HV * profile = newHV();
         pset_sv( items, menuItems);
         pset_H ( owner, self);
         pset_i ( selected, false);
         my-> set_menu( self, create_instance( "Prima::Menu"));
         sv_free(( SV *) profile);
      }
   } else
     CMenu( var-> menu)-> set_items( var-> menu, menuItems);
   return menuItems;
}

void
pack_modify_request_ref(SV *dest, HV *hv) {
    STRLEN offset1, offset2;
    SV *changes;
    offset1 = start_constructed(dest, ASN1_APPLICATION|ASN1_CONSTRUCTED, LDAP_OP_MODIFY_REQUEST);
    pack_string_utf8(dest, hv_fetchs_def_undef(hv, "dn"));
    offset2 = start_sequence(dest);
    changes = hv_fetchs_def_undef(hv, "changes");
    if (changes && SvOK(changes)) {
	AV *av;
	I32 i, len;
	if (SvROK(changes) && (av = (AV*)SvRV(changes)) && (SvTYPE(av) == SVt_PVAV)) {
	    len = av_len(av);
	    for (i = 0; i <= len; i++)
		ldap_pack_modop(dest, av_fetch_def_undef(av, i));
	}
	else
	    ldap_pack_modop(dest, changes);
    }
    end_sequence(dest, offset2);
    end_constructed(dest, offset1);
}

static SV *load_psgi(apr_pool_t *pool, const char *file)
{
    dTHX;
    SV *app;
    char *code;

    code = apr_psprintf(pool, "do q\"%s\" or die [email protected]",
            ap_escape_quotes(pool, file));
    app = eval_pv(code, FALSE);

    if (SvTRUE(ERRSV)) {
        ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "%s", SvPV_nolen(ERRSV));
        CLEAR_ERRSV();
        return NULL;
    }
    if (!SvOK(app) || !SvROK(app) || SvTYPE(SvRV(app)) != SVt_PVCV) {
        ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL,
                "%s does not return an application code reference", file);
        return NULL;
    }
    return app;
}

SV *
Widget_popupItems( Handle self, Bool set, SV * popupItems)
{
    dPROFILE;
    enter_method;
    if ( var-> stage > csFrozen) return nilSV;
    if ( !set)
        return var-> popupMenu ?
               CAbstractMenu( var-> popupMenu)-> get_items( var-> popupMenu, "") : nilSV;

    if ( var-> popupMenu == nilHandle) {
        if ( SvTYPE( popupItems)) {
            HV * profile = newHV();
            pset_sv( items, popupItems);
            pset_H ( owner, self);
            my-> set_popup( self, create_instance( "Prima::Popup"));
            sv_free(( SV *) profile);
        }
    }
    else
        CAbstractMenu( var-> popupMenu)-> set_items( var-> popupMenu, popupItems);
    return popupItems;
}

apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
                                                  SV *avrv)
{
    AV *av;
    apr_array_header_t *array;
    int i, av_size;

    if (!(SvROK(avrv) && (SvTYPE(SvRV(avrv)) == SVt_PVAV))) {
        Perl_croak(aTHX_ "Not an array reference");
    }

    av = (AV*)SvRV(avrv);
    av_size = av_len(av);
    array = apr_array_make(p, av_size+1, sizeof(char *));

    for (i = 0; i <= av_size; i++) {
        SV *sv = *av_fetch(av, i, FALSE);
        char **entry = (char **)apr_array_push(array);
        *entry = apr_pstrdup(p, SvPV_nolen(sv));
    }

    return array;
}

int sv2constant(SV * svconstant, const char * context) {
    AV * avparam;
    int val = 0;
    SV **tmpsv;
    int i;
    if (svconstant == NULL) {
        return 0;
    } else if (!SvOK(svconstant)) {
        return 0;
    } else if (SvPOK(svconstant) || SvIOK(svconstant)) {
        if (!scalar2constant(svconstant, context, &val))
            warn("Unknow value '%s' in '%s'", SvPV_nolen(svconstant), context);
    } else if (SvTYPE(SvRV(svconstant)) == SVt_PVAV) {
        avparam = (AV*) SvRV(svconstant);
        for (i = 0; i <= av_len(avparam); i++) {
            tmpsv = av_fetch(avparam, i, 0);
            if (!scalar2constant(*tmpsv, context, &val))
                warn("Unknow value '%s' in '%s' from array", SvPV_nolen(*tmpsv), context);
        }
    } else {
    }
    return val;
}

GdkRectangle * SvGdkRectangle(SV * data, GdkRectangle * rect)
{
	AV * a;
	SV ** s;

	if ((!data) || (!SvOK(data)) || (!SvRV(data)) || (SvTYPE(SvRV(data)) != SVt_PVAV))
		return 0;
		
	a = (AV*)SvRV(data);

	if (av_len(a) != 3)
		croak("rectangle must have four elements");

	if (!rect)
		rect = alloc_temp(sizeof(GdkRectangle));
	
	rect->x = SvIV(*av_fetch(a, 0, 0));
	rect->y = SvIV(*av_fetch(a, 1, 0));
	rect->width = SvIV(*av_fetch(a, 2, 0));
	rect->height = SvIV(*av_fetch(a, 3, 0));
	
	return rect;
}

static OP *parser_callback(pTHX_ GV *namegv, SV *psobj, U32 *flagsp) {
    dSP;
    SV *args_generator;
    SV *statement = NULL;
    I32 count;
 
    /* call the parser callback
     * it should take no arguments and return a coderef which, when called,
     * produces the arguments to the keyword function
     * the optree we want to generate is for something like
     *   mykeyword($code->())
     * where $code is the thing returned by the parser function
     */
 
    PUSHMARK(SP);
    mXPUSHp(GvNAME(namegv), GvNAMELEN(namegv));
    PUTBACK;
    count = call_sv(psobj, G_ARRAY);
    SPAGAIN;
    if (count > 1) {
        statement = POPs;
    }
    args_generator = SvREFCNT_inc(POPs);
    PUTBACK;
 
    if (!SvROK(args_generator) || SvTYPE(SvRV(args_generator)) != SVt_PVCV) {
        croak("The parser function for %s must return a coderef, not %"SVf,
              GvNAME(namegv), args_generator);
    }
 
    if (SvTRUE(statement)) {
        *flagsp |= CALLPARSER_STATEMENT;
    }
 
    return newUNOP(OP_ENTERSUB, OPf_STACKED,
                   newCVREF(0, newSVOP(OP_CONST, 0, args_generator)));
}

/*
 * convert perl HV to job_desc_msg_t
 * return 0 on success, -1 on failure
 */
int
hv_to_job_desc_msg(HV *hv, job_desc_msg_t *job_desc)
{
	SV **svp;
	HV *environ_hv;
	AV *argv_av;
	SV *val;
	char *env_key, *env_val;
	I32 klen;
	STRLEN vlen;
	int num_keys, i;

	slurm_init_job_desc_msg(job_desc);

	FETCH_FIELD(hv, job_desc, account, charp, FALSE);
	FETCH_FIELD(hv, job_desc, acctg_freq, charp, FALSE);
	FETCH_FIELD(hv, job_desc, alloc_node, charp, FALSE);
	FETCH_FIELD(hv, job_desc, alloc_resp_port, uint16_t, FALSE);
	FETCH_FIELD(hv, job_desc, alloc_sid, uint32_t, FALSE);
	/* argv, argc */
	if((svp = hv_fetch(hv, "argv", 4, FALSE))) {
		if(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
			argv_av = (AV*)SvRV(*svp);
			job_desc->argc = av_len(argv_av) + 1;
			if (job_desc->argc > 0) {
				Newz(0, job_desc->argv, (int32_t)(job_desc->argc + 1), char*);
				for(i = 0; i < job_desc->argc; i ++) {
					if((svp = av_fetch(argv_av, i, FALSE)))
						*(job_desc->argv + i) = (char*) SvPV_nolen(*svp);
					else {
						Perl_warn(aTHX_ "error fetching `argv' of job descriptor");
						free_job_desc_msg_memory(job_desc);
						return -1;
					}
				}
			}
		} else {

I32 p5_get_type(PerlInterpreter *my_perl, SV *sv) {
    int is_hash;
    PERL_SET_CONTEXT(my_perl);
    if (p5_is_object(my_perl, sv)) {
        return 1;
    }
    else if (p5_is_sub_ref(my_perl, sv)) {
        return 2;
    }
    else if (p5_SvNOK(my_perl, sv)) {
        return 3;
    }
    else if (p5_SvIOK(my_perl, sv)) {
        return 4;
    }
    else if (p5_SvPOK(my_perl, sv)) {
        return 5;
    }
    else if (p5_is_array(my_perl, sv)) {
        return 6;
    }
    else if ((is_hash = p5_is_hash(my_perl, sv)) > 0) {
        return 6 + is_hash;
    }
    else if (p5_is_undef(my_perl, sv)) {
        return 9;
    }
    else if (p5_is_scalar_ref(my_perl, sv)) {
        return 10;
    }
    else if (SvTYPE(sv) == SVt_PVGV) {
        return 11;
    }
    else {
        return 0;
    }
}

SV *
PerlFMM_bufmagic(PerlFMM *self, SV *buf)
{
    unsigned char *buffer;
    char *type;
    int rc;
    SV *ret;

    /* rt #28040, allow RV to SVs to be passed here */
    if (SvROK(buf) && SvTYPE(SvRV(buf)) == SVt_PV) {
        buffer = (unsigned char *) SvPV_nolen( SvRV( buf ) );
    } else {
        buffer = (unsigned char *) SvPV_nolen(buf);
    }

    FMM_SET_ERROR(self, NULL);

    Newz(1234, type, BUFSIZ, char);

    rc = fmm_bufmagic(self, &buffer, &type);
    ret = FMM_RESULT(type, rc);
    Safefree(type);
    return ret;
}

USER_OBJECT_
RS_getHV(USER_OBJECT_ name, USER_OBJECT_ convert, USER_OBJECT_ interpreter)
{
  USER_OBJECT_ ans = NULL_USER_OBJECT;
  HV *table;
  dTHX;

  if(!IS_CHARACTER(name)) {
    SV *tmp = getForeignPerlReference(name);
    if(tmp == NULL || SvTYPE(tmp) != SVt_PVHV) {
      PROBLEM "non-array reference passed to RS_getHV"
      ERROR;
    }
    table = (HV*) tmp;
  } else {
    table = get_hv(CHAR_DEREF(STRING_ELT(name,0)), FALSE);
  }

  if(table != NULL) {
   if(TYPEOF(convert) == LGLSXP || TYPEOF(convert) == INTSXP) {
     unsigned int depth;
     depth = (TYPEOF(convert) == LGLSXP ? LOGICAL(convert)[0] : INTEGER(convert)[0]);

     if(depth) {
         ans = fromPerlHV(table, depth);
     } else {
      /*       ans = fromPerl((SV*) table); */
      ans = makeForeignPerlReference((SV*) table, makeRSPerlClassVector("PerlHashReference"), &exportReferenceTable);
    }
   } else {
      ans = directConvertFromPerl((SV*) table, convert);
   }
  }

  return(ans);
}

Point *
Drawable_polypoints( SV * points, char * procName, int mod, int * n_points)
{
   AV * av;
   int i, count;
   Point * p;

   if ( !SvROK( points) || ( SvTYPE( SvRV( points)) != SVt_PVAV)) {
      warn("RTC0050: Invalid array reference passed to %s", procName);
      return nil;
   }
   av = ( AV *) SvRV( points);
   count = av_len( av) + 1;
   if ( count % mod) {
      warn("RTC0051: Drawable::%s: Number of elements in an array must be a multiple of %d",
           procName, mod);
      return nil;
   }
   count /= 2;
   if ( count < 2) return nil;
   if (!( p = allocn( Point, count))) return false;
   for ( i = 0; i < count; i++)
   {
       SV** psvx = av_fetch( av, i * 2, 0);
       SV** psvy = av_fetch( av, i * 2 + 1, 0);
       if (( psvx == nil) || ( psvy == nil)) {
          free( p);
          warn("RTC0052: Array panic on item pair %d on Drawable::%s", i, procName);
          return nil;
       }
       p[ i]. x = SvIV( *psvx);
       p[ i]. y = SvIV( *psvy);
   }
   *n_points = count;
   return p;
}