1 // This file is part of Golly.
2 // See docs/License.html for the copyright notice.
3
4 #include "wx/wxprec.h" // for compilers that support precompilation
5 #ifndef WX_PRECOMP
6 #include "wx/wx.h" // for all others include the necessary headers
7 #endif
8
9 #include "wx/filename.h" // for wxFileName
10
11 #include "bigint.h"
12 #include "lifealgo.h"
13 #include "qlifealgo.h"
14 #include "hlifealgo.h"
15 #include "readpattern.h"
16 #include "writepattern.h"
17
18 #include "wxgolly.h" // for wxGetApp, mainptr, viewptr, statusptr
19 #include "wxmain.h" // for mainptr->...
20 #include "wxselect.h" // for Selection
21 #include "wxview.h" // for viewptr->...
22 #include "wxstatus.h" // for statusptr->...
23 #include "wxutils.h" // for Warning, Note, GetString, etc
24 #include "wxprefs.h" // for perllib, gollydir, etc
25 #include "wxinfo.h" // for ShowInfo
26 #include "wxhelp.h" // for ShowHelp
27 #include "wxundo.h" // for currlayer->undoredo->...
28 #include "wxalgos.h" // for *_ALGO, CreateNewUniverse, etc
29 #include "wxlayer.h" // for AddLayer, currlayer, currindex, etc
30 #include "wxscript.h" // for inscript, abortmsg, GSF_*, etc
31 #include "wxperl.h"
32
33 // =============================================================================
34
35 #ifdef ENABLE_PERL
36
37 /*
38 Golly uses an embedded Perl interpreter to execute scripts.
39 See "perldoc perlembed" for details.
40 Perl is Copyright (C) 1993-2007, by Larry Wall and others.
41 It is free software; you can redistribute it and/or modify it under the terms of either:
42 a) the GNU General Public License as published by the Free Software Foundation;
43 either version 1, or (at your option) any later version, or
44 b) the "Artistic License" (http://dev.perl.org/licenses/artistic.html).
45 */
46
47 #ifndef __WXMAC__
48 #include "wx/dynlib.h" // for wxDynamicLibrary
49 #endif
50
51 // avoid warning about _ being redefined
52 #undef _
53
54 #ifdef __WXMSW__
55 // on Windows, wxWidgets defines uid_t/gid_t which breaks Perl's typedefs:
56 #undef uid_t
57 #undef gid_t
58 // can't do "#undef mode_t" for a typedef so use this hack:
59 typedef unsigned short MODE1; // from C:\Perl\lib\CORE\win32.h
60 typedef int MODE2; // from C:\wxWidgets\include\wx\filefn.h
61 #define mode_t MODE1
62 #endif
63
64 #include <EXTERN.h>
65 #include <perl.h>
66 #include <XSUB.h>
67
68 #ifdef __WXMSW__
69 #undef mode_t
70 #define mode_t MODE2
71 #endif
72
73 // restore wxWidgets definition for _ (from include/wx/intl.h)
74 #undef _
75 #define _(s) wxGetTranslation(_T(s))
76
77 /*
78 * Quoting Jan Dubois of Active State:
79 * ActivePerl build 822 still identifies itself as 5.8.8 but already
80 * contains many of the changes from the upcoming Perl 5.8.9 release.
81 *
82 * The changes include addition of two symbols (Perl_sv_2iv_flags,
83 * Perl_newXS_flags) not present in earlier releases.
84 *
85 * Jan Dubois suggested the following guarding scheme:
86 */
87 #if (ACTIVEPERL_VERSION >= 822)
88 #define PERL589_OR_LATER
89 #endif
90 #if (PERL_REVISION == 5) && (PERL_VERSION == 8) && (PERL_SUBVERSION >= 9)
91 #define PERL589_OR_LATER
92 #endif
93 #if (PERL_REVISION == 5) && (PERL_VERSION >= 9)
94 #define PERL589_OR_LATER
95 #endif
96
97 // check if we're building with Perl 5.10 or later
98 #if (ACTIVEPERL_VERSION >= 1000)
99 #define PERL510_OR_LATER
100 #endif
101 #if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
102 #define PERL510_OR_LATER
103 #endif
104
105 // check if we're building with Perl 5.10.1 or later
106 #if (PERL_REVISION == 5) && (PERL_VERSION == 10) && (PERL_SUBVERSION >= 1)
107 #define PERL5101_OR_LATER
108 #endif
109 #if (PERL_REVISION == 5) && (PERL_VERSION >= 11)
110 #define PERL5101_OR_LATER
111 #endif
112
113 // check if we're building with Perl 5.14 or later
114 #if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
115 #define PERL514_OR_LATER
116 #endif
117
118 // Check if PL_thr_key is a real variable or instead a macro which calls
119 // Perl_Gthr_key_ptr(NULL), which was the default before Perl 5.14:
120 #ifdef PL_thr_key
121 #define PERL_THR_KEY_FUNC 1
122 #endif
123
124 static PerlInterpreter* my_perl = NULL;
125
126 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
127
128 // =============================================================================
129
130 // On Windows and Linux we try to load the Perl library at runtime so Golly
131 // will start up even if Perl isn't installed.
132
133 // On Linux we can only load libperl dynamically if using Perl 5.10 or later.
134 // In older Perl versions boot_DynaLoader is in DynaLoader.a and so libperl
135 // has to be statically linked.
136
137 #if defined(__WXMSW__) || (defined(__WXGTK__) && defined(PERL510_OR_LATER))
138 // load Perl lib at runtime
139 #define USE_PERL_DYNAMIC
140 #endif
141
142 #ifdef USE_PERL_DYNAMIC
143
144 // declare G_* wrappers for the functions we want to use from Perl lib
145 extern "C"
146 {
147 #ifdef USE_ITHREADS
148 #ifdef PERL_THR_KEY_FUNC
149 perl_key*(*G_Perl_Gthr_key_ptr)(register PerlInterpreter*);
150 #else
151 perl_key *G_PL_thr_key;
152 #endif
153 #endif
154 SV**(*G_Perl_av_fetch)(pTHX_ AV*, I32, I32);
155 I32(*G_Perl_av_len)(pTHX_ AV*);
156 void(*G_Perl_av_push)(pTHX_ AV*, SV*);
157 void(*G_Perl_croak)(pTHX_ const char*, ...);
158 void*(*G_Perl_get_context)(void);
159 AV*(*G_Perl_newAV)(pTHX);
160 SV*(*G_Perl_newRV)(pTHX_ SV*);
161 SV*(*G_Perl_newSViv)(pTHX_ IV);
162 SV*(*G_Perl_newSVpv)(pTHX_ const char*, STRLEN);
163 CV*(*G_Perl_newXS)(pTHX_ char*, XSUBADDR_t, char*);
164 SV**(*G_Perl_stack_grow)(pTHX_ SV**, SV**, int);
165 IV(*G_Perl_sv_2iv)(pTHX_ SV*);
166 SV*(*G_Perl_sv_2mortal)(pTHX_ SV*);
167 char*(*G_Perl_sv_2pv_flags)(pTHX_ SV*, STRLEN*, I32);
168 PerlInterpreter*(*G_perl_alloc)(void);
169 void(*G_perl_construct)(PerlInterpreter*);
170 int(*G_perl_destruct)(PerlInterpreter*);
171 void(*G_perl_free)(PerlInterpreter*);
172 int(*G_perl_parse)(PerlInterpreter*, XSINIT_t, int, char**, char**);
173 int(*G_perl_run)(PerlInterpreter*);
174 SV*(*G_Perl_eval_pv)(pTHX_ const char*, I32);
175 #ifdef PERL589_OR_LATER
176 IV(*G_Perl_sv_2iv_flags)(pTHX_ SV* sv, I32 flags);
177 #endif
178 #ifdef PERL510_OR_LATER
179 void(*G_Perl_sys_init3)(int*, char***, char***);
180 void(*G_Perl_sys_term)(void);
181 #endif
182 #ifdef PERL5101_OR_LATER
183 SV*(*G_Perl_newSV_type)(pTHX_ svtype type);
184 #endif
185 void(*G_boot_DynaLoader)(pTHX_ CV*);
186
187 #ifdef MULTIPLICITY
188 #ifdef PERL510_OR_LATER
189 SV***(*G_Perl_Istack_sp_ptr)(register PerlInterpreter*);
190 SV***(*G_Perl_Istack_base_ptr)(register PerlInterpreter*);
191 SV***(*G_Perl_Istack_max_ptr)(register PerlInterpreter*);
192 I32**(*G_Perl_Imarkstack_ptr_ptr)(register PerlInterpreter*);
193 #else
194 SV***(*G_Perl_Tstack_sp_ptr)(register PerlInterpreter*);
195 SV***(*G_Perl_Tstack_base_ptr)(register PerlInterpreter*);
196 SV***(*G_Perl_Tstack_max_ptr)(register PerlInterpreter*);
197 I32**(*G_Perl_Tmarkstack_ptr_ptr)(register PerlInterpreter*);
198 #endif
199 U8*(*G_Perl_Iexit_flags_ptr)(register PerlInterpreter*);
200 signed char *(*G_Perl_Iperl_destruct_level_ptr)(register PerlInterpreter*);
201 #else
202 SV ***G_PL_stack_sp;
203 SV ***G_PL_stack_base;
204 SV ***G_PL_stack_max;
205 I32 **G_PL_markstack_ptr;
206 U8 *G_PL_exit_flags;
207 signed char *G_PL_perl_destruct_level;
208 #endif
209 }
210
211 // redefine Perl functions to their equivalent G_* wrappers
212 #ifdef USE_ITHREADS
213 #ifdef PERL_THR_KEY_FUNC
214 #define Perl_Gthr_key_ptr G_Perl_Gthr_key_ptr
215 #else
216 #define PL_thr_key (*G_PL_thr_key)
217 #endif
218 #endif
219 #define Perl_av_fetch G_Perl_av_fetch
220 #define Perl_av_len G_Perl_av_len
221 #define Perl_av_push G_Perl_av_push
222 #define Perl_croak G_Perl_croak
223 #define Perl_get_context G_Perl_get_context
224 #define Perl_newAV G_Perl_newAV
225 #define Perl_newRV G_Perl_newRV
226 #define Perl_newSViv G_Perl_newSViv
227 #define Perl_newSVpv G_Perl_newSVpv
228 #define Perl_newXS G_Perl_newXS
229 #define Perl_stack_grow G_Perl_stack_grow
230 #define Perl_sv_2iv G_Perl_sv_2iv
231 #define Perl_sv_2mortal G_Perl_sv_2mortal
232 #define Perl_sv_2pv_flags G_Perl_sv_2pv_flags
233 #define perl_alloc G_perl_alloc
234 #define perl_construct G_perl_construct
235 #define perl_destruct G_perl_destruct
236 #define perl_free G_perl_free
237 #define perl_parse G_perl_parse
238 #define perl_run G_perl_run
239 #define Perl_eval_pv G_Perl_eval_pv
240 #ifdef PERL589_OR_LATER
241 #define Perl_sv_2iv_flags G_Perl_sv_2iv_flags
242 #endif
243 #ifdef PERL510_OR_LATER
244 #define Perl_sys_init3 G_Perl_sys_init3
245 #define Perl_sys_term G_Perl_sys_term
246 #endif
247 #ifdef MULTIPLICITY
248 #ifdef PERL510_OR_LATER
249 #define Perl_Imarkstack_ptr_ptr G_Perl_Imarkstack_ptr_ptr
250 #define Perl_Istack_base_ptr G_Perl_Istack_base_ptr
251 #define Perl_Istack_max_ptr G_Perl_Istack_max_ptr
252 #define Perl_Istack_sp_ptr G_Perl_Istack_sp_ptr
253 #else
254 #define Perl_Tmarkstack_ptr_ptr G_Perl_Tmarkstack_ptr_ptr
255 #define Perl_Tstack_base_ptr G_Perl_Tstack_base_ptr
256 #define Perl_Tstack_max_ptr G_Perl_Tstack_max_ptr
257 #define Perl_Tstack_sp_ptr G_Perl_Tstack_sp_ptr
258 #endif
259 #define Perl_Iexit_flags_ptr G_Perl_Iexit_flags_ptr
260 #define Perl_Iperl_destruct_level_ptr G_Perl_Iperl_destruct_level_ptr
261 #else /* no MULTIPLICITY */
262 #define PL_stack_sp (*G_PL_stack_sp)
263 #define PL_stack_base (*G_PL_stack_base)
264 #define PL_stack_max (*G_PL_stack_max)
265 #define PL_markstack_ptr (*G_PL_markstack_ptr)
266 #define PL_exit_flags (*G_PL_exit_flags)
267 #define PL_perl_destruct_level (*G_PL_perl_destruct_level)
268 #endif
269 #ifdef PERL5101_OR_LATER
270 #define Perl_newSV_type G_Perl_newSV_type
271 #endif
272 #define boot_DynaLoader G_boot_DynaLoader
273
274 #ifdef __WXMSW__
275 #define PERL_PROC FARPROC
276 #else
277 #define PERL_PROC void *
278 #endif
279
280 #define PERL_FUNC(func) { _T(#func), (PERL_PROC*)&G_ ## func },
281
282 // store function names and their addresses in Perl lib
283 static struct PerlFunc
284 {
285 const wxChar* name; // function name
286 PERL_PROC* ptr; // function pointer
287 } perlFuncs[] =
288 {
289 #ifdef USE_ITHREADS
290 #ifdef PERL_THR_KEY_FUNC
291 PERL_FUNC(Perl_Gthr_key_ptr)
292 #else
293 PERL_FUNC(PL_thr_key)
294 #endif
295 #endif
296 PERL_FUNC(Perl_av_fetch)
297 PERL_FUNC(Perl_av_len)
298 PERL_FUNC(Perl_av_push)
299 PERL_FUNC(Perl_croak)
300 PERL_FUNC(Perl_get_context)
301 PERL_FUNC(Perl_newAV)
302 PERL_FUNC(Perl_newRV)
303 PERL_FUNC(Perl_newSViv)
304 PERL_FUNC(Perl_newSVpv)
305 PERL_FUNC(Perl_newXS)
306 PERL_FUNC(Perl_stack_grow)
307 PERL_FUNC(Perl_sv_2iv)
308 PERL_FUNC(Perl_sv_2mortal)
309 PERL_FUNC(Perl_sv_2pv_flags)
310 PERL_FUNC(perl_alloc)
311 PERL_FUNC(perl_construct)
312 PERL_FUNC(perl_destruct)
313 PERL_FUNC(perl_free)
314 PERL_FUNC(perl_parse)
315 PERL_FUNC(perl_run)
316 PERL_FUNC(Perl_eval_pv)
317 #ifdef PERL589_OR_LATER
318 PERL_FUNC(Perl_sv_2iv_flags)
319 #endif
320 #ifdef PERL510_OR_LATER
321 PERL_FUNC(Perl_sys_init3)
322 PERL_FUNC(Perl_sys_term)
323 #endif
324 #ifdef MULTIPLICITY
325 #ifndef PERL514_OR_LATER
326 // before Perl 5.14:
327 PERL_FUNC(Perl_Iexit_flags_ptr)
328 PERL_FUNC(Perl_Iperl_destruct_level_ptr)
329 #ifdef PERL510_OR_LATER
330 // Perl 5.10/5.12 only:
331 PERL_FUNC(Perl_Imarkstack_ptr_ptr)
332 PERL_FUNC(Perl_Istack_base_ptr)
333 PERL_FUNC(Perl_Istack_max_ptr)
334 PERL_FUNC(Perl_Istack_sp_ptr)
335 #else
336 // before Perl 5.10:
337 PERL_FUNC(Perl_Tmarkstack_ptr_ptr)
338 PERL_FUNC(Perl_Tstack_base_ptr)
339 PERL_FUNC(Perl_Tstack_max_ptr)
340 PERL_FUNC(Perl_Tstack_sp_ptr)
341 #endif
342 #endif
343 #else /* no MULTIPLICITY */
344 /* N.B. these are actually variables, not functions, but the distinction does
345 not matter for symbol resolution: */
346 PERL_FUNC(PL_stack_sp)
347 PERL_FUNC(PL_stack_base)
348 PERL_FUNC(PL_stack_max)
349 PERL_FUNC(PL_markstack_ptr)
350 PERL_FUNC(PL_exit_flags)
351 PERL_FUNC(PL_perl_destruct_level)
352 #endif
353 #ifdef PERL5101_OR_LATER
354 PERL_FUNC(Perl_newSV_type)
355 #endif
356 PERL_FUNC(boot_DynaLoader)
357 { _T(""), NULL }
358 };
359
360 // handle for Perl library
361 static wxDllType perldll = NULL;
362
FreePerlLib()363 static void FreePerlLib()
364 {
365 if ( perldll ) {
366 wxDynamicLibrary::Unload(perldll);
367 perldll = NULL;
368 }
369 }
370
LoadPerlLib()371 static bool LoadPerlLib()
372 {
373 // load the Perl library
374 wxDynamicLibrary dynlib;
375
376 // don't log errors in here
377 wxLogNull noLog;
378
379 // wxDL_GLOBAL corresponds to RTLD_GLOBAL on Linux (ignored on Windows)
380 while ( !dynlib.Load(perllib, wxDL_NOW | wxDL_VERBATIM | wxDL_GLOBAL) ) {
381 // prompt user for a different Perl library;
382 // on Windows perllib should be something like "perl510.dll"
383 // and on Linux it should be something like "libperl.so.5.10"
384 Beep();
385 wxString str = _("If Perl isn't installed then you'll have to Cancel,");
386 str += _("\notherwise change the version numbers to match the");
387 str += _("\nversion installed on your system and try again.");
388 #ifdef __WXMSW__
389 str += _("\n\nIf that fails, search your system for a perl*.dll");
390 str += _("\nfile and enter the full path to that file.");
391 #endif
392 wxTextEntryDialog dialog( wxGetActiveWindow(), str,
393 _("Could not load the Perl library"),
394 perllib, wxOK | wxCANCEL );
395 if (dialog.ShowModal() == wxID_OK) {
396 perllib = dialog.GetValue();
397 } else {
398 return false;
399 }
400 }
401
402 if ( dynlib.IsLoaded() ) {
403 // load all functions named in perlFuncs
404 void* funcptr;
405 PerlFunc* pf = perlFuncs;
406 while ( pf->name[0] ) {
407 funcptr = dynlib.GetSymbol(pf->name);
408 if ( !funcptr ) {
409 wxString err = _("The Perl library does not have this symbol:\n");
410 err += pf->name;
411 err += _("\nYou need to install Perl ");
412 #ifdef PERL510_OR_LATER
413 err += _("5.10 or later.");
414 #else
415 err += _("5.8.x.");
416 #endif
417 Warning(err);
418 return false;
419 }
420 *(pf++->ptr) = (PERL_PROC)funcptr;
421 }
422 perldll = dynlib.Detach();
423 }
424
425 if ( perldll == NULL ) {
426 // should never happen
427 Warning(_("Oh dear, the Perl library is not loaded!"));
428 }
429
430 return perldll != NULL;
431 }
432
433 #endif // USE_PERL_DYNAMIC
434
435 // =============================================================================
436
437 // some useful macros
438
439 #define RETURN_IF_ABORTED if (PerlScriptAborted()) Perl_croak(aTHX_ NULL)
440
441 #define PERL_ERROR(msg) { Perl_croak(aTHX_ "%s", msg); }
442
443 #define CheckRGB(r,g,b,cmd) \
444 if (r < 0 || r > 255 || g < 0 || g > 255 || g < 0 || g > 255) { \
445 char msg[128]; \
446 sprintf(msg, "Bad rgb value in %s (%d,%d,%d).", cmd, r, g, b); \
447 PERL_ERROR(msg); \
448 }
449
450 #ifdef __WXMSW__
451 #define IGNORE_UNUSED_PARAMS wxUnusedVar(cv); wxUnusedVar(my_perl);
452 #else
453 #define IGNORE_UNUSED_PARAMS
454 #endif
455
456 #ifdef __WXMAC__
457 // use decomposed UTF8 so fopen will work
458 #define FILENAME wxString(filename,wxConvLocal).fn_str()
459 #else
460 #define FILENAME filename
461 #endif
462
463 // -----------------------------------------------------------------------------
464
PerlScriptAborted()465 bool PerlScriptAborted()
466 {
467 if (allowcheck) wxGetApp().Poller()->checkevents();
468
469 // if user hit escape key then PassKeyToScript has called AbortPerlScript
470
471 return !scripterr.IsEmpty();
472 }
473
474 // -----------------------------------------------------------------------------
475
AddPadding(AV * array)476 static void AddPadding(AV* array)
477 {
478 // assume array is multi-state and add an extra int if necessary so the array
479 // has an odd number of ints (this is how we distinguish multi-state arrays
480 // from one-state arrays -- the latter always have an even number of ints)
481 int len = av_len(array) + 1;
482 if (len == 0) return; // always return () rather than (0)
483 if ((len & 1) == 0) {
484 av_push(array, newSViv(0));
485 }
486 }
487
488 // -----------------------------------------------------------------------------
489
ExtractCellArray(AV * outarray,lifealgo * universe,bool shift=false)490 static const char* ExtractCellArray(AV* outarray, lifealgo* universe, bool shift = false)
491 {
492 // extract cell array from given universe
493 if ( !universe->isEmpty() ) {
494 bigint top, left, bottom, right;
495 universe->findedges(&top, &left, &bottom, &right);
496 if ( viewptr->OutsideLimits(top, left, bottom, right) ) {
497 return "Universe is too big to extract all cells!";
498 }
499 bool multistate = universe->NumCellStates() > 2;
500 int itop = top.toint();
501 int ileft = left.toint();
502 int ibottom = bottom.toint();
503 int iright = right.toint();
504 int cx, cy;
505 int v = 0;
506 int cntr = 0;
507 for ( cy=itop; cy<=ibottom; cy++ ) {
508 for ( cx=ileft; cx<=iright; cx++ ) {
509 int skip = universe->nextcell(cx, cy, v);
510 if (skip >= 0) {
511 // found next live cell in this row
512 cx += skip;
513 if (shift) {
514 // shift cells so that top left cell of bounding box is at 0,0
515 av_push(outarray, newSViv(cx - ileft));
516 av_push(outarray, newSViv(cy - itop));
517 } else {
518 av_push(outarray, newSViv(cx));
519 av_push(outarray, newSViv(cy));
520 }
521 if (multistate) av_push(outarray, newSViv(v));
522 } else {
523 cx = iright; // done this row
524 }
525 cntr++;
526 if ((cntr % 4096) == 0 && PerlScriptAborted()) return NULL;
527 }
528 }
529 if (multistate) AddPadding(outarray);
530 }
531 return NULL;
532 }
533
534 // =============================================================================
535
536 // The following pl_* routines can be called from Perl scripts.
537
XS(pl_open)538 XS(pl_open)
539 {
540 IGNORE_UNUSED_PARAMS;
541 RETURN_IF_ABORTED;
542 dXSARGS;
543 if (items < 1 || items > 2) PERL_ERROR("Usage: g_open($filename,$remember=0).");
544
545 STRLEN n_a;
546 const char* filename = SvPV(ST(0), n_a);
547 int remember = 0;
548 if (items > 1) remember = SvIV(ST(1));
549
550 const char* err = GSF_open(wxString(filename,wxConvLocal), remember);
551 if (err) PERL_ERROR(err);
552
553 XSRETURN(0);
554 }
555
556 // -----------------------------------------------------------------------------
557
XS(pl_save)558 XS(pl_save)
559 {
560 IGNORE_UNUSED_PARAMS;
561 RETURN_IF_ABORTED;
562 dXSARGS;
563 if (items < 2 || items > 3) PERL_ERROR("Usage: g_save($filename,$format,$remember=0).");
564
565 STRLEN n_a;
566 const char* filename = SvPV(ST(0), n_a);
567 const char* format = SvPV(ST(1), n_a);
568 int remember = 0;
569 if (items > 2) remember = SvIV(ST(2));
570
571 const char* err = GSF_save(wxString(filename,wxConvLocal), format, remember);
572 if (err) PERL_ERROR(err);
573
574 XSRETURN(0);
575 }
576
577 // -----------------------------------------------------------------------------
XS(pl_opendialog)578 XS(pl_opendialog)
579 {
580 IGNORE_UNUSED_PARAMS;
581 RETURN_IF_ABORTED;
582 dXSARGS;
583 if (items > 5) PERL_ERROR("Usage: g_opendialog($title, $filetypes,"
584 "$initialdir, $initialfname, $mustexist=1).");
585
586 const char* title = "Choose a file";
587 const char* filetypes = "All files (*)|*";
588 const char* initialdir = "";
589 const char* initialfname = "";
590 int mustexist = 1;
591 STRLEN n_a;
592 if (items > 0) title = SvPV(ST(0), n_a);
593 if (items > 1) filetypes = SvPV(ST(1), n_a);
594 if (items > 2) initialdir = SvPV(ST(2), n_a);
595 if (items > 3) initialfname = SvPV(ST(3), n_a);
596 if (items > 4) mustexist = SvIV(ST(4));
597
598 wxString wxs_title(title, wxConvLocal);
599 wxString wxs_filetypes(filetypes, wxConvLocal);
600 wxString wxs_initialdir(initialdir, wxConvLocal);
601 wxString wxs_initialfname(initialfname, wxConvLocal);
602 wxString wxs_result = wxEmptyString;
603
604 if (wxs_initialdir.IsEmpty()) wxs_initialdir = wxFileName::GetCwd();
605
606 if (wxs_filetypes == wxT("dir")) {
607 // let user choose a directory
608 wxDirDialog dirdlg(NULL, wxs_title, wxs_initialdir, wxDD_NEW_DIR_BUTTON);
609 if (dirdlg.ShowModal() == wxID_OK) {
610 wxs_result = dirdlg.GetPath();
611 if (wxs_result.Last() != wxFILE_SEP_PATH) wxs_result += wxFILE_SEP_PATH;
612 }
613 } else {
614 // let user choose a file
615 wxFileDialog opendlg(NULL, wxs_title, wxs_initialdir, wxs_initialfname, wxs_filetypes,
616 wxFD_OPEN | (mustexist == 0 ? 0 : wxFD_FILE_MUST_EXIST) );
617 if (opendlg.ShowModal() == wxID_OK) wxs_result = opendlg.GetPath();
618 }
619
620 XSRETURN_PV((const char*)wxs_result.mb_str(wxConvLocal));
621 }
622
623 // -----------------------------------------------------------------------------
624
XS(pl_savedialog)625 XS(pl_savedialog)
626 {
627 IGNORE_UNUSED_PARAMS;
628 RETURN_IF_ABORTED;
629 dXSARGS;
630 if (items > 5) PERL_ERROR("Usage: g_savedialog($title, $filetypes,"
631 " $initialdir, $initialfname, $suppressprompt=0).");
632
633 const char* title = "Choose a save location and filename";
634 const char* filetypes = "All files (*)|*";
635 const char* initialdir = "";
636 const char* initialfname = "";
637 STRLEN n_a;
638 if (items > 0) title = SvPV(ST(0), n_a);
639 if (items > 1) filetypes = SvPV(ST(1), n_a);
640 if (items > 2) initialdir = SvPV(ST(2), n_a);
641 if (items > 3) initialfname = SvPV(ST(3), n_a);
642 int suppressprompt = 0;
643 if (items > 4) suppressprompt = SvIV(ST(4));
644
645 wxString wxs_title(title, wxConvLocal);
646 wxString wxs_filetypes(filetypes, wxConvLocal);
647 wxString wxs_initialdir(initialdir, wxConvLocal);
648 wxString wxs_initialfname(initialfname, wxConvLocal);
649
650 if (wxs_initialdir.IsEmpty()) wxs_initialdir = wxFileName::GetCwd();
651
652 // suppress Overwrite? popup if user just wants to retrieve the string
653 wxFileDialog savedlg( NULL, wxs_title, wxs_initialdir, wxs_initialfname, wxs_filetypes,
654 wxFD_SAVE | (suppressprompt == 0 ? wxFD_OVERWRITE_PROMPT : 0) );
655
656 wxString wxs_savefname = wxEmptyString;
657 if ( savedlg.ShowModal() == wxID_OK ) wxs_savefname = savedlg.GetPath();
658
659 XSRETURN_PV((const char*)wxs_savefname.mb_str(wxConvLocal));
660 }
661
662 // -----------------------------------------------------------------------------
663
XS(pl_load)664 XS(pl_load)
665 {
666 IGNORE_UNUSED_PARAMS;
667 RETURN_IF_ABORTED;
668 dXSARGS;
669 if (items != 1) PERL_ERROR("Usage: $cells = g_load($filename).");
670
671 STRLEN n_a;
672 const char* filename = SvPV(ST(0), n_a);
673
674 // create temporary universe of same type as current universe
675 lifealgo* tempalgo = CreateNewUniverse(currlayer->algtype, allowcheck);
676 // readpattern will call setrule
677
678 // read pattern into temporary universe
679 const char* err = readpattern(FILENAME, *tempalgo);
680 if (err) {
681 // try all other algos until readpattern succeeds
682 for (int i = 0; i < NumAlgos(); i++) {
683 if (i != currlayer->algtype) {
684 delete tempalgo;
685 tempalgo = CreateNewUniverse(i, allowcheck);
686 err = readpattern(FILENAME, *tempalgo);
687 if (!err) break;
688 }
689 }
690 }
691
692 if (err) {
693 delete tempalgo;
694 PERL_ERROR(err);
695 }
696
697 // convert pattern into a cell array, shifting cell coords so that the
698 // bounding box's top left cell is at 0,0
699 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
700 err = ExtractCellArray(outarray, tempalgo, true);
701 delete tempalgo;
702 if (err) PERL_ERROR(err);
703
704 SP -= items;
705 ST(0) = newRV( (SV*)outarray );
706 sv_2mortal(ST(0));
707 XSRETURN(1);
708 }
709
710 // -----------------------------------------------------------------------------
711
XS(pl_store)712 XS(pl_store)
713 {
714 IGNORE_UNUSED_PARAMS;
715 RETURN_IF_ABORTED;
716 dXSARGS;
717 if (items != 2) PERL_ERROR("Usage: g_store($cells,$filename).");
718
719 SV* cells = ST(0);
720 if ( (!SvROK(cells)) || (SvTYPE(SvRV(cells)) != SVt_PVAV) ) {
721 PERL_ERROR("g_store error: 1st parameter is not a valid array reference.");
722 }
723 AV* inarray = (AV*)SvRV(cells);
724
725 STRLEN n_a;
726 const char* filename = SvPV(ST(1), n_a);
727
728 // create temporary universe of same type as current universe
729 lifealgo* tempalgo = CreateNewUniverse(currlayer->algtype, allowcheck);
730 const char* err = tempalgo->setrule(currlayer->algo->getrule());
731 if (err) tempalgo->setrule(tempalgo->DefaultRule());
732
733 // copy cell array into temporary universe
734 bool multistate = ((av_len(inarray) + 1) & 1) == 1;
735 int ints_per_cell = multistate ? 3 : 2;
736 int num_cells = (av_len(inarray) + 1) / ints_per_cell;
737 for (int n = 0; n < num_cells; n++) {
738 int item = ints_per_cell * n;
739 int x = SvIV( *av_fetch(inarray, item, 0) );
740 int y = SvIV( *av_fetch(inarray, item + 1, 0) );
741 // check if x,y is outside bounded grid
742 const char* err = GSF_checkpos(tempalgo, x, y);
743 if (err) { delete tempalgo; PERL_ERROR(err); }
744 if (multistate) {
745 int state = SvIV( *av_fetch(inarray, item + 2, 0) );
746 if (tempalgo->setcell(x, y, state) < 0) {
747 tempalgo->endofpattern();
748 delete tempalgo;
749 PERL_ERROR("g_store error: state value is out of range.");
750 }
751 } else {
752 tempalgo->setcell(x, y, 1);
753 }
754 if ((n % 4096) == 0 && PerlScriptAborted()) {
755 tempalgo->endofpattern();
756 delete tempalgo;
757 Perl_croak(aTHX_ NULL);
758 }
759 }
760 tempalgo->endofpattern();
761
762 // write pattern to given file in RLE/XRLE format
763 bigint top, left, bottom, right;
764 tempalgo->findedges(&top, &left, &bottom, &right);
765 pattern_format format = savexrle ? XRLE_format : RLE_format;
766 // if grid is bounded then force XRLE_format so that position info is recorded
767 if (tempalgo->gridwd > 0 || tempalgo->gridht > 0) format = XRLE_format;
768 err = writepattern(FILENAME, *tempalgo, format, no_compression,
769 top.toint(), left.toint(), bottom.toint(), right.toint());
770 delete tempalgo;
771 if (err) PERL_ERROR(err);
772
773 XSRETURN(0);
774 }
775
776 // -----------------------------------------------------------------------------
777
778 // deprecated (use pl_getdir)
XS(pl_appdir)779 XS(pl_appdir)
780 {
781 IGNORE_UNUSED_PARAMS;
782 RETURN_IF_ABORTED;
783 dXSARGS;
784 if (items != 0) PERL_ERROR("Usage: $dir = g_appdir().");
785
786 XSRETURN_PV((const char*)gollydir.mb_str(wxConvLocal));
787 }
788
789 // -----------------------------------------------------------------------------
790
791 // deprecated (use pl_getdir)
XS(pl_datadir)792 XS(pl_datadir)
793 {
794 IGNORE_UNUSED_PARAMS;
795 RETURN_IF_ABORTED;
796 dXSARGS;
797 if (items != 0) PERL_ERROR("Usage: $dir = g_datadir().");
798
799 XSRETURN_PV((const char*)datadir.mb_str(wxConvLocal));
800 }
801
802 // -----------------------------------------------------------------------------
803
XS(pl_setdir)804 XS(pl_setdir)
805 {
806 IGNORE_UNUSED_PARAMS;
807 RETURN_IF_ABORTED;
808 dXSARGS;
809 if (items != 2) PERL_ERROR("Usage: g_setdir($dirname,$newdir).");
810
811 STRLEN n_a;
812 const char* dirname = SvPV(ST(0), n_a);
813 const char* newdir = SvPV(ST(1), n_a);
814
815 const char* err = GSF_setdir(dirname, wxString(newdir,wxConvLocal));
816 if (err) PERL_ERROR(err);
817
818 XSRETURN(0);
819 }
820
821 // -----------------------------------------------------------------------------
822
XS(pl_getdir)823 XS(pl_getdir)
824 {
825 IGNORE_UNUSED_PARAMS;
826 RETURN_IF_ABORTED;
827 dXSARGS;
828 if (items != 1) PERL_ERROR("Usage: $dir = g_getdir($dirname).");
829
830 STRLEN n_a;
831 const char* dirname = SvPV(ST(0), n_a);
832
833 const char* dirstring = GSF_getdir(dirname);
834 if (dirstring == NULL) PERL_ERROR("g_getdir error: unknown directory name.");
835
836 XSRETURN_PV(dirstring);
837 }
838
839 // -----------------------------------------------------------------------------
840
XS(pl_new)841 XS(pl_new)
842 {
843 IGNORE_UNUSED_PARAMS;
844 RETURN_IF_ABORTED;
845 dXSARGS;
846 if (items != 1) PERL_ERROR("Usage: g_new($title).");
847
848 STRLEN n_a;
849 const char* title = SvPV(ST(0), n_a);
850
851 mainptr->NewPattern(wxString(title,wxConvLocal));
852 DoAutoUpdate();
853
854 XSRETURN(0);
855 }
856
857 // -----------------------------------------------------------------------------
858
XS(pl_cut)859 XS(pl_cut)
860 {
861 IGNORE_UNUSED_PARAMS;
862 RETURN_IF_ABORTED;
863 dXSARGS;
864 if (items != 0) PERL_ERROR("Usage: g_cut().");
865
866 if (viewptr->SelectionExists()) {
867 viewptr->CutSelection();
868 DoAutoUpdate();
869 } else {
870 PERL_ERROR("g_cut error: no selection.");
871 }
872
873 XSRETURN(0);
874 }
875
876 // -----------------------------------------------------------------------------
877
XS(pl_copy)878 XS(pl_copy)
879 {
880 IGNORE_UNUSED_PARAMS;
881 RETURN_IF_ABORTED;
882 dXSARGS;
883 if (items != 0) PERL_ERROR("Usage: g_copy().");
884
885 if (viewptr->SelectionExists()) {
886 viewptr->CopySelection();
887 DoAutoUpdate();
888 } else {
889 PERL_ERROR("g_copy error: no selection.");
890 }
891
892 XSRETURN(0);
893 }
894
895 // -----------------------------------------------------------------------------
896
XS(pl_clear)897 XS(pl_clear)
898 {
899 IGNORE_UNUSED_PARAMS;
900 RETURN_IF_ABORTED;
901 dXSARGS;
902 if (items != 1) PERL_ERROR("Usage: g_clear($where).");
903
904 int where = SvIV(ST(0));
905
906 if (viewptr->SelectionExists()) {
907 if (where == 0)
908 viewptr->ClearSelection();
909 else
910 viewptr->ClearOutsideSelection();
911 DoAutoUpdate();
912 } else {
913 PERL_ERROR("g_clear error: no selection.");
914 }
915
916 XSRETURN(0);
917 }
918
919 // -----------------------------------------------------------------------------
920
XS(pl_paste)921 XS(pl_paste)
922 {
923 IGNORE_UNUSED_PARAMS;
924 RETURN_IF_ABORTED;
925 dXSARGS;
926 if (items != 3) PERL_ERROR("Usage: g_paste($x,$y,$mode).");
927
928 int x = SvIV(ST(0));
929 int y = SvIV(ST(1));
930
931 STRLEN n_a;
932 const char* mode = SvPV(ST(2), n_a);
933
934 const char* err = GSF_paste(x, y, mode);
935 if (err) PERL_ERROR(err);
936
937 XSRETURN(0);
938 }
939
940 // -----------------------------------------------------------------------------
941
XS(pl_shrink)942 XS(pl_shrink)
943 {
944 IGNORE_UNUSED_PARAMS;
945 RETURN_IF_ABORTED;
946 dXSARGS;
947 if (items != 0) PERL_ERROR("Usage: g_shrink().");
948
949 if (viewptr->SelectionExists()) {
950 viewptr->ShrinkSelection(false); // false == don't fit in viewport
951 DoAutoUpdate();
952 } else {
953 PERL_ERROR("g_shrink error: no selection.");
954 }
955
956 XSRETURN(0);
957 }
958
959 // -----------------------------------------------------------------------------
960
XS(pl_randfill)961 XS(pl_randfill)
962 {
963 IGNORE_UNUSED_PARAMS;
964 RETURN_IF_ABORTED;
965 dXSARGS;
966 if (items != 1) PERL_ERROR("Usage: g_randfill($percentage).");
967
968 int perc = SvIV(ST(0));
969
970 if (perc < 1 || perc > 100) {
971 PERL_ERROR("g_randfill error: percentage must be from 1 to 100.");
972 }
973
974 if (viewptr->SelectionExists()) {
975 int oldperc = randomfill;
976 randomfill = perc;
977 viewptr->RandomFill();
978 randomfill = oldperc;
979 DoAutoUpdate();
980 } else {
981 PERL_ERROR("g_randfill error: no selection.");
982 }
983
984 XSRETURN(0);
985 }
986
987 // -----------------------------------------------------------------------------
988
XS(pl_flip)989 XS(pl_flip)
990 {
991 IGNORE_UNUSED_PARAMS;
992 RETURN_IF_ABORTED;
993 dXSARGS;
994 if (items != 1) PERL_ERROR("Usage: g_flip($direction).");
995
996 int direction = SvIV(ST(0));
997
998 if (viewptr->SelectionExists()) {
999 viewptr->FlipSelection(direction != 0); // 1 = top-bottom
1000 DoAutoUpdate();
1001 } else {
1002 PERL_ERROR("g_flip error: no selection.");
1003 }
1004
1005 XSRETURN(0);
1006 }
1007
1008 // -----------------------------------------------------------------------------
1009
XS(pl_rotate)1010 XS(pl_rotate)
1011 {
1012 IGNORE_UNUSED_PARAMS;
1013 RETURN_IF_ABORTED;
1014 dXSARGS;
1015 if (items != 1) PERL_ERROR("Usage: g_rotate($direction).");
1016
1017 int direction = SvIV(ST(0));
1018
1019 if (viewptr->SelectionExists()) {
1020 viewptr->RotateSelection(direction == 0); // 0 = clockwise
1021 DoAutoUpdate();
1022 } else {
1023 PERL_ERROR("g_rotate error: no selection.");
1024 }
1025
1026 XSRETURN(0);
1027 }
1028
1029 // -----------------------------------------------------------------------------
1030
XS(pl_parse)1031 XS(pl_parse)
1032 {
1033 IGNORE_UNUSED_PARAMS;
1034 RETURN_IF_ABORTED;
1035 dXSARGS;
1036 if (items < 1 || items > 7)
1037 PERL_ERROR("Usage: $outcells = g_parse($string,$x=0,$y=0,$axx=1,$axy=0,$ayx=0,$ayy=1).");
1038
1039 STRLEN n_a;
1040 const char* s = SvPV(ST(0), n_a);
1041
1042 // default values for optional params
1043 int x0 = 0;
1044 int y0 = 0;
1045 int axx = 1;
1046 int axy = 0;
1047 int ayx = 0;
1048 int ayy = 1;
1049 if (items > 1) x0 = SvIV(ST(1));
1050 if (items > 2) y0 = SvIV(ST(2));
1051 if (items > 3) axx = SvIV(ST(3));
1052 if (items > 4) axy = SvIV(ST(4));
1053 if (items > 5) ayx = SvIV(ST(5));
1054 if (items > 6) ayy = SvIV(ST(6));
1055
1056 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
1057
1058 int x = 0, y = 0;
1059
1060 if (strchr(s, '*')) {
1061 // parsing 'visual' format
1062 int c = *s++;
1063 while (c) {
1064 switch (c) {
1065 case '\n': if (x) { x = 0; y++; } break;
1066 case '.': x++; break;
1067 case '*':
1068 av_push(outarray, newSViv(x0 + x * axx + y * axy));
1069 av_push(outarray, newSViv(y0 + x * ayx + y * ayy));
1070 x++;
1071 break;
1072 }
1073 c = *s++;
1074 }
1075 } else {
1076 // parsing RLE format; first check if multi-state data is present
1077 bool multistate = false;
1078 const char* p = s;
1079 while (*p) {
1080 char c = *p++;
1081 if ((c == '.') || ('p' <= c && c <= 'y') || ('A' <= c && c <= 'X')) {
1082 multistate = true;
1083 break;
1084 }
1085 }
1086 int prefix = 0;
1087 bool done = false;
1088 int c = *s++;
1089 while (c && !done) {
1090 if (isdigit(c))
1091 prefix = 10 * prefix + (c - '0');
1092 else {
1093 prefix += (prefix == 0);
1094 switch (c) {
1095 case '!': done = true; break;
1096 case '$': x = 0; y += prefix; break;
1097 case 'b': x += prefix; break;
1098 case '.': x += prefix; break;
1099 case 'o':
1100 for (int k = 0; k < prefix; k++, x++) {
1101 av_push(outarray, newSViv(x0 + x * axx + y * axy));
1102 av_push(outarray, newSViv(y0 + x * ayx + y * ayy));
1103 if (multistate) av_push(outarray, newSViv(1));
1104 }
1105 break;
1106 default:
1107 if (('p' <= c && c <= 'y') || ('A' <= c && c <= 'X')) {
1108 // multistate must be true
1109 int state;
1110 if (c < 'p') {
1111 state = c - 'A' + 1;
1112 } else {
1113 state = 24 * (c - 'p' + 1);
1114 c = *s++;
1115 if ('A' <= c && c <= 'X') {
1116 state = state + c - 'A' + 1;
1117 } else {
1118 // PERL_ERROR("g_parse error: illegal multi-char state.");
1119 // be more forgiving and treat 'p'..'y' like 'o'
1120 state = 1;
1121 s--;
1122 }
1123 }
1124 for (int k = 0; k < prefix; k++, x++) {
1125 av_push(outarray, newSViv(x0 + x * axx + y * axy));
1126 av_push(outarray, newSViv(y0 + x * ayx + y * ayy));
1127 av_push(outarray, newSViv(state));
1128 }
1129 }
1130 }
1131 prefix = 0;
1132 }
1133 c = *s++;
1134 }
1135 if (multistate) AddPadding(outarray);
1136 }
1137
1138 SP -= items;
1139 ST(0) = newRV( (SV*)outarray );
1140 sv_2mortal(ST(0));
1141 XSRETURN(1);
1142 }
1143
1144 // -----------------------------------------------------------------------------
1145
XS(pl_transform)1146 XS(pl_transform)
1147 {
1148 IGNORE_UNUSED_PARAMS;
1149 RETURN_IF_ABORTED;
1150 dXSARGS;
1151 if (items < 3 || items > 7)
1152 PERL_ERROR("Usage: $outcells = g_transform($cells,$x,$y,$axx=1,$axy=0,$ayx=0,$ayy=1).");
1153
1154 SV* cells = ST(0);
1155 if ( (!SvROK(cells)) || (SvTYPE(SvRV(cells)) != SVt_PVAV) ) {
1156 PERL_ERROR("g_transform error: 1st parameter is not a valid array reference.");
1157 }
1158 AV* inarray = (AV*)SvRV(cells);
1159
1160 int x0 = SvIV(ST(1));
1161 int y0 = SvIV(ST(2));
1162
1163 // default values for optional params
1164 int axx = 1;
1165 int axy = 0;
1166 int ayx = 0;
1167 int ayy = 1;
1168 if (items > 3) axx = SvIV(ST(3));
1169 if (items > 4) axy = SvIV(ST(4));
1170 if (items > 5) ayx = SvIV(ST(5));
1171 if (items > 6) ayy = SvIV(ST(6));
1172
1173 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
1174
1175 bool multistate = ((av_len(inarray) + 1) & 1) == 1;
1176 int ints_per_cell = multistate ? 3 : 2;
1177 int num_cells = (av_len(inarray) + 1) / ints_per_cell;
1178 for (int n = 0; n < num_cells; n++) {
1179 int item = ints_per_cell * n;
1180 int x = SvIV( *av_fetch(inarray, item, 0) );
1181 int y = SvIV( *av_fetch(inarray, item + 1, 0) );
1182 av_push(outarray, newSViv(x0 + x * axx + y * axy));
1183 av_push(outarray, newSViv(y0 + x * ayx + y * ayy));
1184 if (multistate) {
1185 int state = SvIV( *av_fetch(inarray, item + 2, 0) );
1186 av_push(outarray, newSViv(state));
1187 }
1188 if ((n % 4096) == 0 && PerlScriptAborted()) break;
1189 }
1190 if (multistate) AddPadding(outarray);
1191
1192 SP -= items;
1193 ST(0) = newRV( (SV*)outarray );
1194 sv_2mortal(ST(0));
1195 XSRETURN(1);
1196 }
1197
1198 // -----------------------------------------------------------------------------
1199
XS(pl_evolve)1200 XS(pl_evolve)
1201 {
1202 IGNORE_UNUSED_PARAMS;
1203 RETURN_IF_ABORTED;
1204 dXSARGS;
1205 if (items != 2) PERL_ERROR("Usage: $outcells = g_evolve($cells,$numgens).");
1206
1207 SV* cells = ST(0);
1208 if ( (!SvROK(cells)) || (SvTYPE(SvRV(cells)) != SVt_PVAV) ) {
1209 PERL_ERROR("g_evolve error: 1st parameter is not a valid array reference.");
1210 }
1211 AV* inarray = (AV*)SvRV(cells);
1212
1213 int ngens = SvIV(ST(1));
1214
1215 if (ngens < 0) {
1216 PERL_ERROR("g_evolve error: number of generations is negative.");
1217 }
1218
1219 // create a temporary universe of same type as current universe
1220 lifealgo* tempalgo = CreateNewUniverse(currlayer->algtype, allowcheck);
1221 const char* err = tempalgo->setrule(currlayer->algo->getrule());
1222 if (err) tempalgo->setrule(tempalgo->DefaultRule());
1223
1224 // copy cell array into temporary universe
1225 bool multistate = ((av_len(inarray) + 1) & 1) == 1;
1226 int ints_per_cell = multistate ? 3 : 2;
1227 int num_cells = (av_len(inarray) + 1) / ints_per_cell;
1228 for (int n = 0; n < num_cells; n++) {
1229 int item = ints_per_cell * n;
1230 int x = SvIV( *av_fetch(inarray, item, 0) );
1231 int y = SvIV( *av_fetch(inarray, item + 1, 0) );
1232 // check if x,y is outside bounded grid
1233 const char* err = GSF_checkpos(tempalgo, x, y);
1234 if (err) { delete tempalgo; PERL_ERROR(err); }
1235 if (multistate) {
1236 int state = SvIV( *av_fetch(inarray, item + 2, 0) );
1237 if (tempalgo->setcell(x, y, state) < 0) {
1238 tempalgo->endofpattern();
1239 delete tempalgo;
1240 PERL_ERROR("g_evolve error: state value is out of range.");
1241 }
1242 } else {
1243 tempalgo->setcell(x, y, 1);
1244 }
1245 if ((n % 4096) == 0 && PerlScriptAborted()) {
1246 tempalgo->endofpattern();
1247 delete tempalgo;
1248 Perl_croak(aTHX_ NULL);
1249 }
1250 }
1251 tempalgo->endofpattern();
1252
1253 // advance pattern by ngens
1254 mainptr->generating = true;
1255 if (tempalgo->unbounded && (tempalgo->gridwd > 0 || tempalgo->gridht > 0)) {
1256 // a bounded grid must use an increment of 1 so we can call
1257 // CreateBorderCells and DeleteBorderCells around each step()
1258 tempalgo->setIncrement(1);
1259 while (ngens > 0) {
1260 if (PerlScriptAborted()) {
1261 mainptr->generating = false;
1262 delete tempalgo;
1263 Perl_croak(aTHX_ NULL);
1264 }
1265 if (!tempalgo->CreateBorderCells()) break;
1266 tempalgo->step();
1267 if (!tempalgo->DeleteBorderCells()) break;
1268 ngens--;
1269 }
1270 } else {
1271 tempalgo->setIncrement(ngens);
1272 tempalgo->step();
1273 }
1274 mainptr->generating = false;
1275
1276 // convert new pattern into a new cell array
1277 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
1278 err = ExtractCellArray(outarray, tempalgo);
1279 delete tempalgo;
1280 if (err) PERL_ERROR(err);
1281
1282 SP -= items;
1283 ST(0) = newRV( (SV*)outarray );
1284 sv_2mortal(ST(0));
1285 XSRETURN(1);
1286 }
1287
1288 // -----------------------------------------------------------------------------
1289
1290 static const char* BAD_STATE = "g_putcells error: state value is out of range.";
1291
XS(pl_putcells)1292 XS(pl_putcells)
1293 {
1294 IGNORE_UNUSED_PARAMS;
1295 RETURN_IF_ABORTED;
1296 dXSARGS;
1297 if (items < 1 || items > 8)
1298 PERL_ERROR("Usage: g_putcells($cells,$x=0,$y=0,$axx=1,$axy=0,$ayx=0,$ayy=1,$mode='or').");
1299
1300 SV* cells = ST(0);
1301 if ( (!SvROK(cells)) || (SvTYPE(SvRV(cells)) != SVt_PVAV) ) {
1302 PERL_ERROR("g_putcells error: 1st parameter is not a valid array reference.");
1303 }
1304 AV* inarray = (AV*)SvRV(cells);
1305
1306 // default values for optional params
1307 int x0 = 0;
1308 int y0 = 0;
1309 int axx = 1;
1310 int axy = 0;
1311 int ayx = 0;
1312 int ayy = 1;
1313 // default for mode is 'or'; 'xor' mode is also supported;
1314 // for a one-state array 'copy' mode currently has the same effect as 'or' mode
1315 // because there is no bounding box to set dead cells, but a multi-state array can
1316 // have dead cells so in that case 'copy' mode is not the same as 'or' mode
1317 const char* mode = "or";
1318
1319 STRLEN n_a;
1320 if (items > 1) x0 = SvIV(ST(1));
1321 if (items > 2) y0 = SvIV(ST(2));
1322 if (items > 3) axx = SvIV(ST(3));
1323 if (items > 4) axy = SvIV(ST(4));
1324 if (items > 5) ayx = SvIV(ST(5));
1325 if (items > 6) ayy = SvIV(ST(6));
1326 if (items > 7) mode = SvPV(ST(7), n_a);
1327
1328 wxString modestr = wxString(mode, wxConvLocal);
1329 if ( !( modestr.IsSameAs(wxT("or"), false)
1330 || modestr.IsSameAs(wxT("xor"), false)
1331 || modestr.IsSameAs(wxT("copy"), false)
1332 || modestr.IsSameAs(wxT("and"), false)
1333 || modestr.IsSameAs(wxT("not"), false)) ) {
1334 PERL_ERROR("g_putcells error: unknown mode.");
1335 }
1336
1337 // save cell changes if undo/redo is enabled and script isn't constructing a pattern
1338 bool savecells = allowundo && !currlayer->stayclean;
1339 // use ChangeCell below and combine all changes due to consecutive setcell/putcells
1340 // if (savecells) SavePendingChanges();
1341
1342 // note that av_len returns max index or -1 if array is empty
1343 bool multistate = ((av_len(inarray) + 1) & 1) == 1;
1344 int ints_per_cell = multistate ? 3 : 2;
1345 int num_cells = (av_len(inarray) + 1) / ints_per_cell;
1346 const char* err = NULL;
1347 bool pattchanged = false;
1348 lifealgo* curralgo = currlayer->algo;
1349
1350 if (modestr.IsSameAs(wxT("copy"), false)) {
1351 // TODO: find bounds of cell array and call ClearRect here (to be added to wxedit.cpp)
1352 }
1353
1354 if (modestr.IsSameAs(wxT("and"), false)) {
1355 if (!curralgo->isEmpty()) {
1356 int newstate = 1;
1357 for (int n = 0; n < num_cells; n++) {
1358 int item = ints_per_cell * n;
1359 int x = SvIV( *av_fetch(inarray, item, 0) );
1360 int y = SvIV( *av_fetch(inarray, item + 1, 0) );
1361 int newx = x0 + x * axx + y * axy;
1362 int newy = y0 + x * ayx + y * ayy;
1363 // check if newx,newy is outside bounded grid
1364 err = GSF_checkpos(curralgo, newx, newy);
1365 if (err) break;
1366 int oldstate = curralgo->getcell(newx, newy);
1367 if (multistate) {
1368 // multi-state lists can contain dead cells so newstate might be 0
1369 newstate = SvIV( *av_fetch(inarray, item + 2, 0) );
1370 }
1371 if (newstate != oldstate && oldstate > 0) {
1372 curralgo->setcell(newx, newy, 0);
1373 if (savecells) ChangeCell(newx, newy, oldstate, 0);
1374 pattchanged = true;
1375 }
1376 if ((n % 4096) == 0 && PerlScriptAborted()) break;
1377 }
1378 }
1379 } else if (modestr.IsSameAs(wxT("xor"), false)) {
1380 // loop code is duplicated here to allow 'or' case to execute faster
1381 int numstates = curralgo->NumCellStates();
1382 for (int n = 0; n < num_cells; n++) {
1383 int item = ints_per_cell * n;
1384 int x = SvIV( *av_fetch(inarray, item, 0) );
1385 int y = SvIV( *av_fetch(inarray, item + 1, 0) );
1386 int newx = x0 + x * axx + y * axy;
1387 int newy = y0 + x * ayx + y * ayy;
1388 // check if newx,newy is outside bounded grid
1389 err = GSF_checkpos(curralgo, newx, newy);
1390 if (err) break;
1391 int oldstate = curralgo->getcell(newx, newy);
1392 int newstate;
1393 if (multistate) {
1394 // multi-state arrays can contain dead cells so newstate might be 0
1395 newstate = SvIV( *av_fetch(inarray, item + 2, 0) );
1396 if (newstate == oldstate) {
1397 if (oldstate != 0) newstate = 0;
1398 } else {
1399 newstate = newstate ^ oldstate;
1400 // if xor overflows then don't change current state
1401 if (newstate >= numstates) newstate = oldstate;
1402 }
1403 if (newstate != oldstate) {
1404 // paste (possibly transformed) cell into current universe
1405 if (curralgo->setcell(newx, newy, newstate) < 0) {
1406 err = BAD_STATE;
1407 break;
1408 }
1409 if (savecells) ChangeCell(newx, newy, oldstate, newstate);
1410 pattchanged = true;
1411 }
1412 } else {
1413 // one-state arrays only contain live cells
1414 newstate = 1 - oldstate;
1415 // paste (possibly transformed) cell into current universe
1416 if (curralgo->setcell(newx, newy, newstate) < 0) {
1417 err = BAD_STATE;
1418 break;
1419 }
1420 if (savecells) ChangeCell(newx, newy, oldstate, newstate);
1421 pattchanged = true;
1422 }
1423 if ((n % 4096) == 0 && PerlScriptAborted()) break;
1424 }
1425 } else {
1426 bool negate = modestr.IsSameAs(wxT("not"), false);
1427 bool ormode = modestr.IsSameAs(wxT("or"), false);
1428 int newstate = negate ? 0 : 1;
1429 int maxstate = curralgo->NumCellStates() - 1;
1430 for (int n = 0; n < num_cells; n++) {
1431 int item = ints_per_cell * n;
1432 int x = SvIV( *av_fetch(inarray, item, 0) );
1433 int y = SvIV( *av_fetch(inarray, item + 1, 0) );
1434 int newx = x0 + x * axx + y * axy;
1435 int newy = y0 + x * ayx + y * ayy;
1436 // check if newx,newy is outside bounded grid
1437 err = GSF_checkpos(curralgo, newx, newy);
1438 if (err) break;
1439 int oldstate = curralgo->getcell(newx, newy);
1440 if (multistate) {
1441 // multi-state arrays can contain dead cells so newstate might be 0
1442 newstate = SvIV( *av_fetch(inarray, item + 2, 0) );
1443 if (negate) newstate = maxstate - newstate;
1444 if (ormode && newstate == 0) newstate = oldstate;
1445 }
1446 if (newstate != oldstate) {
1447 // paste (possibly transformed) cell into current universe
1448 if (curralgo->setcell(newx, newy, newstate) < 0) {
1449 err = BAD_STATE;
1450 break;
1451 }
1452 if (savecells) ChangeCell(newx, newy, oldstate, newstate);
1453 pattchanged = true;
1454 }
1455 if ((n % 4096) == 0 && PerlScriptAborted()) break;
1456 }
1457 }
1458
1459 if (pattchanged) {
1460 curralgo->endofpattern();
1461 MarkLayerDirty();
1462 DoAutoUpdate();
1463 }
1464
1465 if (err) PERL_ERROR(err);
1466
1467 XSRETURN(0);
1468 }
1469
1470 // -----------------------------------------------------------------------------
1471
XS(pl_getcells)1472 XS(pl_getcells)
1473 {
1474 IGNORE_UNUSED_PARAMS;
1475 RETURN_IF_ABORTED;
1476 dXSARGS;
1477 if (items != 0 && items != 4) PERL_ERROR("Usage: $cells = g_getcells(@rect).");
1478
1479 // convert pattern in given rect into a cell array (ie. array of live cell coords)
1480 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
1481
1482 if (items == 0) {
1483 // return empty cell array
1484 } else {
1485 // items == 4
1486 int x = SvIV(ST(0));
1487 int y = SvIV(ST(1));
1488 int wd = SvIV(ST(2));
1489 int ht = SvIV(ST(3));
1490 const char* err = GSF_checkrect(x, y, wd, ht);
1491 if (err) PERL_ERROR(err);
1492 int right = x + wd - 1;
1493 int bottom = y + ht - 1;
1494 int cx, cy;
1495 int v = 0;
1496 int cntr = 0;
1497 lifealgo* curralgo = currlayer->algo;
1498 bool multistate = curralgo->NumCellStates() > 2;
1499 for ( cy=y; cy<=bottom; cy++ ) {
1500 for ( cx=x; cx<=right; cx++ ) {
1501 int skip = curralgo->nextcell(cx, cy, v);
1502 if (skip >= 0) {
1503 // found next live cell in this row so add coords to outarray
1504 cx += skip;
1505 if (cx <= right) {
1506 av_push(outarray, newSViv(cx));
1507 av_push(outarray, newSViv(cy));
1508 if (multistate) av_push(outarray, newSViv(v));
1509 }
1510 } else {
1511 cx = right; // done this row
1512 }
1513 cntr++;
1514 if ((cntr % 4096) == 0) RETURN_IF_ABORTED;
1515 }
1516 }
1517 if (multistate) AddPadding(outarray);
1518 }
1519
1520 SP -= items;
1521 ST(0) = newRV( (SV*)outarray );
1522 sv_2mortal(ST(0));
1523 XSRETURN(1);
1524 }
1525
1526 // -----------------------------------------------------------------------------
1527
XS(pl_join)1528 XS(pl_join)
1529 {
1530 IGNORE_UNUSED_PARAMS;
1531 RETURN_IF_ABORTED;
1532 dXSARGS;
1533 if (items != 2) PERL_ERROR("Usage: $outcells = g_join($cells1,$cells2).");
1534
1535 SV* cells1 = ST(0);
1536 SV* cells2 = ST(1);
1537
1538 if ( (!SvROK(cells1)) || (SvTYPE(SvRV(cells1)) != SVt_PVAV) ) {
1539 PERL_ERROR("g_join error: 1st parameter is not a valid array reference.");
1540 }
1541 if ( (!SvROK(cells2)) || (SvTYPE(SvRV(cells2)) != SVt_PVAV) ) {
1542 PERL_ERROR("g_join error: 2nd parameter is not a valid array reference.");
1543 }
1544
1545 AV* inarray1 = (AV*)SvRV(cells1);
1546 AV* inarray2 = (AV*)SvRV(cells2);
1547
1548 bool multi1 = ((av_len(inarray1) + 1) & 1) == 1;
1549 bool multi2 = ((av_len(inarray2) + 1) & 1) == 1;
1550 bool multiout = multi1 || multi2;
1551 int ints_per_cell, num_cells;
1552 int x, y, state;
1553 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
1554
1555 // append 1st array
1556 ints_per_cell = multi1 ? 3 : 2;
1557 num_cells = (av_len(inarray1) + 1) / ints_per_cell;
1558 for (int n = 0; n < num_cells; n++) {
1559 int item = ints_per_cell * n;
1560 x = SvIV( *av_fetch(inarray1, item, 0) );
1561 y = SvIV( *av_fetch(inarray1, item + 1, 0) );
1562 if (multi1) {
1563 state = SvIV( *av_fetch(inarray1, item + 2, 0) );
1564 } else {
1565 state = 1;
1566 }
1567 av_push(outarray, newSViv(x));
1568 av_push(outarray, newSViv(y));
1569 if (multiout) av_push(outarray, newSViv(state));
1570 if ((n % 4096) == 0 && PerlScriptAborted()) {
1571 Perl_croak(aTHX_ NULL);
1572 }
1573 }
1574
1575 // append 2nd array
1576 ints_per_cell = multi2 ? 3 : 2;
1577 num_cells = (av_len(inarray2) + 1) / ints_per_cell;
1578 for (int n = 0; n < num_cells; n++) {
1579 int item = ints_per_cell * n;
1580 x = SvIV( *av_fetch(inarray2, item, 0) );
1581 y = SvIV( *av_fetch(inarray2, item + 1, 0) );
1582 if (multi2) {
1583 state = SvIV( *av_fetch(inarray2, item + 2, 0) );
1584 } else {
1585 state = 1;
1586 }
1587 av_push(outarray, newSViv(x));
1588 av_push(outarray, newSViv(y));
1589 if (multiout) av_push(outarray, newSViv(state));
1590 if ((n % 4096) == 0 && PerlScriptAborted()) {
1591 Perl_croak(aTHX_ NULL);
1592 }
1593 }
1594
1595 if (multiout) AddPadding(outarray);
1596
1597 SP -= items;
1598 ST(0) = newRV( (SV*)outarray );
1599 sv_2mortal(ST(0));
1600 XSRETURN(1);
1601 }
1602
1603 // -----------------------------------------------------------------------------
1604
XS(pl_hash)1605 XS(pl_hash)
1606 {
1607 IGNORE_UNUSED_PARAMS;
1608 RETURN_IF_ABORTED;
1609 dXSARGS;
1610 if (items != 4) PERL_ERROR("Usage: $int = g_hash(@rect).");
1611
1612 int x = SvIV(ST(0));
1613 int y = SvIV(ST(1));
1614 int wd = SvIV(ST(2));
1615 int ht = SvIV(ST(3));
1616 const char* err = GSF_checkrect(x, y, wd, ht);
1617 if (err) PERL_ERROR(err);
1618
1619 int hash = GSF_hash(x, y, wd, ht);
1620
1621 XSRETURN_IV(hash);
1622 }
1623
1624 // -----------------------------------------------------------------------------
1625
XS(pl_getclip)1626 XS(pl_getclip)
1627 {
1628 IGNORE_UNUSED_PARAMS;
1629 RETURN_IF_ABORTED;
1630 dXSARGS;
1631 if (items != 0) PERL_ERROR("Usage: $cells = g_getclip().");
1632
1633 if (!mainptr->ClipboardHasText()) {
1634 PERL_ERROR("g_getclip error: no pattern in clipboard.");
1635 }
1636
1637 // convert pattern in clipboard into a cell array, but where the first 2 items
1638 // are the pattern's width and height (not necessarily the minimal bounding box
1639 // because the pattern might have empty borders, or it might even be empty)
1640 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
1641
1642 // create a temporary layer for storing the clipboard pattern
1643 Layer* templayer = CreateTemporaryLayer();
1644 if (!templayer) {
1645 PERL_ERROR("g_getclip error: failed to create temporary layer.");
1646 }
1647
1648 // read clipboard pattern into temporary universe and set edges
1649 // (not a minimal bounding box if pattern is empty or has empty borders)
1650 bigint top, left, bottom, right;
1651 if ( viewptr->GetClipboardPattern(templayer, &top, &left, &bottom, &right) ) {
1652 if ( viewptr->OutsideLimits(top, left, bottom, right) ) {
1653 delete templayer;
1654 PERL_ERROR("g_getclip error: pattern is too big.");
1655 }
1656 int itop = top.toint();
1657 int ileft = left.toint();
1658 int ibottom = bottom.toint();
1659 int iright = right.toint();
1660 int wd = iright - ileft + 1;
1661 int ht = ibottom - itop + 1;
1662
1663 av_push(outarray, newSViv(wd));
1664 av_push(outarray, newSViv(ht));
1665
1666 // extract cells from templayer
1667 lifealgo* tempalgo = templayer->algo;
1668 bool multistate = tempalgo->NumCellStates() > 2;
1669 int cx, cy;
1670 int cntr = 0;
1671 int v = 0;
1672 for ( cy=itop; cy<=ibottom; cy++ ) {
1673 for ( cx=ileft; cx<=iright; cx++ ) {
1674 int skip = tempalgo->nextcell(cx, cy, v);
1675 if (skip >= 0) {
1676 // found next live cell in this row
1677 cx += skip;
1678 // shift cells so that top left cell of bounding box is at 0,0
1679 av_push(outarray, newSViv(cx - ileft));
1680 av_push(outarray, newSViv(cy - itop));
1681 if (multistate) av_push(outarray, newSViv(v));
1682 } else {
1683 cx = iright; // done this row
1684 }
1685 cntr++;
1686 if ((cntr % 4096) == 0 && PerlScriptAborted()) {
1687 delete templayer;
1688 Perl_croak(aTHX_ NULL);
1689 }
1690 }
1691 }
1692 // if no live cells then return (wd,ht) rather than (wd,ht,0)
1693 if (multistate && (av_len(outarray) + 1) > 2) {
1694 AddPadding(outarray);
1695 }
1696
1697 delete templayer;
1698 } else {
1699 // assume error message has been displayed
1700 delete templayer;
1701 Perl_croak(aTHX_ NULL);
1702 }
1703
1704 SP -= items;
1705 ST(0) = newRV( (SV*)outarray );
1706 sv_2mortal(ST(0));
1707 XSRETURN(1);
1708 }
1709
1710 // -----------------------------------------------------------------------------
1711
XS(pl_select)1712 XS(pl_select)
1713 {
1714 IGNORE_UNUSED_PARAMS;
1715 RETURN_IF_ABORTED;
1716 dXSARGS;
1717 if (items != 0 && items != 4) PERL_ERROR("Usage: g_select(@rect).");
1718
1719 if (items == 0) {
1720 // remove any existing selection
1721 GSF_select(0, 0, 0, 0);
1722 } else {
1723 // items == 4
1724 int x = SvIV(ST(0));
1725 int y = SvIV(ST(1));
1726 int wd = SvIV(ST(2));
1727 int ht = SvIV(ST(3));
1728 const char* err = GSF_checkrect(x, y, wd, ht);
1729 if (err) PERL_ERROR(err);
1730 // set selection rect
1731 GSF_select(x, y, wd, ht);
1732 }
1733 DoAutoUpdate();
1734
1735 XSRETURN(0);
1736 }
1737
1738 // -----------------------------------------------------------------------------
1739
XS(pl_getrect)1740 XS(pl_getrect)
1741 {
1742 IGNORE_UNUSED_PARAMS;
1743 RETURN_IF_ABORTED;
1744 dXSARGS;
1745 if (items != 0) PERL_ERROR("Usage: @rect = g_getrect().");
1746
1747 if (!currlayer->algo->isEmpty()) {
1748 bigint top, left, bottom, right;
1749 currlayer->algo->findedges(&top, &left, &bottom, &right);
1750 if ( viewptr->OutsideLimits(top, left, bottom, right) ) {
1751 PERL_ERROR("g_getrect error: pattern is too big.");
1752 }
1753 int x = left.toint();
1754 int y = top.toint();
1755 int wd = right.toint() - x + 1;
1756 int ht = bottom.toint() - y + 1;
1757
1758 // items == 0 so no need to reset stack pointer
1759 // SP -= items;
1760 XPUSHs(sv_2mortal(newSViv(x)));
1761 XPUSHs(sv_2mortal(newSViv(y)));
1762 XPUSHs(sv_2mortal(newSViv(wd)));
1763 XPUSHs(sv_2mortal(newSViv(ht)));
1764 XSRETURN(4);
1765 } else {
1766 XSRETURN(0);
1767 }
1768 }
1769
1770 // -----------------------------------------------------------------------------
1771
XS(pl_getselrect)1772 XS(pl_getselrect)
1773 {
1774 IGNORE_UNUSED_PARAMS;
1775 RETURN_IF_ABORTED;
1776 dXSARGS;
1777 if (items != 0) PERL_ERROR("Usage: @rect = g_getselrect().");
1778
1779 if (viewptr->SelectionExists()) {
1780 if (currlayer->currsel.TooBig()) {
1781 PERL_ERROR("g_getselrect error: selection is too big.");
1782 }
1783 int x, y, wd, ht;
1784 currlayer->currsel.GetRect(&x, &y, &wd, &ht);
1785
1786 // items == 0 so no need to reset stack pointer
1787 // SP -= items;
1788 XPUSHs(sv_2mortal(newSViv(x)));
1789 XPUSHs(sv_2mortal(newSViv(y)));
1790 XPUSHs(sv_2mortal(newSViv(wd)));
1791 XPUSHs(sv_2mortal(newSViv(ht)));
1792 XSRETURN(4);
1793 } else {
1794 XSRETURN(0);
1795 }
1796 }
1797
1798 // -----------------------------------------------------------------------------
1799
XS(pl_setcell)1800 XS(pl_setcell)
1801 {
1802 IGNORE_UNUSED_PARAMS;
1803 RETURN_IF_ABORTED;
1804 dXSARGS;
1805 if (items != 3) PERL_ERROR("Usage: g_setcell($x,$y,$state).");
1806
1807 int x = SvIV(ST(0));
1808 int y = SvIV(ST(1));
1809 int state = SvIV(ST(2));
1810
1811 const char* err = GSF_setcell(x, y, state);
1812 if (err) PERL_ERROR(err);
1813
1814 XSRETURN(0);
1815 }
1816
1817 // -----------------------------------------------------------------------------
1818
XS(pl_getcell)1819 XS(pl_getcell)
1820 {
1821 IGNORE_UNUSED_PARAMS;
1822 RETURN_IF_ABORTED;
1823 dXSARGS;
1824 if (items != 2) PERL_ERROR("Usage: $state = g_getcell($x,$y).");
1825
1826 int x = SvIV(ST(0));
1827 int y = SvIV(ST(1));
1828
1829 // check if x,y is outside bounded grid
1830 const char* err = GSF_checkpos(currlayer->algo, x, y);
1831 if (err) PERL_ERROR(err);
1832
1833 int state = currlayer->algo->getcell(x, y);
1834
1835 XSRETURN_IV(state);
1836 }
1837
1838 // -----------------------------------------------------------------------------
1839
XS(pl_setcursor)1840 XS(pl_setcursor)
1841 {
1842 IGNORE_UNUSED_PARAMS;
1843 RETURN_IF_ABORTED;
1844 dXSARGS;
1845 if (items != 1) PERL_ERROR("Usage: $oldcurs = g_setcursor($newcurs).");
1846
1847 STRLEN n_a;
1848 const char* newcursor = SvPV(ST(0), n_a);
1849 const char* oldcursor = CursorToString(currlayer->curs);
1850 wxCursor* cursptr = StringToCursor(newcursor);
1851 if (cursptr) {
1852 viewptr->SetCursorMode(cursptr);
1853 // see the cursor change, including button in edit bar
1854 mainptr->UpdateUserInterface();
1855 } else {
1856 PERL_ERROR("g_setcursor error: unknown cursor string.");
1857 }
1858
1859 // return old cursor (simplifies saving and restoring cursor)
1860 XSRETURN_PV(oldcursor);
1861 }
1862
1863 // -----------------------------------------------------------------------------
1864
XS(pl_getcursor)1865 XS(pl_getcursor)
1866 {
1867 IGNORE_UNUSED_PARAMS;
1868 RETURN_IF_ABORTED;
1869 dXSARGS;
1870 if (items != 0) PERL_ERROR("Usage: $string = g_getcursor().");
1871
1872 XSRETURN_PV(CursorToString(currlayer->curs));
1873 }
1874
1875 // -----------------------------------------------------------------------------
1876
XS(pl_empty)1877 XS(pl_empty)
1878 {
1879 IGNORE_UNUSED_PARAMS;
1880 RETURN_IF_ABORTED;
1881 dXSARGS;
1882 if (items != 0) PERL_ERROR("Usage: $bool = g_empty().");
1883
1884 XSRETURN_IV(currlayer->algo->isEmpty() ? 1 : 0);
1885 }
1886
1887 // -----------------------------------------------------------------------------
1888
XS(pl_run)1889 XS(pl_run)
1890 {
1891 IGNORE_UNUSED_PARAMS;
1892 RETURN_IF_ABORTED;
1893 dXSARGS;
1894 if (items != 1) PERL_ERROR("Usage: g_run($numgens).");
1895
1896 int ngens = SvIV(ST(0));
1897
1898 if (ngens > 0 && !currlayer->algo->isEmpty()) {
1899 if (ngens > 1) {
1900 bigint saveinc = currlayer->algo->getIncrement();
1901 currlayer->algo->setIncrement(ngens);
1902 mainptr->NextGeneration(true); // step by ngens
1903 currlayer->algo->setIncrement(saveinc);
1904 } else {
1905 mainptr->NextGeneration(false); // step 1 gen
1906 }
1907 DoAutoUpdate();
1908 }
1909
1910 XSRETURN(0);
1911 }
1912
1913 // -----------------------------------------------------------------------------
1914
XS(pl_step)1915 XS(pl_step)
1916 {
1917 IGNORE_UNUSED_PARAMS;
1918 RETURN_IF_ABORTED;
1919 dXSARGS;
1920 if (items != 0) PERL_ERROR("Usage: g_step().");
1921
1922 if (!currlayer->algo->isEmpty()) {
1923 mainptr->NextGeneration(true); // step by current increment
1924 DoAutoUpdate();
1925 }
1926
1927 XSRETURN(0);
1928 }
1929
1930 // -----------------------------------------------------------------------------
1931
XS(pl_setstep)1932 XS(pl_setstep)
1933 {
1934 IGNORE_UNUSED_PARAMS;
1935 RETURN_IF_ABORTED;
1936 dXSARGS;
1937 if (items != 1) PERL_ERROR("Usage: g_setstep($int).");
1938
1939 mainptr->SetStepExponent(SvIV(ST(0)));
1940 DoAutoUpdate();
1941
1942 XSRETURN(0);
1943 }
1944
1945 // -----------------------------------------------------------------------------
1946
XS(pl_getstep)1947 XS(pl_getstep)
1948 {
1949 IGNORE_UNUSED_PARAMS;
1950 RETURN_IF_ABORTED;
1951 dXSARGS;
1952 if (items != 0) PERL_ERROR("Usage: $int = g_getstep().");
1953
1954 XSRETURN_IV(currlayer->currexpo);
1955 }
1956
1957 // -----------------------------------------------------------------------------
1958
XS(pl_setbase)1959 XS(pl_setbase)
1960 {
1961 IGNORE_UNUSED_PARAMS;
1962 RETURN_IF_ABORTED;
1963 dXSARGS;
1964 if (items != 1) PERL_ERROR("Usage: g_setbase($int).");
1965
1966 int base = SvIV(ST(0));
1967
1968 if (base < 2) base = 2;
1969 if (base > MAX_BASESTEP) base = MAX_BASESTEP;
1970 currlayer->currbase = base;
1971 mainptr->SetGenIncrement();
1972 DoAutoUpdate();
1973
1974 XSRETURN(0);
1975 }
1976
1977 // -----------------------------------------------------------------------------
1978
XS(pl_getbase)1979 XS(pl_getbase)
1980 {
1981 IGNORE_UNUSED_PARAMS;
1982 RETURN_IF_ABORTED;
1983 dXSARGS;
1984 if (items != 0) PERL_ERROR("Usage: $int = g_getbase().");
1985
1986 XSRETURN_IV(currlayer->currbase);
1987 }
1988
1989 // -----------------------------------------------------------------------------
1990
XS(pl_advance)1991 XS(pl_advance)
1992 {
1993 IGNORE_UNUSED_PARAMS;
1994 RETURN_IF_ABORTED;
1995 dXSARGS;
1996 if (items != 2) PERL_ERROR("Usage: g_advance($where,$numgens).");
1997
1998 int where = SvIV(ST(0));
1999 int ngens = SvIV(ST(1));
2000
2001 if (ngens > 0) {
2002 if (viewptr->SelectionExists()) {
2003 while (ngens > 0) {
2004 ngens--;
2005 if (where == 0)
2006 currlayer->currsel.Advance();
2007 else
2008 currlayer->currsel.AdvanceOutside();
2009 }
2010 DoAutoUpdate();
2011 } else {
2012 PERL_ERROR("g_advance error: no selection.");
2013 }
2014 }
2015
2016 XSRETURN(0);
2017 }
2018
2019 // -----------------------------------------------------------------------------
2020
XS(pl_reset)2021 XS(pl_reset)
2022 {
2023 IGNORE_UNUSED_PARAMS;
2024 RETURN_IF_ABORTED;
2025 dXSARGS;
2026 if (items != 0) PERL_ERROR("Usage: g_reset().");
2027
2028 if (currlayer->algo->getGeneration() != currlayer->startgen) {
2029 mainptr->ResetPattern();
2030 DoAutoUpdate();
2031 }
2032
2033 XSRETURN(0);
2034 }
2035
2036 // -----------------------------------------------------------------------------
2037
XS(pl_setgen)2038 XS(pl_setgen)
2039 {
2040 IGNORE_UNUSED_PARAMS;
2041 RETURN_IF_ABORTED;
2042 dXSARGS;
2043 if (items != 1) PERL_ERROR("Usage: g_setgen($string).");
2044
2045 STRLEN n_a;
2046 const char* genstring = SvPV(ST(0), n_a);
2047
2048 const char* err = GSF_setgen(genstring);
2049 if (err) PERL_ERROR(err);
2050
2051 XSRETURN(0);
2052 }
2053
2054 // -----------------------------------------------------------------------------
2055
XS(pl_getgen)2056 XS(pl_getgen)
2057 {
2058 IGNORE_UNUSED_PARAMS;
2059 RETURN_IF_ABORTED;
2060 dXSARGS;
2061 if (items > 1) PERL_ERROR("Usage: $string = g_getgen($sepchar='').");
2062
2063 char sepchar = '\0';
2064 if (items > 0) {
2065 STRLEN n_a;
2066 char* s = SvPV(ST(0), n_a);
2067 sepchar = s[0];
2068 }
2069
2070 XSRETURN_PV(currlayer->algo->getGeneration().tostring(sepchar));
2071 }
2072
2073 // -----------------------------------------------------------------------------
2074
XS(pl_getpop)2075 XS(pl_getpop)
2076 {
2077 IGNORE_UNUSED_PARAMS;
2078 RETURN_IF_ABORTED;
2079 dXSARGS;
2080 if (items > 1) PERL_ERROR("Usage: $string = g_getpop($sepchar='').");
2081
2082 char sepchar = '\0';
2083 if (items > 0) {
2084 STRLEN n_a;
2085 char* s = SvPV(ST(0), n_a);
2086 sepchar = s[0];
2087 }
2088
2089 XSRETURN_PV(currlayer->algo->getPopulation().tostring(sepchar));
2090 }
2091
2092 // -----------------------------------------------------------------------------
2093
XS(pl_setalgo)2094 XS(pl_setalgo)
2095 {
2096 IGNORE_UNUSED_PARAMS;
2097 RETURN_IF_ABORTED;
2098 dXSARGS;
2099 if (items != 1) PERL_ERROR("Usage: g_setalgo($string).");
2100
2101 STRLEN n_a;
2102 const char* algostring = SvPV(ST(0), n_a);
2103
2104 const char* err = GSF_setalgo(algostring);
2105 if (err) PERL_ERROR(err);
2106
2107 XSRETURN(0);
2108 }
2109
2110 // -----------------------------------------------------------------------------
2111
XS(pl_getalgo)2112 XS(pl_getalgo)
2113 {
2114 IGNORE_UNUSED_PARAMS;
2115 RETURN_IF_ABORTED;
2116 dXSARGS;
2117 if (items > 1) PERL_ERROR("Usage: $algo = g_getalgo($index=current).");
2118
2119 int index = currlayer->algtype;
2120 if (items > 0) index = SvIV(ST(0));
2121
2122 if (index < 0 || index >= NumAlgos()) {
2123 char msg[64];
2124 sprintf(msg, "Bad g_getalgo index (%d).", index);
2125 PERL_ERROR(msg);
2126 }
2127
2128 XSRETURN_PV(GetAlgoName(index));
2129 }
2130
2131 // -----------------------------------------------------------------------------
2132
XS(pl_setrule)2133 XS(pl_setrule)
2134 {
2135 IGNORE_UNUSED_PARAMS;
2136 RETURN_IF_ABORTED;
2137 dXSARGS;
2138 if (items != 1) PERL_ERROR("Usage: g_setrule($string).");
2139
2140 STRLEN n_a;
2141 const char* rulestring = SvPV(ST(0), n_a);
2142
2143 const char* err = GSF_setrule(rulestring);
2144 if (err) PERL_ERROR(err);
2145
2146 XSRETURN(0);
2147 }
2148
2149 // -----------------------------------------------------------------------------
2150
XS(pl_getrule)2151 XS(pl_getrule)
2152 {
2153 IGNORE_UNUSED_PARAMS;
2154 RETURN_IF_ABORTED;
2155 dXSARGS;
2156 if (items != 0) PERL_ERROR("Usage: $string = g_getrule().");
2157
2158 XSRETURN_PV(currlayer->algo->getrule());
2159 }
2160
2161 // -----------------------------------------------------------------------------
2162
XS(pl_getwidth)2163 XS(pl_getwidth)
2164 {
2165 IGNORE_UNUSED_PARAMS;
2166 RETURN_IF_ABORTED;
2167 dXSARGS;
2168 if (items != 0) PERL_ERROR("Usage: $int = g_getwidth().");
2169
2170 XSRETURN_IV(currlayer->algo->gridwd);
2171 }
2172
2173 // -----------------------------------------------------------------------------
2174
XS(pl_getheight)2175 XS(pl_getheight)
2176 {
2177 IGNORE_UNUSED_PARAMS;
2178 RETURN_IF_ABORTED;
2179 dXSARGS;
2180 if (items != 0) PERL_ERROR("Usage: $int = g_getheight().");
2181
2182 XSRETURN_IV(currlayer->algo->gridht);
2183 }
2184
2185 // -----------------------------------------------------------------------------
2186
XS(pl_numstates)2187 XS(pl_numstates)
2188 {
2189 IGNORE_UNUSED_PARAMS;
2190 RETURN_IF_ABORTED;
2191 dXSARGS;
2192 if (items != 0) PERL_ERROR("Usage: $int = g_numstates().");
2193
2194 XSRETURN_IV(currlayer->algo->NumCellStates());
2195 }
2196
2197 // -----------------------------------------------------------------------------
2198
XS(pl_numalgos)2199 XS(pl_numalgos)
2200 {
2201 IGNORE_UNUSED_PARAMS;
2202 RETURN_IF_ABORTED;
2203 dXSARGS;
2204 if (items != 0) PERL_ERROR("Usage: $int = g_numalgos().");
2205
2206 XSRETURN_IV(NumAlgos());
2207 }
2208
2209 // -----------------------------------------------------------------------------
2210
XS(pl_setpos)2211 XS(pl_setpos)
2212 {
2213 IGNORE_UNUSED_PARAMS;
2214 RETURN_IF_ABORTED;
2215 dXSARGS;
2216 if (items != 2) PERL_ERROR("Usage: g_setpos($xstring,$ystring).");
2217
2218 STRLEN n_a;
2219 const char* x = SvPV(ST(0), n_a);
2220 const char* y = SvPV(ST(1), n_a);
2221
2222 const char* err = GSF_setpos(x, y);
2223 if (err) PERL_ERROR(err);
2224
2225 XSRETURN(0);
2226 }
2227
2228 // -----------------------------------------------------------------------------
2229
XS(pl_getpos)2230 XS(pl_getpos)
2231 {
2232 IGNORE_UNUSED_PARAMS;
2233 RETURN_IF_ABORTED;
2234 dXSARGS;
2235 if (items > 1) PERL_ERROR("Usage: @xy = g_getpos($sepchar='').");
2236
2237 char sepchar = '\0';
2238 if (items > 0) {
2239 STRLEN n_a;
2240 char* s = SvPV(ST(0), n_a);
2241 sepchar = s[0];
2242 }
2243
2244 bigint bigx, bigy;
2245 viewptr->GetPos(bigx, bigy);
2246
2247 // return position as x,y strings
2248 SP -= items;
2249 XPUSHs(sv_2mortal(newSVpv( bigx.tostring(sepchar), 0 )));
2250 XPUSHs(sv_2mortal(newSVpv( bigy.tostring(sepchar), 0 )));
2251 XSRETURN(2);
2252 }
2253
2254 // -----------------------------------------------------------------------------
2255
XS(pl_setmag)2256 XS(pl_setmag)
2257 {
2258 IGNORE_UNUSED_PARAMS;
2259 RETURN_IF_ABORTED;
2260 dXSARGS;
2261 if (items != 1) PERL_ERROR("Usage: g_setmag($int).");
2262
2263 int mag = SvIV(ST(0));
2264
2265 viewptr->SetMag(mag);
2266 DoAutoUpdate();
2267
2268 XSRETURN(0);
2269 }
2270
2271 // -----------------------------------------------------------------------------
2272
XS(pl_getmag)2273 XS(pl_getmag)
2274 {
2275 IGNORE_UNUSED_PARAMS;
2276 RETURN_IF_ABORTED;
2277 dXSARGS;
2278 if (items != 0) PERL_ERROR("Usage: $int = g_getmag().");
2279
2280 XSRETURN_IV(viewptr->GetMag());
2281 }
2282
2283 // -----------------------------------------------------------------------------
2284
XS(pl_fit)2285 XS(pl_fit)
2286 {
2287 IGNORE_UNUSED_PARAMS;
2288 RETURN_IF_ABORTED;
2289 dXSARGS;
2290 if (items != 0) PERL_ERROR("Usage: g_fit().");
2291
2292 viewptr->FitPattern();
2293 DoAutoUpdate();
2294
2295 XSRETURN(0);
2296 }
2297
2298 // -----------------------------------------------------------------------------
2299
XS(pl_fitsel)2300 XS(pl_fitsel)
2301 {
2302 IGNORE_UNUSED_PARAMS;
2303 RETURN_IF_ABORTED;
2304 dXSARGS;
2305 if (items != 0) PERL_ERROR("Usage: g_fitsel().");
2306
2307 if (viewptr->SelectionExists()) {
2308 viewptr->FitSelection();
2309 DoAutoUpdate();
2310 } else {
2311 PERL_ERROR("g_fitsel error: no selection.");
2312 }
2313
2314 XSRETURN(0);
2315 }
2316
2317 // -----------------------------------------------------------------------------
2318
XS(pl_visrect)2319 XS(pl_visrect)
2320 {
2321 IGNORE_UNUSED_PARAMS;
2322 RETURN_IF_ABORTED;
2323 dXSARGS;
2324 if (items != 4) PERL_ERROR("Usage: $bool = g_visrect(@rect).");
2325
2326 int x = SvIV(ST(0));
2327 int y = SvIV(ST(1));
2328 int wd = SvIV(ST(2));
2329 int ht = SvIV(ST(3));
2330 const char* err = GSF_checkrect(x, y, wd, ht);
2331 if (err) PERL_ERROR(err);
2332
2333 bigint left = x;
2334 bigint top = y;
2335 bigint right = x + wd - 1;
2336 bigint bottom = y + ht - 1;
2337 int visible = viewptr->CellVisible(left, top) &&
2338 viewptr->CellVisible(right, bottom);
2339
2340 XSRETURN_IV(visible);
2341 }
2342
2343 // -----------------------------------------------------------------------------
2344
XS(pl_update)2345 XS(pl_update)
2346 {
2347 IGNORE_UNUSED_PARAMS;
2348 RETURN_IF_ABORTED;
2349 dXSARGS;
2350 if (items != 0) PERL_ERROR("Usage: g_update().");
2351
2352 GSF_update();
2353
2354 XSRETURN(0);
2355 }
2356
2357 // -----------------------------------------------------------------------------
2358
XS(pl_autoupdate)2359 XS(pl_autoupdate)
2360 {
2361 IGNORE_UNUSED_PARAMS;
2362 RETURN_IF_ABORTED;
2363 dXSARGS;
2364 if (items != 1) PERL_ERROR("Usage: g_autoupdate($bool).");
2365
2366 autoupdate = (SvIV(ST(0)) != 0);
2367
2368 XSRETURN(0);
2369 }
2370
2371 // -----------------------------------------------------------------------------
2372
XS(pl_addlayer)2373 XS(pl_addlayer)
2374 {
2375 IGNORE_UNUSED_PARAMS;
2376 RETURN_IF_ABORTED;
2377 dXSARGS;
2378 if (items != 0) PERL_ERROR("Usage: $newindex = g_addlayer().");
2379
2380 if (numlayers >= MAX_LAYERS) {
2381 PERL_ERROR("g_addlayer error: no more layers can be added.");
2382 } else {
2383 AddLayer();
2384 DoAutoUpdate();
2385 }
2386
2387 // return index of new layer
2388 XSRETURN_IV(currindex);
2389 }
2390
2391 // -----------------------------------------------------------------------------
2392
XS(pl_clone)2393 XS(pl_clone)
2394 {
2395 IGNORE_UNUSED_PARAMS;
2396 RETURN_IF_ABORTED;
2397 dXSARGS;
2398 if (items != 0) PERL_ERROR("Usage: $newindex = g_clone().");
2399
2400 if (numlayers >= MAX_LAYERS) {
2401 PERL_ERROR("g_clone error: no more layers can be added.");
2402 } else {
2403 CloneLayer();
2404 DoAutoUpdate();
2405 }
2406
2407 // return index of new layer
2408 XSRETURN_IV(currindex);
2409 }
2410
2411 // -----------------------------------------------------------------------------
2412
XS(pl_duplicate)2413 XS(pl_duplicate)
2414 {
2415 IGNORE_UNUSED_PARAMS;
2416 RETURN_IF_ABORTED;
2417 dXSARGS;
2418 if (items != 0) PERL_ERROR("Usage: $newindex = g_duplicate().");
2419
2420 if (numlayers >= MAX_LAYERS) {
2421 PERL_ERROR("g_duplicate error: no more layers can be added.");
2422 } else {
2423 DuplicateLayer();
2424 DoAutoUpdate();
2425 }
2426
2427 // return index of new layer
2428 XSRETURN_IV(currindex);
2429 }
2430
2431 // -----------------------------------------------------------------------------
2432
XS(pl_dellayer)2433 XS(pl_dellayer)
2434 {
2435 IGNORE_UNUSED_PARAMS;
2436 RETURN_IF_ABORTED;
2437 dXSARGS;
2438 if (items != 0) PERL_ERROR("Usage: g_dellayer().");
2439
2440 if (numlayers <= 1) {
2441 PERL_ERROR("g_dellayer error: there is only one layer.");
2442 } else {
2443 DeleteLayer();
2444 DoAutoUpdate();
2445 }
2446
2447 XSRETURN(0);
2448 }
2449
2450 // -----------------------------------------------------------------------------
2451
XS(pl_movelayer)2452 XS(pl_movelayer)
2453 {
2454 IGNORE_UNUSED_PARAMS;
2455 RETURN_IF_ABORTED;
2456 dXSARGS;
2457 if (items != 2) PERL_ERROR("Usage: g_movelayer($from,$to).");
2458
2459 int fromindex = SvIV(ST(0));
2460 int toindex = SvIV(ST(1));
2461
2462 if (fromindex < 0 || fromindex >= numlayers) {
2463 char msg[64];
2464 sprintf(msg, "Bad g_movelayer fromindex (%d).", fromindex);
2465 PERL_ERROR(msg);
2466 }
2467 if (toindex < 0 || toindex >= numlayers) {
2468 char msg[64];
2469 sprintf(msg, "Bad g_movelayer toindex (%d).", toindex);
2470 PERL_ERROR(msg);
2471 }
2472
2473 MoveLayer(fromindex, toindex);
2474 DoAutoUpdate();
2475
2476 XSRETURN(0);
2477 }
2478
2479 // -----------------------------------------------------------------------------
2480
XS(pl_setlayer)2481 XS(pl_setlayer)
2482 {
2483 IGNORE_UNUSED_PARAMS;
2484 RETURN_IF_ABORTED;
2485 dXSARGS;
2486 if (items != 1) PERL_ERROR("Usage: g_setlayer($index).");
2487
2488 int index = SvIV(ST(0));
2489
2490 if (index < 0 || index >= numlayers) {
2491 char msg[64];
2492 sprintf(msg, "Bad g_setlayer index (%d).", index);
2493 PERL_ERROR(msg);
2494 }
2495
2496 SetLayer(index);
2497 DoAutoUpdate();
2498
2499 XSRETURN(0);
2500 }
2501
2502 // -----------------------------------------------------------------------------
2503
XS(pl_getlayer)2504 XS(pl_getlayer)
2505 {
2506 IGNORE_UNUSED_PARAMS;
2507 RETURN_IF_ABORTED;
2508 dXSARGS;
2509 if (items != 0) PERL_ERROR("Usage: $int = g_getlayer().");
2510
2511 XSRETURN_IV(currindex);
2512 }
2513
2514 // -----------------------------------------------------------------------------
2515
XS(pl_numlayers)2516 XS(pl_numlayers)
2517 {
2518 IGNORE_UNUSED_PARAMS;
2519 RETURN_IF_ABORTED;
2520 dXSARGS;
2521 if (items != 0) PERL_ERROR("Usage: $int = g_numlayers().");
2522
2523 XSRETURN_IV(numlayers);
2524 }
2525
2526 // -----------------------------------------------------------------------------
2527
XS(pl_maxlayers)2528 XS(pl_maxlayers)
2529 {
2530 IGNORE_UNUSED_PARAMS;
2531 RETURN_IF_ABORTED;
2532 dXSARGS;
2533 if (items != 0) PERL_ERROR("Usage: $int = g_maxlayers().");
2534
2535 XSRETURN_IV(MAX_LAYERS);
2536 }
2537
2538 // -----------------------------------------------------------------------------
2539
XS(pl_setname)2540 XS(pl_setname)
2541 {
2542 IGNORE_UNUSED_PARAMS;
2543 RETURN_IF_ABORTED;
2544 dXSARGS;
2545 if (items < 1 || items > 2) PERL_ERROR("Usage: g_setname($name,$index=current).");
2546
2547 STRLEN n_a;
2548 const char* name = SvPV(ST(0), n_a);
2549 int index = currindex;
2550 if (items > 1) index = SvIV(ST(1));
2551
2552 if (index < 0 || index >= numlayers) {
2553 char msg[64];
2554 sprintf(msg, "Bad g_setname index (%d).", index);
2555 PERL_ERROR(msg);
2556 }
2557
2558 GSF_setname(wxString(name,wxConvLocal), index);
2559
2560 XSRETURN(0);
2561 }
2562
2563 // -----------------------------------------------------------------------------
2564
XS(pl_getname)2565 XS(pl_getname)
2566 {
2567 IGNORE_UNUSED_PARAMS;
2568 RETURN_IF_ABORTED;
2569 dXSARGS;
2570 if (items > 1) PERL_ERROR("Usage: $name = g_getname($index=current).");
2571
2572 int index = currindex;
2573 if (items > 0) index = SvIV(ST(0));
2574
2575 if (index < 0 || index >= numlayers) {
2576 char msg[64];
2577 sprintf(msg, "Bad g_getname index (%d).", index);
2578 PERL_ERROR(msg);
2579 }
2580
2581 XSRETURN_PV((const char*)GetLayer(index)->currname.mb_str(wxConvLocal));
2582 }
2583
2584 // -----------------------------------------------------------------------------
2585
XS(pl_setcolors)2586 XS(pl_setcolors)
2587 {
2588 IGNORE_UNUSED_PARAMS;
2589 RETURN_IF_ABORTED;
2590 dXSARGS;
2591 if (items != 1) PERL_ERROR("Usage: g_setcolors($colors).");
2592
2593 SV* colors = ST(0);
2594 if ( (!SvROK(colors)) || (SvTYPE(SvRV(colors)) != SVt_PVAV) ) {
2595 PERL_ERROR("g_setcolors error: 1st parameter is not a valid array reference.");
2596 }
2597 AV* inarray = (AV*)SvRV(colors);
2598
2599 int len = av_len(inarray) + 1;
2600 if (len == 0) {
2601 // restore default colors in current layer and its clones
2602 UpdateLayerColors();
2603 } else if (len == 6) {
2604 // create gradient from r1,g1,b1 to r2,g2,b2
2605 int r1 = SvIV( *av_fetch(inarray, 0, 0) );
2606 int g1 = SvIV( *av_fetch(inarray, 1, 0) );
2607 int b1 = SvIV( *av_fetch(inarray, 2, 0) );
2608 int r2 = SvIV( *av_fetch(inarray, 3, 0) );
2609 int g2 = SvIV( *av_fetch(inarray, 4, 0) );
2610 int b2 = SvIV( *av_fetch(inarray, 5, 0) );
2611 CheckRGB(r1, g1, b1, "g_setcolors");
2612 CheckRGB(r2, g2, b2, "g_setcolors");
2613 currlayer->fromrgb.Set(r1, g1, b1);
2614 currlayer->torgb.Set(r2, g2, b2);
2615 CreateColorGradient();
2616 UpdateIconColors();
2617 UpdateCloneColors();
2618 } else if (len % 4 == 0) {
2619 int i = 0;
2620 while (i < len) {
2621 int s = SvIV( *av_fetch(inarray, i, 0) ); i++;
2622 int r = SvIV( *av_fetch(inarray, i, 0) ); i++;
2623 int g = SvIV( *av_fetch(inarray, i, 0) ); i++;
2624 int b = SvIV( *av_fetch(inarray, i, 0) ); i++;
2625 CheckRGB(r, g, b, "g_setcolors");
2626 if (s == -1) {
2627 // set all LIVE states to r,g,b (best not to alter state 0)
2628 for (s = 1; s < currlayer->algo->NumCellStates(); s++) {
2629 currlayer->cellr[s] = r;
2630 currlayer->cellg[s] = g;
2631 currlayer->cellb[s] = b;
2632 }
2633 } else {
2634 if (s < 0 || s >= currlayer->algo->NumCellStates()) {
2635 char msg[64];
2636 sprintf(msg, "Bad state in g_setcolors (%d).", s);
2637 PERL_ERROR(msg);
2638 } else {
2639 currlayer->cellr[s] = r;
2640 currlayer->cellg[s] = g;
2641 currlayer->cellb[s] = b;
2642 }
2643 }
2644 }
2645 UpdateIconColors();
2646 UpdateCloneColors();
2647 } else {
2648 PERL_ERROR("g_setcolors error: array length is not a multiple of 4.");
2649 }
2650
2651 DoAutoUpdate();
2652
2653 XSRETURN(0);
2654 }
2655
2656 // -----------------------------------------------------------------------------
2657
XS(pl_getcolors)2658 XS(pl_getcolors)
2659 {
2660 IGNORE_UNUSED_PARAMS;
2661 RETURN_IF_ABORTED;
2662 dXSARGS;
2663 if (items > 1) PERL_ERROR("Usage: $colors = g_getcolors($state=-1).");
2664
2665 int state = -1;
2666 if (items > 0) state = SvIV(ST(0));
2667
2668 AV* outarray = (AV*)sv_2mortal( (SV*)newAV() );
2669
2670 if (state == -1) {
2671 // return colors for ALL states, including state 0
2672 for (state = 0; state < currlayer->algo->NumCellStates(); state++) {
2673 av_push(outarray, newSViv(state));
2674 av_push(outarray, newSViv(currlayer->cellr[state]));
2675 av_push(outarray, newSViv(currlayer->cellg[state]));
2676 av_push(outarray, newSViv(currlayer->cellb[state]));
2677 }
2678 } else if (state >= 0 && state < currlayer->algo->NumCellStates()) {
2679 av_push(outarray, newSViv(state));
2680 av_push(outarray, newSViv(currlayer->cellr[state]));
2681 av_push(outarray, newSViv(currlayer->cellg[state]));
2682 av_push(outarray, newSViv(currlayer->cellb[state]));
2683 } else {
2684 char msg[64];
2685 sprintf(msg, "Bad g_getcolors state (%d).", state);
2686 PERL_ERROR(msg);
2687 }
2688
2689 SP -= items;
2690 ST(0) = newRV( (SV*)outarray );
2691 sv_2mortal(ST(0));
2692 XSRETURN(1);
2693 }
2694
2695 // -----------------------------------------------------------------------------
2696
XS(pl_setoption)2697 XS(pl_setoption)
2698 {
2699 IGNORE_UNUSED_PARAMS;
2700 RETURN_IF_ABORTED;
2701 dXSARGS;
2702 if (items != 2) PERL_ERROR("Usage: $oldval = g_setoption($name,$newval).");
2703
2704 STRLEN n_a;
2705 const char* optname = SvPV(ST(0), n_a);
2706 int newval = SvIV(ST(1));
2707 int oldval;
2708
2709 if (!GSF_setoption(optname, newval, &oldval)) {
2710 PERL_ERROR("g_setoption error: unknown option.");
2711 }
2712
2713 // return old value (simplifies saving and restoring settings)
2714 XSRETURN_IV(oldval);
2715 }
2716
2717 // -----------------------------------------------------------------------------
2718
XS(pl_getoption)2719 XS(pl_getoption)
2720 {
2721 IGNORE_UNUSED_PARAMS;
2722 RETURN_IF_ABORTED;
2723 dXSARGS;
2724 if (items != 1) PERL_ERROR("Usage: $int = g_getoption($name).");
2725
2726 STRLEN n_a;
2727 const char* optname = SvPV(ST(0), n_a);
2728 int optval;
2729
2730 if (!GSF_getoption(optname, &optval)) {
2731 PERL_ERROR("g_getoption error: unknown option.");
2732 }
2733
2734 XSRETURN_IV(optval);
2735 }
2736
2737 // -----------------------------------------------------------------------------
2738
XS(pl_setcolor)2739 XS(pl_setcolor)
2740 {
2741 IGNORE_UNUSED_PARAMS;
2742 RETURN_IF_ABORTED;
2743 dXSARGS;
2744 if (items != 4) PERL_ERROR("Usage: @oldrgb = g_setcolor($name,$r,$g,$b).");
2745
2746 STRLEN n_a;
2747 const char* colname = SvPV(ST(0), n_a);
2748 wxColor newcol(SvIV(ST(1)), SvIV(ST(2)), SvIV(ST(3)));
2749 wxColor oldcol;
2750
2751 if (!GSF_setcolor(colname, newcol, oldcol)) {
2752 PERL_ERROR("g_setcolor error: unknown color.");
2753 }
2754
2755 // return old r,g,b values (simplifies saving and restoring colors)
2756 SP -= items;
2757 XPUSHs(sv_2mortal(newSViv(oldcol.Red())));
2758 XPUSHs(sv_2mortal(newSViv(oldcol.Green())));
2759 XPUSHs(sv_2mortal(newSViv(oldcol.Blue())));
2760 XSRETURN(3);
2761 }
2762
2763 // -----------------------------------------------------------------------------
2764
XS(pl_getcolor)2765 XS(pl_getcolor)
2766 {
2767 IGNORE_UNUSED_PARAMS;
2768 RETURN_IF_ABORTED;
2769 dXSARGS;
2770 if (items != 1) PERL_ERROR("Usage: @rgb = g_getcolor($name).");
2771
2772 STRLEN n_a;
2773 const char* colname = SvPV(ST(0), n_a);
2774 wxColor color;
2775
2776 if (!GSF_getcolor(colname, color)) {
2777 PERL_ERROR("g_getcolor error: unknown color.");
2778 }
2779
2780 // return r,g,b values
2781 SP -= items;
2782 XPUSHs(sv_2mortal(newSViv(color.Red())));
2783 XPUSHs(sv_2mortal(newSViv(color.Green())));
2784 XPUSHs(sv_2mortal(newSViv(color.Blue())));
2785 XSRETURN(3);
2786 }
2787
2788 // -----------------------------------------------------------------------------
2789
XS(pl_setclipstr)2790 XS(pl_setclipstr)
2791 {
2792 IGNORE_UNUSED_PARAMS;
2793 RETURN_IF_ABORTED;
2794 dXSARGS;
2795 if (items != 1) PERL_ERROR("Usage: g_setclipstr($string).");
2796
2797 STRLEN n_a;
2798 const char* clipstr = SvPV(ST(0), n_a);
2799 wxString wxs_clip(clipstr, wxConvLocal);
2800
2801 mainptr->CopyTextToClipboard(wxs_clip);
2802
2803 XSRETURN(0);
2804 }
2805
2806 // -----------------------------------------------------------------------------
2807
XS(pl_getclipstr)2808 XS(pl_getclipstr)
2809 {
2810 IGNORE_UNUSED_PARAMS;
2811 RETURN_IF_ABORTED;
2812 dXSARGS;
2813 if (items > 0) PERL_ERROR("Usage: $string = g_getclipstr().");
2814
2815 wxTextDataObject data;
2816 if ( !mainptr->GetTextFromClipboard(&data) ) PERL_ERROR("Could not get data from clipboard!");
2817
2818 wxString wxs_clipstr = data.GetText();
2819 XSRETURN_PV((const char*)wxs_clipstr.mb_str(wxConvLocal));
2820 }
2821
2822 // -----------------------------------------------------------------------------
2823
XS(pl_getstring)2824 XS(pl_getstring)
2825 {
2826 IGNORE_UNUSED_PARAMS;
2827 RETURN_IF_ABORTED;
2828 dXSARGS;
2829 if (items < 1 || items > 3)
2830 PERL_ERROR("Usage: $string = g_getstring($prompt,$default='',$title='').");
2831
2832 STRLEN n_a;
2833 const char* prompt = SvPV(ST(0), n_a);
2834 const char* initial = "";
2835 const char* title = "";
2836 if (items > 1) initial = SvPV(ST(1),n_a);
2837 if (items > 2) title = SvPV(ST(2),n_a);
2838
2839 wxString result;
2840 if ( !GetString(wxString(title,wxConvLocal), wxString(prompt,wxConvLocal),
2841 wxString(initial,wxConvLocal), result) ) {
2842 // user hit Cancel button
2843 AbortPerlScript();
2844 Perl_croak(aTHX_ NULL);
2845 }
2846
2847 XSRETURN_PV((const char*)result.mb_str(wxConvLocal));
2848 }
2849
2850 // -----------------------------------------------------------------------------
2851
XS(pl_getxy)2852 XS(pl_getxy)
2853 {
2854 IGNORE_UNUSED_PARAMS;
2855 RETURN_IF_ABORTED;
2856 dXSARGS;
2857 if (items != 0) PERL_ERROR("Usage: $string = g_getxy().");
2858
2859 statusptr->CheckMouseLocation(mainptr->infront); // sets mousepos
2860 if (viewptr->showcontrols) mousepos = wxEmptyString;
2861
2862 XSRETURN_PV((const char*)mousepos.mb_str(wxConvLocal));
2863 }
2864
2865 // -----------------------------------------------------------------------------
2866
XS(pl_getevent)2867 XS(pl_getevent)
2868 {
2869 IGNORE_UNUSED_PARAMS;
2870 RETURN_IF_ABORTED;
2871 dXSARGS;
2872 if (items > 1) PERL_ERROR("Usage: $string = g_getevent($get=1).");
2873
2874 int get = 1;
2875 if (items > 0) get = SvIV(ST(0));
2876
2877 wxString event;
2878 GSF_getevent(event, get);
2879
2880 XSRETURN_PV((const char*)event.mb_str(wxConvLocal));
2881 }
2882
2883 // -----------------------------------------------------------------------------
2884
XS(pl_doevent)2885 XS(pl_doevent)
2886 {
2887 IGNORE_UNUSED_PARAMS;
2888 RETURN_IF_ABORTED;
2889 dXSARGS;
2890 if (items != 1) PERL_ERROR("Usage: g_doevent($string).");
2891
2892 STRLEN n_a;
2893 const char* event = SvPV(ST(0), n_a);
2894
2895 if (event[0]) {
2896 const char* err = GSF_doevent(wxString(event,wxConvLocal));
2897 if (err) PERL_ERROR(err);
2898 }
2899
2900 XSRETURN(0);
2901 }
2902
2903 // -----------------------------------------------------------------------------
2904
XS(pl_getkey)2905 XS(pl_getkey)
2906 {
2907 IGNORE_UNUSED_PARAMS;
2908 RETURN_IF_ABORTED;
2909 dXSARGS;
2910 if (items != 0) PERL_ERROR("Usage: $char = g_getkey().");
2911
2912 char s[2]; // room for char + NULL
2913 s[0] = GSF_getkey();
2914 s[1] = '\0';
2915
2916 XSRETURN_PV(s);
2917 }
2918
2919 // -----------------------------------------------------------------------------
2920
XS(pl_dokey)2921 XS(pl_dokey)
2922 {
2923 IGNORE_UNUSED_PARAMS;
2924 RETURN_IF_ABORTED;
2925 dXSARGS;
2926 if (items != 1) PERL_ERROR("Usage: g_dokey($char).");
2927
2928 STRLEN n_a;
2929 const char* ascii = SvPV(ST(0), n_a);
2930
2931 GSF_dokey(ascii);
2932
2933 XSRETURN(0);
2934 }
2935
2936 // -----------------------------------------------------------------------------
2937
XS(pl_show)2938 XS(pl_show)
2939 {
2940 IGNORE_UNUSED_PARAMS;
2941 RETURN_IF_ABORTED;
2942 dXSARGS;
2943 if (items != 1) PERL_ERROR("Usage: g_show($string).");
2944
2945 STRLEN n_a;
2946 const char* s = SvPV(ST(0), n_a);
2947
2948 inscript = false;
2949 statusptr->DisplayMessage(wxString(s,wxConvLocal));
2950 inscript = true;
2951 // make sure status bar is visible
2952 if (!showstatus) mainptr->ToggleStatusBar();
2953
2954 XSRETURN(0);
2955 }
2956
2957 // -----------------------------------------------------------------------------
2958
XS(pl_error)2959 XS(pl_error)
2960 {
2961 IGNORE_UNUSED_PARAMS;
2962 RETURN_IF_ABORTED;
2963 dXSARGS;
2964 if (items != 1) PERL_ERROR("Usage: g_error($string).");
2965
2966 STRLEN n_a;
2967 const char* s = SvPV(ST(0), n_a);
2968
2969 inscript = false;
2970 statusptr->ErrorMessage(wxString(s,wxConvLocal));
2971 inscript = true;
2972 // make sure status bar is visible
2973 if (!showstatus) mainptr->ToggleStatusBar();
2974
2975 XSRETURN(0);
2976 }
2977
2978 // -----------------------------------------------------------------------------
2979
XS(pl_warn)2980 XS(pl_warn)
2981 {
2982 IGNORE_UNUSED_PARAMS;
2983 RETURN_IF_ABORTED;
2984 dXSARGS;
2985 if (items != 1) PERL_ERROR("Usage: g_warn($string).");
2986
2987 STRLEN n_a;
2988 const char* s = SvPV(ST(0), n_a);
2989
2990 Warning(wxString(s,wxConvLocal));
2991
2992 XSRETURN(0);
2993 }
2994
2995 // -----------------------------------------------------------------------------
2996
XS(pl_note)2997 XS(pl_note)
2998 {
2999 IGNORE_UNUSED_PARAMS;
3000 RETURN_IF_ABORTED;
3001 dXSARGS;
3002 if (items != 1) PERL_ERROR("Usage: g_note($string).");
3003
3004 STRLEN n_a;
3005 const char* s = SvPV(ST(0), n_a);
3006
3007 Note(wxString(s,wxConvLocal));
3008
3009 XSRETURN(0);
3010 }
3011
3012 // -----------------------------------------------------------------------------
3013
XS(pl_help)3014 XS(pl_help)
3015 {
3016 IGNORE_UNUSED_PARAMS;
3017 RETURN_IF_ABORTED;
3018 dXSARGS;
3019 if (items != 1) PERL_ERROR("Usage: g_help($string).");
3020
3021 STRLEN n_a;
3022 const char* htmlfile = SvPV(ST(0), n_a);
3023
3024 ShowHelp(wxString(htmlfile,wxConvLocal));
3025
3026 XSRETURN(0);
3027 }
3028
3029 // -----------------------------------------------------------------------------
3030
XS(pl_check)3031 XS(pl_check)
3032 {
3033 IGNORE_UNUSED_PARAMS;
3034 // don't call checkevents() here otherwise we can't safely write code like
3035 // if (g_getlayer() == target) {
3036 // g_check(0);
3037 // ... do stuff to target layer ...
3038 // g_check(1);
3039 // }
3040 // RETURN_IF_ABORTED;
3041 dXSARGS;
3042 if (items != 1) PERL_ERROR("Usage: g_check($bool).");
3043
3044 allowcheck = (SvIV(ST(0)) != 0);
3045
3046 XSRETURN(0);
3047 }
3048
3049 // -----------------------------------------------------------------------------
3050
XS(pl_exit)3051 XS(pl_exit)
3052 {
3053 IGNORE_UNUSED_PARAMS;
3054 RETURN_IF_ABORTED;
3055 dXSARGS;
3056 if (items > 1) PERL_ERROR("Usage: g_exit($string='').");
3057
3058 STRLEN n_a;
3059 const char* err = (items == 1) ? SvPV(ST(0),n_a) : NULL;
3060
3061 GSF_exit(wxString(err, wxConvLocal));
3062 AbortPerlScript();
3063 Perl_croak(aTHX_ NULL);
3064 }
3065
3066 // -----------------------------------------------------------------------------
3067
XS(pl_fatal)3068 XS(pl_fatal)
3069 {
3070 IGNORE_UNUSED_PARAMS;
3071 // don't call RETURN_IF_ABORTED;
3072 dXSARGS;
3073 // don't call PERL_ERROR in here
3074 if (items != 1) Warning(_("Bug: usage is g_fatal($string)"));
3075
3076 STRLEN n_a;
3077 const char* err = SvPV(ST(0),n_a);
3078
3079 if (scripterr == wxString(abortmsg,wxConvLocal)) {
3080 // this can happen in Perl 5.14 so don't change scripterr
3081 // otherwise a message box will appear
3082 } else {
3083 // store message in global string (shown after script finishes)
3084 scripterr = wxString(err, wxConvLocal);
3085 }
3086
3087 XSRETURN(0);
3088 }
3089
3090 // -----------------------------------------------------------------------------
3091
3092 // xs_init is passed into perl_parse and initializes statically linked extensions
3093
xs_init(pTHX)3094 EXTERN_C void xs_init(pTHX)
3095 {
3096 #ifdef __WXMSW__
3097 wxUnusedVar(my_perl);
3098 #endif
3099 const char* file = __FILE__;
3100 dXSUB_SYS;
3101
3102 // DynaLoader allows dynamic loading of other Perl extensions
3103 newXS((char*)"DynaLoader::boot_DynaLoader", boot_DynaLoader, (char*)file);
3104
3105 // filing
3106 newXS((char*)"g_open", pl_open, (char*)file);
3107 newXS((char*)"g_save", pl_save, (char*)file);
3108 newXS((char*)"g_opendialog", pl_opendialog, (char*)file);
3109 newXS((char*)"g_savedialog", pl_savedialog, (char*)file);
3110 newXS((char*)"g_load", pl_load, (char*)file);
3111 newXS((char*)"g_store", pl_store, (char*)file);
3112 newXS((char*)"g_setdir", pl_setdir, (char*)file);
3113 newXS((char*)"g_getdir", pl_getdir, (char*)file);
3114 // next two are deprecated (use g_getdir)
3115 newXS((char*)"g_appdir", pl_appdir, (char*)file);
3116 newXS((char*)"g_datadir", pl_datadir, (char*)file);
3117 // editing
3118 newXS((char*)"g_new", pl_new, (char*)file);
3119 newXS((char*)"g_cut", pl_cut, (char*)file);
3120 newXS((char*)"g_copy", pl_copy, (char*)file);
3121 newXS((char*)"g_clear", pl_clear, (char*)file);
3122 newXS((char*)"g_paste", pl_paste, (char*)file);
3123 newXS((char*)"g_shrink", pl_shrink, (char*)file);
3124 newXS((char*)"g_randfill", pl_randfill, (char*)file);
3125 newXS((char*)"g_flip", pl_flip, (char*)file);
3126 newXS((char*)"g_rotate", pl_rotate, (char*)file);
3127 newXS((char*)"g_parse", pl_parse, (char*)file);
3128 newXS((char*)"g_transform", pl_transform, (char*)file);
3129 newXS((char*)"g_evolve", pl_evolve, (char*)file);
3130 newXS((char*)"g_putcells", pl_putcells, (char*)file);
3131 newXS((char*)"g_getcells", pl_getcells, (char*)file);
3132 newXS((char*)"g_join", pl_join, (char*)file);
3133 newXS((char*)"g_hash", pl_hash, (char*)file);
3134 newXS((char*)"g_getclip", pl_getclip, (char*)file);
3135 newXS((char*)"g_select", pl_select, (char*)file);
3136 newXS((char*)"g_getrect", pl_getrect, (char*)file);
3137 newXS((char*)"g_getselrect", pl_getselrect, (char*)file);
3138 newXS((char*)"g_setcell", pl_setcell, (char*)file);
3139 newXS((char*)"g_getcell", pl_getcell, (char*)file);
3140 newXS((char*)"g_setcursor", pl_setcursor, (char*)file);
3141 newXS((char*)"g_getcursor", pl_getcursor, (char*)file);
3142 // control
3143 newXS((char*)"g_empty", pl_empty, (char*)file);
3144 newXS((char*)"g_run", pl_run, (char*)file);
3145 newXS((char*)"g_step", pl_step, (char*)file);
3146 newXS((char*)"g_setstep", pl_setstep, (char*)file);
3147 newXS((char*)"g_getstep", pl_getstep, (char*)file);
3148 newXS((char*)"g_setbase", pl_setbase, (char*)file);
3149 newXS((char*)"g_getbase", pl_getbase, (char*)file);
3150 newXS((char*)"g_advance", pl_advance, (char*)file);
3151 newXS((char*)"g_reset", pl_reset, (char*)file);
3152 newXS((char*)"g_setgen", pl_setgen, (char*)file);
3153 newXS((char*)"g_getgen", pl_getgen, (char*)file);
3154 newXS((char*)"g_getpop", pl_getpop, (char*)file);
3155 newXS((char*)"g_numstates", pl_numstates, (char*)file);
3156 newXS((char*)"g_numalgos", pl_numalgos, (char*)file);
3157 newXS((char*)"g_setalgo", pl_setalgo, (char*)file);
3158 newXS((char*)"g_getalgo", pl_getalgo, (char*)file);
3159 newXS((char*)"g_setrule", pl_setrule, (char*)file);
3160 newXS((char*)"g_getrule", pl_getrule, (char*)file);
3161 newXS((char*)"g_getwidth", pl_getwidth, (char*)file);
3162 newXS((char*)"g_getheight", pl_getheight, (char*)file);
3163 // viewing
3164 newXS((char*)"g_setpos", pl_setpos, (char*)file);
3165 newXS((char*)"g_getpos", pl_getpos, (char*)file);
3166 newXS((char*)"g_setmag", pl_setmag, (char*)file);
3167 newXS((char*)"g_getmag", pl_getmag, (char*)file);
3168 newXS((char*)"g_fit", pl_fit, (char*)file);
3169 newXS((char*)"g_fitsel", pl_fitsel, (char*)file);
3170 newXS((char*)"g_visrect", pl_visrect, (char*)file);
3171 newXS((char*)"g_update", pl_update, (char*)file);
3172 newXS((char*)"g_autoupdate", pl_autoupdate, (char*)file);
3173 // layers
3174 newXS((char*)"g_addlayer", pl_addlayer, (char*)file);
3175 newXS((char*)"g_clone", pl_clone, (char*)file);
3176 newXS((char*)"g_duplicate", pl_duplicate, (char*)file);
3177 newXS((char*)"g_dellayer", pl_dellayer, (char*)file);
3178 newXS((char*)"g_movelayer", pl_movelayer, (char*)file);
3179 newXS((char*)"g_setlayer", pl_setlayer, (char*)file);
3180 newXS((char*)"g_getlayer", pl_getlayer, (char*)file);
3181 newXS((char*)"g_numlayers", pl_numlayers, (char*)file);
3182 newXS((char*)"g_maxlayers", pl_maxlayers, (char*)file);
3183 newXS((char*)"g_setname", pl_setname, (char*)file);
3184 newXS((char*)"g_getname", pl_getname, (char*)file);
3185 newXS((char*)"g_setcolors", pl_setcolors, (char*)file);
3186 newXS((char*)"g_getcolors", pl_getcolors, (char*)file);
3187 // miscellaneous
3188 newXS((char*)"g_setoption", pl_setoption, (char*)file);
3189 newXS((char*)"g_getoption", pl_getoption, (char*)file);
3190 newXS((char*)"g_setcolor", pl_setcolor, (char*)file);
3191 newXS((char*)"g_getcolor", pl_getcolor, (char*)file);
3192 newXS((char*)"g_setclipstr", pl_setclipstr, (char*)file);
3193 newXS((char*)"g_getclipstr", pl_getclipstr, (char*)file);
3194 newXS((char*)"g_getstring", pl_getstring, (char*)file);
3195 newXS((char*)"g_getxy", pl_getxy, (char*)file);
3196 newXS((char*)"g_getevent", pl_getevent, (char*)file);
3197 newXS((char*)"g_doevent", pl_doevent, (char*)file);
3198 // next two are deprecated (use g_getevent and g_doevent)
3199 newXS((char*)"g_getkey", pl_getkey, (char*)file);
3200 newXS((char*)"g_dokey", pl_dokey, (char*)file);
3201 newXS((char*)"g_show", pl_show, (char*)file);
3202 newXS((char*)"g_error", pl_error, (char*)file);
3203 newXS((char*)"g_warn", pl_warn, (char*)file);
3204 newXS((char*)"g_note", pl_note, (char*)file);
3205 newXS((char*)"g_help", pl_help, (char*)file);
3206 newXS((char*)"g_check", pl_check, (char*)file);
3207 newXS((char*)"g_exit", pl_exit, (char*)file);
3208 // internal use only (don't document)
3209 newXS((char*)"g_fatal", pl_fatal, (char*)file);
3210 }
3211
3212 #ifdef PERL510_OR_LATER
3213 static bool inited = false;
3214 #endif
3215
3216 #endif // ENABLE_PERL
3217
3218 // =============================================================================
3219
RunPerlScript(const wxString & filepath)3220 void RunPerlScript(const wxString &filepath)
3221 {
3222 #ifdef ENABLE_PERL
3223
3224 // allow re-entrancy
3225 bool already_in_perl = (my_perl != NULL);
3226
3227 if (!already_in_perl) {
3228 #ifdef USE_PERL_DYNAMIC
3229 if (perldll == NULL) {
3230 // try to load Perl library
3231 if ( !LoadPerlLib() ) return;
3232 }
3233 #endif
3234
3235 // create a dummy environment for initializing the embedded interpreter
3236 static int argc = 3;
3237 static char arg1[] = "-e", arg2[] = "0";
3238 static char *args[] = { NULL, arg1, arg2, NULL }, **argv = &args[0];
3239
3240 #ifdef PERL510_OR_LATER
3241 static char *ens[] = { NULL }, **env = &ens[0];
3242 if (!inited) {
3243 PERL_SYS_INIT3(&argc, &argv, &env);
3244 inited = true;
3245 }
3246 #endif
3247
3248 my_perl = perl_alloc();
3249 if (!my_perl) {
3250 Warning(_("Could not create Perl interpreter!"));
3251 return;
3252 }
3253
3254 PL_perl_destruct_level = 1;
3255 perl_construct(my_perl);
3256
3257 // set PERL_EXIT_DESTRUCT_END flag so that perl_destruct will execute
3258 // any END blocks in given script (this flag requires Perl 5.7.2+)
3259 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
3260
3261 perl_parse(my_perl, xs_init, argc, argv, NULL);
3262 perl_run(my_perl);
3263 }
3264
3265 // convert any \ to \\ and then convert any ' to \'
3266 wxString fpath = filepath;
3267 fpath.Replace(wxT("\\"), wxT("\\\\"));
3268 fpath.Replace(wxT("'"), wxT("\\'"));
3269
3270 // construct a command to run the given script file and capture errors
3271 wxString command = wxT("do '") + fpath + wxT("'; g_fatal($@) if $@;");
3272 perl_eval_pv(command.mb_str(wxConvLocal), TRUE);
3273
3274 if (!already_in_perl) {
3275 // any END blocks will now be executed by perl_destruct, so we temporarily
3276 // clear scripterr so that RETURN_IF_ABORTED won't call Perl_croak;
3277 // this allows g_* commands in END blocks to work after user hits escape
3278 // or if g_exit has been called
3279 wxString savestring = scripterr;
3280 scripterr = wxEmptyString;
3281 PL_perl_destruct_level = 1;
3282 perl_destruct(my_perl);
3283 scripterr = savestring;
3284
3285 perl_free(my_perl);
3286 my_perl = NULL;
3287 }
3288
3289 #else
3290
3291 Warning(_("Sorry, but Perl scripting is no longer supported."));
3292
3293 #endif // ENABLE_PERL
3294 }
3295
3296 // -----------------------------------------------------------------------------
3297
AbortPerlScript()3298 void AbortPerlScript()
3299 {
3300 #ifdef ENABLE_PERL
3301
3302 scripterr = wxString(abortmsg,wxConvLocal);
3303 // can't call Perl_croak here (done via RETURN_IF_ABORTED)
3304
3305 #endif // ENABLE_PERL
3306 }
3307
3308 // -----------------------------------------------------------------------------
3309
FinishPerlScripting()3310 void FinishPerlScripting()
3311 {
3312 #ifdef ENABLE_PERL
3313
3314 #ifdef PERL510_OR_LATER
3315 if (inited) {
3316 PERL_SYS_TERM();
3317 }
3318 #endif
3319
3320 #ifdef USE_PERL_DYNAMIC
3321 // probably don't really need to do this
3322 FreePerlLib();
3323 #endif
3324
3325 #endif // ENABLE_PERL
3326 }
3327