예제 #1
0
void dualize(SV* arg, const char* string) {
	svtype sv_type;
	
	sv_type = SvTYPE(arg);
	switch(sv_type) {
		case SVt_IV:
			SvUPGRADE(arg, SVt_PVIV);
			sv_setpv(arg, string);
			SvIOK_on(arg);
			break;
		
		case SVt_NV:
			SvUPGRADE(arg, SVt_PVNV);
			sv_setpv(arg, string);
			SvNOK_on(arg);
			break;
		
		// how do we do this for blessed refs?
		// this doesn't work
		case SVt_PVMG:
			sv_setpv(arg, string);
			break;
		
		default:
			DEBUGME(2, "Got svtype of %d", sv_type);
	}
}
/*----------------------------------------------------------------------------
try_match__()
The pattern matching function which includes loading perl interpreter and 
trying the perl pattern matching.
arguments: 
  input: char* string,    -- input text
	 char* pattern    --  match pattern
  output:if no match found, return FAILURE (0).
----------------------------------------------------------------------------*/
int try_match__( void )
{
  SV *text;        /* the storage for the string in embedded Perl */
  SV *string_buff; /* the storage for the string in embedded Perl */
  int was_match;   /* number of the matches */

#ifdef MULTI_THREAD
  if( NULL == th)
	th = xsb_get_main_thread();
#endif

  char *string = ptoc_string(CTXTc 1),
    *pattern = ptoc_string(CTXTc 2);

  /* first load the perl interpreter, if unloaded */
  if (perlObjectStatus == UNLOADED) load_perl__();

  text = newSV(0);
  string_buff = newSV(0);
  sv_setpv(text, string);  /* store the string in the SV */
    
  was_match = match(text, pattern );
  
  global_pattern_mode = is_global_pattern(pattern);
  
  SvREFCNT_dec(string_buff);
  SvREFCNT_dec(text);
  
  return(was_match);
}
예제 #3
0
void BacnetGetError(
    SV * errorMsg)
{
    sv_setpv(errorMsg, Last_Error);
    strcpy(Last_Error, NO_ERROR);
    Error_Detected = false;
}
예제 #4
0
파일: gv.c 프로젝트: fduhia/metamage_1
GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
    char smallbuf[256];
    char *tmpbuf;
    STRLEN tmplen;
    GV *gv;

    if (!PL_defstash)
	return Nullgv;

    tmplen = strlen(name) + 2;
    if (tmplen < sizeof smallbuf)
	tmpbuf = smallbuf;
    else
	New(603, tmpbuf, tmplen + 1, char);
    tmpbuf[0] = '_';
    tmpbuf[1] = '<';
    strcpy(tmpbuf + 2, name);
    gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
    if (!isGV(gv)) {
	gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
	sv_setpv(GvSV(gv), name);
	if (PERLDB_LINE)
	    hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
    }
    if (tmpbuf != smallbuf)
	Safefree(tmpbuf);
    return gv;
}
/*----------------------------------------------------------------------------
perl_substitute__()
The pattern substitution function which includes loading perl interpreter 
and doing the pattern substitution, then returning the replaced string.
arguments: 
  input: char* string, input text
	 char* pattern, match pattern
  output:char* string, output text
----------------------------------------------------------------------------*/
int perl_substitute__( void )
{
  SV *text;    /* Perl representation for the string to be 
		  modified by substitution */ 
  char *subst_cmd = ptoc_string(CTXTc 2);
  
#ifdef MULTI_THREAD
  if( NULL == th)
	th = xsb_get_main_thread();
#endif

  /* first load the perl interpreter, if unloaded */
  if (perlObjectStatus == UNLOADED) load_perl__();
  
  text = newSV(0);
  sv_setpv(text, ptoc_string(CTXTc 1));  /* put the string to the SV */
     
  if( !substitute(&text, subst_cmd) )
    return(FAILURE);
  
  global_pattern_mode = is_global_pattern(subst_cmd);

  if (substituteString != NULL ) free(substituteString);

  substituteString = malloc(strlen(SvPV(text,PL_na))+1);
  strcpy(substituteString,SvPV(text,PL_na));
  
  SvREFCNT_dec(text);  /*release space*/
  
  ctop_string(CTXTc 3, string_find(substituteString,1));  /*return changed text*/
  return SUCCESS;
}
예제 #6
0
void decode_inet(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
    if (len == 4) {
        char str[INET_ADDRSTRLEN];
        inet_ntop(AF_INET, (char*)input, str, INET_ADDRSTRLEN);
        sv_setpv(output, str);

    } else if (len == 16) {
        char str[INET6_ADDRSTRLEN];
        inet_ntop(AF_INET6, (char*)input, str, INET6_ADDRSTRLEN);
        sv_setpv(output, str);

    } else {
        croak("decode_inet: len != (4|16)");
    }
}
예제 #7
0
int
perl_math_int128_load(int required_version) {
    dTHX;
    sv_setpv(ERRSV, "Unable to load Math::Int128 C API: your compiler does not support 128bit integers");
    SvSETMAGIC(ERRSV);
    return 0;
}
예제 #8
0
int modperl_require_module(pTHX_ const char *pv, int logfailure)
{
    SV *sv;

    dSP;
    PUSHSTACKi(PERLSI_REQUIRE);
    ENTER;SAVETMPS;
    PUTBACK;
    sv = sv_newmortal();
    sv_setpv(sv, "require ");
    sv_catpv(sv, pv);
    eval_sv(sv, G_DISCARD);
    SPAGAIN;
    POPSTACK;
    FREETMPS;LEAVE;

    if (SvTRUE(ERRSV)) {
        if (logfailure) {
            (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
                                NULL, NULL);
        }
        return FALSE;
    }

    return TRUE;
}
예제 #9
0
파일: locale.c 프로젝트: OPSF/uClinux
void
Perl_set_numeric_radix(pTHX)
{
#ifdef USE_LOCALE_NUMERIC
# ifdef HAS_LOCALECONV
    struct lconv* lc;

    lc = localeconv();
    if (lc && lc->decimal_point) {
	if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
	    SvREFCNT_dec(PL_numeric_radix_sv);
	    PL_numeric_radix_sv = Nullsv;
	}
	else {
	    if (PL_numeric_radix_sv)
		sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
	    else
		PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
	}
    }
    else
	PL_numeric_radix_sv = Nullsv;
