/* Guts library, main file */
#define GENERATE_TABLE_GENERATOR yes
#include "apricot.h"
#include <sys/types.h>
#include <stdio.h>
#include <stdarg.h>
#include <float.h>
#include <dirent.h>
#include "guts.h"
#include "Object.h"
#include "Component.h"
#include "File.h"
#include "Clipboard.h"
#include "DeviceBitmap.h"
#include "Drawable.h"
#include "Widget.h"
#include "Window.h"
#include "Image.h"
#include "Icon.h"
#include "AbstractMenu.h"
#include "AccelTable.h"
#include "Menu.h"
#include "Popup.h"
#include "Application.h"
#include "Timer.h"
#include "Utils.h"
#include "Printer.h"
#include "img_conv.h"
#include <Types.inc>
#ifdef __cplusplus
extern "C" {
#endif
#include "thunks.tinc"
#if defined(_MSC_VER) && defined(PERL_OBJECT)
XSLockManager g_XSLock;
CPerlObj* pPerl;
#endif
static PHash vmtHash = nil;
static List staticObjects;
static List staticHashes;
static int prima_init_ok = 0;
Handle application = nilHandle;
long apcError = 0;
List postDestroys;
int recursiveCall = 0;
PHash primaObjects = nil;
SV * eventHook = nil;
char *
duplicate_string( const char *s)
{
int l;
char *d;
if (!s) return nil;
l = strlen( s) + 1;
d = ( char*)malloc( l);
if ( d) memcpy( d, s, l);
return d;
}
void *
prima_mallocz( size_t sz)
{
void *p = malloc( sz);
if (p)
bzero( p, sz);
return p;
}
char *
prima_normalize_resource_string( char *name, Bool isClass)
{
static Bool initialize = true;
static char table[256];
int i;
unsigned char *s;
if ( initialize) {
for ( i = 0; i < 256; i++) {
table[i] = isalnum(i) ? i : '_';
}
table[0] = 0;
initialize = false;
}
s = (unsigned char*)name;
while (*s) {
*s = table[*s];
s++;
}
name[0] = isClass ? toupper(name[0]) : tolower(name[0]);
return name;
}
#ifndef HAVE_BZERO
void
bzero( void * data, size_t size)
{
memset( data, 0, size);
}
#endif
#ifdef PRIMA_NEED_OWN_STRICMP
int
stricmp(const char *s1, const char *s2)
{
/* Code was taken from FreeBSD 4.0 /usr/src/lib/libc/string/strcasecmp.c */
const unsigned char *u1 = (const unsigned char *)s1;
const unsigned char *u2 = (const unsigned char *)s2;
while (tolower(*u1) == tolower(*u2++))
if (*u1++ == '\0')
return 0;
return (tolower(*u1) - tolower(*--u2));
}
#endif
#ifdef PRIMA_NEED_OWN_STRNICMP
int
strnicmp(const char *s1, const char *s2, size_t count)
{
const unsigned char *u1 = (const unsigned char *)s1;
const unsigned char *u2 = (const unsigned char *)s2;
if ( count == 0) return 0;
while (tolower(*u1) == tolower(*u2++))
if (--count == 0 || *u1++ == '\0')
return 0;
return (tolower(*u1) - tolower(*--u2));
}
#endif
#ifndef HAVE_STRCASESTR
/* Code was taken from FreeBSD 4.8 /usr/src/lib/libc/string/strcasestr.c */
char *
strcasestr( register const char * s, register const char * find)
{
register char c, sc;
register size_t len;
if ((c = *find++) != 0) {
c = tolower((unsigned char)c);
len = strlen(find);
do {
do {
if ((sc = *s++) == 0)
return (NULL);
} while ((char)tolower((unsigned char)sc) != c);
} while (strnicmp(s, find, len) != 0);
s--;
}
return ((char *)s);
}
#endif
#ifndef HAVE_REALLOCF
/*
This code was taken from FreeBSD 4.0 /usr/src/lib/libc/stdlib/reallocf.c
Thanks, Poul Henning! :-)
*/
void *
reallocf(void *ptr, size_t size)
{
void *nptr;
nptr = realloc(ptr, size);
if (!nptr && ptr)
free(ptr);
return (nptr);
}
#endif
#if ! ( defined( HAVE_SNPRINTF) || defined( HAVE__SNPRINTF))
int
snprintf( char *buf, size_t len, const char *format, ...)
{
int rc;
va_list args;
va_start( args, format);
rc = vsnprintf( buf, len, format, args);
va_end( args);
return rc;
}
#endif
I32
clean_perl_call_method( char* methname, I32 flags)
{
I32 ret;
dPUB_ARGS;
dG_EVAL_ARGS;
if ( !( flags & G_EVAL)) { OPEN_G_EVAL; }
ret = perl_call_method( methname, flags | G_EVAL);
if ( SvTRUE( GvSV( PL_errgv))) {
PUB_CHECK;
if (( flags & (G_SCALAR|G_DISCARD|G_ARRAY)) == G_SCALAR) {
dSP;
SPAGAIN;
(void)POPs;
}
if ( flags & G_EVAL) return ret;
CLOSE_G_EVAL;
croak( "%s", SvPV_nolen( GvSV( PL_errgv)));
}
if ( !( flags & G_EVAL)) { CLOSE_G_EVAL; }
return ret;
}
I32
clean_perl_call_pv( char* subname, I32 flags)
{
I32 ret;
dPUB_ARGS;
dG_EVAL_ARGS;
if ( !( flags & G_EVAL)) { OPEN_G_EVAL; }
ret = perl_call_pv( subname, flags | G_EVAL);
if ( SvTRUE( GvSV( PL_errgv))) {
PUB_CHECK;
if (( flags & (G_SCALAR|G_DISCARD|G_ARRAY)) == G_SCALAR) {
dSP;
SPAGAIN;
(void)POPs;
}
if ( flags & G_EVAL) return ret;
CLOSE_G_EVAL;
croak( "%s", SvPV_nolen( GvSV( PL_errgv)));
}
if ( !( flags & G_EVAL)) { CLOSE_G_EVAL; }
return ret;
}
SV *
eval( char *string)
{
return perl_eval_pv( string, FALSE);
}
Handle
create_mate( SV *perlObject)
{
PAnyObject object;
Handle self = nilHandle;
char *className;
PVMT vmt;
/* finding the vmt */
className = HvNAME( SvSTASH( SvRV( perlObject))); if ( !className) return 0;
vmt = gimme_the_vmt( className); if ( !vmt) return 0;
/* allocating an instance */
object = ( PAnyObject) malloc( vmt-> instanceSize);
if ( !object) return nilHandle;
memset( object, 0, vmt-> instanceSize);
object-> self = ( PVMT) vmt;
object-> super = ( PVMT *) vmt-> super;
(void) hv_store( (HV*)SvRV( perlObject), "__CMATE__", 9, newSViv( PTR2IV(object)), 0);
/* extra check */
self = gimme_the_mate( perlObject);
if ( self != (Handle)object)
croak( "GUTS007: create_mate() consistency check failed.\n");
return self;
}
Handle
gimme_the_real_mate( SV *perlObject)
{
HV *obj;
SV **mate;
if ( !SvROK( perlObject)) return nilHandle;
obj = (HV*)SvRV( perlObject);
if ( SvTYPE((SV*)obj) != SVt_PVHV) return nilHandle;
mate = hv_fetch( obj, "__CMATE__", 9, 0);
if ( mate == nil) return nilHandle;
return SvIV( *mate);
}
Handle
gimme_the_mate( SV *perlObject)
{
Handle cMate;
cMate = gimme_the_real_mate( perlObject);
return (( cMate == nilHandle) || ((( PObject) cMate)-> stage == csDead)) ? nilHandle : cMate;
}
XS( create_from_Perl)
{
dXSARGS;
if (( items - 2 + 1) % 2 != 0)
croak("Invalid usage of Prima::Object::create");
{
Handle _c_apricot_res_;
HV *hv = parse_hv( ax, sp, items, mark, 2 - 1, "Object_create");
_c_apricot_res_ = Object_create(
( char*) SvPV_nolen( ST( 0)),
hv
);
SPAGAIN;
SP -= items;
if ( _c_apricot_res_ && (( PAnyObject) _c_apricot_res_)-> mate && (( PAnyObject) _c_apricot_res_)-> mate != nilSV)
{
XPUSHs( sv_mortalcopy((( PAnyObject) _c_apricot_res_)-> mate));
--SvREFCNT( SvRV((( PAnyObject) _c_apricot_res_)-> mate));
} else XPUSHs( &PL_sv_undef);
/* push_hv( ax, sp, items, mark, 1, hv); */
sv_free(( SV *) hv);
}
PUTBACK;
return;
}
XS( destroy_from_Perl)
{
dXSARGS;
Handle self;
if ( items != 1)
croak ("Invalid usage of Prima::Object::destroy");
self = gimme_the_real_mate( ST( 0));
if ( self == nilHandle)
croak( "Illegal object reference passed to Prima::Object::destroy");
{
Object_destroy( self);
}
XSRETURN_EMPTY;
}
static PAnyObject killChain = nil;
static PObject ghostChain = nil;
void
kill_zombies( void)
{
while ( killChain != nil)
{
PAnyObject killee = killChain;
killChain = killee-> killPtr;
free( killee);
}
}
void
protect_object( Handle obj)
{
PObject o = (PObject)obj;
if ( o-> protectCount >= 0) o-> protectCount++;
}
void
unprotect_object( Handle obj)
{
PObject o = (PObject)obj;
if (!o || o-> protectCount<=0)
return;
o-> protectCount--;
if (o-> protectCount>0) return;
if (o-> stage == csDead || o-> mate == nil || o-> mate == nilSV)
{
PObject ghost, lg;
lg = nil;
ghost = ghostChain;
while ( ghost != nil && ghost != o)
{
lg = ghost;
ghost = (PObject)(ghost-> killPtr);
}
if ( ghost == o)
{
if ( lg == nil)
ghostChain = (PObject)(o-> killPtr);
else
lg-> killPtr = o-> killPtr;
o-> killPtr = killChain;
killChain = (PAnyObject)o;
}
}
}
XS( destroy_mate)
{
dXSARGS;
Handle self;
if ( items != 1)
croak ("Invalid usage of ::destroy_mate");
self = gimme_the_real_mate( ST( 0));
if ( self == nilHandle)
croak( "Illegal object reference passed to ::destroy_mate");
{
Object_destroy( self);
if (((PObject)self)-> protectCount > 0)
{
(( PObject) self)-> killPtr = (PAnyObject)ghostChain;
ghostChain = ( PObject) self;
}
else
{
free(( void*) self);
}
}
XSRETURN_EMPTY;
}
Bool
kind_of( Handle object, void *cls)
{
PVMT vmt = object ? (( PAnyObject) object)-> self : nil;
while (( vmt != nil) && ( vmt != cls))
vmt = vmt-> base;
return vmt != nil;
}
CV *
query_method( Handle object, char *methodName, Bool cacheIt)
{
if ( object == nilHandle)
return nil;
return sv_query_method((( PObject) object)-> mate, methodName, cacheIt);
}
CV *
sv_query_method( SV *sv, char *methodName, Bool cacheIt)
{
HV *stash = nil;
if ( SvROK( sv)) {
sv = (SV*)SvRV( sv);
if ( SvOBJECT( sv))
stash = SvSTASH(sv);
} else {
stash = gv_stashsv( sv, false);
}
if ( stash) {
GV *gv = gv_fetchmeth( stash, methodName, strlen( methodName), cacheIt ? 0 : -1);
if ( gv && isGV( gv))
return GvCV(gv);
}
return nil;
}
static void
register_notifications( PVMT vmt)
{
SV *package;
SV *nt_sub;
SV *nt_ref;
HV *nt;
PVMT v = vmt;
HE *he;
char buf[ 1024];
while (( v != nil) && ( v != (PVMT) CComponent)) v = v-> base;
if (!v) return;
package = newSVpv( vmt-> className, 0);
if ( !package) croak( "GUTS016: Not enough memory");
nt_sub = ( SV*) sv_query_method( package, "notification_types", 0);
if ( !nt_sub) croak( "GUTS016: Invalid package %s", vmt-> className);
nt_ref = cv_call_perl( package, nt_sub, "<");
if ( !nt_ref || !SvROK(nt_ref) || SvTYPE(SvRV(nt_ref)) != SVt_PVHV)
croak( "GUTS016: %s: Bad notification_types() return value", vmt-> className);
nt = (HV*)SvRV(nt_ref);
hv_iterinit( nt);
while (( he = hv_iternext( nt)) != nil) {
snprintf( buf, 1024, "on%s", HeKEY( he));
if (sv_query_method( package, buf, 0)) continue;
snprintf( buf, 1024, "%s::on%s", vmt-> className, HeKEY( he));
newXS( buf, Component_set_notification_FROMPERL, vmt-> className);
}
sv_free( package);
}
static Bool
common_get_options( int * argc, char *** argv)
{
#ifdef HAVE_OPENMP
static char * common_argv[] = {
"openmp_threads", "sets number of openmp threads"
};
*argv = common_argv;
*argc = sizeof( common_argv) / sizeof( char*);
#else
*argc = 0;
#endif
return true;
}
static Bool
common_set_option( char * option, char * value)
{
if ( strcmp( option, "openmp_threads") == 0) {
if ( value) {
int n = strtol( value, &option, 10);
if (*option)
warn("invalid value sent to `--openmp_threads'.");
else
prima_omp_set_num_threads(n);
} else
warn("`--openmp_threads' must be given parameters.");
return true;
}
return false;
}
XS(Prima_options)
{
dXSARGS;
char * option, * value = nil;
(void)items;
switch ( items) {
case 0:
{
int i, argc1 = 0, argc2 = 0;
char ** argv1, ** argv2;
common_get_options( &argc1, &argv1);
window_subsystem_get_options( &argc2, &argv2);
EXTEND( sp, argc1 + argc2);
for ( i = 0; i < argc1; i++)
PUSHs( sv_2mortal( newSVpv( argv1[i], 0)));
for ( i = 0; i < argc2; i++)
PUSHs( sv_2mortal( newSVpv( argv2[i], 0)));
PUTBACK;
return;
}
break;
case 2:
value = (SvOK( ST(1)) ? ( char*) SvPV_nolen( ST(1)) : nil);
case 1:
option = ( char*) SvPV_nolen( ST(0));
if ( !common_set_option( option, value))
window_subsystem_set_option( option, value);
break;
default:
croak("Invalid call to Prima::options");
}
SPAGAIN;
XSRETURN_EMPTY;
}
XS(Prima_init)
{
dXSARGS;
char error_buf[256] = "Error initializing Prima";
(void)items;
if ( items < 1) croak("Invalid call to Prima::init");
{
SV * ref;
SV * package = newSVpv( "Prima::Object", 0);
if ( !package) croak( "GUTS016: Not enough memory");
ref = ( SV *) sv_query_method( package, "profile_default", 0);
sv_free( package);
if ( !ref) croak("'use Prima;' call required in main script");
}
if ( prima_init_ok == 0) {
register_notifications((PVMT)CComponent);
register_notifications((PVMT)CFile);
register_notifications((PVMT)CAbstractMenu);
register_notifications((PVMT)CAccelTable);
register_notifications((PVMT)CMenu);
register_notifications((PVMT)CPopup);
register_notifications((PVMT)CClipboard);
register_notifications((PVMT)CTimer);
register_notifications((PVMT)CDrawable);
register_notifications((PVMT)CImage);
register_notifications((PVMT)CIcon);
register_notifications((PVMT)CDeviceBitmap);
register_notifications((PVMT)CWidget);
register_notifications((PVMT)CWindow);
register_notifications((PVMT)CApplication);
register_notifications((PVMT)CPrinter);
prima_init_ok++;
}
if ( prima_init_ok == 1) {
prima_init_image_subsystem();
prima_init_ok++;
}
if ( prima_init_ok == 2) {
if ( !window_subsystem_init( error_buf))
croak( "%s", error_buf);
prima_init_ok++;
}
SPAGAIN;
XSRETURN_EMPTY;
}
XS( Prima_message_FROMPERL)
{
dXSARGS;
(void)items;
if ( items != 1)
croak("Invalid usage of Prima::%s", "message");
apc_show_message((char*) SvPV_nolen( ST(0)), prima_is_utf8_sv(ST(0)));
XSRETURN_EMPTY;
}
XS( Prima_dl_export)
{
dXSARGS;
(void)items;
if ( items != 1)
croak("Invalid usage of Prima::%s", "dl_export");
apc_dl_export((char*) SvPV_nolen( ST(0)));
XSRETURN_EMPTY;
}
Bool
build_dynamic_vmt( void *vvmmtt, const char *ancestorName, int ancestorVmtSize)
{
PVMT vmt = ( PVMT) vvmmtt;
PVMT ancestorVmt = gimme_the_vmt( ancestorName);
int i, n;
void **to, **from;
if ( ancestorVmt == nil)
{
warn( "GUTS001: Cannot locate base class \"%s\" of class \"%s\"\n", ancestorName, vmt-> className);
return false;
}
if ( ancestorVmt-> base != ancestorVmt-> super)
{
warn( "GUTS002: Cannot inherit C-class \"%s\" from Perl-class \"%s\"\n", vmt-> className, ancestorName);
return false;
}
vmt-> base = vmt-> super = ancestorVmt;
n = (ancestorVmtSize - sizeof(VMT)) / sizeof( void *);
from = (void **)((char *)ancestorVmt + sizeof(VMT));
to = (void **)((char *)vmt + sizeof(VMT));
for ( i = 0; i < n; i++) if ( to[i] == nil) to[i] = from[i];
build_static_vmt( vmt);
register_notifications( vmt);
return true;
}
void
build_static_vmt( void *vvmmtt)
{
PVMT vmt = ( PVMT) vvmmtt;
hash_store( vmtHash, vmt-> className, strlen( vmt-> className), vmt);
}
PVMT
gimme_the_vmt( const char *className)
{
PVMT vmt;
PVMT originalVmt = nil;
int vmtSize;
HV *stash;
SV **proc;
char *newClassName;
int i;
void **addr;
SV **vmtAddr;
SV **isaGlob;
SV **inheritedName;
VmtPatch *patch; int patchLength;
PVMT patchWhom;
/* Check whether this class has been already built... */
vmtAddr = ( SV **) hash_fetch( vmtHash, (char *)className, strlen( className));
if ( vmtAddr != nil) return ( PVMT) vmtAddr;
/* No; try to find inherited VMT... */
stash = gv_stashpv( (char *)className, false);
if ( stash == nil)
{
croak( "GUTS003: Cannot locate package %s\n", className);
return nil; /* Definitely wrong! */
}
isaGlob = hv_fetch( stash, "ISA", 3, 0);
if (! (( isaGlob == nil) ||
( *isaGlob == nil) ||
( !GvAV(( GV *) *isaGlob)) ||
( av_len( GvAV(( GV *) *isaGlob)) < 0)
))
{
/* ISA found! */
inheritedName = av_fetch( GvAV(( GV *) *isaGlob), 0, 0);
if ( inheritedName != nil)
originalVmt = gimme_the_vmt( SvPV_nolen( *inheritedName));
else
return nil; /* The error message will be printed by the previous incarnation */
}
if ( !originalVmt) {
croak( "GUTS005: Error finding ancestor's VMT for %s\n", className);
return nil;
}
/* Do we really need to do this? */
if ( strEQ( className, originalVmt-> className))
return originalVmt;
vmtSize = originalVmt-> vmtSize;
vmt = ( PVMT) malloc( vmtSize);
if ( !vmt) return nil;
memcpy( vmt, originalVmt, vmtSize);
newClassName = duplicate_string( className);
vmt-> className = newClassName;
vmt-> base = originalVmt;
/* Not particularly effective now... */
patchWhom = originalVmt;
while ( patchWhom != nil)
{
if ( patchWhom-> base == patchWhom-> super)
{
patch = patchWhom-> patch;
patchLength = patchWhom-> patchLength;
for ( i = 0; i < patchLength; i++)
{
proc = hv_fetch( stash, patch[ i]. name, strlen( patch[ i]. name), 0);
if (! (( proc == nil) || ( *proc == nil) || ( !GvCV(( GV *) *proc))))
{
addr = ( void **)((( char *)vmt) + ((( char *)( patch[ i]. vmtAddr)) - (( char *)patchWhom)));
*addr = patch[ i]. procAddr;
}
}
}
patchWhom = patchWhom-> base;
}
/* Store newly created vmt into our hash... */
hash_store( vmtHash, (char *)className, strlen( className), vmt);
list_add( &staticObjects, (Handle) vmt);
list_add( &staticObjects, (Handle) vmt-> className);
register_notifications( vmt);
return vmt;
}
SV *
notify_perl( Handle self, char *methodName, const char *format, ...)
{
SV *toReturn;
char subName[ 256];
va_list params;
snprintf( subName, 256, "%s_%s", (( PComponent) self)-> name, methodName);
va_start( params, format);
toReturn = call_perl_indirect((( PComponent) self)-> owner,
subName, format, true, false, params);
va_end( params);
return toReturn;
}
SV *
call_perl( Handle self, char *subName, const char *format, ...)
{
SV *toReturn;
va_list params;
va_start( params, format);
toReturn = call_perl_indirect( self, subName, format, true, false, params);
va_end( params);
return toReturn;
}
SV *
sv_call_perl( SV * mate, char *subName, const char *format, ...)
{
SV *toReturn;
va_list params;
va_start( params, format);
toReturn = call_perl_indirect(( Handle) mate, subName, format, false, false, params);
va_end( params);
return toReturn;
}
SV *
cv_call_perl( SV * mate, SV * coderef, const char *format, ...)
{
SV *toReturn;
va_list params;
va_start( params, format);
toReturn = call_perl_indirect(( Handle) mate, (char*)coderef, format, false, true, params);
va_end( params);
return toReturn;
}
SV *
call_perl_indirect( Handle self, char *subName, const char *format, Bool c_decl, Bool coderef, va_list params)
{
int i;
Handle _Handle;
int _int;
char * _string;
double _number;
Point _Point;
Rect _Rect;
SV * _SV;
Bool returns = false;
SV *toReturn = nil;
int retCount;
int stackExtend = 1;
if ( coderef)
{
if ( SvTYPE(( SV *) subName) != SVt_PVCV) return toReturn;
} else {
if ( c_decl && !query_method ( self, subName, 0))
return toReturn;
if ( !c_decl && !sv_query_method(( SV *) self, subName, 0))
return &PL_sv_undef;
}
if ( format[ 0] == '<')
{
format += 1;
returns = true;
}
/* Parameter check */
i = 0;
while ( format[ i] != '\0')
{
switch ( format[ i])
{
case 'i':
case 's':
case 'n':
case 'H':
case 'S':
stackExtend++;
break;
case 'P':
stackExtend += 2;
break;
case 'R':
stackExtend += 4;
break;
default:
croak( "GUTS004: Illegal parameter description (%c) in call to %s()",
format[ i], ( coderef) ? "code reference" : subName);
return toReturn;
}
i++;
}
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK( sp);
EXTEND( sp, stackExtend);
PUSHs(( c_decl) ? (( PAnyObject) self)-> mate : ( SV *) self);
i = 0;
while ( format[ i] != '\0')
{
switch ( format[ i])
{
case 'i':
_int = va_arg( params, int);
PUSHs( sv_2mortal( newSViv( _int)));
break;
case 's':
_string = va_arg( params, char *);
PUSHs( sv_2mortal( newSVpv( _string, 0)));
break;
case 'n':
_number = va_arg( params, double);
PUSHs( sv_2mortal( newSVnv( _number)));
break;
case 'S':
_SV = va_arg( params, SV *);
PUSHs( sv_2mortal( newSVsv( _SV)));
break;
case 'P':
_Point = va_arg( params, Point);
PUSHs( sv_2mortal( newSViv( _Point. x)));
PUSHs( sv_2mortal( newSViv( _Point. y)));
break;
case 'H':
_Handle = va_arg( params, Handle);
PUSHs( _Handle ? (( PAnyObject) _Handle)-> mate : nilSV);
break;
case 'R':
_Rect = va_arg( params, Rect);
PUSHs( sv_2mortal( newSViv( _Rect. left)));
PUSHs( sv_2mortal( newSViv( _Rect. bottom)));
PUSHs( sv_2mortal( newSViv( _Rect. right)));
PUSHs( sv_2mortal( newSViv( _Rect. top)));
break;
}
i++;
}
PUTBACK;
if ( returns)
{
dPUB_ARGS;
dG_EVAL_ARGS;
OPEN_G_EVAL;
retCount = ( coderef) ?
perl_call_sv(( SV *) subName, G_SCALAR|G_EVAL) :
perl_call_method( subName, G_SCALAR|G_EVAL);
SPAGAIN;
if ( SvTRUE( GvSV( PL_errgv)))
{
(void)POPs;
PUB_CHECK;
CLOSE_G_EVAL;
croak( "%s", SvPV_nolen( GvSV( PL_errgv))); /* propagate */
}
CLOSE_G_EVAL;
if ( retCount == 1)
{
toReturn = newSVsv( POPs);
}
PUTBACK;
FREETMPS;
LEAVE;
if ( toReturn)
toReturn = sv_2mortal( toReturn);
}
else
{
dPUB_ARGS;
dG_EVAL_ARGS;
OPEN_G_EVAL;
if ( coderef) perl_call_sv(( SV *) subName, G_DISCARD|G_EVAL);
else perl_call_method( subName, G_DISCARD|G_EVAL);
if ( SvTRUE( GvSV( PL_errgv)))
{
PUB_CHECK;
CLOSE_G_EVAL;
croak( "%s", SvPV_nolen( GvSV( PL_errgv))); /* propagate */
}
CLOSE_G_EVAL;
SPAGAIN; FREETMPS; LEAVE;
}
}
return toReturn;
}
HV *
parse_hv( I32 ax, SV **sp, I32 items, SV **mark, int expected, const char *methodName)
{
HV *hv;
AV *order;
int i;
if (( items - expected) % 2 != 0)
croak( "GUTS010: Incorrect profile (odd number of arguments) passed to ``%s''", methodName);
hv = newHV();
order = newAV();
for ( i = expected; i < items; i += 2)
{
HE *he;
/* check the validity of a key */
if (!( SvPOK( ST( i)) && ( !SvROK( ST( i)))))
croak( "GUTS011: Illegal value for a profile key (argument #%d) passed to ``%s''", i, methodName);
/* and add the pair */
he = hv_store_ent( hv, ST( i), newSVsv( ST( i+1)), 0);
av_push( order, newSVsv( ST( i)));
}
(void) hv_store( hv, "__ORDER__", 9, newRV_noinc((SV *)order), 0);
return hv;
}
void
push_hv( I32 ax, SV **sp, I32 items, SV **mark, int callerReturns, HV *hv)
{
int n;
HE *he;
int wantarray = GIMME_V;
SV **rorder;
if ( wantarray != G_ARRAY)
{
sv_free((SV *)hv);
PUTBACK;
return;
/* XSRETURN( callerReturns); */
}
rorder = hv_fetch( hv, "__ORDER__", 9, 0);
if ( rorder != nil && *rorder != nil && SvROK( *rorder) && SvTYPE(SvRV(*rorder)) == SVt_PVAV) {
int i, l;
AV *order = (AV*)SvRV(*rorder);
SV **key;
n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != nil) n++;
n--; EXTEND( sp, n*2);
/* push everything in proper order */
l = av_len(order);
for ( i = 0; i <= l; i++) {
key = av_fetch(order, i, 0);
if (key == nil || *key == nil) croak( "GUTS008: Illegal key in order array in push_hv()");
if ( !hv_exists_ent( hv, *key, 0)) continue;
PUSHs( sv_2mortal( newSVsv( *key)));
PUSHs( sv_2mortal( newSVsv( HeVAL(hv_fetch_ent(hv, *key, 0, 0)))));
}
sv_free(( SV *) hv);
PUTBACK;
return;
}
/* Calculate the length of our hv */
n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != nil) n++;
EXTEND( sp, n*2);
/* push everything */
hv_iterinit( hv);
while (( he = hv_iternext( hv)) != nil)
{
PUSHs( sv_2mortal( newSVsv( hv_iterkeysv( he))));
PUSHs( sv_2mortal( newSVsv( HeVAL( he))));
}
sv_free(( SV *) hv);
PUTBACK;
return;
/* XSRETURN( callerReturns + n*2); */
}
SV **
push_hv_for_REDEFINED( SV **sp, HV *hv)
{
int n;
HE *he;
SV **rorder;
rorder = hv_fetch( hv, "__ORDER__", 9, 0);
if ( rorder != nil && *rorder != nil && SvROK( *rorder) && SvTYPE(SvRV(*rorder)) == SVt_PVAV) {
int i, l;
AV *order = (AV*)SvRV(*rorder);
SV **key;
n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != nil) n++;
n--; EXTEND( sp, n*2);
/* push everything in proper order */
l = av_len(order);
for ( i = 0; i <= l; i++) {
key = av_fetch(order, i, 0);
if (key == nil || *key == nil) croak( "GUTS008: Illegal key in order array in push_hv_for_REDEFINED()");
if ( !hv_exists_ent( hv, *key, 0)) continue;
PUSHs( sv_2mortal( newSVsv( *key)));
PUSHs( sv_2mortal( newSVsv( HeVAL( hv_fetch_ent(hv, *key, 0, 0)))));
}
return sp;
}
/* Calculate the length of our hv */
n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != nil) n++;
EXTEND( sp, n*2);
/* push everything */
hv_iterinit( hv);
while (( he = hv_iternext( hv)) != nil)
{
PUSHs( sv_2mortal( newSVsv( hv_iterkeysv( he))));
PUSHs( sv_2mortal( newSVsv( HeVAL( he))));
}
return sp;
}
int
pop_hv_for_REDEFINED( SV **sp, int returned, HV *hv, int expected)
{
int i;
AV *order;
if (( returned - expected) % 2 != 0)
croak( "GUTS012: Cannot create HV from the odd number of arguments returned (%d,%d)", returned, expected);
hv_clear( hv);
order = newAV();
for ( i = 0; i < returned - expected; i += 2)
{
SV *v = POPs;
SV *k = POPs;
if (!( SvPOK( k) && ( !SvROK( k))))
croak( "GUTS013: Illegal value for a profile key passed");
(void) hv_store_ent( hv, k, newSVsv( v), 0);
av_push( order, newSVsv( k));
}
(void) hv_store( hv, "__ORDER__", 9, newRV_noinc((SV *)order), 0);
return expected;
}
static Bool
kill_objects( void * item, int keyLen, Handle * self, void * dummy)
{
Object_destroy( *self);
return false;
}
void
perl_error(void)
{
char * error = apc_last_error();
if ( error == NULL) error = "unknown system error";
sv_setpv( GvSV( PL_errgv), error);
}
Bool appDead = false;
#if (PERL_PATCHLEVEL == 5)
#define PRIMAPERL_scopestack_ix PL_scopestack_ix
#define PRIMAPERL_defstash PL_defstash
#define PRIMAPERL_curstash PL_curstash
#define PRIMAPERL_endav PL_endav
#elif (PERL_PATCHLEVEL == 4)
#define PRIMAPERL_scopestack_ix scopestack_ix
#define PRIMAPERL_defstash defstash
#define PRIMAPERL_curstash curstash
#define PRIMAPERL_endav endav
#endif
XS(Utils_getdir_FROMPERL);
static Bool
kill_hashes( PHash hash, void * dummy)
{
hash_destroy( hash, false);
return false;
}
XS( prima_cleanup)
{
dXSARGS;
(void)items;
if ( application) Object_destroy( application);
appDead = true;
hash_first_that( primaObjects, (void*)kill_objects, nil, nil, nil);
hash_destroy( primaObjects, false);
primaObjects = nil;
if ( prima_init_ok > 1) prima_cleanup_image_subsystem();
if ( prima_init_ok > 2) window_subsystem_cleanup();
hash_destroy( vmtHash, false);
vmtHash = nil;
list_delete_all( &staticObjects, true);
list_destroy( &staticObjects);
list_destroy( &postDestroys);
kill_zombies();
if ( prima_init_ok > 2) window_subsystem_done();
list_first_that( &staticHashes, (void*)kill_hashes, nil);
list_destroy( &staticHashes);
prima_init_ok = 0;
ST(0) = &PL_sv_yes;
XSRETURN(1);
}
static void
register_constants( void)
{
register_nt_constants();
register_kb_constants();
register_km_constants();
register_mb_constants();
register_ta_constants();
register_cl_constants();
register_ci_constants();
register_wc_constants();
register_cm_constants();
register_rop_constants();
register_gm_constants();
register_lp_constants();
register_fp_constants();
register_le_constants();
register_lj_constants();
register_fs_constants();
register_fw_constants();
register_bi_constants();
register_bs_constants();
register_ws_constants();
register_sv_constants();
register_im_constants();
register_ict_constants();
register_ist_constants();
register_is_constants();
register_am_constants();
register_apc_constants();
register_gui_constants();
register_dt_constants();
register_cr_constants();
register_sbmp_constants();
register_tw_constants();
register_fds_constants();
register_fdo_constants();
register_fe_constants();
register_fr_constants();
register_mt_constants();
register_gt_constants();
register_ps_constants();
register_scr_constants();
}
XS( Object_alive_FROMPERL);
XS( Component_event_hook_FROMPERL);
XS( boot_Prima)
{
dXSARGS;
(void)items;
XS_VERSION_BOOTCHECK;
#define TYPECHECK(s1,s2) \
if (sizeof(s1) != (s2)) { \
printf("Error: type %s is %d bytes long (expected to be %d)", #s1, (int)sizeof(s1), s2); \
ST(0) = &PL_sv_no; \
XSRETURN(1); \
}
TYPECHECK( uint8_t, 1);
TYPECHECK( int8_t, 1);
TYPECHECK( uint16_t, 2);
TYPECHECK( int16_t, 2);
TYPECHECK( uint32_t, 4);
TYPECHECK( int32_t, 4);
TYPECHECK( void*, (int)sizeof(Handle));
#undef TYPECHECK
list_create( &staticObjects, 16, 16);
list_create( &staticHashes, 16, 16);
primaObjects = hash_create();
vmtHash = hash_create();
list_create( &postDestroys, 16, 16);
/* register hard coded XSUBs */
newXS( "::destroy_mate", destroy_mate, "Prima Guts");
newXS( "Prima::cleanup", prima_cleanup, "Prima");
newXS( "Prima::init", Prima_init, "Prima");
newXS( "Prima::options", Prima_options, "Prima");
newXS( "Prima::Utils::getdir", Utils_getdir_FROMPERL, "Prima::Utils");
/* register built-in classes */
newXS( "Prima::Object::create", create_from_Perl, "Prima::Object");
newXS( "Prima::Object::destroy", destroy_from_Perl, "Prima::Object");
newXS( "Prima::Object::alive", Object_alive_FROMPERL, "Prima::Object");
newXS( "Prima::Component::event_hook", Component_event_hook_FROMPERL, "Prima::Component");
newXS( "Prima::message", Prima_message_FROMPERL, "Prima");
newXS( "Prima::dl_export", Prima_dl_export, "Prima");
register_constants();
register_Object_Class();
register_Utils_Package();
register_Component_Class();
register_File_Class();
register_Clipboard_Class();
register_DeviceBitmap_Class();
register_Drawable_Class();
register_Widget_Class();
register_Window_Class();
register_Image_Class();
init_image_support();
register_Icon_Class();
register_AbstractMenu_Class();
register_AccelTable_Class();
register_Menu_Class();
register_Popup_Class();
register_Application_Class();
register_Timer_Class();
register_Printer_Class();
ST(0) = &PL_sv_yes;
XSRETURN(1);
}
typedef struct _RemapHashNode_ {
Handle key;
Handle val;
struct _RemapHashNode_ *next;
} RemapHashNode, *PRemapHashNode;
typedef struct _RemapHash_ {
PRemapHashNode table[1];
} RemapHash, *PRemapHash;
Handle
ctx_remap_def( Handle value, Handle *table, Bool direct, Handle default_value)
{
register PRemapHash hash;
register PRemapHashNode node;
if ( table == nil) return default_value;
if ( table[0] != endCtx) {
/* Hash was not built before; building */
Handle *tbl;
PRemapHash hash1, hash2;
PRemapHashNode next;
int sz = 0;
tbl = table;
while ((*tbl) != endCtx) {
tbl += 2;
sz++;
}
/* First way build hash */
hash = ( PRemapHash) malloc( sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1) + sizeof( RemapHashNode) * sz);
if ( !hash) return default_value;
bzero( hash, sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
tbl = table;
next = ( PRemapHashNode )(((char *)hash) + sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
while ((*tbl) != endCtx) {
Handle key = (*tbl)&0x1F;
if (hash->table[key]) {
/* Already exists something */
node = hash->table[key];
while ( node-> next) node = node-> next;
/* node->next = malloc( sizeof( RemapHashNode)); */
node->next = next++;
node->next-> key = tbl[0];
node->next-> val = tbl[1];
node->next-> next = nil;
} else {
/* hash->table[key] = malloc( sizeof( RemapHashNode)); */
hash->table[key] = next++;
hash->table[key]-> key = tbl[0];
hash->table[key]-> val = tbl[1];
hash->table[key]-> next = nil;
}
tbl += 2;
}
hash1 = hash;
/* Second way build hash */
hash = ( PRemapHash) malloc( sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1) + sizeof( RemapHashNode) * sz);
if ( !hash) {
free( hash1);
return default_value;
}
bzero( hash, sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
tbl = table;
next = ( PRemapHashNode)(((char *)hash) + sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
while ((*tbl) != endCtx) {
Handle key = tbl[1]&0x1F;
if (hash->table[key]) {
/* Already exists something */
node = hash->table[key];
while ( node-> next) node = node-> next;
/* node->next = malloc( sizeof( RemapHashNode)); */
node->next = next++;
node->next-> key = tbl[1];
node->next-> val = tbl[0];
node->next-> next = nil;
} else {
/* hash->table[key] = malloc( sizeof( RemapHashNode)); */
hash->table[key] = next++;
hash->table[key]-> key = tbl[1];
hash->table[key]-> val = tbl[0];
hash->table[key]-> next = nil;
}
tbl += 2;
}
hash2 = hash;
table[0] = endCtx;
table[1] = list_add( &staticObjects, ( Handle) hash1);
table[2] = list_add( &staticObjects, ( Handle) hash2);
}
hash = ( PRemapHash) list_at( &staticObjects, direct ? table[1] : table[2]);
node = hash->table[value&0x1F];
while ( node) {
if (node->key == value) return node->val;
node = node->next;
}
return default_value;
}
void *
create_object( const char *objClass, const char *types, ...)
{
va_list params;
HV *profile;
char *s;
Handle res;
va_start( params, types);
profile = newHV();
while (*types)
{
s = va_arg( params, char *);
switch (*types)
{
case 'i':
(void) hv_store( profile, s, strlen( s), newSViv(va_arg(params, int)), 0);
break;
case 's':
(void) hv_store( profile, s, strlen( s), newSVpv(va_arg(params, char *),0), 0);
break;
case 'n':
(void) hv_store( profile, s, strlen( s), newSVnv(va_arg(params, double)), 0);
break;
default:
croak( "GUTS014: create_object: illegal parameter type");
}
types++;
}
va_end( params);
res = Object_create((char *)objClass, profile);
if ( res)
--SvREFCNT( SvRV((( PAnyObject) res)-> mate));
sv_free(( SV *) profile);
return (void*)res;
}
Handle
apc_get_application(void)
{
return application;
}
Handle
apc_get_core_version()
{
return PRIMA_CORE_VERSION;
}
FillPattern fillPatterns[] = {
{0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00},
{0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF},
{0x00, 0x00, 0xFF, 0xFF, 0x00, 0x00, 0xFF, 0xFF},
{0x80, 0x40, 0x20, 0x10, 0x08, 0x04, 0x02, 0x01},
{0x70, 0x38, 0x1C, 0x0E, 0x07, 0x83, 0xC1, 0xE0},
{0xE1, 0xC3, 0x87, 0x0F, 0x1E, 0x3C, 0x78, 0xF0},
{0x4B, 0x96, 0x2D, 0x5A, 0xB4, 0x69, 0xD2, 0xA5},
{0x88, 0x88, 0x88, 0xFF, 0x88, 0x88, 0x88, 0xFF},
{0x18, 0x24, 0x42, 0x81, 0x18, 0x24, 0x42, 0x81},
{0x33, 0xCC, 0x33, 0xCC, 0x33, 0xCC, 0x33, 0xCC},
{0x00, 0x08, 0x00, 0x80, 0x00, 0x08, 0x00, 0x80},
{0x00, 0x22, 0x00, 0x88, 0x00, 0x22, 0x00, 0x88},
{0xaa, 0x55, 0xaa, 0x55, 0xaa, 0x55, 0xaa, 0x55},
{0xaa, 0xff, 0xaa, 0xff, 0xaa, 0xff, 0xaa, 0xff},
{0x51, 0x22, 0x15, 0x88, 0x45, 0x22, 0x54, 0x88},
{0x02, 0x27, 0x05, 0x00, 0x20, 0x72, 0x50, 0x00}
};
/* list section */
void
list_create( PList slf, int size, int delta)
{
if ( !slf) return;
memset( slf, 0, sizeof( List));
slf-> delta = ( delta > 0) ? delta : 1;
if (( slf-> size = size) > 0) {
if ( !( slf-> items = allocn( Handle, size)))
slf-> size = 0;
} else
slf-> items = nil;
}
PList
plist_create( int size, int delta)
{
PList new_list = alloc1( List);
if ( new_list != nil) {
list_create( new_list, size, delta);
}
return new_list;
}
void
list_destroy( PList slf)
{
if ( !slf) return;
free( slf-> items);
slf-> items = nil;
slf-> count = 0;
slf-> size = 0;
}
void
plist_destroy( PList slf)
{
if ( slf != NULL) {
list_destroy( slf);
free( slf);
}
}
int
list_add( PList slf, Handle item)
{
if ( !slf) return -1;
if ( slf-> count == slf-> size)
{
Handle * old = slf-> items;
if ( !( slf-> items = allocn(Handle, ( slf-> size + slf-> delta))))
return -1;
if ( old) {
memcpy( slf-> items, old, slf-> size * sizeof( Handle));
free( old);
}
slf-> size += slf-> delta;
}
slf-> items[ slf-> count++] = item;
return slf-> count - 1;
}
int
list_insert_at( PList slf, Handle item, int pos)
{
int max, ret;
Handle save;
ret = list_add( slf, item);
if ( ret < 0) return ret;
max = slf-> count - 1;
if ( pos < 0 || pos >= max) return ret;
save = slf-> items[ max];
memmove( &slf-> items[ pos + 1], &slf-> items[ pos], ( max - pos) * sizeof( Handle));
slf-> items[ pos] = save;
return pos;
}
int
list_index_of( PList slf, Handle item)
{
int i;
if ( !slf ) return -1;
for ( i = 0; i < slf-> count; i++)
if ( slf-> items[ i] == item) return i;
return -1;
}
void
list_delete( PList slf, Handle item)
{
list_delete_at( slf, list_index_of( slf, item));
}
void
list_delete_at( PList slf, int index)
{
if ( !slf || index < 0 || index >= slf-> count) return;
slf-> count--;
if ( index == slf-> count) return;
memmove( &slf-> items[ index], &slf-> items[ index + 1], ( slf-> count - index) * sizeof( Handle));
}
Handle
list_at( PList slf, int index)
{
return (( index < 0 || !slf) || index >= slf-> count) ? nilHandle : slf-> items[ index];
}
int
list_first_that( PList slf, void * action, void * params)
{
int toRet = -1, i, cnt = slf-> count;
Handle * list;
if ( !action || !slf || !cnt) return -1;
if ( !( list = allocn( Handle, slf-> count)))
return -1;
memcpy( list, slf-> items, slf-> count * sizeof( Handle));
for ( i = 0; i < cnt; i++)
if ((( PListProc) action)( list[ i], params)) {
toRet = i;
break;
}
free( list);
return toRet;
}
void
list_delete_all( PList slf, Bool kill)
{
if ( !slf || ( slf-> count == 0)) return;
if ( kill ) {
int i;
for ( i = 0; i < slf-> count; i++)
free(( void*) slf-> items[ i]);
}
slf-> count = 0;
}
PHash
prima_hash_create()
{
PHash ret = newHV();
list_add( &staticHashes, ( Handle) ret);
return ret;
}
void
hash_destroy( PHash h, Bool killAll)
{
HE *he;
list_delete( &staticHashes, ( Handle) h);
hv_iterinit( h);
while (( he = hv_iternext( h)) != nil) {
if ( killAll) free( HeVAL( he));
HeVAL( he) = &PL_sv_undef;
}
sv_free(( SV *) h);
}
static SV *ksv = nil;
#define ksv_check if ( !ksv) { \
ksv = newSV( keyLen); \
if (!ksv) croak( "GUTS015: Cannot create SV"); \
} \
sv_setpvn( ksv, ( char *) key, keyLen); \
he = hv_fetch_ent( h, ksv, false, 0)
void *
hash_fetch( PHash h, const void *key, int keyLen)
{
HE *he;
ksv_check;
if ( !he) return nil;
return HeVAL( he);
}
void *
hash_delete( PHash h, const void *key, int keyLen, Bool kill)
{
HE *he;
void *val;
ksv_check;
if ( !he) return nil;
val = HeVAL( he);
HeVAL( he) = &PL_sv_undef;
(void) hv_delete_ent( h, ksv, G_DISCARD, 0);
if ( kill) {
free( val);
return nil;
}
return val;
}
Bool
hash_store( PHash h, const void *key, int keyLen, void *val)
{
HE *he;
ksv_check;
if ( he) {
HeVAL( he) = &PL_sv_undef;
(void) hv_delete_ent( h, ksv, G_DISCARD, 0);
}
he = hv_store_ent( h, ksv, &PL_sv_undef, 0);
HeVAL( he) = ( SV *) val;
return true;
}
void *
hash_first_that( PHash h, void * action, void * params, int * pKeyLen, void ** pKey)
{
HE *he;
if ( action == nil || h == nil) return nil;
hv_iterinit(( HV*) h);
for (;;)
{
void *value, *key;
int keyLen;
if (( he = hv_iternext( h)) == nil)
return nil;
value = HeVAL( he);
key = HeKEY( he);
keyLen = HeKLEN( he);
if ((( PHashProc) action)( value, keyLen, key, params)) {
if ( pKeyLen) *pKeyLen = keyLen;
if ( pKey) *pKey = key;
return value;
}
}
return nil;
}
static char* exception_text = NULL;
static Bool exception_blocking = 0;
void
exception_remember(char * text)
{
if ( !exception_blocking ) croak( "%s", text );
if ( exception_text ) {
if ( !( exception_text = realloc(exception_text, strlen(text) + strlen(exception_text) + 1)))
croak("not enough memory");
strcat( exception_text, text );
} else {
exception_text = duplicate_string( text );
}
}
Bool
exception_charged(void)
{
return exception_text != NULL;
}
Bool
exception_block(Bool block)
{
Bool old = exception_blocking;
exception_blocking = block;
return old;
}
void
exception_check_raise(void)
{
char buf[1024];
if ( !exception_text ) return;
strncpy( buf, exception_text, 1023 );
free( exception_text );
exception_text = NULL;
croak("%s", buf);
}
int
prima_utf8_length( const char * utf8)
{
int ret = 0;
while ( *utf8) {
utf8 = ( char*) utf8_hop(( U8*) utf8, 1);
ret++;
}
return ret;
}
Bool
prima_is_utf8_sv( SV * sv)
{
/* from Encode.xs */
if (SvGMAGICAL(sv)) {
SV * sv2 = newSVsv(sv); /* GMAGIG will be done */
Bool ret = SvUTF8(sv2) ? 1 : 0;
SvREFCNT_dec(sv2); /* it was a temp copy */
return ret;
} else {
return SvUTF8(sv) ? 1 : 0;
}
}
#ifdef HAVE_OPENMP
#include <omp.h>
#endif
int
prima_omp_max_threads(void)
{
return
#ifdef HAVE_OPENMP
omp_get_max_threads()
#else
1
#endif
;
}
int
prima_omp_thread_num(void)
{
return
#ifdef HAVE_OPENMP
omp_get_thread_num()
#else
0
#endif
;
}
void
prima_omp_set_num_threads(int num)
{
#ifdef HAVE_OPENMP
omp_set_num_threads(num);
#endif
}
#ifdef __cplusplus
}
#endif