1 /* Guts library, main file */
2
3 #define GENERATE_TABLE_GENERATOR yes
4 #include "apricot.h"
5 #include <sys/types.h>
6 #include <stdio.h>
7 #include <stdarg.h>
8 #include <float.h>
9 #include <dirent.h>
10 #include "guts.h"
11 #include "Object.h"
12 #include "Component.h"
13 #include "File.h"
14 #include "Clipboard.h"
15 #include "DeviceBitmap.h"
16 #include "Drawable.h"
17 #include "Widget.h"
18 #include "Window.h"
19 #include "Image.h"
20 #include "Icon.h"
21 #include "AbstractMenu.h"
22 #include "AccelTable.h"
23 #include "Menu.h"
24 #include "Popup.h"
25 #include "Application.h"
26 #include "Timer.h"
27 #include "Utils.h"
28 #include "Printer.h"
29 #include "Region.h"
30 #include "img_conv.h"
31
32
33 #include <Types.inc>
34
35 #ifdef __cplusplus
36 extern "C" {
37 #endif
38
39 #include "thunks.tinc"
40
41
42 #if defined(_MSC_VER) && defined(PERL_OBJECT)
43 XSLockManager g_XSLock;
44 CPerlObj* pPerl;
45 #endif
46
47 static PHash vmtHash = NULL;
48 static List staticObjects;
49 static List staticHashes;
50 static int prima_init_ok = 0;
51
52 Handle application = NULL_HANDLE;
53 long apcError = 0;
54 List postDestroys;
55 int recursiveCall = 0;
56 PHash primaObjects = NULL;
57 SV * eventHook = NULL;
58 Bool use_fribidi =
59 #ifdef WITH_FRIBIDI
60 true
61 #else
62 false
63 #endif
64 ;
65
66 char *
duplicate_string(const char * s)67 duplicate_string( const char *s)
68 {
69 int l;
70 char *d;
71
72 if (!s) return NULL;
73 l = strlen( s) + 1;
74 d = ( char*)malloc( l);
75 if ( d) memcpy( d, s, l);
76 return d;
77 }
78
79 void *
prima_mallocz(size_t sz)80 prima_mallocz( size_t sz)
81 {
82 void *p = malloc( sz);
83 if (p)
84 bzero( p, sz);
85 return p;
86 }
87
88 char *
prima_normalize_resource_string(char * name,Bool isClass)89 prima_normalize_resource_string( char *name, Bool isClass)
90 {
91 static Bool initialize = true;
92 static char table[256];
93 int i;
94 unsigned char *s;
95
96 if ( initialize) {
97 for ( i = 0; i < 256; i++) {
98 table[i] = isalnum(i) ? i : '_';
99 }
100 table[0] = 0;
101 initialize = false;
102 }
103
104 s = (unsigned char*)name;
105 while (*s) {
106 *s = table[*s];
107 s++;
108 }
109 name[0] = isClass ? toupper(name[0]) : tolower(name[0]);
110 return name;
111 }
112
113 #ifndef HAVE_BZERO
114 void
bzero(void * data,size_t size)115 bzero( void * data, size_t size)
116 {
117 memset( data, 0, size);
118 }
119 #endif
120
121 #ifdef PRIMA_NEED_OWN_STRICMP
122 int
stricmp(const char * s1,const char * s2)123 stricmp(const char *s1, const char *s2)
124 {
125 /* Code was taken from FreeBSD 4.0 /usr/src/lib/libc/string/strcasecmp.c */
126 const unsigned char *u1 = (const unsigned char *)s1;
127 const unsigned char *u2 = (const unsigned char *)s2;
128 while (tolower(*u1) == tolower(*u2++))
129 if (*u1++ == '\0')
130 return 0;
131 return (tolower(*u1) - tolower(*--u2));
132 }
133 #endif
134
135 #ifdef PRIMA_NEED_OWN_STRNICMP
136 int
strnicmp(const char * s1,const char * s2,size_t count)137 strnicmp(const char *s1, const char *s2, size_t count)
138 {
139 const unsigned char *u1 = (const unsigned char *)s1;
140 const unsigned char *u2 = (const unsigned char *)s2;
141 if ( count == 0) return 0;
142 while (tolower(*u1) == tolower(*u2++))
143 if (--count == 0 || *u1++ == '\0')
144 return 0;
145 return (tolower(*u1) - tolower(*--u2));
146 }
147 #endif
148
149 #ifndef HAVE_STRCASESTR
150 /* Code was taken from FreeBSD 4.8 /usr/src/lib/libc/string/strcasestr.c */
151 char *
strcasestr(register const char * s,register const char * find)152 strcasestr( register const char * s, register const char * find)
153 {
154 register char c, sc;
155 register size_t len;
156
157 if ((c = *find++) != 0) {
158 c = tolower((unsigned char)c);
159 len = strlen(find);
160 do {
161 do {
162 if ((sc = *s++) == 0)
163 return (NULL);
164 } while ((char)tolower((unsigned char)sc) != c);
165 } while (strnicmp(s, find, len) != 0);
166 s--;
167 }
168 return ((char *)s);
169 }
170 #endif
171
172
173 #ifndef HAVE_REALLOCF
174 /*
175 This code was taken from FreeBSD 4.0 /usr/src/lib/libc/stdlib/reallocf.c
176 Thanks, Poul Henning! :-)
177 */
178 void *
reallocf(void * ptr,size_t size)179 reallocf(void *ptr, size_t size)
180 {
181 void *nptr;
182
183 nptr = realloc(ptr, size);
184 if (!nptr && ptr)
185 free(ptr);
186 return (nptr);
187 }
188 #endif
189
190 #if ! ( defined( HAVE_SNPRINTF) || defined( HAVE__SNPRINTF))
191 int
snprintf(char * buf,size_t len,const char * format,...)192 snprintf( char *buf, size_t len, const char *format, ...)
193 {
194 int rc;
195 va_list args;
196 va_start( args, format);
197 rc = vsnprintf( buf, len, format, args);
198 va_end( args);
199 return rc;
200 }
201 #endif
202
203 #ifndef HAVE_MEMMEM
204 /* copied from https://github.com/trevd/android_external_bootimage_utils/blob/master/windows/memmem.c */
205 void *
memmem(const void * l,size_t l_len,const void * s,size_t s_len)206 memmem(const void *l, size_t l_len, const void *s, size_t s_len)
207 {
208 register char *cur, *last;
209 const char *cl = (const char *)l;
210 const char *cs = (const char *)s;
211
212 /* we need something to compare */
213 if (l_len == 0 || s_len == 0)
214 return NULL;
215
216 /* "s" must be smaller or equal to "l" */
217 if (l_len < s_len)
218 return NULL;
219
220 /* special case where s_len == 1 */
221 if (s_len == 1)
222 return memchr(l, (int)*cs, l_len);
223
224 /* the last position where its possible to find "s" in "l" */
225 last = (char *)cl + l_len - s_len;
226
227 for (cur = (char *)cl; cur <= last; cur++)
228 if (cur[0] == cs[0] && memcmp(cur, cs, s_len) == 0)
229 return cur;
230
231 return NULL;
232 }
233
234 #endif
235
236 I32
clean_perl_call_method(char * methname,I32 flags)237 clean_perl_call_method( char* methname, I32 flags)
238 {
239 I32 ret;
240 dG_EVAL_ARGS;
241
242 if ( !( flags & G_EVAL)) { OPEN_G_EVAL; }
243 ret = perl_call_method( methname, flags | G_EVAL);
244 if ( SvTRUE( GvSV( PL_errgv))) {
245 if (( flags & (G_SCALAR|G_DISCARD|G_ARRAY)) == G_SCALAR) {
246 dSP;
247 SPAGAIN;
248 (void)POPs;
249 }
250 if ( flags & G_EVAL) return ret;
251 CLOSE_G_EVAL;
252 croak( "%s", SvPV_nolen( GvSV( PL_errgv)));
253 }
254
255 if ( !( flags & G_EVAL)) { CLOSE_G_EVAL; }
256 return ret;
257 }
258
259 I32
clean_perl_call_pv(char * subname,I32 flags)260 clean_perl_call_pv( char* subname, I32 flags)
261 {
262 I32 ret;
263 dG_EVAL_ARGS;
264
265 if ( !( flags & G_EVAL)) { OPEN_G_EVAL; }
266 ret = perl_call_pv( subname, flags | G_EVAL);
267 if ( SvTRUE( GvSV( PL_errgv))) {
268 if (( flags & (G_SCALAR|G_DISCARD|G_ARRAY)) == G_SCALAR) {
269 dSP;
270 SPAGAIN;
271 (void)POPs;
272 }
273 if ( flags & G_EVAL) return ret;
274 CLOSE_G_EVAL;
275 croak( "%s", SvPV_nolen( GvSV( PL_errgv)));
276 }
277
278 if ( !( flags & G_EVAL)) { CLOSE_G_EVAL; }
279 return ret;
280 }
281
282 SV *
eval(char * string)283 eval( char *string)
284 {
285 return perl_eval_pv( string, FALSE);
286 }
287
288 Handle
create_mate(SV * perlObject)289 create_mate( SV *perlObject)
290 {
291 PAnyObject object;
292 Handle self = NULL_HANDLE;
293 char *className;
294 PVMT vmt;
295
296 /* finding the vmt */
297 className = HvNAME( SvSTASH( SvRV( perlObject))); if ( !className) return 0;
298 vmt = gimme_the_vmt( className); if ( !vmt) return 0;
299
300 /* allocating an instance */
301 object = ( PAnyObject) malloc( vmt-> instanceSize);
302 if ( !object) return NULL_HANDLE;
303
304 memset( object, 0, vmt-> instanceSize);
305 object-> self = ( PVMT) vmt;
306 object-> super = ( PVMT *) vmt-> super;
307
308 (void) hv_store( (HV*)SvRV( perlObject), "__CMATE__", 9, newSViv( PTR2IV(object)), 0);
309
310 /* extra check */
311 self = gimme_the_mate( perlObject);
312 if ( self != (Handle)object)
313 croak( "GUTS007: create_mate() consistency check failed.\n");
314 return self;
315 }
316
317
318 Handle
gimme_the_real_mate(SV * perlObject)319 gimme_the_real_mate( SV *perlObject)
320 {
321 HV *obj;
322 SV **mate;
323 if ( !SvROK( perlObject)) return NULL_HANDLE;
324 obj = (HV*)SvRV( perlObject);
325 if ( SvTYPE((SV*)obj) != SVt_PVHV) return NULL_HANDLE;
326 mate = hv_fetch( obj, "__CMATE__", 9, 0);
327 if ( mate == NULL) return NULL_HANDLE;
328 return SvIV( *mate);
329 }
330
331 Handle
gimme_the_mate(SV * perlObject)332 gimme_the_mate( SV *perlObject)
333 {
334 Handle cMate;
335 cMate = gimme_the_real_mate( perlObject);
336 return (( cMate == NULL_HANDLE) || ((( PObject) cMate)-> stage == csDead)) ? NULL_HANDLE : cMate;
337 }
338
339
XS(create_from_Perl)340 XS( create_from_Perl)
341 {
342 dXSARGS;
343 if ( prima_init_ok <= 2 )
344 croak("Prima is not initialized%s.", PL_minus_c ? " under -c mode" : "");
345 if (( items - 2 + 1) % 2 != 0)
346 croak("Invalid usage of Prima::Object::create");
347 {
348 Handle _c_apricot_res_;
349 HV *hv = parse_hv( ax, sp, items, mark, 2 - 1, "Object_create");
350 _c_apricot_res_ = Object_create(
351 ( char*) SvPV_nolen( ST( 0)),
352 hv
353 );
354 SPAGAIN;
355 SP -= items;
356 if ( _c_apricot_res_ && (( PAnyObject) _c_apricot_res_)-> mate && (( PAnyObject) _c_apricot_res_)-> mate != NULL_SV)
357 {
358 XPUSHs( sv_mortalcopy((( PAnyObject) _c_apricot_res_)-> mate));
359 --SvREFCNT( SvRV((( PAnyObject) _c_apricot_res_)-> mate));
360 } else XPUSHs( &PL_sv_undef);
361 /* push_hv( ax, sp, items, mark, 1, hv); */
362 sv_free(( SV *) hv);
363 }
364 PUTBACK;
365 return;
366 }
367
368
XS(destroy_from_Perl)369 XS( destroy_from_Perl)
370 {
371 dXSARGS;
372 Handle self;
373 if ( items != 1)
374 croak ("Invalid usage of Prima::Object::destroy");
375 self = gimme_the_real_mate( ST( 0));
376 if ( self == NULL_HANDLE)
377 croak( "Illegal object reference passed to Prima::Object::destroy");
378 {
379 Object_destroy( self);
380 }
381 XSRETURN_EMPTY;
382 }
383
384 static PAnyObject killChain = NULL;
385 static PObject ghostChain = NULL;
386
387 void
prima_kill_zombies(void)388 prima_kill_zombies( void)
389 {
390 while ( killChain != NULL)
391 {
392 PAnyObject killee = killChain;
393 killChain = killee-> killPtr;
394 free( killee);
395 }
396 }
397
398 void
prima_refcnt_inc(Handle obj)399 prima_refcnt_inc( Handle obj)
400 {
401 if ( obj )
402 ++SvREFCNT( SvRV((( PAnyObject) obj)-> mate));
403 }
404
405 void
prima_refcnt_dec(Handle obj)406 prima_refcnt_dec( Handle obj)
407 {
408 if ( obj )
409 --SvREFCNT( SvRV((( PAnyObject) obj)-> mate));
410 }
411
412 void
protect_object(Handle obj)413 protect_object( Handle obj)
414 {
415 PObject o = (PObject)obj;
416 if ( o-> protectCount >= 0) o-> protectCount++;
417 }
418
419 void
unprotect_object(Handle obj)420 unprotect_object( Handle obj)
421 {
422 PObject o = (PObject)obj;
423 if (!o || o-> protectCount<=0)
424 return;
425 o-> protectCount--;
426 if (o-> protectCount>0) return;
427 if (o-> stage == csDead || o-> mate == NULL || o-> mate == NULL_SV)
428 {
429 PObject ghost, lg;
430
431 lg = NULL;
432 ghost = ghostChain;
433 while ( ghost != NULL && ghost != o)
434 {
435 lg = ghost;
436 ghost = (PObject)(ghost-> killPtr);
437 }
438 if ( ghost == o)
439 {
440 if ( lg == NULL)
441 ghostChain = (PObject)(o-> killPtr);
442 else
443 lg-> killPtr = o-> killPtr;
444 o-> killPtr = killChain;
445 killChain = (PAnyObject)o;
446 }
447 }
448 }
449
XS(destroy_mate)450 XS( destroy_mate)
451 {
452 dXSARGS;
453 Handle self;
454
455 if ( items != 1)
456 croak ("Invalid usage of ::destroy_mate");
457 self = gimme_the_real_mate( ST( 0));
458
459 if ( self == NULL_HANDLE)
460 croak( "Illegal object reference passed to ::destroy_mate");
461 {
462 Object_destroy( self);
463 if (((PObject)self)-> protectCount > 0)
464 {
465 (( PObject) self)-> killPtr = (PAnyObject)ghostChain;
466 ghostChain = ( PObject) self;
467 }
468 else
469 {
470 free(( void*) self);
471 }
472 }
473 XSRETURN_EMPTY;
474 }
475
476 Bool
kind_of(Handle object,void * cls)477 kind_of( Handle object, void *cls)
478 {
479 PVMT vmt = object ? (( PAnyObject) object)-> self : NULL;
480 while (( vmt != NULL) && ( vmt != cls))
481 vmt = vmt-> base;
482 return vmt != NULL;
483 }
484
485 CV *
query_method(Handle object,char * methodName,Bool cacheIt)486 query_method( Handle object, char *methodName, Bool cacheIt)
487 {
488 if ( object == NULL_HANDLE)
489 return NULL;
490 return sv_query_method((( PObject) object)-> mate, methodName, cacheIt);
491 }
492
493 CV *
sv_query_method(SV * sv,char * methodName,Bool cacheIt)494 sv_query_method( SV *sv, char *methodName, Bool cacheIt)
495 {
496 HV *stash = NULL;
497
498 if ( SvROK( sv)) {
499 sv = (SV*)SvRV( sv);
500 if ( SvOBJECT( sv))
501 stash = SvSTASH(sv);
502 } else {
503 stash = gv_stashsv( sv, false);
504 }
505
506 if ( stash) {
507 GV *gv = gv_fetchmeth( stash, methodName, strlen( methodName), cacheIt ? 0 : -1);
508 if ( gv && isGV( gv))
509 return GvCV(gv);
510 }
511 return NULL;
512 }
513
514 static void
cv_set_prototype(char * package,char * method,char * prototype)515 cv_set_prototype(char * package, char * method, char * prototype)
516 {
517 HV * stash;
518 GV * gv;
519 CV * cv;
520 if (!(stash = gv_stashpvn(package, strlen(package), 0)))
521 return;
522 if ( !( gv = gv_fetchmeth( stash, method, strlen( method), 0)))
523 return;
524 if (!( cv = GvCV(gv)))
525 return;
526 sv_setpv((SV *)cv, prototype);
527 }
528
529 static void
register_notifications(PVMT vmt)530 register_notifications( PVMT vmt)
531 {
532 SV *package;
533 SV *nt_sub;
534 SV *nt_ref;
535 HV *nt;
536 PVMT v = vmt;
537 HE *he;
538 char buf[ 1024];
539
540 while (( v != NULL) && ( v != (PVMT) CComponent)) v = v-> base;
541 if (!v) return;
542 package = newSVpv( vmt-> className, 0);
543 if ( !package) croak( "GUTS016: Not enough memory");
544 nt_sub = ( SV*) sv_query_method( package, "notification_types", 0);
545 if ( !nt_sub) croak( "GUTS016: Invalid package %s", vmt-> className);
546 nt_ref = cv_call_perl( package, nt_sub, "<");
547 if ( !nt_ref || !SvROK(nt_ref) || SvTYPE(SvRV(nt_ref)) != SVt_PVHV)
548 croak( "GUTS016: %s: Bad notification_types() return value", vmt-> className);
549 nt = (HV*)SvRV(nt_ref);
550
551 hv_iterinit( nt);
552 while (( he = hv_iternext( nt)) != NULL) {
553 snprintf( buf, 1024, "on%s", HeKEY( he));
554 if (sv_query_method( package, buf, 0)) continue;
555 snprintf( buf, 1024, "%s::on%s", vmt-> className, HeKEY( he));
556 newXS( buf, Component_set_notification_FROMPERL, vmt-> className);
557 }
558 sv_free( package);
559 }
560
561 static Bool
common_get_options(int * argc,char *** argv)562 common_get_options( int * argc, char *** argv)
563 {
564 static char * common_argv[] = {
565 #ifdef HAVE_OPENMP
566 "openmp_threads", "sets number of openmp threads",
567 #endif
568 #ifdef WITH_FRIBIDI
569 "no-fribidi", "do not use fribidi",
570 #endif
571 };
572 *argv = common_argv;
573 *argc = sizeof( common_argv) / sizeof( char*);
574 return true;
575 }
576
577 static Bool
common_set_option(char * option,char * value)578 common_set_option( char * option, char * value)
579 {
580 if ( strcmp( option, "openmp_threads") == 0) {
581 if ( value) {
582 int n = strtol( value, &option, 10);
583 if (*option)
584 warn("invalid value sent to `--openmp_threads'.");
585 else
586 prima_omp_set_num_threads(n);
587 } else
588 warn("`--openmp_threads' must be given parameters.");
589 return true;
590 }
591 #ifdef WITH_FRIBIDI
592 else if ( strcmp( option, "no-fribidi") == 0) {
593 if ( value) warn("`--no-fribidi' option has no parameters");
594 use_fribidi = false;
595 return true;
596 }
597 #endif
598 return false;
599 }
600
XS(Prima_options)601 XS(Prima_options)
602 {
603 dXSARGS;
604 char * option, * value = NULL;
605 (void)items;
606
607 switch ( items) {
608 case 0:
609 {
610 int i, argc1 = 0, argc2 = 0;
611 char ** argv1, ** argv2;
612 common_get_options( &argc1, &argv1);
613 window_subsystem_get_options( &argc2, &argv2);
614 EXTEND( sp, argc1 + argc2);
615 for ( i = 0; i < argc1; i++)
616 PUSHs( sv_2mortal( newSVpv( argv1[i], 0)));
617 for ( i = 0; i < argc2; i++)
618 PUSHs( sv_2mortal( newSVpv( argv2[i], 0)));
619 PUTBACK;
620 return;
621 }
622 break;
623 case 2:
624 value = (SvOK( ST(1)) ? ( char*) SvPV_nolen( ST(1)) : NULL);
625 case 1:
626 option = ( char*) SvPV_nolen( ST(0));
627 if ( !common_set_option( option, value))
628 window_subsystem_set_option( option, value);
629 break;
630 default:
631 croak("Invalid call to Prima::options");
632 }
633 SPAGAIN;
634 XSRETURN_EMPTY;
635 }
636
XS(Prima_init)637 XS(Prima_init)
638 {
639 dXSARGS;
640 char error_buf[256] = "Error initializing Prima";
641 (void)items;
642
643 if ( items < 1) croak("Invalid call to Prima::init");
644
645 {
646 SV * ref;
647 SV * package = newSVpv( "Prima::Object", 0);
648 if ( !package) croak( "GUTS016: Not enough memory");
649 ref = ( SV *) sv_query_method( package, "profile_default", 0);
650 sv_free( package);
651 if ( !ref) croak("'use Prima;' call required in main script");
652 }
653
654 if ( prima_init_ok == 0) {
655 register_notifications((PVMT)CComponent);
656 register_notifications((PVMT)CFile);
657 register_notifications((PVMT)CAbstractMenu);
658 register_notifications((PVMT)CAccelTable);
659 register_notifications((PVMT)CMenu);
660 register_notifications((PVMT)CPopup);
661 register_notifications((PVMT)CClipboard);
662 register_notifications((PVMT)CTimer);
663 register_notifications((PVMT)CDrawable);
664 register_notifications((PVMT)CImage);
665 register_notifications((PVMT)CIcon);
666 register_notifications((PVMT)CDeviceBitmap);
667 register_notifications((PVMT)CWidget);
668 register_notifications((PVMT)CWindow);
669 register_notifications((PVMT)CApplication);
670 register_notifications((PVMT)CPrinter);
671 register_notifications((PVMT)CRegion);
672 prima_init_ok++;
673 }
674
675 if ( prima_init_ok == 1) {
676 prima_init_image_subsystem();
677 prima_init_ok++;
678 }
679
680 if ( prima_init_ok == 2) {
681 prima_init_font_mapper();
682 if ( !window_subsystem_init( error_buf))
683 croak( "%s", error_buf);
684 prima_init_ok++;
685 }
686 SPAGAIN;
687 XSRETURN_EMPTY;
688 }
689
XS(Prima_message_FROMPERL)690 XS( Prima_message_FROMPERL)
691 {
692 dXSARGS;
693 (void)items;
694 if ( items != 1)
695 croak("Invalid usage of Prima::%s", "message");
696 apc_show_message((char*) SvPV_nolen( ST(0)), prima_is_utf8_sv(ST(0)));
697 XSRETURN_EMPTY;
698 }
699
XS(Prima_dl_export)700 XS( Prima_dl_export)
701 {
702 dXSARGS;
703 (void)items;
704 if ( items != 1)
705 croak("Invalid usage of Prima::%s", "dl_export");
706 apc_dl_export((char*) SvPV_nolen( ST(0)));
707 XSRETURN_EMPTY;
708 }
709
710 Bool
build_dynamic_vmt(void * vvmmtt,const char * ancestorName,int ancestorVmtSize)711 build_dynamic_vmt( void *vvmmtt, const char *ancestorName, int ancestorVmtSize)
712 {
713 PVMT vmt = ( PVMT) vvmmtt;
714 PVMT ancestorVmt = gimme_the_vmt( ancestorName);
715 int i, n;
716 void **to, **from;
717
718 if ( ancestorVmt == NULL)
719 {
720 warn( "GUTS001: Cannot locate base class \"%s\" of class \"%s\"\n", ancestorName, vmt-> className);
721 return false;
722 }
723 if ( ancestorVmt-> base != ancestorVmt-> super)
724 {
725 warn( "GUTS002: Cannot inherit C-class \"%s\" from Perl-class \"%s\"\n", vmt-> className, ancestorName);
726 return false;
727 }
728
729 vmt-> base = vmt-> super = ancestorVmt;
730 n = (ancestorVmtSize - sizeof(VMT)) / sizeof( void *);
731 from = (void **)((char *)ancestorVmt + sizeof(VMT));
732 to = (void **)((char *)vmt + sizeof(VMT));
733 for ( i = 0; i < n; i++) if ( to[i] == NULL) to[i] = from[i];
734 build_static_vmt( vmt);
735 register_notifications( vmt);
736 return true;
737 }
738
739 void
build_static_vmt(void * vvmmtt)740 build_static_vmt( void *vvmmtt)
741 {
742 PVMT vmt = ( PVMT) vvmmtt;
743 hash_store( vmtHash, vmt-> className, strlen( vmt-> className), vmt);
744 }
745
746 PVMT
gimme_the_vmt(const char * className)747 gimme_the_vmt( const char *className)
748 {
749 PVMT vmt;
750 PVMT originalVmt = NULL;
751 int vmtSize;
752 HV *stash;
753 SV **proc;
754 char *newClassName;
755 int i;
756 void **addr;
757 SV **vmtAddr;
758 SV **isaGlob;
759 SV **inheritedName;
760 VmtPatch *patch; int patchLength;
761 PVMT patchWhom;
762
763 /* Check whether this class has been already built... */
764 vmtAddr = ( SV **) hash_fetch( vmtHash, (char *)className, strlen( className));
765 if ( vmtAddr != NULL) return ( PVMT) vmtAddr;
766
767 /* No; try to find inherited VMT... */
768 stash = gv_stashpv( (char *)className, false);
769 if ( stash == NULL)
770 {
771 croak( "GUTS003: Cannot locate package %s\n", className);
772 return NULL; /* Definitely wrong! */
773 }
774
775 isaGlob = hv_fetch( stash, "ISA", 3, 0);
776 if (! (( isaGlob == NULL) ||
777 ( *isaGlob == NULL) ||
778 ( !GvAV(( GV *) *isaGlob)) ||
779 ( av_len( GvAV(( GV *) *isaGlob)) < 0)
780 ))
781 {
782 /* ISA found! */
783 inheritedName = av_fetch( GvAV(( GV *) *isaGlob), 0, 0);
784 if ( inheritedName != NULL)
785 originalVmt = gimme_the_vmt( SvPV_nolen( *inheritedName));
786 else
787 return NULL; /* The error message will be printed by the previous incarnation */
788 }
789 if ( !originalVmt) {
790 croak( "GUTS005: Error finding ancestor's VMT for %s\n", className);
791 return NULL;
792 }
793 /* Do we really need to do this? */
794 if ( strEQ( className, originalVmt-> className))
795 return originalVmt;
796
797 vmtSize = originalVmt-> vmtSize;
798 vmt = ( PVMT) malloc( vmtSize);
799 if ( !vmt) return NULL;
800
801 memcpy( vmt, originalVmt, vmtSize);
802 newClassName = duplicate_string( className);
803 vmt-> className = newClassName;
804 vmt-> base = originalVmt;
805
806 /* Not particularly effective now... */
807 patchWhom = originalVmt;
808 while ( patchWhom != NULL)
809 {
810 if ( patchWhom-> base == patchWhom-> super)
811 {
812 patch = patchWhom-> patch;
813 patchLength = patchWhom-> patchLength;
814 for ( i = 0; i < patchLength; i++)
815 {
816 proc = hv_fetch( stash, patch[ i]. name, strlen( patch[ i]. name), 0);
817 if (! (( proc == NULL) || ( *proc == NULL) || ( !GvCV(( GV *) *proc))))
818 {
819 addr = ( void **)((( char *)vmt) + ((( char *)( patch[ i]. vmtAddr)) - (( char *)patchWhom)));
820 *addr = patch[ i]. procAddr;
821 }
822 }
823 }
824 patchWhom = patchWhom-> base;
825 }
826
827 /* Store newly created vmt into our hash... */
828 hash_store( vmtHash, (char *)className, strlen( className), vmt);
829 list_add( &staticObjects, (Handle) vmt);
830 list_add( &staticObjects, (Handle) vmt-> className);
831 register_notifications( vmt);
832 return vmt;
833 }
834
835
836 SV *
notify_perl(Handle self,char * methodName,const char * format,...)837 notify_perl( Handle self, char *methodName, const char *format, ...)
838 {
839 SV *toReturn;
840 char subName[ 256];
841 va_list params;
842
843 snprintf( subName, 256, "%s_%s", (( PComponent) self)-> name, methodName);
844 va_start( params, format);
845 toReturn = call_perl_indirect((( PComponent) self)-> owner,
846 subName, format, true, false, params);
847 va_end( params);
848 return toReturn;
849 }
850
851
852 SV *
call_perl(Handle self,char * subName,const char * format,...)853 call_perl( Handle self, char *subName, const char *format, ...)
854 {
855 SV *toReturn;
856 va_list params;
857
858 va_start( params, format);
859 toReturn = call_perl_indirect( self, subName, format, true, false, params);
860 va_end( params);
861 return toReturn;
862 }
863
864 SV *
sv_call_perl(SV * mate,char * subName,const char * format,...)865 sv_call_perl( SV * mate, char *subName, const char *format, ...)
866 {
867 SV *toReturn;
868 va_list params;
869
870 va_start( params, format);
871 toReturn = call_perl_indirect(( Handle) mate, subName, format, false, false, params);
872 va_end( params);
873 return toReturn;
874 }
875
876 SV *
cv_call_perl(SV * mate,SV * coderef,const char * format,...)877 cv_call_perl( SV * mate, SV * coderef, const char *format, ...)
878 {
879 SV *toReturn;
880 va_list params;
881 va_start( params, format);
882 toReturn = call_perl_indirect(( Handle) mate, (char*)coderef, format, false, true, params);
883 va_end( params);
884 return toReturn;
885 }
886
887 SV *
call_perl_indirect(Handle self,char * subName,const char * format,Bool c_decl,Bool coderef,va_list params)888 call_perl_indirect( Handle self, char *subName, const char *format, Bool c_decl, Bool coderef, va_list params)
889 {
890 int i;
891 Handle _Handle;
892 int _int;
893 char * _string;
894 double _number;
895 Point _Point;
896 Rect _Rect;
897 SV * _SV;
898 Bool returns = false;
899 SV *toReturn = NULL;
900 int retCount;
901 int stackExtend = 1;
902
903
904 if ( coderef)
905 {
906 if ( SvTYPE(( SV *) subName) != SVt_PVCV) return toReturn;
907 } else {
908 if ( c_decl && !query_method ( self, subName, 0))
909 return toReturn;
910 if ( !c_decl && !sv_query_method(( SV *) self, subName, 0))
911 return &PL_sv_undef;
912 }
913
914 if ( format[ 0] == '<')
915 {
916 format += 1;
917 returns = true;
918 }
919
920 /* Parameter check */
921 i = 0;
922 while ( format[ i] != '\0')
923 {
924 switch ( format[ i])
925 {
926 case 'i':
927 case 's':
928 case 'U':
929 case 'n':
930 case 'H':
931 case 'S':
932 stackExtend++;
933 break;
934 case 'P':
935 stackExtend += 2;
936 break;
937 case 'R':
938 stackExtend += 4;
939 break;
940 default:
941 croak( "GUTS004: Illegal parameter description (%c) in call to %s()",
942 format[ i], ( coderef) ? "code reference" : subName);
943 return toReturn;
944 }
945 i++;
946 }
947 {
948 dSP;
949 ENTER;
950 SAVETMPS;
951 PUSHMARK( sp);
952 EXTEND( sp, stackExtend);
953 PUSHs(( c_decl) ? (( PAnyObject) self)-> mate : ( SV *) self);
954
955 i = 0;
956 while ( format[ i] != '\0')
957 {
958 switch ( format[ i])
959 {
960 case 'i':
961 _int = va_arg( params, int);
962 PUSHs( sv_2mortal( newSViv( _int)));
963 break;
964 case 's':
965 _string = va_arg( params, char *);
966 PUSHs( sv_2mortal( newSVpv( _string, 0)));
967 break;
968 case 'U':
969 _string = va_arg( params, char *);
970 _SV = newSVpv( _string, 0 );
971 _int = va_arg( params, int);
972 if ( _int ) SvUTF8_on(_SV);
973 PUSHs( sv_2mortal( _SV ));
974 break;
975 case 'n':
976 _number = va_arg( params, double);
977 PUSHs( sv_2mortal( newSVnv( _number)));
978 break;
979 case 'S':
980 _SV = va_arg( params, SV *);
981 PUSHs( sv_2mortal( newSVsv( _SV)));
982 break;
983 case 'P':
984 _Point = va_arg( params, Point);
985 PUSHs( sv_2mortal( newSViv( _Point. x)));
986 PUSHs( sv_2mortal( newSViv( _Point. y)));
987 break;
988 case 'H':
989 _Handle = va_arg( params, Handle);
990 PUSHs( _Handle ? (( PAnyObject) _Handle)-> mate : NULL_SV);
991 break;
992 case 'R':
993 _Rect = va_arg( params, Rect);
994 PUSHs( sv_2mortal( newSViv( _Rect. left)));
995 PUSHs( sv_2mortal( newSViv( _Rect. bottom)));
996 PUSHs( sv_2mortal( newSViv( _Rect. right)));
997 PUSHs( sv_2mortal( newSViv( _Rect. top)));
998 break;
999 }
1000 i++;
1001 }
1002
1003 PUTBACK;
1004 if ( returns)
1005 {
1006 dG_EVAL_ARGS;
1007 OPEN_G_EVAL;
1008 retCount = ( coderef) ?
1009 perl_call_sv(( SV *) subName, G_SCALAR|G_EVAL) :
1010 perl_call_method( subName, G_SCALAR|G_EVAL);
1011 SPAGAIN;
1012 if ( SvTRUE( GvSV( PL_errgv)))
1013 {
1014 (void)POPs;
1015 CLOSE_G_EVAL;
1016 croak( "%s", SvPV_nolen( GvSV( PL_errgv))); /* propagate */
1017 }
1018 CLOSE_G_EVAL;
1019 if ( retCount == 1)
1020 {
1021 toReturn = newSVsv( POPs);
1022 }
1023 PUTBACK;
1024 FREETMPS;
1025 LEAVE;
1026 if ( toReturn)
1027 toReturn = sv_2mortal( toReturn);
1028 }
1029 else
1030 {
1031 dG_EVAL_ARGS;
1032 OPEN_G_EVAL;
1033 if ( coderef) perl_call_sv(( SV *) subName, G_DISCARD|G_EVAL);
1034 else perl_call_method( subName, G_DISCARD|G_EVAL);
1035 if ( SvTRUE( GvSV( PL_errgv)))
1036 {
1037 CLOSE_G_EVAL;
1038 croak( "%s", SvPV_nolen( GvSV( PL_errgv))); /* propagate */
1039 }
1040 CLOSE_G_EVAL;
1041 SPAGAIN; FREETMPS; LEAVE;
1042 }
1043 }
1044 return toReturn;
1045 }
1046
1047 HV *
parse_hv(I32 ax,SV ** sp,I32 items,SV ** mark,int expected,const char * methodName)1048 parse_hv( I32 ax, SV **sp, I32 items, SV **mark, int expected, const char *methodName)
1049 {
1050 HV *hv;
1051 AV *order;
1052 int i;
1053
1054 if (( items - expected) % 2 != 0)
1055 croak( "GUTS010: Incorrect profile (odd number of arguments) passed to ``%s''", methodName);
1056
1057 hv = newHV();
1058 order = newAV();
1059 for ( i = expected; i < items; i += 2)
1060 {
1061 /* check the validity of a key */
1062 if (!( SvPOK( ST( i)) && ( !SvROK( ST( i)))))
1063 croak( "GUTS011: Illegal value for a profile key (argument #%d) passed to ``%s''", i, methodName);
1064 /* and add the pair */
1065 hv_store_ent( hv, ST( i), newSVsv( ST( i+1)), 0);
1066 av_push( order, newSVsv( ST( i)));
1067 }
1068 (void) hv_store( hv, "__ORDER__", 9, newRV_noinc((SV *)order), 0);
1069 return hv;
1070 }
1071
1072
1073 void
push_hv(I32 ax,SV ** sp,I32 items,SV ** mark,int callerReturns,HV * hv)1074 push_hv( I32 ax, SV **sp, I32 items, SV **mark, int callerReturns, HV *hv)
1075 {
1076 int n;
1077 HE *he;
1078 int wantarray = GIMME_V;
1079 SV **rorder;
1080
1081 if ( wantarray != G_ARRAY)
1082 {
1083 sv_free((SV *)hv);
1084 PUTBACK;
1085 return;
1086 /* XSRETURN( callerReturns); */
1087 }
1088
1089 rorder = hv_fetch( hv, "__ORDER__", 9, 0);
1090 if ( rorder != NULL && *rorder != NULL && SvROK( *rorder) && SvTYPE(SvRV(*rorder)) == SVt_PVAV) {
1091 int i, l;
1092 AV *order = (AV*)SvRV(*rorder);
1093 SV **key;
1094
1095 n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != NULL) n++;
1096 n--; EXTEND( sp, n*2);
1097
1098 /* push everything in proper order */
1099 l = av_len(order);
1100 for ( i = 0; i <= l; i++) {
1101 key = av_fetch(order, i, 0);
1102 if (key == NULL || *key == NULL) croak( "GUTS008: Illegal key in order array in push_hv()");
1103 if ( !hv_exists_ent( hv, *key, 0)) continue;
1104 PUSHs( sv_2mortal( newSVsv( *key)));
1105 PUSHs( sv_2mortal( newSVsv( HeVAL(hv_fetch_ent(hv, *key, 0, 0)))));
1106 }
1107
1108 sv_free(( SV *) hv);
1109 PUTBACK;
1110 return;
1111 }
1112
1113 /* Calculate the length of our hv */
1114 n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != NULL) n++;
1115 EXTEND( sp, n*2);
1116
1117 /* push everything */
1118 hv_iterinit( hv);
1119 while (( he = hv_iternext( hv)) != NULL)
1120 {
1121 PUSHs( sv_2mortal( newSVsv( hv_iterkeysv( he))));
1122 PUSHs( sv_2mortal( newSVsv( HeVAL( he))));
1123 }
1124 sv_free(( SV *) hv);
1125 PUTBACK;
1126 return;
1127 /* XSRETURN( callerReturns + n*2); */
1128 }
1129
1130 SV **
push_hv_for_REDEFINED(SV ** sp,HV * hv)1131 push_hv_for_REDEFINED( SV **sp, HV *hv)
1132 {
1133 int n;
1134 HE *he;
1135 SV **rorder;
1136
1137 rorder = hv_fetch( hv, "__ORDER__", 9, 0);
1138 if ( rorder != NULL && *rorder != NULL && SvROK( *rorder) && SvTYPE(SvRV(*rorder)) == SVt_PVAV) {
1139 int i, l;
1140 AV *order = (AV*)SvRV(*rorder);
1141 SV **key;
1142
1143 n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != NULL) n++;
1144 n--; EXTEND( sp, n*2);
1145
1146 /* push everything in proper order */
1147 l = av_len(order);
1148 for ( i = 0; i <= l; i++) {
1149 key = av_fetch(order, i, 0);
1150 if (key == NULL || *key == NULL) croak( "GUTS008: Illegal key in order array in push_hv_for_REDEFINED()");
1151 if ( !hv_exists_ent( hv, *key, 0)) continue;
1152 PUSHs( sv_2mortal( newSVsv( *key)));
1153 PUSHs( sv_2mortal( newSVsv( HeVAL( hv_fetch_ent(hv, *key, 0, 0)))));
1154 }
1155
1156 return sp;
1157 }
1158
1159 /* Calculate the length of our hv */
1160 n = 0; hv_iterinit( hv); while ( hv_iternext( hv) != NULL) n++;
1161 EXTEND( sp, n*2);
1162
1163 /* push everything */
1164 hv_iterinit( hv);
1165 while (( he = hv_iternext( hv)) != NULL)
1166 {
1167 PUSHs( sv_2mortal( newSVsv( hv_iterkeysv( he))));
1168 PUSHs( sv_2mortal( newSVsv( HeVAL( he))));
1169 }
1170 return sp;
1171 }
1172
1173 int
pop_hv_for_REDEFINED(SV ** sp,int returned,HV * hv,int expected)1174 pop_hv_for_REDEFINED( SV **sp, int returned, HV *hv, int expected)
1175 {
1176 int i;
1177 AV *order;
1178
1179 if (( returned - expected) % 2 != 0)
1180 croak( "GUTS012: Cannot create HV from the odd number of arguments returned (%d,%d)", returned, expected);
1181
1182 hv_clear( hv);
1183 order = newAV();
1184 for ( i = 0; i < returned - expected; i += 2)
1185 {
1186 SV *v = POPs;
1187 SV *k = POPs;
1188 if (!( SvPOK( k) && ( !SvROK( k))))
1189 croak( "GUTS013: Illegal value for a profile key passed");
1190 (void) hv_store_ent( hv, k, newSVsv( v), 0);
1191 av_push( order, newSVsv( k));
1192 }
1193 (void) hv_store( hv, "__ORDER__", 9, newRV_noinc((SV *)order), 0);
1194 return expected;
1195 }
1196
1197
1198 static Bool
kill_objects(void * item,int keyLen,Handle * self,void * dummy)1199 kill_objects( void * item, int keyLen, Handle * self, void * dummy)
1200 {
1201 Object_destroy( *self);
1202 return false;
1203 }
1204
1205 void
perl_error(void)1206 perl_error(void)
1207 {
1208 char * error = apc_last_error();
1209 if ( error == NULL) error = "unknown system error";
1210 sv_setpv( GvSV( PL_errgv), error);
1211 }
1212
1213 Bool appDead = false;
1214
1215
1216 #if (PERL_PATCHLEVEL == 5)
1217 #define PRIMAPERL_scopestack_ix PL_scopestack_ix
1218 #define PRIMAPERL_defstash PL_defstash
1219 #define PRIMAPERL_curstash PL_curstash
1220 #define PRIMAPERL_endav PL_endav
1221 #elif (PERL_PATCHLEVEL == 4)
1222 #define PRIMAPERL_scopestack_ix scopestack_ix
1223 #define PRIMAPERL_defstash defstash
1224 #define PRIMAPERL_curstash curstash
1225 #define PRIMAPERL_endav endav
1226 #endif
1227
1228 XS(Utils_getdir_FROMPERL);
1229 XS(Utils_stat_FROMPERL);
1230 XS(Utils_closedir_FROMPERL);
1231
1232 static Bool
kill_hashes(PHash hash,void * dummy)1233 kill_hashes( PHash hash, void * dummy)
1234 {
1235 hash_destroy( hash, false);
1236 return false;
1237 }
1238
XS(prima_cleanup)1239 XS( prima_cleanup)
1240 {
1241 dXSARGS;
1242 (void)items;
1243
1244 if ( application) Object_destroy( application);
1245 appDead = true;
1246 hash_first_that( primaObjects, (void*)kill_objects, NULL, NULL, NULL);
1247 hash_destroy( primaObjects, false);
1248 primaObjects = NULL;
1249 if ( prima_init_ok > 1) prima_cleanup_image_subsystem();
1250 if ( prima_init_ok > 2) {
1251 window_subsystem_cleanup();
1252 prima_cleanup_font_mapper();
1253 }
1254 hash_destroy( vmtHash, false);
1255 vmtHash = NULL;
1256 list_delete_all( &staticObjects, true);
1257 list_destroy( &staticObjects);
1258 list_destroy( &postDestroys);
1259 prima_kill_zombies();
1260 if ( prima_init_ok > 2) window_subsystem_done();
1261 list_first_that( &staticHashes, (void*)kill_hashes, NULL);
1262 list_destroy( &staticHashes);
1263 prima_init_ok = 0;
1264
1265 ST(0) = &PL_sv_yes;
1266 XSRETURN(1);
1267 }
1268
1269 static void
register_constants(void)1270 register_constants( void)
1271 {
1272 register_nt_constants();
1273 register_kb_constants();
1274 register_km_constants();
1275 register_mb_constants();
1276 register_ta_constants();
1277 register_cl_constants();
1278 register_ci_constants();
1279 register_wc_constants();
1280 register_cm_constants();
1281 register_rop_constants();
1282 register_gm_constants();
1283 register_lp_constants();
1284 register_fp_constants();
1285 register_le_constants();
1286 register_lj_constants();
1287 register_fs_constants();
1288 register_fw_constants();
1289 register_bi_constants();
1290 register_bs_constants();
1291 register_ws_constants();
1292 register_sv_constants();
1293 register_im_constants();
1294 register_ictp_constants();
1295 register_ictd_constants();
1296 register_ict_constants();
1297 register_ist_constants();
1298 register_is_constants();
1299 register_am_constants();
1300 register_apc_constants();
1301 register_gui_constants();
1302 register_dt_constants();
1303 register_cr_constants();
1304 register_sbmp_constants();
1305 register_tw_constants();
1306 register_fds_constants();
1307 register_fdo_constants();
1308 register_fe_constants();
1309 register_fr_constants();
1310 register_mt_constants();
1311 register_gt_constants();
1312 register_ps_constants();
1313 register_scr_constants();
1314 register_dbt_constants();
1315 register_rgn_constants();
1316 register_rgnop_constants();
1317 register_fm_constants();
1318 register_ggo_constants();
1319 register_fv_constants();
1320 register_dnd_constants();
1321 register_to_constants();
1322 register_ts_constants();
1323 }
1324
1325 XS( Object_alive_FROMPERL);
1326 XS( Component_event_hook_FROMPERL);
1327
1328 /* This stuff is not part of the API! Yes, I have been warned. */
1329 #ifndef PERL_VERSION_DECIMAL
1330 # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
1331 #endif
1332 #ifndef PERL_DECIMAL_VERSION
1333 # define PERL_DECIMAL_VERSION \
1334 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
1335 #endif
1336 #ifndef PERL_VERSION_GE
1337 # define PERL_VERSION_GE(r,v,s) \
1338 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
1339 #endif
1340 #ifndef PERL_VERSION_LE
1341 # define PERL_VERSION_LE(r,v,s) \
1342 (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
1343 #endif
1344
1345
XS(boot_Prima)1346 XS( boot_Prima)
1347 {
1348 dXSARGS;
1349 (void)items;
1350
1351 #if PERL_VERSION_LE(5, 21, 5)
1352 XS_VERSION_BOOTCHECK;
1353 # ifdef XS_APIVERSION_BOOTCHECK
1354 XS_APIVERSION_BOOTCHECK;
1355 # endif
1356 #endif
1357
1358
1359 #define TYPECHECK(s1,s2) \
1360 if (sizeof(s1) != (s2)) { \
1361 printf("Error: type %s is %d bytes long (expected to be %d)", #s1, (int)sizeof(s1), s2); \
1362 ST(0) = &PL_sv_no; \
1363 XSRETURN(1); \
1364 }
1365 TYPECHECK( uint8_t, 1);
1366 TYPECHECK( int8_t, 1);
1367 TYPECHECK( uint16_t, 2);
1368 TYPECHECK( int16_t, 2);
1369 TYPECHECK( uint32_t, 4);
1370 TYPECHECK( int32_t, 4);
1371 TYPECHECK( void*, (int)sizeof(Handle));
1372 TYPECHECK( Point, 2*(int)sizeof(int));
1373 TYPECHECK( NPoint, 2*(int)sizeof(double));
1374 TYPECHECK( Rect, 4*(int)sizeof(int));
1375 #undef TYPECHECK
1376
1377 list_create( &staticObjects, 16, 16);
1378 list_create( &staticHashes, 16, 16);
1379 primaObjects = hash_create();
1380 vmtHash = hash_create();
1381 list_create( &postDestroys, 16, 16);
1382
1383 /* register hard coded XSUBs */
1384 newXS( "::destroy_mate", destroy_mate, "Prima Guts");
1385 newXS( "Prima::cleanup", prima_cleanup, "Prima");
1386 newXS( "Prima::init", Prima_init, "Prima");
1387 newXS( "Prima::options", Prima_options, "Prima");
1388 newXS( "Prima::Utils::getdir", Utils_getdir_FROMPERL, "Prima::Utils");
1389 newXS( "Prima::Utils::stat", Utils_stat_FROMPERL, "Prima::Utils");
1390 newXS( "Prima::Utils::DIRHANDLE::DESTROY", Utils_closedir_FROMPERL, "Prima::Utils");
1391 /* register built-in classes */
1392 newXS( "Prima::Object::create", create_from_Perl, "Prima::Object");
1393 newXS( "Prima::Object::destroy", destroy_from_Perl, "Prima::Object");
1394 newXS( "Prima::Object::alive", Object_alive_FROMPERL, "Prima::Object");
1395 newXS( "Prima::Component::event_hook", Component_event_hook_FROMPERL, "Prima::Component");
1396 newXS( "Prima::message", Prima_message_FROMPERL, "Prima");
1397 newXS( "Prima::dl_export", Prima_dl_export, "Prima");
1398 register_constants();
1399 register_Object_Class();
1400 register_Utils_Package();
1401 cv_set_prototype("Prima::Utils", "closedir", "$");
1402 cv_set_prototype("Prima::Utils", "rewinddir", "$");
1403 cv_set_prototype("Prima::Utils", "seekdir", "$$");
1404 cv_set_prototype("Prima::Utils", "telldir", "$");
1405 register_Component_Class();
1406 register_File_Class();
1407 register_Clipboard_Class();
1408 register_DeviceBitmap_Class();
1409 register_Drawable_Class();
1410 register_Widget_Class();
1411 register_Window_Class();
1412 register_Image_Class();
1413 init_image_support();
1414 register_Icon_Class();
1415 register_AbstractMenu_Class();
1416 register_AccelTable_Class();
1417 register_Menu_Class();
1418 register_Popup_Class();
1419 register_Application_Class();
1420 register_Timer_Class();
1421 register_Printer_Class();
1422 register_Region_Class();
1423
1424 #if PERL_VERSION_LE(5, 21, 5)
1425 # if PERL_VERSION_GE(5, 9, 0)
1426 if (PL_unitcheckav)
1427 call_list(PL_scopestack_ix, PL_unitcheckav);
1428 # endif
1429 XSRETURN_YES;
1430 #else
1431 Perl_xs_boot_epilog(aTHX_ ax);
1432 #endif
1433 }
1434
1435 typedef struct _RemapHashNode_ {
1436 Handle key;
1437 Handle val;
1438 struct _RemapHashNode_ *next;
1439 } RemapHashNode, *PRemapHashNode;
1440
1441 typedef struct _RemapHash_ {
1442 PRemapHashNode table[1];
1443 } RemapHash, *PRemapHash;
1444
1445 Handle
ctx_remap_def(Handle value,Handle * table,Bool direct,Handle default_value)1446 ctx_remap_def( Handle value, Handle *table, Bool direct, Handle default_value)
1447 {
1448 register PRemapHash hash;
1449 register PRemapHashNode node;
1450
1451 if ( table == NULL) return default_value;
1452 if ( table[0] != endCtx) {
1453 /* Hash was not built before; building */
1454 Handle *tbl;
1455 PRemapHash hash1, hash2;
1456 PRemapHashNode next;
1457 int sz = 0;
1458
1459 tbl = table;
1460 while ((*tbl) != endCtx) {
1461 tbl += 2;
1462 sz++;
1463 }
1464
1465 /* First way build hash */
1466 hash = ( PRemapHash) malloc( sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1) + sizeof( RemapHashNode) * sz);
1467 if ( !hash) return default_value;
1468 bzero( hash, sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
1469 tbl = table;
1470 next = ( PRemapHashNode )(((char *)hash) + sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
1471 while ((*tbl) != endCtx) {
1472 Handle key = (*tbl)&0x1F;
1473 if (hash->table[key]) {
1474 /* Already exists something */
1475 node = hash->table[key];
1476 while ( node-> next) node = node-> next;
1477 /* node->next = malloc( sizeof( RemapHashNode)); */
1478 node->next = next++;
1479 node->next-> key = tbl[0];
1480 node->next-> val = tbl[1];
1481 node->next-> next = NULL;
1482 } else {
1483 /* hash->table[key] = malloc( sizeof( RemapHashNode)); */
1484 hash->table[key] = next++;
1485 hash->table[key]-> key = tbl[0];
1486 hash->table[key]-> val = tbl[1];
1487 hash->table[key]-> next = NULL;
1488 }
1489 tbl += 2;
1490 }
1491 hash1 = hash;
1492
1493 /* Second way build hash */
1494 hash = ( PRemapHash) malloc( sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1) + sizeof( RemapHashNode) * sz);
1495 if ( !hash) {
1496 free( hash1);
1497 return default_value;
1498 }
1499 bzero( hash, sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
1500 tbl = table;
1501 next = ( PRemapHashNode)(((char *)hash) + sizeof(RemapHash) + sizeof( PRemapHashNode) * (32-1));
1502 while ((*tbl) != endCtx) {
1503 Handle key = tbl[1] & 0x1F;
1504 if (hash->table[key]) {
1505 /* Already exists something */
1506 node = hash->table[key];
1507 while ( node-> next) node = node-> next;
1508 /* node->next = malloc( sizeof( RemapHashNode)); */
1509 node->next = next++;
1510 node->next-> key = tbl[1];
1511 node->next-> val = tbl[0];
1512 node->next-> next = NULL;
1513 } else {
1514 /* hash->table[key] = malloc( sizeof( RemapHashNode)); */
1515 hash->table[key] = next++;
1516 hash->table[key]-> key = tbl[1];
1517 hash->table[key]-> val = tbl[0];
1518 hash->table[key]-> next = NULL;
1519 }
1520 tbl += 2;
1521 }
1522 hash2 = hash;
1523 table[0] = endCtx;
1524 table[1] = list_add( &staticObjects, ( Handle) hash1);
1525 table[2] = list_add( &staticObjects, ( Handle) hash2);
1526 }
1527
1528 hash = ( PRemapHash) list_at( &staticObjects, direct ? table[1] : table[2]);
1529 node = hash->table[value&0x1F];
1530 while ( node) {
1531 if (node->key == value) return node->val;
1532 node = node->next;
1533 }
1534 return default_value;
1535 }
1536
1537 void *
create_object(const char * objClass,const char * types,...)1538 create_object( const char *objClass, const char *types, ...)
1539 {
1540 va_list params;
1541 HV *profile;
1542 char *s;
1543 Handle res;
1544
1545 va_start( params, types);
1546 profile = newHV();
1547 while (*types)
1548 {
1549 s = va_arg( params, char *);
1550 switch (*types)
1551 {
1552 case 'i':
1553 (void) hv_store( profile, s, strlen( s), newSViv(va_arg(params, int)), 0);
1554 break;
1555 case 's':
1556 (void) hv_store( profile, s, strlen( s), newSVpv(va_arg(params, char *),0), 0);
1557 break;
1558 case 'n':
1559 (void) hv_store( profile, s, strlen( s), newSVnv(va_arg(params, double)), 0);
1560 break;
1561 default:
1562 croak( "GUTS014: create_object: illegal parameter type");
1563 }
1564 types++;
1565 }
1566 va_end( params);
1567 res = Object_create((char *)objClass, profile);
1568 if ( res)
1569 --SvREFCNT( SvRV((( PAnyObject) res)-> mate));
1570 sv_free(( SV *) profile);
1571 return (void*)res;
1572 }
1573
1574 Handle
apc_get_application(void)1575 apc_get_application(void)
1576 {
1577 return application;
1578 }
1579
1580 Handle
apc_get_core_version(void)1581 apc_get_core_version(void)
1582 {
1583 return PRIMA_CORE_VERSION;
1584 }
1585
1586 FillPattern fillPatterns[] = {
1587 {0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00},
1588 {0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF},
1589 {0x00, 0x00, 0xFF, 0xFF, 0x00, 0x00, 0xFF, 0xFF},
1590 {0x80, 0x40, 0x20, 0x10, 0x08, 0x04, 0x02, 0x01},
1591 {0x70, 0x38, 0x1C, 0x0E, 0x07, 0x83, 0xC1, 0xE0},
1592 {0xE1, 0xC3, 0x87, 0x0F, 0x1E, 0x3C, 0x78, 0xF0},
1593 {0x4B, 0x96, 0x2D, 0x5A, 0xB4, 0x69, 0xD2, 0xA5},
1594 {0x88, 0x88, 0x88, 0xFF, 0x88, 0x88, 0x88, 0xFF},
1595 {0x18, 0x24, 0x42, 0x81, 0x18, 0x24, 0x42, 0x81},
1596 {0x33, 0xCC, 0x33, 0xCC, 0x33, 0xCC, 0x33, 0xCC},
1597 {0x00, 0x08, 0x00, 0x80, 0x00, 0x08, 0x00, 0x80},
1598 {0x00, 0x22, 0x00, 0x88, 0x00, 0x22, 0x00, 0x88},
1599 {0xaa, 0x55, 0xaa, 0x55, 0xaa, 0x55, 0xaa, 0x55},
1600 {0xaa, 0xff, 0xaa, 0xff, 0xaa, 0xff, 0xaa, 0xff},
1601 {0x51, 0x22, 0x15, 0x88, 0x45, 0x22, 0x54, 0x88},
1602 {0x02, 0x27, 0x05, 0x00, 0x20, 0x72, 0x50, 0x00}
1603 };
1604
1605
1606 /* list section */
1607
1608 void
list_create(PList slf,int size,int delta)1609 list_create( PList slf, int size, int delta)
1610 {
1611 if ( !slf) return;
1612 memset( slf, 0, sizeof( List));
1613 slf-> delta = ( delta > 0) ? delta : 1;
1614 if (( slf-> size = size) > 0) {
1615 if ( !( slf-> items = allocn( Handle, size)))
1616 slf-> size = 0;
1617 } else
1618 slf-> items = NULL;
1619 }
1620
1621 PList
plist_create(int size,int delta)1622 plist_create( int size, int delta)
1623 {
1624 PList new_list = alloc1( List);
1625 if ( new_list != NULL) {
1626 list_create( new_list, size, delta);
1627 }
1628 return new_list;
1629 }
1630
1631 PList
plist_dup(PList slf)1632 plist_dup( PList slf )
1633 {
1634 PList n = plist_create( slf-> count, slf-> delta );
1635 if ( n ) {
1636 n-> count = slf->count;
1637 memcpy( n-> items, slf-> items, n->count * sizeof(Handle));
1638 }
1639 return n;
1640 }
1641
1642 void
list_destroy(PList slf)1643 list_destroy( PList slf)
1644 {
1645 if ( !slf) return;
1646 free( slf-> items);
1647 slf-> items = NULL;
1648 slf-> count = 0;
1649 slf-> size = 0;
1650 }
1651
1652 void
plist_destroy(PList slf)1653 plist_destroy( PList slf)
1654 {
1655 if ( slf != NULL) {
1656 list_destroy( slf);
1657 free( slf);
1658 }
1659 }
1660
1661 int
list_add(PList slf,Handle item)1662 list_add( PList slf, Handle item)
1663 {
1664 if ( !slf) return -1;
1665 if ( slf-> count == slf-> size)
1666 {
1667 Handle * old = slf-> items;
1668 if ( !( slf-> items = allocn(Handle, ( slf-> size + slf-> delta))))
1669 return -1;
1670 if ( old) {
1671 memcpy( slf-> items, old, slf-> size * sizeof( Handle));
1672 free( old);
1673 }
1674 slf-> size += slf-> delta;
1675 }
1676 slf-> items[ slf-> count++] = item;
1677 return slf-> count - 1;
1678 }
1679
1680 int
list_insert_at(PList slf,Handle item,int pos)1681 list_insert_at( PList slf, Handle item, int pos)
1682 {
1683 int max, ret;
1684 Handle save;
1685 ret = list_add( slf, item);
1686 if ( ret < 0) return ret;
1687 max = slf-> count - 1;
1688 if ( pos < 0 || pos >= max) return ret;
1689 save = slf-> items[ max];
1690 memmove( &slf-> items[ pos + 1], &slf-> items[ pos], ( max - pos) * sizeof( Handle));
1691 slf-> items[ pos] = save;
1692 return pos;
1693 }
1694
1695 int
list_index_of(PList slf,Handle item)1696 list_index_of( PList slf, Handle item)
1697 {
1698 int i;
1699 if ( !slf ) return -1;
1700 for ( i = 0; i < slf-> count; i++)
1701 if ( slf-> items[ i] == item) return i;
1702 return -1;
1703 }
1704
1705 void
list_delete(PList slf,Handle item)1706 list_delete( PList slf, Handle item)
1707 {
1708 list_delete_at( slf, list_index_of( slf, item));
1709 }
1710
1711 void
list_delete_at(PList slf,int index)1712 list_delete_at( PList slf, int index)
1713 {
1714 if ( !slf || index < 0 || index >= slf-> count) return;
1715 slf-> count--;
1716 if ( index == slf-> count) return;
1717 memmove( &slf-> items[ index], &slf-> items[ index + 1], ( slf-> count - index) * sizeof( Handle));
1718 }
1719
1720 Handle
list_at(PList slf,int index)1721 list_at( PList slf, int index)
1722 {
1723 return (( index < 0 || !slf) || index >= slf-> count) ? NULL_HANDLE : slf-> items[ index];
1724 }
1725
1726 int
list_first_that(PList slf,void * action,void * params)1727 list_first_that( PList slf, void * action, void * params)
1728 {
1729 int toRet = -1, i, cnt;
1730 Handle * list;
1731 if ( !action || !slf || !slf->count) return -1;
1732 if ( !( list = allocn( Handle, slf-> count)))
1733 return -1;
1734 memcpy( list, slf-> items, slf-> count * sizeof( Handle));
1735 cnt = slf->count;
1736 for ( i = 0; i < cnt; i++)
1737 if ((( PListProc) action)( list[ i], params)) {
1738 toRet = i;
1739 break;
1740 }
1741 free( list);
1742 return toRet;
1743 }
1744
1745 void
list_delete_all(PList slf,Bool kill)1746 list_delete_all( PList slf, Bool kill)
1747 {
1748 if ( !slf || ( slf-> count == 0)) return;
1749 if ( kill ) {
1750 int i;
1751 for ( i = 0; i < slf-> count; i++)
1752 free(( void*) slf-> items[ i]);
1753 }
1754 slf-> count = 0;
1755 }
1756
1757 PHash
prima_hash_create()1758 prima_hash_create()
1759 {
1760 PHash ret = newHV();
1761 list_add( &staticHashes, ( Handle) ret);
1762 return ret;
1763 }
1764
1765 void
hash_destroy(PHash h,Bool killAll)1766 hash_destroy( PHash h, Bool killAll)
1767 {
1768 HE *he;
1769 list_delete( &staticHashes, ( Handle) h);
1770 hv_iterinit( h);
1771 while (( he = hv_iternext( h)) != NULL) {
1772 if ( killAll) free( HeVAL( he));
1773 HeVAL( he) = &PL_sv_undef;
1774 }
1775 sv_free(( SV *) h);
1776 }
1777
1778 static SV *ksv = NULL;
1779
1780 #define ksv_check if ( !ksv) { \
1781 ksv = newSV( keyLen); \
1782 if (!ksv) croak( "GUTS015: Cannot create SV"); \
1783 } \
1784 sv_setpvn( ksv, ( char *) key, keyLen); \
1785 he = hv_fetch_ent( h, ksv, false, 0)
1786
1787
1788 void *
hash_fetch(PHash h,const void * key,int keyLen)1789 hash_fetch( PHash h, const void *key, int keyLen)
1790 {
1791 HE *he;
1792 ksv_check;
1793 if ( !he) return NULL;
1794 return HeVAL( he);
1795 }
1796
1797 void *
hash_delete(PHash h,const void * key,int keyLen,Bool kill)1798 hash_delete( PHash h, const void *key, int keyLen, Bool kill)
1799 {
1800 HE *he;
1801 void *val;
1802 ksv_check;
1803 if ( !he) return NULL;
1804 val = HeVAL( he);
1805 HeVAL( he) = &PL_sv_undef;
1806 (void) hv_delete_ent( h, ksv, G_DISCARD, 0);
1807 if ( kill) {
1808 free( val);
1809 return NULL;
1810 }
1811 return val;
1812 }
1813
1814 Bool
hash_store(PHash h,const void * key,int keyLen,void * val)1815 hash_store( PHash h, const void *key, int keyLen, void *val)
1816 {
1817 HE *he;
1818 ksv_check;
1819 if ( he) {
1820 HeVAL( he) = &PL_sv_undef;
1821 (void) hv_delete_ent( h, ksv, G_DISCARD, 0);
1822 }
1823 he = hv_store_ent( h, ksv, &PL_sv_undef, 0);
1824 HeVAL( he) = ( SV *) val;
1825 return true;
1826 }
1827
1828 void *
hash_first_that(PHash h,void * action,void * params,int * pKeyLen,void ** pKey)1829 hash_first_that( PHash h, void * action, void * params, int * pKeyLen, void ** pKey)
1830 {
1831 HE *he;
1832
1833 if ( action == NULL || h == NULL) return NULL;
1834 hv_iterinit(( HV*) h);
1835 for (;;)
1836 {
1837 void *value, *key;
1838 int keyLen;
1839 if (( he = hv_iternext( h)) == NULL)
1840 return NULL;
1841 value = HeVAL( he);
1842 key = HeKEY( he);
1843 keyLen = HeKLEN( he);
1844 if ((( PHashProc) action)( value, keyLen, key, params)) {
1845 if ( pKeyLen) *pKeyLen = keyLen;
1846 if ( pKey) *pKey = key;
1847 return value;
1848 }
1849 }
1850 return NULL;
1851 }
1852
1853 static char* exception_text = NULL;
1854 static Bool exception_blocking = 0;
1855
1856 void
exception_remember(char * text)1857 exception_remember(char * text)
1858 {
1859 if ( !exception_blocking ) croak( "%s", text );
1860
1861 if ( exception_text ) {
1862 char * new_text = realloc(exception_text, strlen(text) + strlen(exception_text) + 1);
1863 if ( !new_text )
1864 croak("not enough memory");
1865 strcat( exception_text = new_text, text );
1866 } else {
1867 exception_text = duplicate_string( text );
1868 }
1869 }
1870
1871 Bool
exception_charged(void)1872 exception_charged(void)
1873 {
1874 return exception_text != NULL;
1875 }
1876
1877 Bool
exception_block(Bool block)1878 exception_block(Bool block)
1879 {
1880 Bool old = exception_blocking;
1881 exception_blocking = block;
1882 return old;
1883 }
1884
1885 void
exception_check_raise(void)1886 exception_check_raise(void)
1887 {
1888 char buf[1024];
1889 if ( !exception_text ) return;
1890 strncpy( buf, exception_text, 1023 );
1891 free( exception_text );
1892 exception_text = NULL;
1893 croak("%s", buf);
1894 }
1895
1896 int
prima_utf8_length(const char * utf8,int maxlen)1897 prima_utf8_length( const char * utf8, int maxlen)
1898 {
1899 int ulen = 0;
1900 if ( maxlen < 0 ) maxlen = INT16_MAX;
1901 while ( maxlen > 0 && *utf8 ) {
1902 const char *u = (char*) utf8_hop(( U8*) utf8, 1);
1903 ulen++;
1904 maxlen -= u - utf8;
1905 utf8 = u;
1906 }
1907 return ulen;
1908 }
1909
1910 Bool
prima_is_utf8_sv(SV * sv)1911 prima_is_utf8_sv( SV * sv)
1912 {
1913 /* from Encode.xs */
1914 if (SvGMAGICAL(sv)) {
1915 SV * sv2 = newSVsv(sv); /* GMAGIG will be done */
1916 Bool ret = SvUTF8(sv2) ? 1 : 0;
1917 SvREFCNT_dec(sv2); /* it was a temp copy */
1918 return ret;
1919 } else {
1920 return SvUTF8(sv) ? 1 : 0;
1921 }
1922 }
1923
1924 SV*
prima_svpv_utf8(const char * text,int is_utf8)1925 prima_svpv_utf8( const char *text, int is_utf8)
1926 {
1927 SV *sv = newSVpv(text, 0);
1928 if ( is_utf8 ) SvUTF8_on(sv);
1929 return sv;
1930 }
1931
1932 FILE*
prima_open_file(const char * text,Bool is_utf8,const char * mode)1933 prima_open_file( const char *text, Bool is_utf8, const char * mode)
1934 {
1935 int fd, o, m;
1936 const char * omode = mode;
1937 char *cwd = NULL;
1938 FILE * ret;
1939
1940 (void)cwd;
1941
1942 switch ( *mode++ ) {
1943 case 'r':
1944 m = O_RDONLY;
1945 o = 0;
1946 break;
1947 case 'w':
1948 m = O_WRONLY;
1949 o = O_CREAT | O_TRUNC;
1950 break;
1951 case 'a':
1952 m = O_WRONLY;
1953 o = O_CREAT | O_APPEND;
1954 break;
1955 default:
1956 errno = EINVAL;
1957 return NULL;
1958 }
1959
1960 if ( *mode == 'b' ) {
1961 mode++;
1962 #ifdef O_BINARY
1963 o |= O_BINARY;
1964 #endif
1965 }
1966 if ( *mode == '+' ) m = O_RDWR;
1967
1968 #if defined(PERL_IMPLICIT_SYS)
1969 if (
1970 (*text != '/') &&
1971 !(isalpha(text[0]) && text[1] == ':')
1972 ) {
1973 cwd = apc_fs_getcwd();
1974 apc_fs_chdir(PerlEnv_get_childdir(), false);
1975 }
1976 #endif
1977
1978 if (( fd = apc_fs_open_file( text, is_utf8, m | o, 0666)) < 0) {
1979 free(cwd);
1980 return NULL;
1981 }
1982
1983 #if defined(PERL_IMPLICIT_SYS)
1984 if (cwd) {
1985 apc_fs_chdir(cwd, true);
1986 free(cwd);
1987 }
1988 #endif
1989
1990 if (!( ret = fdopen( fd, omode ))) {
1991 close(fd);
1992 return NULL;
1993 }
1994
1995 if ( o & O_APPEND )
1996 fseek( ret, 0, SEEK_END);
1997 else
1998 fseek( ret, 0, SEEK_SET);
1999
2000 return ret;
2001 }
2002
2003 #ifdef HAVE_OPENMP
2004 #include <omp.h>
2005 #endif
2006
2007 int
prima_omp_max_threads(void)2008 prima_omp_max_threads(void)
2009 {
2010 return
2011 #ifdef HAVE_OPENMP
2012 omp_get_max_threads()
2013 #else
2014 1
2015 #endif
2016 ;
2017 }
2018
2019 int
prima_omp_thread_num(void)2020 prima_omp_thread_num(void)
2021 {
2022 return
2023 #ifdef HAVE_OPENMP
2024 omp_get_thread_num()
2025 #else
2026 0
2027 #endif
2028 ;
2029 }
2030
2031 void
prima_omp_set_num_threads(int num)2032 prima_omp_set_num_threads(int num)
2033 {
2034 #ifdef HAVE_OPENMP
2035 omp_set_num_threads(num);
2036 #endif
2037 }
2038
2039 SV *
prima_array_new(size_t size)2040 prima_array_new( size_t size)
2041 {
2042 SV * sv;
2043 if ( size == 0 ) return newSVpv("", 0);
2044 sv = newSV( size );
2045 SvPOK_only(sv);
2046 SvCUR_set(sv, size );
2047 return sv;
2048 }
2049
2050 void
prima_array_truncate(SV * array,size_t length)2051 prima_array_truncate( SV * array, size_t length )
2052 {
2053 SvCUR_set(array, length );
2054 SvPOK_only(array);
2055 }
2056
2057 SV *
prima_array_tie(SV * array,size_t size_of_entry,char * letter)2058 prima_array_tie( SV * array, size_t size_of_entry, char * letter)
2059 {
2060 SV * tie;
2061 AV * av1, * av2;
2062
2063 av1 = newAV();
2064 av_push(av1, array);
2065 av_push(av1, newSViv(size_of_entry));
2066 av_push(av1, newSVpv(letter, 1));
2067 tie = newRV_noinc((SV*) av1);
2068 sv_bless(tie, gv_stashpv("Prima::array", GV_ADD));
2069
2070 av2 = newAV();
2071 hv_magic(av2, (GV*)tie, PERL_MAGIC_tied);
2072 SvREFCNT(tie)--;
2073 return newRV_noinc((SV*) av2);
2074 }
2075
2076 Bool
prima_array_parse(SV * sv,void ** ref,size_t * length,char ** letter)2077 prima_array_parse( SV * sv, void ** ref, size_t * length, char ** letter)
2078 {
2079 SV * tied;
2080 const MAGIC * mg;
2081 SV ** ssv;
2082 AV * av;
2083 int cur;
2084
2085 if ( !SvROK(sv) || SvTYPE( SvRV( sv)) != SVt_PVAV)
2086 return false;
2087 av = (AV *) SvRV(sv);
2088
2089 if (( mg = SvTIED_mg(( SV*) av, PERL_MAGIC_tied )) == NULL)
2090 return false;
2091
2092 tied = SvTIED_obj(( SV* ) av, mg );
2093 if ( !tied || !SvROK(tied) || !sv_isa( tied, "Prima::array" ))
2094 return false;
2095
2096 av = (AV*) SvRV(tied);
2097 if ( SvTYPE((SV*) av) != SVt_PVAV)
2098 croak("panic: corrupted array");
2099
2100 ssv = av_fetch( av, 0, 0);
2101 if ( ssv == NULL ) croak("panic: corrupted array");
2102 if( ref) *ref = SvPVX(*ssv);
2103 cur = SvCUR(*ssv);
2104
2105 ssv = av_fetch( av, 1, 0);
2106 if ( ssv == NULL || SvIV(*ssv) <= 0 ) croak("panic: corrupted array");
2107 if( length) *length = cur / SvIV(*ssv);
2108
2109 ssv = av_fetch( av, 2, 0);
2110 if ( ssv == NULL ) croak("panic: corrupted array");
2111 if( letter) *letter = SvPV(*ssv, PL_na);
2112
2113 return true;
2114 }
2115
2116 Bool
prima_read_point(SV * rv_av,int * pt,int number,char * error)2117 prima_read_point( SV *rv_av, int * pt, int number, char * error)
2118 {
2119 SV ** holder;
2120 int i;
2121 AV *av;
2122 Bool result = true;
2123
2124 if ( !rv_av || !SvROK( rv_av) || ( SvTYPE( SvRV( rv_av)) != SVt_PVAV)) {
2125 result = false;
2126 if ( error) croak( "%s", error);
2127 } else {
2128 av = (AV*)SvRV(rv_av);
2129 for ( i = 0; i < number; i++) {
2130 holder = av_fetch( av, i, 0);
2131 if ( holder)
2132 pt[i] = SvIV( *holder);
2133 else {
2134 pt[i] = 0;
2135 result = false;
2136 if ( error) croak( "%s", error);
2137 }
2138 }
2139 }
2140 return result;
2141 }
2142
2143 #define xmovi(src_t,dst_t) { \
2144 int i; \
2145 src_t* src = (src_t*)ref; \
2146 dst_t* dst = (dst_t*)p; \
2147 for ( i = 0; i < count; i++) \
2148 *(dst++) = *(src++); \
2149 } \
2150 break \
2151
2152 #define xmovd(src_t,dst_t) { \
2153 int i; \
2154 src_t* src = (src_t*)ref; \
2155 dst_t* dst = (dst_t*)p; \
2156 for ( i = 0; i < count; i++) { \
2157 register src_t x = *(src++); \
2158 *(dst++) = x + ((x < 0) ? -.5 : +.5); \
2159 }} \
2160 break \
2161
2162
2163 void *
prima_read_array(SV * points,char * procName,char type,int div,int min,int max,int * n_points,Bool * do_free)2164 prima_read_array( SV * points, char * procName, char type, int div, int min, int max, int * n_points, Bool * do_free)
2165 {
2166 AV * av;
2167 int i, count, psize;
2168 void * p;
2169
2170 switch(type) {
2171 case 's': psize = sizeof(uint16_t); break;
2172 case 'i': psize = sizeof(int); break;
2173 case 'd': psize = sizeof(double); break;
2174 default: croak("Bad type %c", type);
2175 }
2176 if ( !SvROK( points) || ( SvTYPE( SvRV( points)) != SVt_PVAV)) {
2177 warn("Invalid array reference passed to %s", procName);
2178 return NULL;
2179 }
2180 av = ( AV *) SvRV( points);
2181 count = av_len( av) + 1;
2182 if ( min == max && count != min * div ) {
2183 warn("%s: array must contain %d elements", procName, min * div);
2184 return NULL;
2185 }
2186 if ( count < min * div ) {
2187 warn("%s: array must contain at least %d elements", procName, min * div);
2188 return NULL;
2189 }
2190 if ( max >= 0 && count > max * div ) {
2191 warn("%s: array must contain maximum %d elements", procName, max * div);
2192 return NULL;
2193 }
2194 if ( count % div != 0 ) {
2195 warn("%s: number of elements in an array must be a multiple of %d", procName, div);
2196 return NULL;
2197 }
2198 if ( n_points)
2199 *n_points = count / div;
2200 if ( count == 0)
2201 return NULL;
2202
2203 {
2204 void * ref;
2205 char * pack;
2206 if ( prima_array_parse( points, &ref, NULL, &pack )) {
2207 if (*pack == type && do_free) {
2208 *do_free = false;
2209 return ref;
2210 }
2211
2212 if (!( p = malloc( psize * count))) {
2213 warn("not enough memory");
2214 return false;
2215 }
2216 if (do_free) *do_free = true;
2217
2218 if ( *pack == type )
2219 memcpy( p, ref, psize * count);
2220 else switch ( *pack ) {
2221 case 'i':
2222 switch (type) {
2223 case 'd': xmovi(int,double);
2224 case 's': xmovi(int,uint16_t);
2225 }
2226 break;
2227 case 's':
2228 switch (type) {
2229 case 'd': xmovi(uint16_t,double);
2230 case 'i': xmovi(uint16_t,int);
2231 }
2232 break;
2233 case 'd':
2234 switch (type) {
2235 case 'i': xmovd(double,int);
2236 case 's': xmovd(double,uint16_t);
2237 }
2238 break;
2239 }
2240 return p;
2241 }
2242 }
2243
2244
2245 if (!( p = malloc( psize * count))) {
2246 warn("not enough memory");
2247 return NULL;
2248 }
2249
2250 for ( i = 0; i < count; i++)
2251 {
2252 SV** psv = av_fetch( av, i, 0);
2253 if ( psv == NULL) {
2254 free( p);
2255 warn("Array panic on item %d on %s", i, procName);
2256 return NULL;
2257 }
2258 switch (type) {
2259 case 'i':
2260 *(((int*)p) + i) = SvIV( *psv);
2261 break;
2262 case 'd':
2263 *(((double*)p) + i) = SvNV( *psv);
2264 break;
2265 case 's':
2266 *(((uint16_t*)p) + i) = SvIV( *psv);
2267 break;
2268 }
2269 }
2270
2271 if ( do_free )
2272 *do_free = true;
2273
2274 return p;
2275 }
2276
2277 void
semistatic_init(semistatic_t * s,void * stack,unsigned int elem_size,unsigned int static_size)2278 semistatic_init( semistatic_t * s, void * stack, unsigned int elem_size, unsigned int static_size)
2279 {
2280 bzero(s, sizeof(semistatic_t));
2281 s->stack = s->heap = stack;
2282 s->elem_size = elem_size;
2283 s->size = static_size;
2284 }
2285
2286 int
semistatic_expand(semistatic_t * s,unsigned int desired_elems)2287 semistatic_expand( semistatic_t * s, unsigned int desired_elems )
2288 {
2289 void * n;
2290
2291 if ( desired_elems > 0 ) {
2292 if ( s-> size >= desired_elems )
2293 return 1;
2294 s-> size = desired_elems;
2295 } else {
2296 s-> size *= 2;
2297 }
2298
2299 if ( s->stack == s->heap ) {
2300 if (( n = malloc(s->elem_size * s->size)) == NULL)
2301 goto FAIL;
2302 memcpy( n, s->stack, s->elem_size * s->count);
2303 } else {
2304 if (( n = realloc(s->heap, s->elem_size * s->size)) == NULL )
2305 goto FAIL;
2306 }
2307 s-> heap = n;
2308 return 1;
2309 FAIL:
2310 warn("not enough memory");
2311 return 0;
2312 }
2313
2314 void
semistatic_done(semistatic_t * s)2315 semistatic_done( semistatic_t * s)
2316 {
2317 if ( s->stack != s->heap )
2318 free(s->heap);
2319 }
2320
2321 #ifdef __cplusplus
2322 }
2323 #endif
2324