# endif /* HAS_LOCALECONV */
#endif /* USE_LOCALE_NUMERIC */
}
예제 #10
0
파일: xs.c 프로젝트: gitpan/Data-AMF-XS
static SV* _amf0_sv(amf0_data_t* data) {
    SV* sv = NULL;
    SV* svh;
    SV* sva;
    HV* hv;
    AV* av;
    int i;
    amf0_object_t* obj;
    const char* key;
    amf0_data_t* value;

    switch (data->type) {
        case AMF0_NUMBER:
            sv = newSVnv(((amf0_number_t*)data)->value);
            break;
        case AMF0_BOOLEAN:
            sv = newSViv(((amf0_boolean_t*)data)->value);
            break;
        case AMF0_STRING:
            sv = newSV(0);
            sv_setpv(sv, ((amf0_string_t*)data)->value);
            break;
        case AMF0_OBJECT:
            hv = newHV();
            obj = (amf0_object_t*)data;

            for (i = 0; i < obj->used; ++i) {
                key   = obj->data[i]->key;
                value = obj->data[i]->value;

                svh = _amf0_sv(value);
                hv_store(hv, key, strlen(key), svh, 0);
            }

            sv = newRV(sv_2mortal((SV*)hv));

            break;
        case AMF0_NULL:
        case AMF0_UNDEFINED:
            sv = newSV(0);
            break;
        case AMF0_STRICTARRAY:
            av = newAV();

            for (i = 0; i < ((amf0_strictarray_t*)data)->used; ++i) {
                sva = _amf0_sv(((amf0_strictarray_t*)data)->data[i]);
                av_push(av, sva);
            }

            sv = newRV(sv_2mortal((SV *)av));

            break;
        default:
            Perl_croak(aTHX_ "Unsupported datatype: %d\n", data->type);
            break;
    }

    return sv;
}
예제 #11
0
파일: Socket.c 프로젝트: macholic/perl5
static SV *err_to_SV(pTHX_ int err)
{
	SV *ret = sv_newmortal();
	SvUPGRADE(ret, SVt_PVNV);

	if(err) {
		const char *error = gai_strerror(err);
		sv_setpv(ret, error);
	}
	else {
		sv_setpv(ret, "");
	}

	SvIV_set(ret, err); SvIOK_on(ret);

	return ret;
}
예제 #12
0
/* xs_init is the second argument perl_parse. As the name hints, it
   initializes XS subroutines (see the perlembed manpage) */
