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);
}
void BacnetGetError(
SV * errorMsg)
{
sv_setpv(errorMsg, Last_Error);
strcpy(Last_Error, NO_ERROR);
Error_Detected = false;
}
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;
}
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)");
}
}
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;
}
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;
}
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 */
}
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;
}
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;
}
/* 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 );
}
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);
}
}
int StrToScalar(PERL_CALL SV *string, PSTR str)
{
if(!string)
return 0;
if(str)
sv_setpv(string, str);
return 1;
}
/*
**
** 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;
}
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;
}
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;
}
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;
}
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;
}
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;
}
/* 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 );
}
/*----------------------------------------------------------------------------
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);
}
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;
}
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
}
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;
}
/* 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);
}
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;
}
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;
}
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;
}