static void
xs_init (pTHX)
{
	HV *stash;
	SV *version;
	/* This one allows dynamic loading of perl modules in perl
	   scripts by the 'use perlmod;' construction */
	newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
	/* load up all the custom IRC perl functions */
	newXS ("Xchat::Internal::register", XS_Xchat_register, __FILE__);
	newXS ("Xchat::Internal::hook_server", XS_Xchat_hook_server, __FILE__);
	newXS ("Xchat::Internal::hook_command", XS_Xchat_hook_command, __FILE__);
	newXS ("Xchat::Internal::hook_print", XS_Xchat_hook_print, __FILE__);
	newXS ("Xchat::Internal::hook_timer", XS_Xchat_hook_timer, __FILE__);
	newXS ("Xchat::Internal::hook_fd", XS_Xchat_hook_fd, __FILE__);
	newXS ("Xchat::Internal::unhook", XS_Xchat_unhook, __FILE__);
	newXS ("Xchat::Internal::print", XS_Xchat_print, __FILE__);
	newXS ("Xchat::Internal::command", XS_Xchat_command, __FILE__);
	newXS ("Xchat::Internal::set_context", XS_Xchat_set_context, __FILE__);
	newXS ("Xchat::Internal::get_info", XS_Xchat_get_info, __FILE__);
	newXS ("Xchat::Internal::context_info", XS_Xchat_context_info, __FILE__);
	newXS ("Xchat::Internal::get_list", XS_Xchat_get_list, __FILE__);
	
	newXS ("Xchat::find_context", XS_Xchat_find_context, __FILE__);
	newXS ("Xchat::get_context", XS_Xchat_get_context, __FILE__);
	newXS ("Xchat::get_prefs", XS_Xchat_get_prefs, __FILE__);
	newXS ("Xchat::emit_print", XS_Xchat_emit_print, __FILE__);
	newXS ("Xchat::send_modes", XS_Xchat_send_modes, __FILE__);
	newXS ("Xchat::nickcmp", XS_Xchat_nickcmp, __FILE__);

	newXS ("Xchat::Embed::plugingui_remove", XS_Xchat_Embed_plugingui_remove,
			 __FILE__);

	stash = get_hv ("Xchat::", TRUE);
	if (stash == NULL) {
		exit (1);
	}

	newCONSTSUB (stash, "PRI_HIGHEST", newSViv (XCHAT_PRI_HIGHEST));
	newCONSTSUB (stash, "PRI_HIGH", newSViv (XCHAT_PRI_HIGH));
	newCONSTSUB (stash, "PRI_NORM", newSViv (XCHAT_PRI_NORM));
	newCONSTSUB (stash, "PRI_LOW", newSViv (XCHAT_PRI_LOW));
	newCONSTSUB (stash, "PRI_LOWEST", newSViv (XCHAT_PRI_LOWEST));

	newCONSTSUB (stash, "EAT_NONE", newSViv (XCHAT_EAT_NONE));
	newCONSTSUB (stash, "EAT_XCHAT", newSViv (XCHAT_EAT_XCHAT));
	newCONSTSUB (stash, "EAT_PLUGIN", newSViv (XCHAT_EAT_PLUGIN));
	newCONSTSUB (stash, "EAT_ALL", newSViv (XCHAT_EAT_ALL));
	newCONSTSUB (stash, "FD_READ", newSViv (XCHAT_FD_READ));
	newCONSTSUB (stash, "FD_WRITE", newSViv (XCHAT_FD_WRITE));
	newCONSTSUB (stash, "FD_EXCEPTION", newSViv (XCHAT_FD_EXCEPTION));
	newCONSTSUB (stash, "FD_NOTSOCKET", newSViv (XCHAT_FD_NOTSOCKET));
	newCONSTSUB (stash, "KEEP", newSViv (1));
	newCONSTSUB (stash, "REMOVE", newSViv (0));

	version = get_sv( "Xchat::VERSION", 1 );
	sv_setpv( version, PACKAGE_VERSION );
}
예제 #13
0
void decode_varint(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
    if (UNLIKELY(len <= 0)) {
        croak("decode_varint: len <= 0");
    } else if (len == 1) {
        decode_tinyint(aTHX_ input, len, type, output);
    } else if (len == 2) {
        decode_smallint(aTHX_ input, len, type, output);
    } else if (len == 3) {
        unsigned char bytes[4];
        memcpy(bytes+1, input, 3);
        if (input[0] & 0x80) {
            bytes[0] = 0xff;
        } else {
            bytes[0] = 0;
        }
        decode_int(aTHX_ bytes, 4, type, output);
    } else if (len == 4) {
        decode_int(aTHX_ input, len, type, output);
#ifdef CAN_64BIT
    } else if (len < 8) {
        unsigned char bytes[8];
        memset(bytes, (input[0] & 0x80) ? 0xff : 0, 8);
        memcpy(bytes+8-len, input, len);
        decode_bigint(aTHX_ bytes, 8, type, output);
    } else if (len == 8) {
        decode_bigint(aTHX_ input, len, type, output);
#endif
    } else {
        unsigned char *tmp;
        char *tmpout;
        struct cc_bignum bn;
        int i;

        Newxz(tmpout, (len*4)+2, char);

        if (!IS_BIG_ENDIAN) {
            Newxz(tmp, len, unsigned char);
            for (i = 0; i < len; i++) {
                tmp[len-i-1] = (unsigned char)input[i];
            }
        } else {
            tmp = input;
        }

        cc_bignum_init_bytes(&bn, tmp, len);

        cc_bignum_stringify(&bn, tmpout, (len*4)+2);
        sv_setpv(output, tmpout);

        cc_bignum_destroy(&bn);
        if (!IS_BIG_ENDIAN) {
            Safefree(tmp);
        }
        Safefree(tmpout);
    }
}
예제 #14
0
파일: plmisc.cpp 프로젝트: gitpan/setupsup
int StrToScalar(PERL_CALL SV *string, PSTR str)
{
	if(!string)
		return 0;

	if(str)
		sv_setpv(string, str);
	
	return 1;
}
예제 #15
0
/*
**
**  sets a Perl scalar variable
**
*/
void Perl5_SetScalar(pTHX_ char *pname, char *vname, char *vvalue)
{
    dTHR;
    ENTER;
    save_hptr(&PL_curstash); 
    PL_curstash = gv_stashpv(pname, TRUE);
    sv_setpv(perl_get_sv(vname, TRUE), vvalue);
    LEAVE;
    return;
}
예제 #16
0
파일: gv.c 프로젝트: fduhia/metamage_1
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
    char autoload[] = "AUTOLOAD";
    STRLEN autolen = sizeof(autoload)-1;
    GV* gv;
    CV* cv;
    HV* varstash;
    GV* vargv;
    SV* varsv;

    if (len == autolen && strnEQ(name, autoload, autolen))
	return Nullgv;
    if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
	return Nullgv;
    cv = GvCV(gv);

    if (!CvROOT(cv))
	return Nullgv;

    /*
     * Inheriting AUTOLOAD for non-methods works ... for now.
     */
    if (ckWARN(WARN_DEPRECATED) && !method &&
	(GvCVGEN(gv) || GvSTASH(gv) != stash))
	Perl_warner(aTHX_ WARN_DEPRECATED,
	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
	     HvNAME(stash), (int)len, name);

    /*
     * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
     * The subroutine's original name may not be "AUTOLOAD", so we don't
     * use that, but for lack of anything better we will use the sub's
     * original package to look up $AUTOLOAD.
     */
    varstash = GvSTASH(CvGV(cv));
    vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
    ENTER;

#ifdef USE_THREADS
    sv_lock((SV *)varstash);
#endif
    if (!isGV(vargv))
	gv_init(vargv, varstash, autoload, autolen, FALSE);
    LEAVE;
    varsv = GvSV(vargv);
#ifdef USE_THREADS
    sv_lock(varsv);
#endif
    sv_setpv(varsv, HvNAME(stash));
    sv_catpvn(varsv, "::", 2);
    sv_catpvn(varsv, name, len);
    SvTAINTED_off(varsv);
    return gv;
}
예제 #17
0
파일: gv.c 프로젝트: fduhia/metamage_1
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
    register GP *gp;
    bool doproto = SvTYPE(gv) > SVt_NULL;
    char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;

    sv_upgrade((SV*)gv, SVt_PVGV);
    if (SvLEN(gv)) {
	if (proto) {
	    SvPVX(gv) = NULL;
	    SvLEN(gv) = 0;
	    SvPOK_off(gv);
	} else
	    Safefree(SvPVX(gv));
    }
    Newz(602, gp, 1, GP);
    GvGP(gv) = gp_ref(gp);
    GvSV(gv) = NEWSV(72,0);
    GvLINE(gv) = CopLINE(PL_curcop);
    GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
    GvCVGEN(gv) = 0;
    GvEGV(gv) = gv;
    sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
    GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
    GvNAME(gv) = savepvn(name, len);
    GvNAMELEN(gv) = len;
    if (multi || doproto)              /* doproto means it _was_ mentioned */
	GvMULTI_on(gv);
    if (doproto) {			/* Replicate part of newSUB here. */
	SvIOK_off(gv);
	ENTER;
	/* XXX unsafe for threads if eval_owner isn't held */
	start_subparse(0,0);		/* Create CV in compcv. */
	GvCV(gv) = PL_compcv;
	LEAVE;

	PL_sub_generation++;
	CvGV(GvCV(gv)) = gv;
	CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
	CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
	CvOWNER(GvCV(gv)) = 0;
	if (!CvMUTEXP(GvCV(gv))) {
	    New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
	    MUTEX_INIT(CvMUTEXP(GvCV(gv)));
	}
#endif /* USE_THREADS */
	if (proto) {
	    sv_setpv((SV*)GvCV(gv), proto);
	    Safefree(proto);
	}
    }
}
/*----------------------------------------------------------------------------
do_bulk_match__()
The pattern match function which includes loading perl interpreter and 
doing the global perl pattern match, and storing the results in the global 
array of bulkMatchList.
argument: 
  input: char* string	     	     -- input text
	 char* pattern	     	     --  match pattern
  output: int* num_match     	     --  the number of the matches	 
----------------------------------------------------------------------------*/
int do_bulk_match__( void )
{
  AV *match_list;           /* AV storage of matches list*/
  SV *text;                 /* storage for the embedded perl cmd */
  SV *string_buff;          /* storage for the embedded perl cmd */
  int num_match;            /* the number of the matches */
  int i;
 
#ifdef MULTI_THREAD
  if( NULL == th)
	th = xsb_get_main_thread();
#endif

  /* first load the perl interpreter, if unloaded */
  if (perlObjectStatus == UNLOADED) load_perl__();

  text = newSV(0);
  string_buff = newSV(0);
  sv_setpv(text, ptoc_string(CTXTc 1));  /*put the string into an SV */
 
  /*------------------------------------------------------------------------
    free the old match list space and allocate new space for current match list
    -----------------------------------------------------------------------*/
  for ( i=0; i<preBulkMatchNumber; i++ ) 
    free(bulkMatchList[i]);
  if (bulkMatchList != NULL ) free(bulkMatchList);
  bulkMatchList = NULL;   

  /*------------------------------------------------------------------------
    do bulk match
    ----------------------------------------------------------------------*/
  num_match = all_matches(text, ptoc_string(CTXTc 2),&match_list);
    
  /* allocate the space to store the matches */
  if ( num_match != 0 ) {
    preBulkMatchNumber = num_match; /* reset the pre bulk match number */
    bulkMatchList = (char **)malloc(num_match*sizeof(char *)); 
    if ( bulkMatchList == NULL ) 
      xsb_abort("Cannot alocate memory to store the results for bulk match");
  }

  /*get the matches from the AV */
  for ( i=0;i<num_match;i++ ) {
    string_buff = av_shift(match_list);
    bulkMatchList[i] = (char *)malloc( strlen(SvPV(string_buff,PL_na))+1 ); 
    strcpy((char *)bulkMatchList[i], SvPV(string_buff,PL_na) );   
  } 

  SvREFCNT_dec(string_buff); /* release space*/
  SvREFCNT_dec(text);
  
  ctop_int(CTXTc 3, num_match);           /*return the number of matches*/
  return SUCCESS;
}
예제 #19
0
파일: plmisc.cpp 프로젝트: gitpan/setupsup
int WStrToScalar(PERL_CALL SV *string, PWSTR str)
{
	if(!string)
		return 0;

	PSTR strPtr = str ? W2S(str) : NULL;

	if(strPtr)
		sv_setpv(string, strPtr);
	
	FreeStr(strPtr);

	return 1;
}
예제 #20
0
파일: epoc.c 프로젝트: OPSF/uClinux
static
XS(epoc_getcwd)   /* more or less stolen from win32.c */
{
    dXSARGS;
    /* Make the host for current directory */
    char *buffer; 
    int buflen = 256;

    char *ptr;
    buffer = (char *) malloc( buflen);
    if (buffer == NULL) {
      XSRETURN_UNDEF;
    }
    while ((NULL == ( ptr = getcwd( buffer, buflen))) && (errno == ERANGE)) {
      buflen *= 2;
      if (NULL == realloc( buffer, buflen)) {
	 XSRETURN_UNDEF;
      }
      
    }

    /* 
     * If ptr != Nullch 
     *   then it worked, set PV valid, 
     *   else return 'undef' 
     */

    if (ptr) {
	SV *sv = sv_newmortal();
	char *tptr;

	for (tptr = ptr; *tptr != '\0'; tptr++) {
	  if (*tptr == '\\') {
	    *tptr = '/';
	  }
	}
	sv_setpv(sv, ptr);
	free( buffer);

	EXTEND(SP,1);
	SvPOK_on(sv);
	ST(0) = sv;
#ifndef INCOMPLETE_TAINTS
	SvTAINTED_on(ST(0));
#endif
	XSRETURN(1);
    }
    free( buffer);
    XSRETURN_UNDEF;
}
예제 #21
0
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;
}
예제 #22
0
파일: Util.c 프로젝트: gitpan/Aw
/* keep this simple for now, don't count % tokens, etc */
char *
setErrMsg ( char ** gErrMsg, int count, ... )
{
int i;
int argLength = 1, length;
char * strings[5];

	va_list ap;
	va_start ( ap, count );

	for ( i = 0; i < count; i++ ) {
		strings[i] =  va_arg ( ap, char* );
		argLength += strlen ( strings[i] );
	}

	va_end ( ap );

	if ( *gErrMsg )
	  free ( *gErrMsg );

	*gErrMsg = (char *)safemalloc ( argLength * sizeof (char) );

	switch ( count ) {
		case 1:
			strcpy ( *gErrMsg, strings[0] );
			break;
		case 2:
			sprintf ( *gErrMsg, strings[0], strings[1] );
			break;
		case 3:
			sprintf ( *gErrMsg, strings[0], strings[1], strings[2] );
			break;
		case 4:
			sprintf ( *gErrMsg, strings[0], strings[1], strings[2], strings[3] );
			break;
		case 5:
			sprintf ( *gErrMsg, strings[0], strings[1], strings[2], strings[3], strings[4] );
			break;
	}

	// sv_setpv ( perl_get_sv("!",0), gErrMsg );
	sv_setpv ( perl_get_sv("@",0), *gErrMsg );

	return ( *gErrMsg );

}
예제 #23
0
/*----------------------------------------------------------------------------
try_match__()
The pattern matching function which includes loading perl interpreter and 
trying the perl pattern matching.
arguments: 
  input: char* string,    -- input text
	 char* pattern    --  match pattern
  output:if no match found, return FAILURE (0).
----------------------------------------------------------------------------*/
int try_match__( void )
{
  SV *text;        /* the storage for the string in embedded Perl */
  SV *string_buff; /* the storage for the string in embedded Perl */
  int was_match;   /* number of the matches */
  char *string = ptoc_string(1),
    *pattern = ptoc_string(2);

  /* first load the perl interpreter, if unloaded */
  if (perlObjectStatus == UNLOADED) load_perl__();

  text = newSV(0);
  string_buff = newSV(0);
  sv_setpv(text, string);  /* store the string in the SV */
    
  was_match = match(text, pattern );
  
  global_pattern_mode = is_global_pattern(pattern);
  
  SvREFCNT_dec(string_buff);
  SvREFCNT_dec(text);
  
  return(was_match);
}
예제 #24
0
JSBool PJS_invoke_perl_property_getter(JSContext *cx, JSObject *obj, jsval id, jsval *vp) {
    dSP;
    PJS_Context *pcx;
    PJS_Class *pcls;
    PJS_Property *pprop;
    SV *caller;
    char *name;
    jsint slot;
    U8 invocation_mode;

    if (!(JSVAL_IS_INT(id) || JSVAL_IS_STRING(id))) {
        return JS_TRUE;
    }
    
    if((pcx = PJS_GET_CONTEXT(cx)) == NULL) {
        JS_ReportError(cx, "Can't find context %d", cx);
        return JS_FALSE;
    }

    if (JS_TypeOfValue(cx, OBJECT_TO_JSVAL(obj)) == JSTYPE_OBJECT) {
        /* Called as instsance */
        JSClass *clasp = PJS_GET_CLASS(cx, obj);
        name = (char *) clasp->name;
        invocation_mode = 1;
    }
    else {
        /* Called as static */
        JSFunction *parent_jfunc = JS_ValueToFunction(cx, OBJECT_TO_JSVAL(obj));
        if (parent_jfunc == NULL) {
            JS_ReportError(cx, "Failed to extract class for static property getter");
            return JS_FALSE;
        }
        name = (char *) JS_GetFunctionName(parent_jfunc);
        invocation_mode = 0;
    }
    
    if ((pcls = PJS_GetClassByName(pcx, name)) == NULL) {
        JS_ReportError(cx, "Can't find class '%s'", name);
        return JS_FALSE;
    }
    
    if (invocation_mode) {
        caller = (SV *) JS_GetPrivate(cx, obj);
    }
    else {
        caller = newSVpv(pcls->pkg, 0);
    }
    
    if (JSVAL_IS_INT(id)) {
      slot = JSVAL_TO_INT(id);
    
      if ((pprop = PJS_get_property_by_id(pcls,  (int8) slot)) == NULL) {
        if (SvTRUE(pcls->property_getter)) {
            if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
                return JS_FALSE;
            }
            return JS_TRUE;
        }
        JS_ReportError(cx, "Can't find property handler");
        return JS_FALSE;
      }

      if (pprop->getter == NULL) {
        JS_ReportError(cx, "Property is write-only");
        return JS_FALSE;
      }

      if (perl_call_sv_with_jsvals(cx, obj, pprop->getter, caller, 0, NULL, vp) < 0) {
        return JS_FALSE;
      }
    }
    else if (JSVAL_IS_STRING(id) && SvTRUE(pcls->property_getter)) {
      SV *sv = sv_newmortal();
#ifdef JS_C_STRINGS_ARE_UTF8
      char *tmp = JS_smprintf("%hs", JS_GetStringChars(JSVAL_TO_STRING(id)));
      sv_setpv(sv, tmp);
      SvUTF8_on(sv);
      free(tmp);
#else
      sv_setpv(sv, JS_GetStringBytes(JSVAL_TO_STRING(id)));
#endif         

      if (PJS_get_method_by_name(pcls, SvPV_nolen(sv))) {
        return JS_TRUE;
      }
      
      if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
        return JS_FALSE;
      }      
    }

    return JS_TRUE;
}
예제 #25
0
파일: caretx.c 프로젝트: rurban/perl
void
Perl_set_caret_X(pTHX) {
    GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
    SV *const caret_x = GvSV(tmpgv);
#if defined(OS2)
    sv_setpv(caret_x, os2_execname(aTHX));
#elif defined(USE_KERN_PROC_PATHNAME)
    size_t size = 0;
    int mib[4];
    mib[0] = CTL_KERN;
    mib[1] = KERN_PROC;
    mib[2] = KERN_PROC_PATHNAME;
    mib[3] = -1;

    if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
        && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
        sv_grow(caret_x, size);

        if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
            && size > 2) {
            SvPOK_only(caret_x);
            SvCUR_set(caret_x, size - 1);
            SvTAINT(caret_x);
            return;
        }
    }
#elif defined(USE_NSGETEXECUTABLEPATH)
    char buf[1];
    uint32_t size = sizeof(buf);

    _NSGetExecutablePath(buf, &size);
    if (size < MAXPATHLEN * MAXPATHLEN) {
        sv_grow(caret_x, size);
        if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
            char *const tidied = realpath(SvPVX(caret_x), NULL);
            if (tidied) {
                sv_setpv(caret_x, tidied);
                free(tidied);
            } else {
                SvPOK_only(caret_x);
                SvCUR_set(caret_x, size);
            }
            return;
        }
    }
#elif defined(HAS_PROCSELFEXE)
    char buf[MAXPATHLEN];
    SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
    /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
     * it is impossible to know whether the result was truncated. */

    if (len != -1) {
        buf[len] = '\0';
    }

    /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
       includes a spurious NUL which will cause $^X to fail in system
       or backticks (this will prevent extensions from being built and
       many tests from working). readlink is not meant to add a NUL.
       Normal readlink works fine.
    */
    if (len > 0 && buf[len-1] == '\0') {
        len--;
    }

    /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
       returning the text "unknown" from the readlink rather than the path
       to the executable (or returning an error from the readlink). Any
       valid path has a '/' in it somewhere, so use that to validate the
       result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
    */
    if (len > 0 && memchr(buf, '/', len)) {
        sv_setpvn(caret_x, buf, len);
        return;
    }
#elif defined(WIN32)
    char *ansi;
    WCHAR widename[MAX_PATH];
    GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
    ansi = win32_ansipath(widename);
    sv_setpv(caret_x, ansi);
    win32_free(ansi);
    return;
#else
    /* Fallback to this:  */
    sv_setpv(caret_x, PL_origargv[0]);
#endif
}
예제 #26
0
SV *single_hook_call(pTHX_ SV *self, const char *hook_id_str, const char *id_pre,
                     const char *id, const SingleHook *hook, SV *in, int mortal)
{
  dSP;
  int count;
  SV *out;

  CT_DEBUG(MAIN, ("single_hook_call(hid='%s', id='%s%s', hook=%p, in=%p(%d), mortal=%d)",
                  hook_id_str, id_pre, id, hook, in, in ? (int) SvREFCNT(in) : 0, mortal));

  assert(self != NULL);
  assert(hook != NULL);

  if (hook->sub == NULL)
    return in;

  ENTER;
  SAVETMPS;

  PUSHMARK(SP);

  if (hook->arg)
  {
    I32 ix, len;
    len = av_len(hook->arg);

    for (ix = 0; ix <= len; ++ix)
    {
      SV **pSV = av_fetch(hook->arg, ix, 0);
      SV *sv;

      if (pSV == NULL)
        fatal("NULL returned by av_fetch() in single_hook_call()");

      if (SvROK(*pSV) && sv_isa(*pSV, ARGTYPE_PACKAGE))
      {
        HookArgType type = (HookArgType) SvIV(SvRV(*pSV));

        switch (type)
        {
          case HOOK_ARG_SELF:
            sv = sv_mortalcopy(self);
            break;

          case HOOK_ARG_DATA:
            assert(in != NULL);
            sv = sv_mortalcopy(in);
            break;

          case HOOK_ARG_TYPE:
            assert(id != NULL);
            sv = sv_newmortal();
            if (id_pre)
            {
              sv_setpv(sv, id_pre);
              sv_catpv(sv, CONST_CHAR(id));
            }
            else
              sv_setpv(sv, id);
            break;

          case HOOK_ARG_HOOK:
            if (hook_id_str)
            {
              sv = sv_newmortal();
              sv_setpv(sv, hook_id_str);
            }
            else
            {
              sv = &PL_sv_undef;
            }
            break;

          default:
            fatal("Invalid hook argument type (%d) in single_hook_call()", type);
            break;
        }
      }
      else
        sv = sv_mortalcopy(*pSV);

      XPUSHs(sv);
    }
  }
  else
  {
    if (in)
    {
      /* only push the data argument */
      XPUSHs(in);
    }
  }

  PUTBACK;

  count = call_sv(hook->sub, G_SCALAR);

  SPAGAIN;

  if (count != 1)
    fatal("Hook returned %d elements instead of 1", count);

  out = POPs;

  CT_DEBUG(MAIN, ("single_hook_call: in=%p(%d), out=%p(%d)",
                  in, in ? (int) SvREFCNT(in) : 0, out, (int) SvREFCNT(out)));

  if (!mortal && in != NULL)
    SvREFCNT_dec(in);
  SvREFCNT_inc(out);

  PUTBACK;
  FREETMPS;
  LEAVE;

  if (mortal)
    sv_2mortal(out);

  CT_DEBUG(MAIN, ("single_hook_call: out=%p(%d)", out, (int) SvREFCNT(out)));

  return out;
}
예제 #27
0
/* caller must free result, if not NULL */
CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
{
  int ret;
  PerlInterpreter *p;
  char *err;
  const char *args[4] = {"", "-e", "0;", NULL};
  AV *inc;
  char *path;

  /* create and initialize interpreter */
  PERL_SYS_INIT3(Pargc, Pargv, Penv);
  p=perl_alloc();
  owl_global_set_perlinterp(&g, p);
  perl_construct(p);

  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;

  owl_global_set_no_have_config(&g);

  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
  if (ret || SvTRUE(ERRSV)) {
    err=g_strdup(SvPV_nolen(ERRSV));
    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
    return(err);
  }

  ret=perl_run(p);
  if (ret || SvTRUE(ERRSV)) {
    err=g_strdup(SvPV_nolen(ERRSV));
    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
    return(err);
  }

  owl_global_set_have_config(&g);

  /* create legacy variables */
  get_sv("BarnOwl::id", TRUE);
  get_sv("BarnOwl::class", TRUE);
  get_sv("BarnOwl::instance", TRUE);
  get_sv("BarnOwl::recipient", TRUE);
  get_sv("BarnOwl::sender", TRUE);
  get_sv("BarnOwl::realm", TRUE);
  get_sv("BarnOwl::opcode", TRUE);
  get_sv("BarnOwl::zsig", TRUE);
  get_sv("BarnOwl::msg", TRUE);
  get_sv("BarnOwl::time", TRUE);
  get_sv("BarnOwl::host", TRUE);
  get_av("BarnOwl::fields", TRUE);

  if(file) {
    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
    sv_setpv(cfg, file);
  }

  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);

  /* Add the system lib path to @INC */
  inc = get_av("INC", 0);
  path = g_build_filename(owl_get_datadir(), "lib", NULL);
  av_unshift(inc, 1);
  av_store(inc, 0, owl_new_sv(path));
  g_free(path);

  eval_pv("use BarnOwl;", FALSE);

  if (SvTRUE(ERRSV)) {
    err=g_strdup(SvPV_nolen(ERRSV));
    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
    return(err);
  }

  /* check if we have the formatting function */
  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
    owl_global_set_config_format(&g, 1);
  }

  return(NULL);
}
예제 #28
0
int
perl_math_int64_load(int required_version) {
    dTHX;
    SV **svp;
    eval_pv("require Math::Int64", TRUE);
    if (SvTRUE(ERRSV)) return 0;

   math_int64_c_api_hash = get_hv("Math::Int64::C_API", 0);
    if (!math_int64_c_api_hash) {
        sv_setpv(ERRSV, "Unable to load Math::Int64 C API");
        SvSETMAGIC(ERRSV);
        return 0;
    }

    svp = hv_fetch(math_int64_c_api_hash, "min_version", 11, 0);
    if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_min_version = SvIV(*svp);

    svp = hv_fetch(math_int64_c_api_hash, "max_version", 11, 0);
    if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_max_version = SvIV(*svp);

    if ((required_version < math_int64_c_api_min_version) ||
        (required_version > math_int64_c_api_max_version)) {
        sv_setpvf(ERRSV,
                  "Math::Int64 C API version mismatch. "
                  "The installed module supports versions %d to %d but %d is required",
                  math_int64_c_api_min_version,
                  math_int64_c_api_max_version,
                  required_version);
        SvSETMAGIC(ERRSV);
        return 0;
    }

    svp = hv_fetch(math_int64_c_api_hash, "SvI64", 5, 0);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64' C function from Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_SvI64 = INT2PTR(void *, SvIV(*svp));
    svp = hv_fetch(math_int64_c_api_hash, "SvI64OK", 7, 0);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64OK' C function from Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_SvI64OK = INT2PTR(void *, SvIV(*svp));
    svp = hv_fetch(math_int64_c_api_hash, "SvU64", 5, 0);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64' C function from Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_SvU64 = INT2PTR(void *, SvIV(*svp));
    svp = hv_fetch(math_int64_c_api_hash, "SvU64OK", 7, 0);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64OK' C function from Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_SvU64OK = INT2PTR(void *, SvIV(*svp));
    svp = hv_fetch(math_int64_c_api_hash, "newSVi64", 8, 0);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to fetch pointer 'newSVi64' C function from Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_newSVi64 = INT2PTR(void *, SvIV(*svp));
    svp = hv_fetch(math_int64_c_api_hash, "newSVu64", 8, 0);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to fetch pointer 'newSVu64' C function from Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_newSVu64 = INT2PTR(void *, SvIV(*svp));
    svp = hv_fetch(math_int64_c_api_hash, "randU64", 7, 0);
    if (!svp || !*svp) {
        sv_setpv(ERRSV, "Unable to fetch pointer 'randU64' C function from Math::Int64");
        SvSETMAGIC(ERRSV);
        return 0;
    }
    math_int64_c_api_randU64 = INT2PTR(void *, SvIV(*svp));

    return 1;
}
예제 #29
0
파일: tester.c 프로젝트: alexmv/barnowl
int main(int argc, char **argv, char **env)
{
  FILE *rnull;
  FILE *wnull;
  char *perlerr;
  int status = 0;

  if (argc <= 1) {
    fprintf(stderr, "Usage: %s --builtin|TEST.t|-le CODE\n", argv[0]);
    return 1;
  }

  /* initialize a fake ncurses, detached from std{in,out} */
  wnull = fopen("/dev/null", "w");
  rnull = fopen("/dev/null", "r");
  newterm("xterm", wnull, rnull);
  /* initialize global structures */
  owl_global_init(&g);

  perlerr = owl_perlconfig_initperl(NULL, &argc, &argv, &env);
  if (perlerr) {
    endwin();
    fprintf(stderr, "Internal perl error: %s\n", perlerr);
    status = 1;
    goto out;
  }

  owl_global_complete_setup(&g);
  owl_global_setup_default_filters(&g);

  owl_view_create(owl_global_get_current_view(&g), "main",
                  owl_global_get_filter(&g, "all"),
                  owl_global_get_style_by_name(&g, "default"));

  owl_function_firstmsg();

  ENTER;
  SAVETMPS;

  if (strcmp(argv[1], "--builtin") == 0) {
    status = owl_regtest();
  } else if (strcmp(argv[1], "-le") == 0 && argc > 2) {
    /*
     * 'prove' runs its harness perl with '-le CODE' to get some
     * information out.
     */
    moreswitches("l");
    eval_pv(argv[2], true);
  } else {
    sv_setpv(get_sv("0", false), argv[1]);
    sv_setpv(get_sv("main::test_prog", TRUE), argv[1]);

    eval_pv("do $main::test_prog; die($@) if($@)", true);
  }

  status = 0;

  FREETMPS;
  LEAVE;

 out:
  perl_destruct(owl_global_get_perlinterp(&g));
  perl_free(owl_global_get_perlinterp(&g));
  /* probably not necessary, but tear down the screen */
  endwin();
  fclose(rnull);
  fclose(wnull);
  return status;
}
예제 #30
0
파일: gv.c 프로젝트: gitpan/ponie
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
    char autoload[] = "AUTOLOAD";
    STRLEN autolen = sizeof(autoload)-1;
    GV* gv;
    CV* cv;
    HV* varstash;
    GV* vargv;
    SV* varsv;
    char *packname = "";

    if (len == autolen && strnEQ(name, autoload, autolen))
	return Nullgv;
    if (stash) {
	if (SvTYPE(stash) < SVt_PVHV) {
	    packname = SvPV_nolen((SV*)stash);
	    stash = Nullhv;
	}
	else {
	    packname = HvNAME(stash);
	}
    }
    if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
	return Nullgv;
    cv = GvCV(gv);

    if (!(CvROOT(cv) || CvXSUB(cv)))
	return Nullgv;

    /*
     * Inheriting AUTOLOAD for non-methods works ... for now.
     */
    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
	(GvCVGEN(gv) || GvSTASH(gv) != stash))
	Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
	     packname, (int)len, name);

    if (CvXSUB(cv)) {
        /* rather than lookup/init $AUTOLOAD here
         * only to have the XSUB do another lookup for $AUTOLOAD
         * and split that value on the last '::',
         * pass along the same data via some unused fields in the CV
         */
        CvSTASH(cv) = stash;
        SvPVX(cv) = (char *)name; /* cast to lose constness warning */
        SvCUR(cv) = len;
        return gv;
    }

    /*
     * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
     * The subroutine's original name may not be "AUTOLOAD", so we don't
     * use that, but for lack of anything better we will use the sub's
     * original package to look up $AUTOLOAD.
     */
    varstash = GvSTASH(CvGV(cv));
    vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
    ENTER;

    if (!isGV(vargv))
	gv_init(vargv, varstash, autoload, autolen, FALSE);
    LEAVE;
    varsv = GvSV(vargv);
    sv_setpv(varsv, packname);
    sv_catpvn(varsv, "::", 2);
    sv_catpvn(varsv, name, len);
    SvTAINTED_off(varsv);
    return gv;
}