├── debian ├── compat ├── libguidefate-qt.install ├── libguidefate-tk.install ├── libguidefate-wx.install ├── libguidefate-gtk.install ├── libguidefate-gtk2.install ├── libguidefate-html.install ├── libguidefate-web.install ├── libguidefate-win32.install ├── libguidefate-common-perl.docs ├── rules ├── changelog.in ├── libguidefate-common-perl.install ├── copyright └── control ├── Examples ├── PlantsList │ ├── plants │ │ ├── genera.csv │ │ └── images │ │ │ ├── noImage.png │ │ │ ├── unresolved.png │ │ │ └── Readme.txt │ └── plantslist.pl ├── rpsls │ ├── Spock.jpg │ ├── paper.jpg │ ├── rock.jpg │ ├── Lizard.jpg │ ├── sister.jpg │ ├── scissors.jpg │ └── rpsls.pl ├── bounce │ ├── ball.svg │ ├── clock.svg │ ├── ecg.svg │ └── bounce.pl ├── Readme.md ├── HelloWorld.pl ├── GUIgnuplot │ ├── InterlockingTori.plt │ └── GUIgnuplot.pl ├── GFModules.pl ├── texteditor.pl ├── Servocontroller │ └── Servocontroller.pl ├── screenshot.pl.old ├── calculator.pl ├── RunDemos.pl ├── screenshot.pl ├── ImageMagickGUI │ └── ImageMagickGUI.pl ├── SimpleLogo │ └── SimpleLogo.pl └── scripts │ └── logo.ext ├── Changes ├── AUTHORS ├── support_files ├── Wx-Perl-Imagick │ ├── Readme.txt │ └── Wx-Perl-Imagick-0.02.tar.gz └── Restructure.txt ├── t ├── 01.pod.t ├── 00.load.t ├── 04.kwalitee.t └── 03.pod_coverage.t ├── .gitignore ├── MANIFEST.SKIP ├── META.yml ├── META.json ├── Makefile.PL ├── man └── GUIDeFATE.pod ├── perl-GUIDeFATE.spec.in ├── INSTALL ├── lib ├── GUIDeFATE │ ├── GFtemplate.pm │ ├── GFhtml.pm │ ├── GFprima.pm │ ├── GFwin32.pm │ ├── GFqt.pm │ └── GFgtk.pm ├── Language │ └── SIMPLE │ │ └── logo.ext └── GUIDeFATE.pm └── README.md /debian/compat: -------------------------------------------------------------------------------- 1 | 12 2 | -------------------------------------------------------------------------------- /Examples/PlantsList/plants/genera.csv: -------------------------------------------------------------------------------- 1 | Data from: 23/11/21 2 | -------------------------------------------------------------------------------- /debian/libguidefate-qt.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFqt.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-tk.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFtk.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-wx.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFwx.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-gtk.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFgtk.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-gtk2.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFgtk2.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-html.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFhtml.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-web.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFweb.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-win32.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE/GFwin32.pm 2 | -------------------------------------------------------------------------------- /debian/libguidefate-common-perl.docs: -------------------------------------------------------------------------------- 1 | AUTHORS 2 | Changes 3 | INSTALL 4 | LICENSE 5 | README.md 6 | -------------------------------------------------------------------------------- /Examples/rpsls/Spock.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/rpsls/Spock.jpg -------------------------------------------------------------------------------- /Examples/rpsls/paper.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/rpsls/paper.jpg -------------------------------------------------------------------------------- /Examples/rpsls/rock.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/rpsls/rock.jpg -------------------------------------------------------------------------------- /Examples/bounce/ball.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | -------------------------------------------------------------------------------- /Examples/rpsls/Lizard.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/rpsls/Lizard.jpg -------------------------------------------------------------------------------- /Examples/rpsls/sister.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/rpsls/sister.jpg -------------------------------------------------------------------------------- /Examples/rpsls/scissors.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/rpsls/scissors.jpg -------------------------------------------------------------------------------- /debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | 3 | BUILD_ROOT=$(CURDIR)/debian/GUIDeFATE 4 | 5 | 6 | %: 7 | dh $@ 8 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 0.13 2019-07-01 2 | - New release 3 | 4 | 0.12 2018-07-16 5 | - New Release 6 | 7 | 0.11 2018-04-25 8 | - Initial release 9 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Saif Ahmed 2 | Lars Dɪᴇᴄᴋᴏᴡ 3 | Olivier Lahaye 4 | -------------------------------------------------------------------------------- /Examples/PlantsList/plants/images/noImage.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/PlantsList/plants/images/noImage.png -------------------------------------------------------------------------------- /Examples/PlantsList/plants/images/unresolved.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/Examples/PlantsList/plants/images/unresolved.png -------------------------------------------------------------------------------- /support_files/Wx-Perl-Imagick/Readme.txt: -------------------------------------------------------------------------------- 1 | This version of Wx-Perl-Imagick installs in Linux systems 2 | Extract the tar file, and follow the instructions 3 | -------------------------------------------------------------------------------- /support_files/Wx-Perl-Imagick/Wx-Perl-Imagick-0.02.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/saiftynet/GUIDeFATE/HEAD/support_files/Wx-Perl-Imagick/Wx-Perl-Imagick-0.02.tar.gz -------------------------------------------------------------------------------- /Examples/PlantsList/plants/images/Readme.txt: -------------------------------------------------------------------------------- 1 | This folder and these images are for plantslist.pl. 2 | When Plantslist.pl is run, it is the cache for the plant images found. 3 | -------------------------------------------------------------------------------- /t/01.pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | eval "use Test::Pod 1.14"; 8 | plan skip_all => 'Test::Pod 1.14 required' if $@; 9 | all_pod_files_ok(); 10 | -------------------------------------------------------------------------------- /debian/changelog.in: -------------------------------------------------------------------------------- 1 | libguidefate-perl (__VERSION__-1) unstable; urgency=low 2 | 3 | * New upstream version released. 4 | 5 | -- Olivier Lahaye Thu, 03 Oct 2019 10:30:19 +0200 6 | 7 | -------------------------------------------------------------------------------- /t/00.load.t: -------------------------------------------------------------------------------- 1 | use Test; 2 | use Carp; 3 | 4 | BEGIN { 5 | plan tests => 1; 6 | } 7 | 8 | # 1/ Test use 9 | eval { 10 | use GUIDeFATE; 11 | return 1; 12 | }; 13 | ok($@,'') or croak("Couldn't use GUIDeFATE.pm"); 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | Makefile.old 3 | *.tar.bz2 4 | *.tar.gz 5 | *.tar 6 | *.bak 7 | MANIFEST 8 | Build$ 9 | cover_db 10 | pm_to_blib 11 | blib 12 | MYMETA.* 13 | *.spec 14 | debian/changelog 15 | plotter.png 16 | dial.svg 17 | simplelogo.svg 18 | -------------------------------------------------------------------------------- /Examples/Readme.md: -------------------------------------------------------------------------------- 1 | ## GUIDeFATE Examples 2 | To test, just run the following command: 3 | perl ./RunDemos.sh 4 | backend can be any of: win32 wx tk qt html web gtk gtk2 (provided that perl GUI module is installed). 5 | backend is optionnal and defaults to tk 6 | -------------------------------------------------------------------------------- /debian/libguidefate-common-perl.install: -------------------------------------------------------------------------------- 1 | usr/share/perl5/GUIDeFATE.pod 2 | usr/share/perl5/GUIDeFATE.pm 3 | usr/share/perl5/GUIDeFATE/GFtemplate.pm 4 | usr/share/perl5/Language/SIMPLE.pm 5 | usr/share/perl5/Language/SIMPLE/logo.ext 6 | usr/share/man/man3/GUIDeFATE.3pm 7 | -------------------------------------------------------------------------------- /t/04.kwalitee.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | if (!$ENV{RELEASE_TESTING}) { 8 | plan skip_all => 'These tests are for only for release candidate testing. Enable with RELEASE_TESTING=1'; 9 | } 10 | 11 | eval "use Test::Kwalitee"; 12 | plan skip_all => 'Test::Kwalitee required' if $@; 13 | -------------------------------------------------------------------------------- /t/03.pod_coverage.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | if (!$ENV{RELEASE_TESTING}) { 4 | plan skip_all => 'These tests are for only for release candidate testing. Enable with RELEASE_TESTING=1'; 5 | } 6 | 7 | eval "use Test::Pod::Coverage"; 8 | 9 | if( $@ ) { 10 | plan skip_all => "Test::Pod::Coverage required for testing POD"; 11 | } 12 | else { 13 | plan tests => 1; 14 | pod_coverage_ok( "GUIDeFATE" ); 15 | } 16 | -------------------------------------------------------------------------------- /Examples/HelloWorld.pl: -------------------------------------------------------------------------------- 1 | #!perl 2 | use GUIDeFATE; 3 | my $window=<new($window,$backend,$assist); 16 | my $frame=$gui->getFrame||$gui; 17 | $gui->MainLoop; 18 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | # Avoid version control files. 2 | \B\.git\b 3 | .gitignore 4 | 5 | # Avoid Makemaker generated and utility files. 6 | \bMakefile$ 7 | \bblib 8 | \bMakeMaker-\d 9 | \bpm_to_blib$ 10 | \bblibdirs$ 11 | ^MANIFEST\.SKIP$ 12 | 13 | # Avoid Module::Build generated and utility files. 14 | \bBuild$ 15 | \bBuild.bat$ 16 | \b_build 17 | 18 | # Avoid temp and backup files. 19 | ~$ 20 | \.tmp$ 21 | \.old$ 22 | \.bak$ 23 | \#$ 24 | \.# 25 | \.rej$ 26 | ^#.*#$ 27 | 28 | # Avoid archives of this distribution 29 | ^cover_db 30 | ^MYMETA\. 31 | support_files 32 | -------------------------------------------------------------------------------- /META.yml: -------------------------------------------------------------------------------- 1 | --- 2 | abstract: 'Graphical User Interface Design From A Text Editor' 3 | author: 4 | - 'Saif Ahmed ' 5 | build_requires: 6 | Test::More: 1.001014 7 | configure_requires: 8 | ExtUtils::MakeMaker: 0 9 | dynamic_config: 0 10 | generated_by: 'ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.120921' 11 | license: perl 12 | meta-spec: 13 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 14 | version: 1.4 15 | name: GUIDeFATE 16 | no_index: 17 | directory: 18 | - t 19 | - inc 20 | requires: {} 21 | version: 0.13 22 | -------------------------------------------------------------------------------- /debian/copyright: -------------------------------------------------------------------------------- 1 | This package was debianized by Olivier Lahaye 2 | 3 | Upstream Author: 4 | saiftynet Saif Ahmed 5 | 6 | Copyright 2017-2021 saiftynet 7 | 8 | This is free software; you can redistribute it and/or 9 | modify it under the terms of the GNU General Public 10 | License as published by the Free Software Foundation; either 11 | version 3 of the License. 12 | 13 | This library is distributed in the hope that it will be useful, 14 | but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | General Public License for more details. 17 | 18 | On Debian systems, the complete text of the GNU General Public 19 | License, version 3, can be found in /usr/share/common-licenses/GPL-3. 20 | -------------------------------------------------------------------------------- /Examples/GUIgnuplot/InterlockingTori.plt: -------------------------------------------------------------------------------- 1 | set multiplot title "Interlocking Tori" 2 | set title "PM3D surface\nno depth sorting" 3 | 4 | set parametric 5 | set urange [-pi:pi] 6 | set vrange [-pi:pi] 7 | set isosamples 50,20 8 | 9 | set origin -0.02,0.0 10 | set size 0.55, 0.9 11 | 12 | unset key 13 | unset xtics 14 | unset ytics 15 | unset ztics 16 | set border 0 17 | set view 60, 30, 1.5, 0.9 18 | unset colorbox 19 | 20 | set pm3d scansbackward 21 | splot cos(u)+.5*cos(u)*cos(v),sin(u)+.5*sin(u)*cos(v),.5*sin(v) with pm3d, 1+cos(u)+.5*cos(u)*cos(v),.5*sin(v),sin(u)+.5*sin(u)*cos(v) with pm3d 22 | 23 | set title "PM3D surface\ndepth sorting" 24 | 25 | set origin 0.40,0.0 26 | set size 0.55, 0.9 27 | set colorbox vertical user origin 0.9, 0.15 size 0.02, 0.50 28 | set format cb "%.1f" 29 | 30 | set pm3d depthorder 31 | splot cos(u)+.5*cos(u)*cos(v),sin(u)+.5*sin(u)*cos(v),.5*sin(v) with pm3d, 1+cos(u)+.5*cos(u)*cos(v),.5*sin(v),sin(u)+.5*sin(u)*cos(v) with pm3d 32 | 33 | unset multiplot 34 | 35 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "Graphical User Interface Design From A Text Editor", 3 | "author" : [ 4 | "Saif Ahmed " 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.120921", 8 | "license" : [ 9 | "perl_5" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : "2" 14 | }, 15 | "name" : "GUIDeFATE", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "inc" 20 | ] 21 | }, 22 | "prereqs" : { 23 | "build" : { 24 | "requires" : { 25 | "Test::More" : "1.001014" 26 | } 27 | }, 28 | "configure" : { 29 | "requires" : { 30 | "ExtUtils::MakeMaker" : "0" 31 | } 32 | }, 33 | "runtime" : { 34 | "requires" : {} 35 | } 36 | }, 37 | "release_status" : "stable", 38 | "version" : "0.13" 39 | } 40 | -------------------------------------------------------------------------------- /Examples/bounce/clock.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 1 4 | 2 5 | 3 6 | 4 7 | 5 8 | 6 9 | 7 10 | 8 11 | 9 12 | 10 13 | 11 14 | 12 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /Examples/GFModules.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that calls the test files in scripts folder 3 | #uses GUIDeFATE (which in turn depends on Wx or Tk) 4 | 5 | use strict; 6 | use warnings; 7 | use GUIDeFATE; 8 | 9 | my @workingModules; 10 | 11 | eval { 12 | eval "use GUIDeFATE" or die; 13 | }; 14 | if ($@ && $@ =~ /GUIDeFATE/) { 15 | # print " GUIDeFATE not installed\n"; 16 | exit; 17 | } 18 | # contains list of modules reuired for each backend 19 | # in order of preference 20 | foreach my $module ( qw/ GFwin32 GFwx GFtk GFqt GFhtml GFweb GFgtk / ) { 21 | eval { 22 | eval "use GUIDeFATE::$module" or die; 23 | }; 24 | if ($@ && $@ =~ /$module/) { 25 | # print " $module not installed\n"; 26 | } 27 | else { 28 | # print " $module found\n"; 29 | my $m=$module; 30 | $m=~s/^GF//; 31 | push (@workingModules, ucfirst $m); 32 | } 33 | } 34 | if (! $workingModules[0]){ # at least one module works 35 | # print "no working GFxx modules intalled\n"; 36 | exit; 37 | }; 38 | 39 | my $backends=join(",",@workingModules); 40 | print $backends; 41 | -------------------------------------------------------------------------------- /support_files/Restructure.txt: -------------------------------------------------------------------------------- 1 | Olivier Lahaye suggeted a restructure to enable easier installation 2 | 3 | a/ create a directory named support_files (or what ever matches the things that are not part of the package but that are still usefull) 4 | b/ move src/{Makefile.PL,debian,perl-GUIDeFATE.spec.in} to ./ 5 | c/ move TestEnvironment to support files 6 | d/ move WXPerlImagick to support_files 7 | e/ move *.jpg *.png ./Images 8 | f/ move Images to support_files 9 | g/ Clean duplicates between ./Examples and ./src/scripts 10 | h/ not sure that Old Versions shouldbe in git repo. Maybe put that in packages? Note that you can tag your releases 11 | i/ src/license.txt is redundant with /LICENSE 12 | 13 | In My Humble Opinion (you decide), Ideally, once cleaned up, your repo should look like this in / 14 | 15 | Examples 16 | Support_files/WxPerlImagick 17 | Support_files/TestEnvironment 18 | SupportFiles/Win32. 19 | (maybe handle that in Makefile.PL would be better: depending on OS, the correct file is chosen) 20 | Support_Files/Images 21 | 22 | LICENSE 23 | README.md 24 | INSTALL (from src/README keeping only install stuffs as the other parts are redundant with README.md) 25 | MANIFEST.stub (from src/MANIFEST.stub) 26 | Makefile.PM (from src) 27 | lib/* (from src) 28 | man/GUIDeFATE.pod (from src, needs MANIFEST.stub update) 29 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use ExtUtils::MakeMaker; 5 | 6 | WriteMakefile 7 | ( 8 | NAME => 'GUIDeFATE', 9 | VERSION_FROM => 'lib/GUIDeFATE.pm', 10 | AUTHOR => 'Saif Ahmed ', 11 | ABSTRACT_FROM => 'man/GUIDeFATE.pod', 12 | LICENSE => 'Perl', 13 | PREREQ_PM => { 14 | }, 15 | BUILD_REQUIRES => { 16 | 17 | }, 18 | TEST_REQUIRES => { 19 | 'Test::More' => 1.001014, 20 | }, 21 | dist => { 22 | COMPRESS => 'bzip2 -f', 23 | SUFFIX => 'bz2' 24 | }, 25 | realclean => {FILES => "*.old *.bak *.tar.bz2 *.tar *.tar.gz *.spec Makefile debian/changelog"}, 26 | test => {TESTS => 't/*.t'}, 27 | ); 28 | 29 | # Specific part of the Makefile. 30 | 31 | package MY; 32 | 33 | sub dist_core { 34 | my $dist = shift->SUPER::dist_core(@_); 35 | $dist =~ s/^(\S.* :.*)/$1 perl-GUIDeFATE.spec debian\/changelog/mg; 36 | $dist 37 | } 38 | 39 | sub dist_basics { 40 | my $dist_basics = shift->SUPER::dist_basics(@_); 41 | $dist_basics =~ s/^(manifest :)/$1 perl-GUIDeFATE.spec debian\/changelog/mg; 42 | $dist_basics 43 | } 44 | 45 | sub postamble { 46 | my $string = < \$@ 49 | 50 | perl-GUIDeFATE.spec :: perl-GUIDeFATE.spec.in 51 | \tsed -e 's/__VERSION__/\$(VERSION)/' < \$< > \$@ 52 | 53 | deb :: dist 54 | \tmkdir -p /tmp/scdeb 55 | \tmv \$(NAME)-\$(VERSION).tar.bz2 /tmp/scdeb 56 | \tcd /tmp/scdeb && tar -xvzf \$(NAME)-\$(VERSION).tar.bz2 57 | \tcd /tmp/scdeb/\$(NAME)-\$(VERSION) && dpkg-buildpackage -rfakeroot -us -uc 58 | \techo "Debian packages are available in /tmp/scdeb" 59 | \trm -rf /tmp/scdeb/\$(NAME)-\$(VERSION) 60 | 61 | rpm :: dist 62 | \trpmbuild -tb --target noarch \$(NAME)-\$(VERSION).tar.bz2 63 | 64 | srpm :: dist 65 | \trpmbuild -ts --target noarch --nodeps \$(NAME)-\$(VERSION).tar.bz2 66 | 67 | EOF 68 | } 69 | 70 | -------------------------------------------------------------------------------- /Examples/texteditor.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that crtaes a minimalist text editor 3 | #use GUIDeFATE (which in turn depends on Wx) 4 | 5 | use strict; 6 | use warnings; 7 | use GUIDeFATE; 8 | 9 | my $window=<new($window,$backend,$assist); 38 | my $frame=$gui->getFrame||$gui; 39 | $gui->MainLoop; 40 | 41 | sub menu4{ 42 | if($frame->showDialog("Sure?","This will wipe existing text...proceed?","OKC","!")){ 43 | $frame->setValue("TextCtrl1",""); 44 | } 45 | } 46 | sub menu5{ 47 | if($frame->showDialog("Sure?","This will wipe existing text...proceed?","OKC","!")){ 48 | $frame->setValue("TextCtrl1",""); 49 | my $file= $frame->showFileSelectorDialog("Open file",1); 50 | if (open(my $fh, '<:encoding(UTF-8)', $file)) { 51 | while (my $row = <$fh>) { 52 | $frame->appendValue("TextCtrl1",$row) 53 | } 54 | close $fh; 55 | } 56 | } 57 | } 58 | sub menu6{ 59 | my $file= $frame->showFileSelectorDialog("Save file",0); 60 | if (open(my $fh, '>', $file)) { 61 | print $fh $frame->getValue("TextCtrl1"); 62 | close $fh 63 | } 64 | } 65 | 66 | sub menu7{ 67 | $frame->quit(); 68 | } 69 | -------------------------------------------------------------------------------- /Examples/bounce/ecg.svg: -------------------------------------------------------------------------------- 1 | 162 | -------------------------------------------------------------------------------- /debian/control: -------------------------------------------------------------------------------- 1 | Source: libguidefate-perl 2 | Section: misc 3 | Priority: optional 4 | Maintainer: Saif Ahmed 5 | Build-Depends: debhelper (>= 4.0.0) 6 | Standards-Version: 3.7.2.2 7 | 8 | Package: libguidefate-perl 9 | Architecture: all 10 | Depends: libguidefate-common-perl, libguidefate-win32, libguidefate-gtk2, libguidefate-gtk, libguidefate-wx, libguidefate-html, libguidefate-web, libguidefate-qt, libguidefate-tk 11 | Description: GUI Design From A Text Editor 12 | GUIDeFATE enables the user to convert a textual representation into a Graphical 13 | User Interface. It attempts to abstract out the underlying framework. A visually 14 | recognisable pattern is passed as a string to GUIDeFATE and this is transformed 15 | into an Interactive Interface. 16 | 17 | Package: libguidefate-common-perl 18 | Architecture: all 19 | Depends: ${perl:Depends} 20 | Description: Main GUIDeFATE perl module 21 | Main GUIDeFATE perl module 22 | 23 | Package: libguidefate-win32 24 | Architecture: all 25 | Depends: ${perl:Depends}, libguidefate-common-perl 26 | Description: win32 GUIDeFATE plugin 27 | win32 GUIDeFATE plugin 28 | 29 | Package: libguidefate-gtk2 30 | Architecture: all 31 | Depends: ${perl:Depends}, libguidefate-common-perl, libglib-perl, libgtk2-perl 32 | Description: gtk2 GUIDeFATE plugin 33 | gtk2 GUIDeFATE plugin 34 | 35 | Package: libguidefate-gtk 36 | Architecture: all 37 | Depends: ${perl:Depends}, libguidefate-common-perl, libglib-perl, libgtk3-perl 38 | Description: gtk (v3) GUIDeFATE plugin 39 | gtk (v3) GUIDeFATE plugin 40 | 41 | Package: libguidefate-wx 42 | Architecture: all 43 | Depends: ${perl:Depends}, libguidefate-common-perl, libwx-perl 44 | Description: wx GUIDeFATE plugin 45 | wx GUIDeFATE plugin 46 | 47 | Package: libguidefate-html 48 | Architecture: all 49 | Depends: ${perl:Depends}, libguidefate-common-perl 50 | Description: html GUIDeFATE plugin 51 | html GUIDeFATE plugin 52 | 53 | Package: libguidefate-web 54 | Architecture: all 55 | Depends: ${perl:Depends}, libguidefate-common-perl 56 | Description: web socket GUIDeFATE plugin 57 | web socket GUIDeFATE plugin 58 | 59 | Package: libguidefate-qt 60 | Architecture: all 61 | Depends: ${perl:Depends}, libguidefate-common-perl 62 | Description: qt4 GUIDeFATE plugin 63 | qt4 GUIDeFATE plugin 64 | 65 | Package: libguidefate-tk 66 | Architecture: all 67 | Depends: ${perl:Depends}, libguidefate-common-perl, libanyevent-perl, libimage-magick-perl 68 | Description: tk GUIDeFATE plugin 69 | tk GUIDeFATE plugin 70 | -------------------------------------------------------------------------------- /Examples/Servocontroller/Servocontroller.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that test servo state 3 | # You need the following available binary to run this demo: fswebcam 4 | #use GUIDeFATE 5 | 6 | use strict; 7 | use warnings; 8 | use lib"../lib/"; 9 | use GUIDeFATE; 10 | 11 | #use Device::PWMGenerator::PCA9685; 12 | 13 | #my $dev = Device::PWMGenerator::PCA9685->new( 14 | #I2CBusDevicePath => '/dev/i2c-1', # this would be '//dev/i2c-dev-0 for Model A Pi 15 | #debug => 1, 16 | #frequency => 400, #Hz 17 | #); 18 | #$dev->enable(); 19 | ##$dev->setChannelPWM(4,0,$dutycycle); # Duty cycle values between 0 and 4096 channel 4 20 | 21 | 22 | my $window=<new($window,$backend,$assist); 48 | my $frame=$gui->getFrame()||$gui; 49 | drawDial(); 50 | $gui->MainLoop; 51 | 52 | 53 | sub drawDial{ 54 | my $filename = 'dial.svg'; 55 | open(my $fh, '>', $filename) or die "Could not open file '$filename' $!"; 56 | print $fh "\n\n\n\n"; 57 | close $fh; 58 | $frame->setImage("Image2","dial.svg"); 59 | } 60 | 61 | sub textctrl9{ 62 | 63 | } 64 | 65 | sub btn8{ #send 66 | 67 | 68 | } 69 | 70 | sub btn10{ #callibrate button pressed 71 | 72 | 73 | } 74 | 75 | sub btn11{ #capture button pressed 76 | `fswebcam -r 640x480 --jpeg 85 -D 1 servocam.jpg`; 77 | $frame->setImage("Image2","servocam.jpg"); 78 | 79 | } 80 | 81 | sub btn12{ #CW button pressed 82 | $degrees-=10; 83 | drawDial(); 84 | } 85 | 86 | sub btn13{ #CW button pressed 87 | $degrees+=10; 88 | drawDial(); 89 | } 90 | -------------------------------------------------------------------------------- /man/GUIDeFATE.pod: -------------------------------------------------------------------------------- 1 | 2 | =head1 GUIDeFATE 3 | 4 | GUIDeFATE - Graphical User Interface Design From A Text Editor 5 | 6 | =head1 SYNOPSIS 7 | 8 | use GUIDeFATE; 9 | 10 | my $window=<new($window,[$backend],[$assist]); # API changed at version 0.06 27 | # $backend is one of Wx(Default), Tk or Gtk 28 | # $assist is one or "q" (quiet, default), "v" (verbose), "d" for debug (websocket) or "a" for Autogenerate 29 | 30 | $frame=$gui->getFrame||$gui; 31 | $gui->MainLoop; 32 | 33 | =head1 REQUIRES 34 | 35 | Perl5.8.8, Exporter, Wx, Wx::Perl::Imagick (for Wx interface) 36 | Perl5.8.8, Exporter, Tk, Image::Magick, Tk::JPEG, MIME::Base64 (for Tk interface) 37 | Perl5.8.8, Exporter, Glib, Gtk (for Gtk interface) 38 | Perl5.8.8, Exporter, QtCore4, QtGui4 (for Qt interface) 39 | Perl5.8.8, Exporter, Win32, Imager (for Win32 interface) 40 | Perl5.8.8, Exporter (for HTML interface) 41 | Perl5.8.8, Exporter, Net::WebSocket::Server (for HTML interface) 42 | 43 | =head1 EXPORTS 44 | 45 | getFrame() 46 | returns an object containing Widgets (referencesd by id) and 47 | GUI interaction functions. This is actually provided by the middle-man 48 | ((GFwx, GFtk etc) but not availlable for GFhtml 49 | 50 | =head1 DESCRIPTION 51 | 52 | GUIDeFATE enables the user to convert a textual representation into a 53 | Graphical User Interface. It attempts to abstract out the underlying 54 | framework. A visually recognisable pattern is passed as a string to 55 | GUIDeFATE and this is transformed into an Interactive Interface. 56 | 57 | =head1 METHODS 58 | 59 | =head2 Creation 60 | 61 | =over 4 62 | 63 | =item my $gui=GUIDeFATE->new($window, $backend, $options); 64 | 65 | Extracts dimensions and widgets in a window from the textual 66 | representation. 67 | If $backend not provided, defaults to "Wx"; options are Wx and Tk, 68 | Gtk, Qt, Win32 and Web 69 | If $options contains "v", then a verbose output is sent to console, 70 | if it contains "a", and autogenerated file is produced with all the 71 | called functions 72 | 73 | =item my $frame=$gui->getFrame || $gui; 74 | 75 | Returns reference to the frame for both abstracted and backend 76 | specific functions. 77 | 78 | For more details visit The GUIDeFATE wiki at its Github pages 79 | 80 | =back 81 | 82 | =head1 AUTHOR 83 | 84 | Saif Ahmed, SAIFTYNET { at } gmail.com 85 | 86 | =head1 SEE ALSO 87 | 88 | L, L, L, L, 89 | L,L, 90 | L, L, L, L, 91 | L 92 | 93 | =cut 94 | -------------------------------------------------------------------------------- /Examples/rpsls/rpsls.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that plays Rock Paper Scissors Lizard Spock 3 | #use GUIDeFATE 4 | 5 | use strict; 6 | use warnings; 7 | use lib"../lib/"; 8 | use GUIDeFATE; 9 | 10 | my $window=< {scissors => 'crush', 40 | lizard => 'crush', 41 | file => 'rock.jpg'}, 42 | paper => {rock => 'cover', 43 | spock => 'disprove', 44 | file => 'paper.jpg'}, 45 | scissors => {paper => 'cut', 46 | lizard => 'decapitate', 47 | file => 'scissors.jpg'}, 48 | lizard => {spock => 'poison', 49 | paper => 'eat', 50 | file => 'Lizard.jpg'}, 51 | spock => {scissors => 'smash', 52 | rock => 'vaporize', 53 | file => 'Spock.jpg'}); 54 | 55 | 56 | my $backend=$ARGV[0]?$ARGV[0]:"wx"; 57 | my $assist=$ARGV[1]?$ARGV[1]:"q"; 58 | my $gui=GUIDeFATE->new($window,$backend,$assist); 59 | my $frame=$gui->getFrame|| $gui; 60 | $gui->MainLoop; 61 | 62 | #Subroutines called by clicking buttons 63 | #function names are btn 64 | sub btn6 { getResults("rock") ; } 65 | sub btn14{ getResults("spock"); } 66 | sub btn15{ getResults("paper"); } 67 | sub btn21{ getResults("lizard"); } 68 | sub btn22{ getResults("scissors");} 69 | 70 | #Function described by u/choroba at reddit 71 | sub getResults{ 72 | my $player= shift; 73 | my $computer=(keys %rpsls)[rand 5]; 74 | 75 | # setImage takes the Filename, id number of subpanel 76 | $frame->setImage("Image12",$rpsls{$computer}{file}); 77 | 78 | if ($rpsls{$player}{$computer}) { 79 | $frame->setLabel("stattext16","You $rpsls{$player}{$computer} me!"); 80 | } 81 | elsif ($player eq $computer) { 82 | $frame->setLabel("stattext16","Draw"); 83 | } 84 | else { 85 | $frame->setLabel("stattext16","I $rpsls{$computer}{$player} you!"); 86 | } 87 | } 88 | 89 | 90 | 91 | 92 | -------------------------------------------------------------------------------- /perl-GUIDeFATE.spec.in: -------------------------------------------------------------------------------- 1 | %define module_name GUIDeFATE 2 | Summary: GUI Design From A Text Editor 3 | Name: perl-%{module_name} 4 | Version: __VERSION__ 5 | Release: 1%{?dist} 6 | Packager: Olivier Lahaye 7 | License: GPLv3+ 8 | Group: Development/Libraries 9 | Source: %{module_name}-%{version}.tar.bz2 10 | BuildRoot: /usr/src/redhat/BUILD/%{name}-%{version} 11 | #BuildRoot: /var/tmp/%{name}-buildroot 12 | BuildArch: noarch 13 | Requires: perl-%{module_name}-common = %{version}, perl-%{module_name}-win32 = %{version}, perl-%{module_name}-gtk2 = %{version}, perl-%{module_name}-gtk = %{version}, perl-%{module_name}-wx = %{version}, perl-%{module_name}-html = %{version}, perl-%{module_name}-web = %{version}, perl-%{module_name}-qt = %{version}, perl-%{module_name}-tk = %{version} 14 | %description 15 | GUIDeFATE enables the user to convert a textual representation into a Graphical 16 | User Interface. It attempts to abstract out the underlying framework. A visually 17 | recognisable pattern is passed as a string to GUIDeFATE and this is transformed 18 | into an Interactive Interface. 19 | 20 | %package common 21 | Summary: Main GUIDeFATE perl module 22 | 23 | %description common 24 | Main GUIDeFATE perl module 25 | 26 | %package win32 27 | Summary: win32 GUIDeFATE plugin 28 | Requires: %{name}-common = %{version} 29 | 30 | %description win32 31 | win32 GUIDeFATE plugin 32 | 33 | %package gtk2 34 | Summary: gtk2 GUIDeFATE plugin 35 | Requires: %{name}-common = %{version} 36 | 37 | %description gtk2 38 | gtk2 GUIDeFATE plugin 39 | 40 | %package gtk 41 | Summary: gtk (gtk3) GUIDeFATE plugin 42 | Requires: %{name}-common = %{version} 43 | 44 | %description gtk 45 | gtk2 GUIDeFATE plugin 46 | 47 | %package wx 48 | Summary: wx GUIDeFATE plugin 49 | Requires: %{name}-common = %{version} 50 | 51 | %description wx 52 | wx GUIDeFATE plugin 53 | 54 | %package html 55 | Summary: html GUIDeFATE plugin 56 | Requires: %{name}-common = %{version} 57 | 58 | %description html 59 | html GUIDeFATE plugin 60 | 61 | %package web 62 | Summary: web GUIDeFATE plugin 63 | Requires: %{name}-common = %{version} 64 | 65 | %description web 66 | web GUIDeFATE plugin 67 | 68 | %package qt 69 | Summary: Qt GUIDeFATE plugin 70 | Requires: %{name}-common = %{version} 71 | 72 | %description qt 73 | qt GUIDeFATE plugin 74 | 75 | %package tk 76 | Summary: tk GUIDeFATE plugin 77 | Requires: %{name}-common = %{version} 78 | 79 | %description tk 80 | tk GUIDeFATE plugin 81 | 82 | %prep 83 | %setup -q -n %{module_name}-%{version} 84 | 85 | %build 86 | %__perl Makefile.PL INSTALLDIRS=vendor # INSTALLDIRS=vendor tells perl that we are in a package 87 | %__make manifest 88 | 89 | %__make 90 | %__rm -rf $RPM_BUILD_ROOT 91 | %__make install SITEPREFIX=/usr DESTDIR=$RPM_BUILD_ROOT 92 | 93 | %__rm -f $RPM_BUILD_ROOT/%{perl_archlib}/perllocal.pod 94 | %__rm -f $RPM_BUILD_ROOT/%{perl_vendorarch}/auto/GUIDeFATE/.packlist 95 | 96 | %files 97 | %defattr(-,root,root) 98 | 99 | %files common 100 | %doc README.md INSTALL Changes AUTHORS LICENSE 101 | %{_mandir}/man3/GUIDeFATE.3pm 102 | %{perl_vendorlib}/GUIDeFATE.pm 103 | %{perl_vendorlib}/GUIDeFATE/GFtemplate.pm 104 | %{perl_vendorlib}/Language/SIMPLE.pm 105 | %{perl_vendorlib}/Language/SIMPLE/logo.ext 106 | 107 | %files win32 108 | %{perl_vendorlib}/GUIDeFATE/GFwin32.pm 109 | 110 | %files gtk2 111 | %{perl_vendorlib}/GUIDeFATE/GFgtk2.pm 112 | 113 | %files gtk 114 | %{perl_vendorlib}/GUIDeFATE/GFgtk.pm 115 | 116 | %files wx 117 | %{perl_vendorlib}/GUIDeFATE/GFwx.pm 118 | 119 | %files html 120 | %{perl_vendorlib}/GUIDeFATE/GFhtml.pm 121 | 122 | %files web 123 | %{perl_vendorlib}/GUIDeFATE/GFweb.pm 124 | 125 | %files qt 126 | %{perl_vendorlib}/GUIDeFATE/GFqt.pm 127 | 128 | %files tk 129 | %{perl_vendorlib}/GUIDeFATE/GFtk.pm 130 | 131 | %changelog 132 | * Mon Nov 15 2021 Olivier Lahaye 133 | - v0.13 Initial packaging. 134 | -------------------------------------------------------------------------------- /Examples/screenshot.pl.old: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that captures a screenshot for Linux 3 | # uses GUIDeFATE, which in turn depends on a backends 4 | # (e.g. Wx, Tk, Gtk, but not yet Win32 ) 5 | # requires commands xprop (normally installed in Ubuntu) in Ubuntu 6 | # and xclip for the clipboard (sudo apt-get install xclip) 7 | # This file designed to be called by Executioner for backend testing 8 | 9 | use strict; 10 | use warnings; 11 | my $lib='../lib/'; 12 | use lib '../lib/'; 13 | use GUIDeFATE; 14 | use Imager; 15 | use Imager::Screenshot 'screenshot'; #This version uses Imager to get screenshot 16 | use File::Copy; 17 | 18 | my $window=<} | 28 | | | | | 29 | | | | | 30 | | +--------------------+ | 31 | | {Save as }{ Copy }{Refresh } | 32 | | {Edit }{Delayed }^times^ | 33 | +--------------------------------+ 34 | 35 | times=5 secs,10 secs,30 secs 36 | END 37 | 38 | my $windowList= `xprop -root|grep ^_NET_CLIENT_LIST`; 39 | my @winIds=$windowList=~m/(0x[0-9a-f]{7})/g; 40 | unshift @winIds, 0; 41 | my $currentID=0; 42 | my $workingDir="/tmp/screenshot/"; 43 | mkdir $workingDir; 44 | my $workingFile="screenshot.png"; 45 | my %images; 46 | $images{0} = screenshot(); 47 | $images{0} -> write(file => $workingDir.$workingFile, type => 'png' ) || die "cannot write $workingDir.$workingFile $!"; 48 | my %names; 49 | $names{0}='Full Screen'; 50 | 51 | my $backend=$ARGV[0]?$ARGV[0]:'wx'; 52 | my $assist=$ARGV[1]?$ARGV[1]:'a'; 53 | my $gui=GUIDeFATE->new($window,$backend,$assist); 54 | my $frame=$gui->getFrame()||$gui; 55 | 56 | $gui->MainLoop(); 57 | 58 | sub showScreenshot{ 59 | my ($id,$refresh)=@_; 60 | $id=$winIds[$id]; 61 | if ((! exists $images{$id})||$refresh){ 62 | $images{$id}=screenshot(id=>hex $id, decor => 1 ) ; 63 | if ($id){ 64 | my $name=`xprop -id $id|grep '^WM_NAME(STRING)'`; 65 | $name=~s/WM_NAME\(STRING\) =//; 66 | $name=~s/"//g; 67 | chomp $name; 68 | $names{$id}=$name?$name:$id; 69 | } 70 | } 71 | $images{$id} ->write(file => $workingDir.$workingFile, type => 'png'); 72 | $frame->setImage('Image1',$workingDir.$workingFile); 73 | $frame->setValue('textctrl0',$names{$id}); 74 | } 75 | 76 | sub textctrl0{ # called using textctrl0 77 | } 78 | 79 | sub btn3 {#called using button with label < 80 | $currentID-- if ($currentID>0); 81 | showScreenshot($currentID); 82 | }; 83 | 84 | sub btn4 {#called using button with label > 85 | $currentID++ if ($currentID<$#winIds); 86 | showScreenshot($currentID); 87 | }; 88 | 89 | sub btn5 {#called using button with label Save as 90 | my $outFile= $frame->showFileSelectorDialog('Save file',0); 91 | if ($outFile) { 92 | copy($workingDir.$workingFile,$outFile) or die "could not copy file $workingDir$workingFile into $outFile $!"; 93 | } 94 | }; 95 | 96 | sub btn6 {#called using button with label Clipboard 97 | system("xclip -selection clipboard -t image/png -i $workingDir.$workingFile "); 98 | }; 99 | 100 | sub btn7 {#called using button with label Refresh 101 | system('( speaker-test -t sine -f 1000 )& pid=$! ; sleep 0.1s ; kill -9 $pid'); 102 | showScreenshot($currentID,1); 103 | }; 104 | 105 | sub combo8 {#called using combobox with data from @times 106 | }; 107 | 108 | sub btn9{ 109 | system("gimp $workingDir$workingFile"); 110 | }; 111 | 112 | sub btn10 {#called using button with label Delayed 113 | my $delay=$frame->getValue("combo8"); 114 | $delay=~s/[^\d]//g; 115 | sleep $delay; 116 | #https://unix.stackexchange.com/questions/1974/how-do-i-make-my-pc-speaker-beep 117 | system('( speaker-test -t sine -f 1000 )& pid=$! ; sleep 0.1s ; kill -9 $pid'); 118 | showScreenshot($currentID,1); 119 | }; 120 | 121 | 122 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | GUI Design From A Text Editor 2 | 3 | Installation: 4 | 5 | This may install even if its dependencies fail to install. This is 6 | because different backends will have different needs. GUIDeFATE will 7 | work currently with Gtk, Wx and Tk. 8 | 9 | Perl5.8.8, Exporter, Wx, Wx::Perl::Imagick (for Wx interface) 10 | Perl5.8.8, Exporter, Tk, Image::Imagick, Tk::JPEG, MIME::Base64 (for Tk interface) 11 | Perl5.8.8, Exporter, Glib, Gtk (for Gtk interface) 12 | Perl5.8.8, Exporter, QtCore4 QtGUI4 (for Qt interface) 13 | Perl5.8.8, Exporter, Win32::GUI and Imager (for Win32 interface) 14 | 15 | Designing a graphical User interface requires knowledge of things like 16 | toolkit libraries, platform context etc. At least I think it does. I 17 | am a relatively new programmer in that I have near zero experience in 18 | GUI programming outside a web page. So when I explore how to design an 19 | application which works outside a command line or a browser window, I 20 | feel tremendously out of my depth. When I see the programming 21 | interfaces to these interfaces (QT, GTK, TK, ncurses, HTML) my 22 | bewilderment reaches even greater heights. 23 | 24 | Sure there are clever things like wxGlade, and QT Designer etc. These 25 | are tools that also require more skill than I possess; I am old and I 26 | can just about use a text editor as an IDE. So what is needed? I need a 27 | GUI designer that: - 28 | 1) Is simple, abstracting away from the underlying Toolkit/platform 29 | 2) Requires the simplest designer possible, with a visual 30 | representation of the interface 31 | 3) Allows the use use of multiple different GUI engines 32 | 4) Makes it easy recognise the interface elements by simply looking at 33 | the code 34 | 35 | # So how might this work? 36 | 37 | The user uses a text editor to design the window. Not new of course, 38 | text editors have had to be used to describe windows when other 39 | graphical representation methods were not possible. As this is already 40 | a two dimensional data, it should be possible to convert this into an 41 | actual graphical interface through an interpreter. The developer 42 | simply has to draw the interface in text and then program the 43 | interaction that is required. 44 | 45 | # Textual Representation of a Graphical Interface 46 | 47 | A simple hellow world 48 | 49 | +------------------+ 50 | |T Message | 51 | +------------------+ 52 | | | 53 | | Hello World! ! | 54 | | | 55 | +------------------+ 56 | 57 | A Calculator 58 | 59 | +------------------------+ 60 | |T Calculator | 61 | +------------------------+ 62 | | [__________________] | 63 | | { V }{ % }{ C }{AC } | 64 | | { 1 }{ 2 }{ 3 }{ + } | 65 | | { 4 }{ 5 }{ 6 }{ - } | 66 | | { 7 }{ 8 }{ 9 }{ * } | 67 | | { . }{ 0 }{ = }{ / } | 68 | | made with GUIdeFATE | 69 | +------------------------+ 70 | 71 | 72 | # Example PERL script 73 | 74 | perl 75 | #!/usr/bin/perl -w 76 | use strict; 77 | use GUIDeFATE; 78 | package Main; 79 | 80 | my $window=<new($window,$backend,$assist); 99 | my $frame=$gui->getFrame()||$gui; 100 | $gui->MainLoop(); 101 | 102 | This produces something like 103 | https://github.com/saiftynet/dummyrepo/blob/main/GUIDeFATE/calculator%20screenshot.png 104 | 105 | 106 | Of course this is at a very early stage, and I have only implemented 107 | buttons, static text and text control widgets. More will come. 108 | Suggestions welcome. 109 | 110 | EDIT> have implemented Menu and image subpanels at version 0.0.2 111 | EDIT> have implemented Multiline text ctrl subpanels at version 0.0.3 112 | EDIT> have implemented Message Boxes and file selector at Version 0.04 113 | EDIT> have implemented an potential modification to allow other backends 114 | EDIT> Have implemented a Tk backend 115 | 116 | 117 | Copyright (C) 2018 Saif Ahmed 118 | 119 | This library is free software; you can redistribute it and/or modify 120 | it under the same terms as Perl itself, either Perl version 5.8.6 or, 121 | at your option, any later version of Perl 5 you may have available. 122 | -------------------------------------------------------------------------------- /Examples/bounce/bounce.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that tests timers 3 | #using GUIDeFATE 4 | 5 | use strict; 6 | use warnings; 7 | use lib"../lib/"; 8 | use GUIDeFATE; 9 | 10 | my $window=<50, 39 | y =>50, 40 | dirX=>2.5, 41 | dirY=>4, 42 | ); 43 | # for ecg 44 | my @ecg=(50,45,50,50,60,10,60,50,50,40,40,50,50,50,50,50)x10; 45 | my $index=0; # 46 | # for slideshow 47 | my @files = ; # list picture files 48 | my $number=0; # picture number 49 | my $t=10; # number of calls before action 50 | # for timing and memory tests 51 | my $time=time(); 52 | 53 | my $backend=$ARGV[0]?$ARGV[0]:"gtk"; 54 | my $assist=$ARGV[1]?$ARGV[1]:"q"; 55 | my $gui=GUIDeFATE->new($window,$backend,$assist); 56 | my $frame=$gui->getFrame()||$gui; 57 | $gui->MainLoop; 58 | 59 | sub slideshow{ 60 | return if $t++<10; 61 | if ($files[$number] && (-f "$files[$number]")){ 62 | $frame->setImage("Image0",$files[$number++]); 63 | } 64 | elsif($number>=@files){ 65 | $number=0; 66 | } 67 | else {$number++} 68 | $t=0; 69 | } 70 | sub spin{ 71 | $degrees=($degrees+10)%360; 72 | my $svg= " 73 | \n 74 | "; 75 | loadImage ('dial.svg',$svg); 76 | } 77 | sub bounce{ 78 | $ball{x}+=$ball{dirX}; 79 | $ball{y}+=$ball{dirY}; 80 | if ($ball{x}>95) { $ball{x}=95; $ball{dirX}=-$ball{dirX} } 81 | elsif ($ball{x}<5) { $ball{x}=5 ; $ball{dirX}=-$ball{dirX} } 82 | if ($ball{y}>95) { $ball{y}=95; $ball{dirY}=-$ball{dirY} } 83 | elsif ($ball{y}<5) { $ball{y}=5 ; $ball{dirY}=-$ball{dirY} }; 84 | my $svg="\n\n\n"; 85 | loadImage('ball.svg',$svg); 86 | } 87 | sub clock{ 88 | my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(); 89 | my @numbers=1..12; 90 | my $clockFace= "\n "; 91 | my $pos=$hStep; 92 | foreach $number(@numbers){ 93 | $clockFace.="\n $number"; 94 | $pos+=$hStep; 95 | } 96 | $clockFace.= "\n ". 97 | "\n ". 98 | "\n ". 99 | "\n"; 100 | 101 | loadImage('clock.svg',$clockFace); 102 | } 103 | sub ecg{ 104 | my $limit=$#ecg; 105 | my $points=""; 106 | my $x=0; 107 | foreach ($index..$limit,0..($index-1)){ # the array of points is cycled around $index 108 | $points.="$x,$ecg[$_] \n"; 109 | $x+=2; 110 | } 111 | if ($ecg[$index] <30){ # a peak is detected; Uses system call to produce beep 112 | system('( speaker-test -t square -f 500 >/dev/null)& pid=$! ; sleep 0.1s ; kill -9 $pid'); 113 | } 114 | $index=($index>=$limit)?0:$index+1; 115 | my $svg= "\n"; 116 | 117 | loadImage( 'ecg.svg',$svg); 118 | } 119 | sub choose{ # This is the function called by the timer. 120 | my $fn=lc($frame->getValue("combo2") ); 121 | my $sub=\&{$fn}; # Calls the function selected in the combo 122 | $sub->(); 123 | } 124 | sub combo2{}; 125 | sub loadImage{ 126 | my ($filename,$data)=@_; 127 | open(my $fh, '>', $filename) or die "Could not open file '$filename' $!"; 128 | print $fh $data; 129 | close $fh; 130 | $frame->setImage("Image0",$filename); 131 | } 132 | -------------------------------------------------------------------------------- /Examples/calculator.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that generates a calculator style interface 3 | #uses GUIDeFATE (which in turn depends on Wx or Tk) 4 | #This file designed to be called by Executioner for backend testing 5 | 6 | use strict; 7 | use warnings; 8 | use GUIDeFATE; 9 | 10 | my $window=<new($window,$backend,$assist); 32 | my $frame=$gui->getFrame()||$gui; 33 | $gui->MainLoop(); 34 | 35 | sub textctrl0 #called using Text Control with default text ' ' 36 | { 37 | $result=$frame->getValue("textctrl0"); 38 | }; 39 | 40 | sub btn1 #called using button with label V 41 | { 42 | my $tmp=$frame->getValue("textctrl0"); 43 | $result=sqrt($tmp); 44 | $frame->setValue("textctrl0", $result) 45 | }; 46 | 47 | sub btn2 #called using button with label pi 48 | { 49 | $frame->setValue("textctrl0", 3.14159267) 50 | }; 51 | 52 | sub btn3 #called using button with label C 53 | { 54 | $result=0; 55 | $frame->setValue("textctrl0", $result) 56 | }; 57 | 58 | sub btn4 #called using button with label AC 59 | { 60 | $result=0; 61 | $frame->setValue("textctrl0", $result) 62 | }; 63 | 64 | sub btn5 #called using button with label 1 65 | { 66 | my $tmp=$frame->getValue("textctrl0"); 67 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 1) } 68 | else {$frame->appendValue("textctrl0", 1) } 69 | }; 70 | 71 | sub btn6 #called using button with label 2 72 | { 73 | my $tmp=$frame->getValue("textctrl0"); 74 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 2) } 75 | else {$frame->appendValue("textctrl0", 2) } 76 | }; 77 | 78 | sub btn7 #called using button with label 3 79 | { 80 | my $tmp=$frame->getValue("textctrl0"); 81 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 3) } 82 | else {$frame->appendValue("textctrl0", 3) } 83 | }; 84 | 85 | sub btn8 #called using button with label + 86 | { 87 | my $tmp=$frame->getValue("textctrl0"); 88 | $acc.=$tmp."+";print $acc."\n"; 89 | $frame->setValue("textctrl0", 0) 90 | }; 91 | 92 | sub btn9 #called using button with label 4 93 | { 94 | my $tmp=$frame->getValue("textctrl0"); 95 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 4) } 96 | else {$frame->appendValue("textctrl0", 4) } 97 | 98 | }; 99 | 100 | sub btn10 #called using button with label 5 101 | { 102 | my $tmp=$frame->getValue("textctrl0"); 103 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 5) } 104 | else {$frame->appendValue("textctrl0", 5) } 105 | }; 106 | 107 | sub btn11 #called using button with label 6 108 | { 109 | my $tmp=$frame->getValue("textctrl0"); 110 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 6) } 111 | else {$frame->appendValue("textctrl0", 6) } 112 | }; 113 | 114 | sub btn12 #called using button with label - 115 | { 116 | my $tmp=$frame->getValue("textctrl0"); 117 | $acc.=$tmp."-";print $acc."\n"; 118 | $frame->setValue("textctrl0", 0) 119 | }; 120 | 121 | sub btn13 #called using button with label 7 122 | { 123 | my $tmp=$frame->getValue("textctrl0"); 124 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 7) } 125 | else {$frame->appendValue("textctrl0", 7) } 126 | }; 127 | 128 | sub btn14 #called using button with label 8 129 | { 130 | my $tmp=$frame->getValue("textctrl0"); 131 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 8) } 132 | else {$frame->appendValue("textctrl0", 8) } 133 | }; 134 | 135 | sub btn15 #called using button with label 9 136 | { 137 | my $tmp=$frame->getValue("textctrl0"); 138 | if ($tmp eq "0"){ $frame->setValue("textctrl0", 9) } 139 | else {$frame->appendValue("textctrl0", 9)} 140 | } 141 | 142 | sub btn16 #called using button with label * 143 | { 144 | my $tmp=$frame->getValue("textctrl0"); 145 | $acc.=$tmp."*";print $acc."\n"; 146 | print $acc."\n"; 147 | $frame->setValue("textctrl0", 0) 148 | }; 149 | 150 | sub btn17 #called using button with label . 151 | { 152 | $frame->appendValue("textctrl0", ".") 153 | }; 154 | 155 | sub btn18 #called using button with label 0 156 | { 157 | $frame->appendValue("textctrl0", 0) 158 | }; 159 | 160 | sub btn19 #called using button with label = 161 | { 162 | my $tmp=$frame->getValue("textctrl0"); 163 | $acc.=$tmp;print $acc."\n"; 164 | $result=eval($acc); 165 | print $acc."=".$result."\n"; 166 | $frame->setValue("textctrl0", $result ); 167 | $acc=""; 168 | }; 169 | 170 | sub btn20 #called using button with label / 171 | { 172 | my $tmp=$frame->getValue("textctrl0"); 173 | $acc.=$tmp."/"; 174 | $frame->setValue("textctrl0", 0) 175 | }; 176 | 177 | #Static text 'made with GUIdeFATE' with id stattext21 178 | #Static text 'and happy things' with id stattext22 179 | #Menu found 180 | -------------------------------------------------------------------------------- /Examples/RunDemos.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that calls the test files in scripts folder 3 | #uses GUIDeFATE (which in turn depends on Wx or Tk) 4 | 5 | # For experimental purposes, before installlation use a 6 | # set this to where the GUIDeFATE moduels are... 7 | my $lib='../../../lib'; 8 | use lib '../../../lib'; 9 | use strict; 10 | use warnings; 11 | use GUIDeFATE; 12 | 13 | # an external program that returns a list of available backends 14 | # that work. The Gtk module always generates errors so added 15 | # manually but not guaranteed to work unless setup is ok 16 | #my $backends=`perl -I$lib GFModules.pl`; 17 | #$backends.=",Gtk,Gtk2"; 18 | my @workingModules; 19 | BEGIN { 20 | # Uncomment the following line to debug. 21 | #$DB::single = 1; 22 | eval { 23 | eval "use GUIDeFATE" or die; 24 | }; 25 | if ($@ && $@ =~ /GUIDeFATE/) { 26 | print " GUIDeFATE not installed\n"; 27 | exit; 28 | } 29 | # contains list of modules reuired for each backend 30 | # in order of preference 31 | foreach my $module ( qw/ GFwin32 GFwx GFtk GFqt GFhtml GFweb / ) { 32 | eval { 33 | eval "use GUIDeFATE::$module" or die; 34 | }; 35 | if ($@ && $@ =~ /$module/) { 36 | print " $module not installed\n"; 37 | } 38 | else { 39 | print " $module found\n"; 40 | my $m=$module; 41 | $m=~s/^GF//; 42 | push (@workingModules, ucfirst $m); 43 | } 44 | } 45 | if (! $workingModules[0]){ # at least one module works 46 | print "no working GFxx modules intalled"; 47 | exit; 48 | }; 49 | } 50 | my $backends=join(",",@workingModules); 51 | $backends.=",gtk,gtk2"; # Assuming gtk2 available (can't test gtk3 and gtk2 at the same time (conflicts) 52 | print "carrying on with $backends\n"; 53 | 54 | 55 | 56 | my $window=<new($window,$backend,$assist); 87 | my $frame=$gui->getFrame||$gui; 88 | $gui->MainLoop; 89 | 90 | sub combo0{ 91 | $backend=$frame->getValue("combo0"); 92 | } 93 | sub combo1{ 94 | $assist=$frame->getValue("combo1"); 95 | } 96 | 97 | sub btn3 #called using button with label Hello World 98 | { 99 | system("$preLine perl -I$lib HelloWorld.pl $backend $assist $postLine"); 100 | }; 101 | sub btn4 #called using button with label Calculator 102 | { 103 | system("$preLine perl -I$lib calculator.pl $backend $assist $postLine"); 104 | }; 105 | sub btn5 #called using button with label Rock Paper Scissors Lizard Spock 106 | { 107 | system("cd rpsls; $preLine perl -I$lib rpsls.pl $backend $assist $postLine"); 108 | }; 109 | sub btn6 #called using button with label GUI Gnuplotter 110 | { 111 | system("cd GUIgnuplot; $preLine perl -I$lib GUIgnuplot.pl $backend $assist $postLine"); 112 | }; 113 | sub btn7 #called using button with label GUI Gnuplotter 114 | { 115 | system("$preLine perl -I$lib texteditor.pl $backend $assist $postLine"); 116 | }; 117 | sub btn8 #called using button with label Text editor 118 | { 119 | system("cd ImageMagickGUI; $preLine perl -I$lib ImageMagickGUI.pl $backend $assist $postLine"); 120 | }; 121 | sub btn9 #called using button with label PlantList 122 | { 123 | system("cd PlantsList; $preLine perl -I$lib plantslist.pl $backend $assist $postLine"); 124 | }; 125 | sub btn10 #called using button with label screenshot 126 | { 127 | system("$preLine perl -I$lib screenshot.pl $backend $assist $postLine"); 128 | }; 129 | sub btn11 #called using button with label SimpleLogo 130 | { 131 | system("cd SimpleLogo; $preLine perl -I$lib SimpleLogo.pl $backend $assist $postLine"); 132 | }; 133 | sub btn12 #called using button with label Servocontroler 134 | { 135 | system("cd Servocontroller; $preLine perl -I$lib Servocontroller.pl $backend $assist $postLine"); 136 | }; 137 | sub btn13 #called using button with label RunDemos 138 | { 139 | system("$preLine perl -I$lib RunDemos.pl $backend $assist $postLine"); 140 | }; 141 | sub textctrl15 142 | { 143 | system("$preLine perl -I$lib ". $frame->getValue("textctrl15") . " $backend $assist $postLine"); 144 | }; 145 | sub btn14 #called using button with label from textctrl15 146 | { 147 | system("$preLine perl -I$lib ". $frame->getValue("textctrl15") . " $backend $assist $postLine"); 148 | }; 149 | -------------------------------------------------------------------------------- /Examples/screenshot.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that captures a screenshot for Linux 3 | # uses GUIDeFATE, which in turn depends on a backends 4 | # (e.g. Wx, Tk, Gtk, but not yet Win32 ) 5 | # requires commands xprop (normally installed in Ubuntu) in Ubuntu 6 | # and xclip for the clipboard (sudo apt-get install xclip) 7 | # This file designed to be called by Executioner for backend testing 8 | 9 | use strict; 10 | use warnings; 11 | my $lib='../lib/'; 12 | use lib '../lib/'; 13 | use GUIDeFATE; 14 | use Imager; 15 | use Imager::Screenshot 'screenshot'; #This version uses Imager to get screenshot 16 | use File::Copy; 17 | 18 | my $window=<} | 28 | | | | | 29 | | | | | 30 | | +--------------------+ | 31 | | {Save as }{ Copy }{Refresh } | 32 | | {Edit }{Delayed}^times^{Multi} | 33 | +--------------------------------+ 34 | 35 | times=5 secs,10 secs,30 secs 36 | END 37 | 38 | my $workingDir="/tmp/screenshot/"; 39 | mkdir $workingDir; 40 | my $workingFile="screenshot.png"; 41 | my $multiMax=30; 42 | my @winIds; 43 | my $currentID=0; 44 | makeList(); 45 | my %images; 46 | $images{0} = screenshot(); 47 | $images{0} -> write(file => $workingDir.$workingFile, type => 'png' ) || 48 | die "cannot write $workingDir.$workingFile $!"; 49 | my %names; 50 | $names{0}='Full Screen'; 51 | 52 | my $backend=$ARGV[0]?$ARGV[0]:'wx'; 53 | my $assist=$ARGV[1]?$ARGV[1]:'a'; 54 | my $gui=GUIDeFATE->new($window,$backend,$assist); 55 | my $frame=$gui->getFrame()||$gui; 56 | 57 | $gui->MainLoop(); 58 | 59 | sub sound{ # makes a sound 60 | #https://unix.stackexchange.com/questions/1974/how-do-i-make-my-pc-speaker-beep 61 | system('( speaker-test -t square -f 1000 >/dev/null)& pid=$! ; sleep 0.1s ; kill -9 $pid'); 62 | }; 63 | 64 | sub showScreenshot{ 65 | my ($id,$refresh)=@_; 66 | $id=$winIds[$id]; 67 | if ((! exists $images{$id})||$refresh){ 68 | $images{$id} = screenshot(id=>hex $id) ; 69 | getName($id); 70 | } 71 | $images{$id} ->write(file => $workingDir.$workingFile, type => 'png') || 72 | die "cannot write $workingDir.$workingFile $!"; 73 | $frame->setImage('Image2',$workingDir.$workingFile); 74 | $frame->setValue('textctrl1',$names{$id}); 75 | } 76 | 77 | sub getName{ # gets Name from given winodw ID (or returns Id if no name found) 78 | my $id=shift; 79 | if (! exists $names{$id}){ 80 | my $name=`xprop -id $id|grep '^WM_NAME(STRING)'`; 81 | $name=~s/WM_NAME\(STRING\) =//; 82 | $name=~s/"//g; 83 | chomp $name; 84 | $names{$id}=$name ? $name: $id ; 85 | } 86 | return $names{$id}; 87 | }; 88 | 89 | sub makeList{ # makes a list of Ids, and filters the list if needed 90 | my $searchTerm=shift; 91 | my $windowList= `xprop -root|grep ^_NET_CLIENT_LIST`; 92 | @winIds=$windowList=~m/(0x[0-9a-f]{7})/g; 93 | unshift @winIds, 0; 94 | if ((defined $searchTerm)&&($searchTerm)){ 95 | my @filtered; 96 | foreach my $id (@winIds){ 97 | my $name=getName($id); 98 | if ($name=~/$searchTerm/i){ 99 | push @filtered, $id; 100 | } 101 | } 102 | if (@filtered){ @winIds=@filtered } 103 | else {sound()}; 104 | } 105 | $currentID=0; 106 | }; 107 | 108 | sub textctrl1{ # called using textctrl1 109 | 110 | } 111 | 112 | sub btn0{ 113 | my $search=$frame->getValue('textctrl1'); 114 | makeList($search); 115 | showScreenshot(0); 116 | }; 117 | 118 | sub btn4 {#called using button with label < 119 | $currentID-- if ($currentID>0); 120 | showScreenshot($currentID); 121 | }; 122 | 123 | sub btn5 {#called using button with label > 124 | $currentID++ if ($currentID<$#winIds); 125 | showScreenshot($currentID); 126 | }; 127 | 128 | sub btn6 {#called using button with label Save as 129 | my $outFile= $frame->showFileSelectorDialog('Save file',0); 130 | if ($outFile) { 131 | copy($workingDir.$workingFile,$outFile) or die "could not copy file $workingDir$workingFile into $outFile $!"; 132 | } 133 | }; 134 | 135 | sub btn7 {#called using button with label Clipboard 136 | system("xclip -selection clipboard -t image/png -i $workingDir.$workingFile "); 137 | }; 138 | 139 | sub btn8 {#called using button with label Refresh 140 | sound(); 141 | showScreenshot($currentID,1); 142 | }; 143 | 144 | sub combo9 {#called using combobox with data from @times 145 | }; 146 | 147 | sub btn10{ 148 | my $pid = fork; 149 | return if $pid; 150 | system("gimp $workingDir$workingFile"); 151 | exit; 152 | }; 153 | 154 | sub btn11 {#called using button with label Delayed 155 | my $pid = fork; 156 | return if $pid; 157 | my $delay=$frame->getValue("combo9"); 158 | $delay=~s/[^\d]//g; 159 | sleep $delay; 160 | sound(); 161 | showScreenshot($currentID,1); 162 | exit; 163 | }; 164 | 165 | sub btn12{ 166 | if (-e $workingDir."multi"){ 167 | unlink ( $workingDir."multi") 168 | } 169 | else { 170 | open(my $fh, '>', $workingDir."multi"); 171 | print $fh $multiMax; 172 | close $fh; 173 | my $pid = fork; 174 | return if $pid; 175 | while ((-e $workingDir."multi") && ($multiMax--)){ 176 | my $delay=$frame->getValue("combo9"); 177 | $delay=~s/[^\d]//g; 178 | sleep $delay; 179 | sound(); 180 | } 181 | exit; 182 | 183 | } 184 | 185 | 186 | } 187 | 188 | -------------------------------------------------------------------------------- /Examples/GUIgnuplot/GUIgnuplot.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that crtaes a minimalist gui gnuplot 3 | #uses GUIDeFATE (which in turn depends on Wx or Tk) 4 | #This file designed to be called by Executioner for backend testing 5 | 6 | use strict; 7 | use warnings; 8 | use GUIDeFATE; 9 | 10 | use File::Copy qw(copy); 11 | 12 | my $window=<new($window,$backend,$assist); 52 | my $frame=$gui->getFrame()||$gui; 53 | $gui->MainLoop; 54 | 55 | sub menu6{ 56 | if($frame->showDialog("Sure?","This will wipe existing text...proceed?","OKC","!")){ 57 | $frame->setValue("TextCtrl1",""); 58 | } 59 | } 60 | sub menu7{ 61 | if($frame->showDialog("Sure?","This will wipe existing text...proceed?","OKC","!")){ 62 | $frame->setValue("TextCtrl1",""); 63 | my $file= $frame->showFileSelectorDialog("Open file",1); 64 | if (open(my $fh, '<:encoding(UTF-8)', $file)) { 65 | while (my $row = <$fh>) { 66 | $frame->appendValue("TextCtrl1",$row); 67 | } 68 | close $fh; 69 | } 70 | } 71 | } 72 | sub menu8{ 73 | my $file= $frame->showFileSelectorDialog("Save file",0); 74 | if (open(my $fh, '>', $file)) { 75 | print $fh $frame->getValue("TextCtrl1"); 76 | close $fh 77 | } 78 | } 79 | 80 | sub menu9{ 81 | $frame->quit(); 82 | } 83 | sub menu12{ 84 | open(GP, "| gnuplot") or die "Error while piping to Gnuplot: $! \n"; 85 | print GP <getValue("TextCtrl1"); 90 | print GP $tmp; 91 | 92 | close(GP); 93 | $frame->setImage("Image2","plotter.png") 94 | } 95 | sub menu13{ 96 | my $file= $frame->showFileSelectorDialog("Save plot image file",0); 97 | copy("plotter.png", $file) 98 | 99 | } 100 | sub menu16{ 101 | my $plot=<setValue("TextCtrl1",$plot); 110 | menu12(); 111 | } 112 | sub menu17{ 113 | my $plot=<setValue("TextCtrl1",$plot); 139 | menu12(); 140 | } 141 | sub menu18{ 142 | my $plot=<setValue("TextCtrl1",$plot); 180 | menu12(); 181 | } 182 | -------------------------------------------------------------------------------- /lib/GUIDeFATE/GFtemplate.pm: -------------------------------------------------------------------------------- 1 | package GFtemplate; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '0.12'; 6 | 7 | use Exporter 'import'; 8 | our @EXPORT = qw; 9 | our $frame; 10 | 11 | our $winX=30; 12 | our $winY=30; 13 | our $winWidth; 14 | our $winHeight; 15 | our $winTitle="title"; 16 | our $winScale=6.5; 17 | 18 | # these arrays will contain the widgets each as an arrayref of the parameters 19 | my @widgets=(); 20 | my %iVars=(); #vars for interface operation (e.g. 21 | my %oVars=(); #vars for interface creation (e.g. list of options) 22 | my %styles; 23 | 24 | my $lastMenuLabel; #bug workaround in menu generator may be needed for submenus 25 | 26 | sub new 27 | { 28 | my $class = shift; 29 | my $self={}; 30 | bless( $self, $class ); 31 | 32 | 33 | 34 | return $self; 35 | }; 36 | 37 | sub MainLoop{ #activate UI 38 | 39 | } 40 | 41 | # setupContent sets up the initial content before Mainloop can be run. 42 | sub setupContent{ 43 | my ($self, $canvas)=@_; # pass both object as well as the frame element 44 | $self ->{"menubar"}=undef; # menu not yet defined 45 | my $currentMenu; # undefined menu 46 | foreach my $widget (@widgets){ # read each widget data and call gnerator 47 | my @params=@$widget; 48 | my $wtype=shift @params; 49 | if ($wtype eq "btn") {aBt($self, $canvas, @params);} 50 | elsif ($wtype eq "textctrl") {aTC($self, $canvas, @params);} 51 | elsif ($wtype eq "stattext") {aST($self, $canvas, @params);} 52 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 53 | elsif ($wtype eq "combo") {aCB($self, $canvas, @params);} 54 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 55 | elsif ($wtype eq "mb") 56 | { 57 | if (! $self->{"menubar"}){ 58 | $self ->{"menubar"} = Gtk3::MenuBar->new; 59 | $canvas->put($self ->{"menubar"},0,0); 60 | } 61 | $currentMenu=aMB($self,$canvas,$currentMenu,@params) 62 | } 63 | } 64 | 65 | sub aBt{ 66 | my ($self,$canvas, $id, $label, $location, $size, $action)=@_;# Button generator 67 | } 68 | sub aTC{ 69 | my ($self,$canvas, $id, $text, $location, $size, $action)=@_;0# Single line input generator 70 | } 71 | sub aST{ 72 | my ($self,$canvas, $id, $text, $location)=@_; #Static text element generator 73 | } 74 | sub aCB{ 75 | my ($self,$canvas, $id, $label, $location, $size, $action)=@_; #gnerator for comoboxes 76 | 77 | } 78 | sub aMB{ 79 | my ($self,$canvas,$currentMenu, $id, $label, $type, $action)=@_; 80 | if (($lastMenuLabel) &&($label eq $lastMenuLabel)){return $currentMenu} # bug workaround 81 | else {$lastMenuLabel=$label}; # in menu generator 82 | if ($type eq "menuhead"){ 83 | $currentMenu="menu".$id; 84 | } 85 | elsif ($type eq "radio"){ 86 | 87 | } 88 | elsif ($type eq "check"){ 89 | 90 | } 91 | elsif ($type eq "separator"){ 92 | 93 | } 94 | else{ 95 | if($currentMenu!~m/$label/){ 96 | 97 | } 98 | } 99 | return $currentMenu; 100 | } 101 | sub aSP{ 102 | my ($self,$canvas, $id, $panelType, $content, $location, $size)=@_; 103 | 104 | if ($panelType eq "I"){ # Image panels start with I 105 | 106 | } 107 | elsif ($panelType eq "T"){ 108 | 109 | } 110 | } 111 | 112 | 113 | } 114 | 115 | 116 | #functions for GUIDeFATE to load the widgets into the backend 117 | sub addWidget{ 118 | push (@widgets,shift ); 119 | } 120 | sub addStyle{ 121 | my ($name,$style)=@_; 122 | $styles{$name}=$style; 123 | } 124 | sub addVar{ 125 | my ($varName,$value)=@_; 126 | $oVars{$varName}=$value; 127 | } 128 | 129 | # Functions for internal use 130 | sub getSize{ 131 | my ($self,$id)=@_; 132 | my $found=getItem($self,$id); 133 | return ( $found!=-1) ? $widgets[$found][5]:0; 134 | 135 | } 136 | sub getLocation{ 137 | my ($self,$id)=@_; 138 | my $found=getItem($self,$id); 139 | return ( $found!=-1) ? $widgets[$found][4]:0; 140 | 141 | } 142 | sub getItem{ 143 | my ($self,$id)=@_; 144 | $id=~s/[^\d]//g; 145 | my $i=0; my $found=-1; 146 | while ($i<@widgets){ 147 | if ($widgets[$i][1]==$id) { 148 | $found=$i; 149 | } 150 | $i++; 151 | } 152 | return $found; 153 | } 154 | 155 | sub setScale{ 156 | $winScale=shift; 157 | }; 158 | 159 | sub getFrame{ 160 | 161 | }; 162 | 163 | # The functions for GUI Interactions 164 | #Static Text functions 165 | sub setLabel{ 166 | my ($self,$id,$text)=@_; 167 | 168 | } 169 | 170 | #Image functions 171 | sub setImage{ 172 | my ($self,$id,$file)=@_; 173 | 174 | } 175 | 176 | #Text input functions 177 | sub getValue{ 178 | my ($self,$id)=@_; 179 | if ($id =~/TextCtrl/){ 180 | } 181 | else { 182 | if (exists $iVars{$id}){ 183 | return $iVars{$id} 184 | } 185 | } 186 | 187 | } 188 | sub setValue{ 189 | my ($self,$id,$text)=@_; 190 | 191 | } 192 | sub appendValue{ 193 | my ($self,$id,$text)=@_; 194 | 195 | } 196 | 197 | #Message box, Fileselector and Dialog Boxes 198 | sub showFileSelectorDialog{ 199 | 200 | my ($self, $message,$load,$filter) = @_; 201 | my $filename; 202 | 203 | return $filename; 204 | }; 205 | sub showDialog{ 206 | my ($self, $title, $message,$response,$icon) = @_; 207 | 208 | }; 209 | 210 | # Quit 211 | sub quit{ 212 | 213 | } 214 | 1; 215 | 216 | -------------------------------------------------------------------------------- /Examples/ImageMagickGUI/ImageMagickGUI.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | #A test script that creates a minimalist image magick 3 | #uses GUIDeFATE (which in turn depends on Wx, Tk or Gtk) 4 | #uses Image Magick https://xkcd.com/979/ 5 | 6 | use strict; 7 | use warnings; 8 | use lib "../lib/"; 9 | use GUIDeFATE; 10 | use Image::Magick; 11 | use File::Copy; 12 | 13 | my %IMCommands; 14 | open my $in, '<', "IMCommands.hsh" or die $!; 15 | { local $/; 16 | %IMCommands = eval <$in>; 17 | } 18 | close $in; 19 | 20 | my $menuString=makeGFMenu(17); 21 | 22 | my $window=<new($window,$backend,$assist); 70 | my $frame=$gui->getFrame||$gui; 71 | $gui->MainLoop; 72 | 73 | 74 | sub menu6 { #called using Menu with label New 75 | if($frame->showDialog("Sure?","This will wipe existing script...proceed?","OKC","!")){ 76 | $frame->setValue("TextCtrl1",""); 77 | } 78 | }; 79 | 80 | sub menu7 {#called using Menu with label Open 81 | if($frame->showDialog("Sure?","This will wipe existing script...proceed?","OKC","!")){ 82 | $frame->setValue("TextCtrl1",""); 83 | my $file= $frame->showFileSelectorDialog("Open file",1); 84 | if (open(my $fh, '<:encoding(UTF-8)', $file)) { 85 | while (my $row = <$fh>) { 86 | $frame->appendValue("TextCtrl1",$row) 87 | } 88 | close $fh; 89 | } 90 | } 91 | }; 92 | 93 | #Menu Save found, calls function &menu8 94 | sub menu8 {#called using Menu with label Save 95 | my $file= $gui->getFrame()->showFileSelectorDialog("Save file",0); 96 | if (open(my $fh, '>', $file)) { 97 | print $fh $frame->getValue("TextCtrl1"); 98 | close $fh 99 | } 100 | }; 101 | 102 | #Menu Quit found, calls function &menu9 103 | sub menu9 {#called using Menu with label Quit 104 | $frame->quit(); 105 | }; 106 | 107 | #Menuhead Image found 108 | #Menu Load found, calls function &menu12 109 | sub menu12 {#called using Menu with label Load Image 110 | if($frame->showDialog("Sure?","This will wipe existing image...proceed?","OKC","!")){ 111 | $inFile= $frame->showFileSelectorDialog("Open file",1); 112 | if ($inFile) {loadImage($inFile) }; 113 | } 114 | }; 115 | 116 | 117 | sub menu13 {#called using Menu with label Reload Image 118 | if($frame->showDialog("Sure?","This will wipe existing image...proceed?","OKC","!")){ 119 | if ($inFile) {loadImage($inFile) }; 120 | } 121 | }; 122 | 123 | sub menu14 {#called using Menu with label Run Script 124 | my $p = new Image::Magick; 125 | $p->Read($workingFile); 126 | my @script=split (";",$frame->getValue("TextCtrl1")); 127 | foreach my $line (@script){ 128 | $line=~s/\n//; 129 | $line="\$p->".$line; 130 | eval $line; 131 | print $!; 132 | } 133 | copy($workingFile,$workingFile.".bak") ; 134 | $p->Write($workingFile); 135 | $frame->setImage("Image2",$workingFile); 136 | 137 | }; 138 | 139 | sub menu15 {#called using Menu with label Undo 140 | if (-e $workingDir."/".$inFile.".bak") 141 | {copy($workingFile.".bak",$workingFile)}; 142 | loadImage($workingFile); 143 | 144 | 145 | }; 146 | 147 | 148 | sub menu16 { 149 | $outFile= $frame->showFileSelectorDialog("Save file",0); 150 | if ($outFile) { 151 | copy($workingFile,$outFile) or die "could not copy file $workingFile into $outFile $!"; 152 | } 153 | 154 | }; 155 | 156 | 157 | sub loadImage{ 158 | my $fileToLoad=shift; 159 | $workingFile= $fileToLoad; 160 | $workingFile=$workingDir."/".(split(/[\/\\]/,$workingFile))[-1]; 161 | if (-e $workingFile) { copy($workingFile,$workingFile.".bak") }; 162 | copy($fileToLoad,$workingFile) or die "could not copy file $fileToLoad into $workingFile $!"; 163 | $frame->setImage("Image2",$workingFile); 164 | } 165 | 166 | sub makeGFMenu{ 167 | my %IMMenu; my $type; my $menuString;my $commandsList; my $index=shift; 168 | foreach my $function (keys %IMCommands){ 169 | $type= ($IMCommands{$function}{Type} eq "")?"Misc":$IMCommands{$function}{Type}; 170 | if (!exists $IMMenu{$type}){ $IMMenu{$type}=[];}; 171 | push (@{$IMMenu{$type}}, $function); 172 | } 173 | foreach my $menuHead (sort(keys %IMMenu)){ 174 | $menuString.="-$menuHead\n"; 175 | $index+=2; 176 | foreach my $menuItem (sort(@{$IMMenu{$menuHead}})){ 177 | $index++; 178 | $menuString.="--$menuItem\n"; 179 | eval "sub menu$index {makePopUp($menuItem)};"; 180 | } 181 | } 182 | return $menuString; 183 | } 184 | 185 | sub makePopUp{ 186 | 187 | my $command=shift; 188 | if ($frame->showDialog($command,$IMCommands{$command}{Description}, "OKC" , "I") ){ 189 | my $params=$IMCommands{$command}{Parameters}; 190 | $params=~s/(([a-z]+=>[^{,]+,)|([a-z]+=>{[^}]+}),)/ $1\n/g; 191 | $frame->appendValue("TextCtrl1","\n$command(\n$params\n);\n"); 192 | } 193 | 194 | } 195 | 196 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # GUIDeFATE 2 | GUI Design From A Text Editor 3 | 4 | Designing a graphical User interface requires knowledge of things like toolkit libraries, platform context etc. At least I think it does. I am a relatively new programmer in that I have near zero experience in GUI programming outside a web page. So when I explore how to design an application which works outside a command line or a browser window, I feel tremendously out of my depth. When I see the programming interfaces to these interfaces (QT, GTK, TK, ncurses, HTML) my bewilderment reaches even greater heights. 5 | 6 | Sure there are clever things like wxGlade, and QT Designer etc. These are tools that also require more skill than I possess; I am old and I can just about use a text editor as an IDE. So what is needed? I need a GUI designer that: - 7 | 1) Is simple, abstracting away from the underlying Toolkit/platform 8 | 2) Requires the simplest designer possible, with a visual representation of the interface 9 | 3) Allows the use use of multiple different GUI engines 10 | 4) Makes it easy recognise the interface elements by simply looking at the code 11 | 12 | # How might this work? 13 | 14 | The user uses a text editor to design the window. Not new of course...text editors have had to be used to describe windows when other graphical representation methods were not possible. As this is already a two dimensional data, it should be possible to convert this into an actual graphical interface through an interpreter. The developer simply has to draw the interface in text and then program the interaction that is required. From version 0.06 multiple backends are supported, version 0.11 has 7 backends. For more details and working examples see the [wiki](https://github.com/saiftynet/GUIDeFATE/wiki) 15 | 16 | # How do I use it? 17 | 18 | GUIDeFATE requires an available working backend with their relevant connecting Perl modules. Different users will find different backends can be installed on their system. For instance Wx may not install easily in Perl versions before 5.16 without a lot of effort. Tk installs relatively easily gnerally and Gtk, and Win32 (for windows machines) may be more easily installed. Currently I dont feel it is robust enough for installation through CPAN...primarily because an attempt is made to install the backends which inariably fail because (e.g. Win32 is not available on Linux machines). So what I would suggest is that you test by unpacking this repo, and use the [Examples Folder](https://github.com/saiftynet/GUIDeFATE/tree/master/support_files/Examples); scrpting using `use lib ;` in your code will allow testing without committing. The [example code](https://github.com/saiftynet/GUIDeFATE/wiki/Example-Programs) that comes with the folder will probably be the best way to see how it works. 19 | 20 | # Textual Representation of a Graphical Interface 21 | 22 | A simple [hello world](https://github.com/saiftynet/GUIDeFATE/wiki/Hello-World) 23 | ``` 24 | +------------------+ 25 | |T Message | 26 | +------------------+ 27 | | | 28 | | Hello World! ! | 29 | | | 30 | +------------------+ 31 | ``` 32 | ![hello world](https://github.com/saiftynet/dummyrepo/blob/main/GUIDeFATE/helloworld.png) 33 | 34 | A Calculator 35 | ``` 36 | +------------------------+ 37 | |T Calculator | 38 | +------------------------+ 39 | | [__________________] | 40 | | { V }{ % }{ C }{AC } | 41 | | { 1 }{ 2 }{ 3 }{ + } | 42 | | { 4 }{ 5 }{ 6 }{ - } | 43 | | { 7 }{ 8 }{ 9 }{ * } | 44 | | { . }{ 0 }{ = }{ / } | 45 | | made with GUIdeFATE | 46 | +------------------------+ 47 | ``` 48 | 49 | # Example PERL script 50 | 51 | ```perl 52 | #!/usr/bin/perl -w 53 | use strict; 54 | use GUIDeFATE; 55 | use GUIDeFATE qw<$frame>; 56 | package Main; 57 | 58 | my $window=<new($window [$backend],[$assist]); # API changed at version 0.06 74 | # $backend is one of Wx(Default), Tk, Qt, Html, Web, Gtk2 or Gtk 75 | # $assist is one or "q" (quiet, default), "v" (verbose) or "a" for Autogenerate 76 | $gui->MainLoop; 77 | ``` 78 | This produces something like:- 79 | 80 | ![Calculator Screenshot](https://github.com/saiftynet/dummyrepo/blob/main/GUIDeFATE/calculator%20screenshot.png) 81 | 82 | From Version 0.10 seven backends are supported. Wx, Tk, Gtk, Qt, Win32, HTML, Websocket. These have different prerequisites. 83 | ![Multiple Backends](https://github.com/saiftynet/dummyrepo/blob/main/GUIDeFATE/Four%20backends%20supported.png) 84 | 85 | 86 | * Perl5.8.8, Exporter, Wx, Wx::Perl::Imagick (for Wx interface) 87 | * Perl5.8.8, Exporter, Tk, Image::Magick, Tk::JPEG, MIME::Base64 (for Tk interface) 88 | * Perl5.8.8, Exporter, Glib, Gtk3 (for Gtk3 interface) 89 | * Perl5.8.8, Exporter, Glib, Gtk2 (for Gtk2 interface) 90 | * Perl5.8.8, Exporter, QtCore4, QtGui4 (for Qt interface) 91 | * Perl5.8.8, Exporter, Win32, Imager (for Win32 interface) 92 | * Perl5.8.8, Exporter (for HTML interface) 93 | * Perl5.8.8, Exporter, Net::WebSocket::Server (for [WebSocket interface](https://github.com/saiftynet/GUIDeFATE/wiki/WebSocket-Applications) ) 94 | 95 | ## Widgets 96 | 97 | Supported Widgets: - 98 | 99 | 100 | # Widgets supported:- 101 | 102 | * Static Text 103 | ``` 104 | | Static text | 105 | ``` 106 | * Text Entry box 107 | ``` 108 | | [ Default text ] | 109 | ``` 110 | * Buttons 111 | ``` 112 | | {Button Label } | 113 | ``` 114 | * MultiLine Text box 115 | ``` 116 | | +T-----------------+ | 117 | | | | | 118 | | | | | 119 | | | | | 120 | | +------------------+ | 121 | ``` 122 | * Combo Box 123 | ``` 124 | | ^listName ^ | 125 | ``` 126 | * Image Panel 127 | ``` 128 | | +I-----------------+ | 129 | | | | | 130 | | | | | 131 | | | | | 132 | | +------------------+ | 133 | ``` 134 | * Menu 135 | ``` 136 | Menu 137 | -File 138 | --New 139 | --Open 140 | --Save Script 141 | --Quit 142 | ``` 143 | * Fileselector 144 | ``` 145 | my $file= $frame->showFileSelectorDialog("Save file",0); 146 | ``` 147 | * Message box 148 | ``` 149 | if($frame->showDialog("Sure?","This will wipe existing text...proceed?","OKC","!")){ 150 | 151 | } 152 | ``` 153 | 154 | * Timer (experimental memory leaks in non GTK backends) 155 | 156 | * Tooltips 157 | ``` 158 | $frame->tooltip(,); 159 | ``` 160 | * CheckListBox (not so well in Websocket and Wx) 161 | ``` 162 | | +C-------------------+ | 163 | | |checklistitems | | 164 | | | | | 165 | | +--------------------+ | 166 | ``` 167 | * [Timers](https://github.com/saiftynet/GUIDeFATE/wiki/Timers) also supported 168 | 169 | More will be made as time goes along 170 | 171 | NOTE: Amajor change happens from version 0.13 onwards. The Back-end modules (e.g. GFTk, GFWx, etc) will now reside in a folder called GUIDeFATE...this is reduce root namespace pollution making it easier to maintain. This will be commited to CPAN in a few months. 172 | 173 | 174 | -------------------------------------------------------------------------------- /Examples/SimpleLogo/SimpleLogo.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # A test script that allows a Logo-like program to be editted and run 3 | # uses GUIDeFATE (which in turn depends on Wx , GTK, QT, or Tk) 4 | # This file designed to be called by Executioner for backend testing 5 | # It uses Language::SIMPLE extended to interpret a script that can then be used 6 | # to generate an SVG file, which is displayed in a graphical panel 7 | 8 | use strict; 9 | use warnings; 10 | use GUIDeFATE; 11 | use lib '../lib/'; 12 | use Language::SIMPLE; 13 | 14 | use File::Copy qw(copy); 15 | 16 | my $window=<}{Center all}{AC}{Reset}| 21 | |+T---------------------++I---------------------------------------------------+| 22 | ||# Simple Logo ||simplelogo.svg || 23 | || || || 24 | || || || 25 | || || || 26 | || || || 27 | || || || 28 | || || || 29 | || || || 30 | || || || 31 | || || || 32 | || || || 33 | || || || 34 | || || || 35 | || || || 36 | || || || 37 | || || || 38 | || || || 39 | |+----------------------+| || 40 | |[ ]+----------------------------------------------------+| 41 | +------------------------------------------------------------------------------+ 42 | 43 | Menu 44 | -File 45 | --New 46 | --Open 47 | --Save Script 48 | --Quit 49 | -Image36 50 | --Draw 51 | --Save SVG 52 | --Save PNG 53 | -Examples 54 | --Star 55 | --Spiral 56 | --Flower 57 | --About 58 | END 59 | 60 | my $backend=$ARGV[0]?$ARGV[0]:"wx"; 61 | my $assist=$ARGV[1]?$ARGV[1]:"q"; 62 | my $gui=GUIDeFATE->new($window,$backend,$assist); 63 | my $frame=$gui->getFrame()||$gui; 64 | 65 | my $test= SIMPLE->new(); 66 | $test->extend("logo"); 67 | my $refresh=sub{$frame->setImage("Image14","simplelogo.svg");}; 68 | $test->setRefresh($refresh); 69 | my $turtle=""; 70 | my $logMode=0; 71 | menu33(); 72 | $gui->MainLoop; 73 | 74 | sub menu19{ 75 | if($frame->showDialog("Sure?","This will wipe existing text...proceed?","OKC","!")){ 76 | $frame->setValue("TextCtrl13",""); 77 | } 78 | } 79 | sub menu20{ 80 | if($frame->showDialog("Sure?","This will wipe existing text...proceed?","OKC","!")){ 81 | $frame->setValue("TextCtrl13",""); 82 | my $file= $frame->showFileSelectorDialog("Open file",1); 83 | if (open(my $fh, '<:encoding(UTF-8)', $file)) { 84 | while (my $row = <$fh>) { 85 | $frame->appendValue("TextCtrl13",$row); 86 | } 87 | close $fh; 88 | } 89 | } 90 | } 91 | sub menu21{ 92 | my $file= $frame->showFileSelectorDialog("Save file",0); 93 | if (open(my $fh, '>', $file)) { 94 | print $fh $frame->getValue("TextCtrl13"); 95 | close $fh 96 | } 97 | } 98 | sub menu22{ 99 | $frame->quit(); 100 | } 101 | sub menu25{ 102 | if ($logMode==1){ 103 | $frame->setValue("TextCtrl13",$turtle); 104 | $logMode=0; 105 | } 106 | else{ 107 | $turtle=$frame->getValue("TextCtrl13"); 108 | } 109 | $test->runCode($turtle); 110 | $test->execBlock(); 111 | $test->execBlock("svgout simplelogo"); 112 | $test->execBlock("refresh"); 113 | #$frame->setImage("Image15","simplelogo.svg"); 114 | } 115 | sub menu26{ 116 | my $file= $frame->showFileSelectorDialog("Save SVG image file",0); 117 | copy("simplelogo.svg", $file) 118 | } 119 | 120 | 121 | sub btn0{ 122 | menu25(); 123 | } 124 | sub btn1{ 125 | my $logs=$test->logs(); 126 | $turtle=$frame->getValue("TextCtrl13"); 127 | $logMode=1; 128 | $frame->setValue("TextCtrl13",$logs); 129 | } 130 | sub btn2{ 131 | $test->execBlock(['zoom in', 'svgout simplelogo','refresh']); 132 | } 133 | sub btn3{ 134 | $test->execBlock(['zoom out', 'svgout simplelogo','refresh']); 135 | } 136 | sub btn4{ 137 | $test->execBlock(['zoom all', 'svgout simplelogo','refresh']); 138 | } 139 | sub btn5{ 140 | $test->execBlock(['pan right','svgout simplelogo','refresh']); 141 | } 142 | sub btn6{ 143 | $test->execBlock(['pan up', 'svgout simplelogo','refresh']); 144 | } 145 | sub btn7{ 146 | $test->execBlock(['pan down', 'svgout simplelogo','refresh']); 147 | } 148 | sub btn8{ 149 | $test->execBlock(['pan left', 'svgout simplelogo','refresh']); 150 | } 151 | sub btn9{ 152 | $test->execBlock(['center all', 'svgout simplelogo','refresh']); 153 | } 154 | sub btn10{ 155 | $frame->setValue("TextCtrl13",""); 156 | $test->execBlock(['clear', 'svgout simplelogo','refresh']); 157 | } 158 | sub btn11{ 159 | $frame->setValue("TextCtrl13",""); 160 | $test->execBlock(['reset', 'svgout simplelogo','refresh']); 161 | 162 | } 163 | 164 | 165 | sub menu30{ 166 | $turtle=<setValue("TextCtrl13",$turtle); 183 | menu25(); 184 | } 185 | sub menu31{ 186 | $turtle=<setValue("TextCtrl13",$turtle); 225 | menu25(); 226 | } 227 | sub menu32{ 228 | $turtle=< 245 | minY+randint(maxY-minY) 246 | flower 247 | } 248 | 249 | sub flower{ 250 | mode polygon 251 | fill random 252 | repeat petals{ 253 | petal 254 | right 360-arc-360/petals 255 | } 256 | } 257 | 258 | sub petal{ 259 | fd seg 260 | repeat steps{ 261 | right arc/steps 262 | fd seg 263 | } 264 | } 265 | 266 | END 267 | 268 | $frame->setValue("TextCtrl13",$turtle); 269 | menu25(); 270 | } 271 | sub menu33{ 272 | $turtle=<setValue("TextCtrl13",$turtle); 315 | menu25(); 316 | } 317 | -------------------------------------------------------------------------------- /Examples/PlantsList/plantslist.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # A test script that search through the Plants List Database and uses 3 | # GUIDeFATE (which in turn depends on other graphical toolkits) 4 | # This file designed to be called by Executioner for backend testing 5 | # The main purpose is to test the various backends specially Websockets 6 | 7 | use strict; 8 | use warnings; 9 | use GUIDeFATE; 10 | 11 | use LWP::Simple; 12 | 13 | my $dataFolder="./plants"; # Path to data store 14 | my $imageFolder="./plants/images"; # path to images 15 | mkdir $dataFolder unless -d $dataFolder; 16 | mkdir $imageFolder unless -d $imageFolder; 17 | 18 | my @genera=(); # List of all genera found 19 | my @results=(); # indexes filtered species or genenera list 20 | my @genusList=(); # list off genera after filters (if filters applied) 21 | my @speciesList=(); # list of indexes of Species 22 | my $currentContext="No items in list"; 23 | my $oldContext; 24 | my $currentItem=0; 25 | my $currentGenus; 26 | my $currentGroup; 27 | my $currentSpecies; 28 | my $currentSearch=""; 29 | 30 | my $dateString; 31 | my($day, $month, $year)=(localtime)[3,4,5]; 32 | $month++; 33 | $year-=100; 34 | 35 | my %groups=( A => { name=> "Angiosperm", filtered =>0, total=>0, widget=>'stattext6' }, 36 | B => { name=> "Bryophytes", filtered =>0, total=>0, widget=>'stattext11' }, 37 | G => { name=> "Gymnosperms", filtered =>0, total=>0, widget=>'stattext7' }, 38 | P => { name=> "Pteridophytes",filtered =>0, total=>0, widget=>'stattext10' }, 39 | ); 40 | 41 | my $window=<} { Upload Photo } | 58 | | 0000 of 0000 | 59 | | www.theplantlist.org wikipedia.org | 60 | +-------------------------------------------+ 61 | END 62 | 63 | my $backend=$ARGV[0]?$ARGV[0]:"tk"; 64 | my $assist=$ARGV[1]?$ARGV[1]:"q"; 65 | my $gui=GUIDeFATE->new($window,$backend,$assist); 66 | my $frame=$gui->getFrame()||$gui; 67 | 68 | loadGenera(); 69 | searchGenera(); 70 | 71 | $frame->setLabel("stattext1",$dateString); 72 | 73 | $gui->MainLoop(); 74 | 75 | sub btn0 {#called using button with label Refresh Data 76 | createGeneraList(); 77 | updateCounts(); 78 | }; 79 | 80 | sub btn2 {#called using button with label Search 81 | $currentSearch=$frame->getValue("textctrl3"); 82 | searchGenera(); 83 | }; 84 | 85 | sub textctrl3 {#called using Text Control with default text ' 86 | }; 87 | 88 | sub btn4 {#called using button with label Angiosperms 89 | searchGenera("A"); 90 | }; 91 | 92 | sub btn5 {#called using button with label Gymnosperms 93 | searchGenera("G"); 94 | }; 95 | 96 | sub btn8 {#called using button with label Pteridophytes 97 | searchGenera("P"); 98 | }; 99 | 100 | sub btn9 {#called using button with label Bryophytes 101 | searchGenera("B"); 102 | }; 103 | 104 | sub btn18 {#called using button with label < 105 | prevItem(); 106 | }; 107 | 108 | sub btn19 {#called using button with label Explore 109 | if ($currentContext!~/Species/){ 110 | createSpeciesList(); 111 | } 112 | else { 113 | @results=@genusList; 114 | $currentItem=$currentGenus; 115 | $currentContext=$oldContext; 116 | updateView(); 117 | } 118 | }; 119 | 120 | sub btn20 {#called using button with label > 121 | nextItem(); 122 | }; 123 | 124 | sub btn21 {#called using button with label Wikipedia 125 | 126 | }; 127 | 128 | sub createGeneraList{ 129 | my $url='http://www.theplantlist.org/1.1/browse/-/-/'; 130 | my $content = get $url; 131 | $dateString="Data from: $day/$month/$year"; 132 | my @lines=split(/\n/, $content); 133 | @genera=(); 134 | foreach my $line (@lines){ 135 | if ($line=~/3){ push @genera, $line;} 139 | } 140 | } 141 | open my $fh, '>', "$dataFolder/genera.csv"; 142 | print $fh $dateString."\n"; 143 | print $fh join("\n",@genera); 144 | close $fh; 145 | } 146 | 147 | sub loadGenera{ 148 | if (! -e "$dataFolder/genera.csv"){ 149 | createGeneraList(); 150 | } 151 | else { 152 | @genera=(); 153 | open my $fh, "$dataFolder/genera.csv" or die "Couldn't open file: $!"; 154 | $dateString = <$fh>; 155 | while (<$fh>){ 156 | push @genera,$_; 157 | $groups{substr($_, 0, 1)}{filtered}++; 158 | } 159 | close $fh; 160 | chomp $dateString; 161 | } 162 | } 163 | 164 | sub createSpeciesList{ 165 | my ($group,$family,$genus,$accepted)=split(',', $genera[$results[$currentItem]]); 166 | my $url="http://www.theplantlist.org/1.1/browse/$group/$family/$genus/"; 167 | 168 | @genusList=@results; 169 | $currentGenus=$currentItem; 170 | 171 | @results=(); 172 | @speciesList=(); 173 | my $content = get $url; 174 | my @lines=split(/([^<]*)([^<]*)(0) ){ 204 | $currentItem--; 205 | updateView(); 206 | } 207 | } 208 | 209 | sub searchGenera{ 210 | my $grpFilter=shift; #search string 211 | 212 | $currentContext=((!$currentSearch ||($currentSearch eq ""))?"Unfiltered Search":"Filtered Search"). 213 | ($grpFilter?" (".$groups{$grpFilter}{name}.")":''); 214 | $oldContext=$currentContext; 215 | @results=(); 216 | foreach (qw/A B G P/){ # clear old counters 217 | $groups{$_}{filtered}=0; 218 | } 219 | for (my $c=0;$c<=$#genera;$c++){ 220 | my ($group,$family,$genus,$accepted)=split(',', $genera[$c]); 221 | if ((!$currentSearch ||($currentSearch eq "")) || (($family =~/\Q$currentSearch\E/i)||($genus =~/\Q$currentSearch\E/i))){ 222 | $groups{$group}{filtered}+=1; 223 | if (!$grpFilter || (($grpFilter)&&($group eq $grpFilter))){ 224 | push @results,$c; 225 | } 226 | } 227 | } 228 | if (! scalar @results){ 229 | @results=(0..$#genera); 230 | } 231 | $currentGenus=$results[0]; 232 | $currentItem=0; 233 | updateCounts(); 234 | updateView(); 235 | } 236 | 237 | sub updateCounts{ 238 | foreach (qw/A B G P/){ 239 | $frame->setLabel($groups{$_}{widget},$groups{$_}{filtered}); 240 | } 241 | } 242 | 243 | sub updateView{ 244 | my ($view,$image); 245 | $frame->setLabel("stattext12",$currentContext); 246 | if ($currentContext =~/Species/){ 247 | my ($group,$family,$genus,$species,$authorship,$record,$status)=split(',', $speciesList[$currentItem]); 248 | $view= "Group: - ".$groups{$group}{name} ."\n". 249 | "Family: - ".$family."\n". 250 | "Genus: - ".$genus."\n". 251 | "Species: - ".$species."\n". 252 | "Authorship:- ".$authorship."\n". 253 | "Record: - ".$record."\n". 254 | "Status: - ".(($status eq "A")?"Accepted":"Unresolved"); 255 | $image=searchImage($status,$genus,$species) 256 | 257 | } 258 | else { 259 | my ($group,$family,$genus,$accepted)=split(',', $genera[$results[$currentItem]]) ; 260 | $view= "Group: - ".$groups{$group}{name} ."\n". 261 | "Family: - ".$family."\n". 262 | "Genus: - ".$genus."\n". 263 | "Status: - ".(($accepted eq "A")?"Accepted":"Unresolved"); 264 | $image= searchImage($accepted,$genus,undef); 265 | } 266 | 267 | $frame->setImage("Image15",$image); 268 | $frame->setValue("TextCtrl14",$view); 269 | $frame->setLabel('stattext22',($currentItem+1) ." of ".($#results+1) ); 270 | } 271 | 272 | sub searchImage{ # looks for an image for the particular viewed item 273 | my ($status,$genus,$species)=@_; 274 | my @files; my $image; 275 | if ($status eq "A"){ # if the iitem is accepted bother to look for picture 276 | if ($species){ 277 | @files = glob( $imageFolder . "/$genus".'_'."$species.*" ); 278 | $image= (scalar @files) ? $files[0] : downloadImageFromWiki($genus.'_'.$species); 279 | } 280 | else { 281 | @files = glob( $imageFolder . "/$genus.*" ); } 282 | $image= (scalar @files) ? $files[0] : downloadImageFromWiki($genus); 283 | } 284 | else { 285 | $image=$imageFolder . '/unresolved.png'; # otherwise show an unresolved picture 286 | } 287 | 288 | return $image; 289 | 290 | sub downloadImageFromWiki{ 291 | my $pageName=shift; 292 | my $imagePath=$imageFolder."/noImage.png"; 293 | my $url="https://en.wikipedia.org/wiki/$pageName"; 294 | my $content = get $url; 295 | if ((defined $content)&&($content =~/]*>/, $content)[1]; 297 | $infoTable=( split /<\/table/, $infoTable )[0]; 298 | if ($infoTable=~/class="image">(]*>)/){ 299 | my $imgSrc=$1; 300 | $imgSrc=~/src="([^"]*\.(png|jpg|gif|bmp))"/; 301 | $imgSrc='http:'.$1; 302 | $imagePath=$imageFolder."/".$pageName.".$2"; 303 | getstore($imgSrc, $imagePath); 304 | } 305 | } 306 | return $imagePath; 307 | 308 | } 309 | } 310 | -------------------------------------------------------------------------------- /lib/GUIDeFATE/GFhtml.pm: -------------------------------------------------------------------------------- 1 | package GFhtml; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '0.14'; 6 | 7 | use Exporter 'import'; 8 | our @EXPORT = qw; 9 | our $frame; 10 | 11 | our $winX=30; 12 | our $winY=30; 13 | our $winWidth; 14 | our $winHeight; 15 | our $winTitle="title"; 16 | our $winScale=6.5; 17 | 18 | # these arrays will contain the widgets each as an arrayref of the parameters 19 | my @widgets=(); 20 | my %iVars=(); #vars for interface operation (e.g. 21 | my %oVars=(); #vars for interface creation (e.g. list of options) 22 | my %styles; 23 | 24 | my $lastMenuLabel; #bug workaround in menu generator may be needed for submenus 25 | 26 | sub new 27 | { 28 | my $class = shift; 29 | my $self={}; 30 | bless( $self, $class ); 31 | $self->{header}=header(); 32 | $self->{header}.="$winTitle $0 \n"; 33 | $self->{content}="
\n"; 34 | setupContent($self,$self->{content}); 35 | 36 | $self->{html}=$self->{header}; 37 | $self->{html}.="\n\n\n". 38 | "\n". 39 | "\n\n"; 40 | $self->{html}.=$self->{content}; 41 | if ($self->{menubar}){ $self->{html}.= $self->{menubar} . "\n
\n";} 42 | $self->{html}.= "
\n\n"; 43 | 44 | my $filename = $0.".html"; 45 | open(my $fh, '>', $filename) or die "Could not open file '$filename' $!"; 46 | print $fh $self->{html}; 47 | close $fh; 48 | return $self; 49 | }; 50 | 51 | sub MainLoop{ #activate UI 52 | my $self=shift; 53 | my $htmlFile=$0.".html"; 54 | if ($^O =~/linux/){ system("xdg-open ./".$htmlFile."\n"); } 55 | elsif ($^O =~/Win/){ system("start .\\".$htmlFile."\n"); } 56 | else{ system("open ./".$htmlFile."\n"); } 57 | } 58 | 59 | # setupContent sets up the initial content before Mainloop can be run. 60 | sub setupContent{ 61 | my ($self, $canvas)=@_; # pass both object as well as the frame element 62 | $self ->{"menubar"}=undef; # menu not yet defined 63 | my $currentMenu; # undefined menu 64 | foreach my $widget (@widgets){ # read each widget data and call gnerator 65 | my @params=@$widget; 66 | my $wtype=shift @params; 67 | if ($wtype eq "btn") {aBt($self, $canvas, @params);} 68 | elsif ($wtype eq "textctrl") {aTC($self, $canvas, @params);} 69 | elsif ($wtype eq "stattext") {aST($self, $canvas, @params);} 70 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 71 | elsif ($wtype eq "combo") {aCB($self, $canvas, @params);} 72 | elsif ($wtype eq "chkbox") {aKB($self, $canvas, @params);} 73 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 74 | elsif ($wtype eq "mb") 75 | { 76 | if (! $self->{"menubar"}){ 77 | $self ->{"menubar"} = "
\n
    "; 78 | } 79 | $currentMenu=aMB($self,$canvas,$currentMenu,@params) 80 | } 81 | else { 82 | print "Widget type $wtype withh parameters ".join(", ",@params). "cannot be created"; 83 | } 84 | } 85 | if ($self->{"menubar"}) { $self->{"menubar"}.="
\n\n"; } 86 | 87 | sub aBt{ 88 | my ($self,$canvas, $id, $label, $location, $size, $action)=@_;# Button generator 89 | $self->{content}.="\n"; 91 | } 92 | sub aTC{ 93 | my ($self,$canvas, $id, $text, $location, $size, $action)=@_;# Single line input generator 94 | $self->{content}.="\n"; 96 | } 97 | sub aST{ 98 | my ($self,$canvas, $id, $text, $location)=@_; #Static text element generator 99 | $self->{content}.="
".$text."
\n"; 100 | } 101 | sub aCB{ 102 | my ($self,$canvas, $id, $label, $location, $size, $action)=@_; #gnerator for comoboxes 103 | if (defined $oVars{$label}){ 104 | my @strings2 = split(",",$oVars{$label}); # extract the defined options 105 | $self->{content}.="\n"; 111 | } 112 | else {print "Combo options not defined for 'combo$id' with label $label\n"}; 113 | } 114 | sub aKB{ 115 | my ($self,$canvas, $id, $label, $location, $action)=@_; 116 | $self->{content}.= "
117 |
" 118 | } 119 | 120 | sub aMB{ 121 | my ($self,$canvas,$currentMenu, $id, $label, $type, $action)=@_; 122 | if (($lastMenuLabel) &&($label eq $lastMenuLabel)){return $currentMenu} # bug workaround 123 | else {$lastMenuLabel=$label}; # in menu generator 124 | if ($type eq "menuhead"){ 125 | if (defined $currentMenu){$canvas.="";} 126 | $currentMenu="menu".$id; 127 | $self ->{"menubar"}.="
  • \n$label\n
    \n"; 128 | } 129 | elsif ($type eq "radio"){ 130 | 131 | } 132 | elsif ($type eq "check"){ 133 | 134 | } 135 | elsif ($type eq "separator"){ 136 | 137 | } 138 | else{ 139 | if($currentMenu!~m/$label/){ 140 | $self ->{"menubar"}.="$label\n" 141 | } 142 | } 143 | return $currentMenu; 144 | } 145 | sub aSP{ 146 | my ($self,$canvas, $id, $panelType, $content, $location, $size)=@_; 147 | 148 | if ($panelType eq "I"){ # Image panels start with I 149 | $self->{content}.="\n"; 151 | } 152 | elsif ($panelType eq "T"){ 153 | $self->{content}.="\n"; 155 | } 156 | elsif ($panelType eq "L"){ 157 | my @strings2 = split(",",$oVars{$content}); # extract the defined options 158 | my $options="";my $index=0; 159 | foreach (@strings2){$options.="\n";} 160 | $self->{content}.="\n"; 162 | } 163 | } 164 | } 165 | 166 | 167 | #functions for GUIDeFATE to load the widgets into the backend 168 | sub addWidget{ 169 | push (@widgets,shift ); 170 | } 171 | sub addStyle{ 172 | my ($name,$style)=@_; 173 | $styles{$name}=$style; 174 | } 175 | sub addVar{ 176 | my ($varName,$value)=@_; 177 | $oVars{$varName}=$value; 178 | } 179 | 180 | # Functions for internal use 181 | sub getSize{ 182 | my ($self,$id)=@_; 183 | my $found=getItem($self,$id); 184 | return ( $found!=-1) ? $widgets[$found][5]:0; 185 | 186 | } 187 | sub getLocation{ 188 | my ($self,$id)=@_; 189 | my $found=getItem($self,$id); 190 | return ( $found!=-1) ? $widgets[$found][4]:0; 191 | 192 | } 193 | sub getItem{ 194 | my ($self,$id)=@_; 195 | $id=~s/[^\d]//g; 196 | my $i=0; my $found=-1; 197 | while ($i<@widgets){ 198 | if ($widgets[$i][1]==$id) { 199 | $found=$i; 200 | } 201 | $i++; 202 | } 203 | return $found; 204 | } 205 | 206 | sub setScale{ 207 | $winScale=shift; 208 | }; 209 | 210 | sub getFrame{ 211 | 212 | }; 213 | 214 | # The functions for GUI Interactions 215 | #Static Text functions 216 | sub setLabel{ 217 | my ($self,$id,$text)=@_; 218 | 219 | } 220 | 221 | #Image functions 222 | sub setImage{ 223 | my ($self,$id,$file)=@_; 224 | 225 | } 226 | 227 | #Text input functions 228 | sub getValue{ 229 | my ($self,$id)=@_; 230 | if ($id =~/TextCtrl/){ 231 | } 232 | else { 233 | if (exists $iVars{$id}){ 234 | return $iVars{$id} 235 | } 236 | } 237 | 238 | } 239 | sub setValue{ 240 | my ($self,$id,$text)=@_; 241 | 242 | } 243 | sub appendValue{ 244 | my ($self,$id,$text)=@_; 245 | 246 | } 247 | 248 | #Message box, Fileselector and Dialog Boxes 249 | sub showFileSelectorDialog{ 250 | 251 | my ($self, $message,$load,$filter) = @_; 252 | my $filename; 253 | 254 | return $filename; 255 | }; 256 | sub showDialog{ 257 | my ($self, $title, $message,$response,$icon) = @_; 258 | 259 | }; 260 | 261 | # Quit 262 | sub quit{ 263 | 264 | } 265 | 266 | 267 | sub css{ 268 | return < 327 | END 328 | 329 | } 330 | 331 | sub js{ 332 | return <; 11 | our $frame; 12 | 13 | our $winX=30; 14 | our $winY=30; 15 | our $winWidth; 16 | our $winHeight; 17 | our $winTitle; 18 | our $winScale=6.5; 19 | 20 | # these arrays will contain the widgets each as an arrayref of the parameters 21 | my @widgets=(); 22 | my %iVars=(); #vars for interface operation (e.g. 23 | my %oVars=(); #vars for interface creation (e.g. list of options) 24 | my %styles; 25 | my %timers; 26 | 27 | my $lastMenuLabel; #bug workaround in menu generator may be needed for submenus 28 | 29 | sub new 30 | { 31 | my $class = shift; 32 | my $self = Prima::MainWindow->new(text=>$winTitle, 33 | size=> [$winWidth,$winHeight]); # call the superclass' constructor 34 | $self->{frame}={}; 35 | setupContent($self,$self->frame); #then add content 36 | run Prima; 37 | return $self; 38 | }; 39 | 40 | # setupContent sets up the initial content before Mainloop can be run. 41 | sub setupContent{ 42 | my ($self, $canvas)=@_; 43 | $self ->{"menubar"}=undef; 44 | my $currentMenu; 45 | foreach my $widget (@widgets){ 46 | my @params=@$widget; 47 | my $wtype=shift @params; 48 | if ($wtype eq "btn") {aBt($self, $canvas, @params);} 49 | elsif ($wtype eq "textctrl") {aTC($self, $canvas, @params);} 50 | elsif ($wtype eq "stattext") {aST($self, $canvas, @params);} 51 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 52 | elsif ($wtype eq "combo") {aCB($self, $canvas, @params);} 53 | elsif ($wtype eq "chkbox") {aKB($self, $canvas, @params);} 54 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 55 | elsif ($wtype eq "mb") 56 | { 57 | if (! $self->{"menubar"}){ 58 | $self->configure(-menu => $self ->{"menubar"} = $self->Menu); 59 | } 60 | $currentMenu=aMB($self,$canvas,$currentMenu,@params) 61 | } 62 | else { 63 | print "Widget type $wtype withh parameters ".join(", ",@params). "cannot be created\n"; 64 | } 65 | } 66 | #setup timers 67 | foreach my $timerID (keys %timers){ 68 | #$timers{$timerID}{timer} = AnyEvent->timer (after => 0, interval => $timers{$timerID}{interval}/1000, cb => $timers{$timerID}{function}); 69 | $canvas->repeat($timers{$timerID}{interval}, $timers{$timerID}{function}); #docstore.mik.ua/orelly/perl3/tk/ch13_22.htm 70 | #$timers{$timerID}{timer} = AE::timer 1, $timers{$timerID}{interval}/1000, $timers{$timerID}{function}; 71 | #if ($timers{$timerID}{interval}>0){ 72 | #$timers{$timerID}{timer}->start($timers{$timerID}{interval}); 73 | #} 74 | } 75 | 76 | sub aBt{ 77 | my ($self,$canvas, $id, $label, $location, $size, $action)=@_; 78 | $canvas->{"btn$id"}=Prima::Button->new(text => $label, 79 | width => ${$size}[0]/6.68-4, 80 | height => ${$size}[1]/16, 81 | owner => $self); 82 | } 83 | sub aTC{ 84 | my ($self,$canvas, $id, $text, $location, $size, $action)=@_; 85 | $canvas->{"textctrl$id"}=Prima::InputLine->new( 86 | bg => 'white', 87 | text => $text, 88 | width => (${$size}[0]+32)/8, 89 | owner =>$self); 90 | } 91 | sub aST{ 92 | my ($self,$canvas, $id, $text, $location)=@_; 93 | $canvas->{"stattext$id"}=Prima::Label->new(text => $text, 94 | owner =>$self); 95 | } 96 | sub aCB{ #adapted from http://www.perlmonks.org/?node_id=799673 97 | my ($self,$canvas, $id, $label, $location, $size, $action)=@_; 98 | if (defined $oVars{$label}){ 99 | my @strings2 = split(",",$oVars{$label}); 100 | $iVars{"combo$id"}=$strings2[0]; 101 | $canvas->{"combo$id"}=$canvas->BrowseEntry( 102 | -variable => \($iVars{"combo$id"}), 103 | -listheight => scalar @strings2, 104 | -listwidth => (${$size}[0]-20)/2, 105 | -browsecmd => $action); 106 | foreach (@strings2){ $canvas->{"combo$id"}->insert("end",$_);} 107 | $canvas->{"cont$id"}=$canvas->{"combo$id"}->Subwidget('slistbox')->Subwidget('scrolled');#?? 108 | 109 | $canvas->createWindow(${$location}[0] ,${$location}[1], 110 | -width => (${$size}[0]-20)*1.5, 111 | -height => ${$size}[1], 112 | -anchor => "nw", 113 | -window =>$canvas->{"combo$id"}); 114 | } 115 | 116 | else {print "Combo options not defined for 'combo$id' with label $label\n"} 117 | 118 | } 119 | sub aKB{ 120 | my ($self,$canvas, $id, $label, $location, $size,$action)=@_; 121 | $canvas->{"chkbox$id"}=$canvas->Checkbutton(-text => $label, 122 | -command => $action); 123 | $canvas->createWindow(${$location}[0] ,${$location}[1], 124 | -anchor => "nw", 125 | -window => $canvas->{"chkbox$id"}); 126 | 127 | } 128 | sub aMB{ 129 | my ($self,$canvas,$currentMenu, $id, $label, $type, $action)=@_; 130 | if (($lastMenuLabel) &&($label eq $lastMenuLabel)){return $currentMenu} # bug workaround 131 | else {$lastMenuLabel=$label}; # in menu generator 132 | 133 | 134 | if ($type eq "menuhead"){ 135 | $currentMenu="menu".$id; 136 | $self ->{$currentMenu} = $self ->{"menubar"}->cascade(-label => "~$label") 137 | } 138 | elsif ($type eq "radio"){ 139 | $self ->{$currentMenu}->radiobutton(-label => $label); 140 | } 141 | elsif ($type eq "check"){ 142 | $self ->{$currentMenu}->checkbutton(-label => $label); 143 | } 144 | elsif ($type eq "separator"){ 145 | $self ->{$currentMenu}->separator; 146 | } 147 | else{ 148 | if($currentMenu!~m/$label/){ 149 | $self ->{$currentMenu}->command(-label => $label, -command =>$action); 150 | } 151 | } 152 | # logging menu generator print "$currentMenu---$id----$label---$type\n"; 153 | return $currentMenu; 154 | } 155 | sub aSP{ 156 | my ($self,$canvas, $id, $panelType, $content, $location, $size)=@_; 157 | 158 | if ($panelType eq "I"){ 159 | } 160 | elsif ($panelType eq "T"){ 161 | } 162 | } 163 | } 164 | 165 | 166 | #functions for GUIDeFATE to load the widgets into the backend 167 | sub addWidget{ 168 | push (@widgets,shift ); 169 | } 170 | sub addStyle{ 171 | my ($name,$style)=@_; 172 | $styles{$name}=$style; 173 | } 174 | sub addVar{ 175 | my ($varName,$value)=@_; 176 | $oVars{$varName}=$value; 177 | } 178 | sub addTimer{ 179 | my ($timerID,$interval,$function,$start)=@_; 180 | $timers{$timerID}{interval}=$interval; 181 | $timers{$timerID}{function}=$function; 182 | $timers{$timerID}{start}=$start; 183 | } 184 | 185 | # Functions for internal use 186 | sub getSize{ 187 | my ($self,$id)=@_; 188 | my $found=getItem($self,$id); 189 | return ( $found!=-1) ? $widgets[$found][5]:0; 190 | 191 | } 192 | sub getLocation{ 193 | my ($self,$id)=@_; 194 | my $found=getItem($self,$id); 195 | return ( $found!=-1) ? $widgets[$found][4]:0; 196 | 197 | } 198 | sub getItem{ 199 | my ($self,$id)=@_; 200 | $id=~s/[^\d]//g; 201 | my $i=0; my $found=-1; 202 | while ($i<@widgets){ 203 | if ($widgets[$i][1]==$id) { 204 | $found=$i; 205 | } 206 | $i++; 207 | } 208 | return $found; 209 | } 210 | 211 | sub setScale{ 212 | $winScale=shift; 213 | }; 214 | 215 | sub getFrame{ 216 | return 1 217 | }; 218 | 219 | # The functions for GUI Interactions 220 | #Static Text functions 221 | sub setLabel{ 222 | my ($self,$id,$text)=@_; 223 | my $location=$widgets[getItem($self,$id)][3]; 224 | $frame->delete($frame->{"$id"}); 225 | $frame->{"$id"}=$frame->createText(${$location}[0] ,${$location}[1], 226 | -anchor => "nw", 227 | -text => $text, 228 | -font =>'medium' 229 | ); 230 | } 231 | 232 | #Image functions 233 | sub setImage{ 234 | my ($self,$id,$file)=@_; 235 | my $location=getLocation($self,$id,\@widgets); 236 | my $size=getSize($self,$id,\@widgets); 237 | if ($size){ 238 | my $image = Image::Magick->new; 239 | my $r = $image->Read("$file"); 240 | if ($image){ 241 | my $bmp; # used to hold the bitmap. 242 | my $geom=${$size}[0]."x".${$size}[1]."!"; 243 | $image->Scale(geometry => $geom); 244 | $bmp = ( $image->ImageToBlob(magick=>'jpg') )[0]; 245 | $frame->{"$id"}=$frame->createImage(${$location}[0],${$location}[1], 246 | -anchor=>"nw", 247 | -image => $frame->Photo(#"img$id", 248 | -format=>'jpeg', 249 | -data=>encode_base64($bmp) )); 250 | # $frame->update(); # force refresh...does not work? 251 | undef $bmp; 252 | } 253 | else {"print failed to load image $file \n";} 254 | } 255 | else {print "Panel not found"} 256 | 257 | 258 | } 259 | 260 | #Text input functions 261 | sub getValue{ 262 | my ($self,$id)=@_; 263 | if ($id =~/TextCtrl/){return $frame->{$id}->get('1.0','end-1c'); } 264 | else { 265 | if (exists $iVars{$id}){ 266 | return $iVars{$id} 267 | } 268 | else{ return $frame->{$id}->get(); } 269 | } 270 | 271 | } 272 | sub setValue{ 273 | my ($self,$id,$text)=@_; 274 | $frame->{"$id"}->delete('0.0','end'); 275 | $frame->{"$id"}->insert("end",$text); 276 | } 277 | sub appendValue{ 278 | my ($self,$id,$text)=@_; 279 | $frame->{$id}->insert('end',$text); 280 | } 281 | 282 | #Message box, Fileselector and Dialog Boxes 283 | sub showFileSelectorDialog{ 284 | 285 | my ($self, $message,$load) = @_; 286 | my $filename; 287 | if ($load){ 288 | $filename = $self->getOpenFile( -title => $message, 289 | -defaultextension => '.txt', -initialdir => '.' ); 290 | warn "Opened $filename\n"; 291 | } 292 | else{ 293 | $filename = $self->getSaveFile( -title => $message, 294 | -defaultextension => '.txt', -initialdir => '.' ); 295 | warn "Saved $filename\n"; 296 | 297 | } 298 | return $filename; 299 | 300 | }; 301 | sub showDialog{ 302 | my ($self, $title, $message,$response,$icon) = @_; 303 | my %responses=( YNC=>'YesNoCancel', 304 | YN =>'YesNo', 305 | OK => 'Ok', 306 | OKC=>'OkCancel' ); 307 | 308 | my %icons= ( "!"=>"warning", 309 | "?"=>"question", 310 | "E"=>"error", 311 | "H"=>"warning", 312 | "I"=>"info" ); 313 | $response=$response?$responses{$response}:"ok"; 314 | $icon=$icon?$icons{$icon}:"info"; 315 | my $answer= $self->messageBox( 316 | -icon => $icon, -message => $message, -title => $title, -type => $response); 317 | return (($answer eq "Ok")||($answer eq "Yes")) 318 | }; 319 | 320 | # Quit 321 | sub quit{ 322 | my ($self) = @_; 323 | $self ->destroy; 324 | } 325 | 1; 326 | -------------------------------------------------------------------------------- /lib/GUIDeFATE/GFwin32.pm: -------------------------------------------------------------------------------- 1 | package GFwin32; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '0.14'; 6 | 7 | use Win32::GUI; 8 | use Imager; 9 | 10 | use Exporter 'import'; ##somefunctions are always passed back to GUIDeFATE.pm 11 | our @EXPORT = qw; 12 | our $frame; # The frame which is the parent of all the widgets 13 | # ever widget is referenced by an id and is accessible by $frame -> {id} 14 | 15 | our $winX=30; # These are the window dimensions and are modified by GUIDeFATE 16 | our $winY=30; 17 | our $winWidth; 18 | our $winHeight; 19 | our $winTitle; 20 | our $winScale=6.5; # This allows the window to be scaled 21 | 22 | # these arrays will contain the widgets each as an arrayref of the parameters 23 | # It may be logical to group them as one array conatining eveything and this 24 | # may be the way to go when ready to push out v1.0 25 | my @widgets=(); 26 | my %iVars=(); #vars for interface operation (e.g. 27 | my %oVars=(); #vars for interface creation (e.g. list of options) 28 | my %styles; # styles is a future mod that allows widgets to be styled 29 | my %timers; 30 | 31 | my $lastMenuLabel; 32 | 33 | sub new 34 | { 35 | my $class=shift; 36 | my $self={}; 37 | bless ($self,$class); 38 | $self->{Window}= new Win32::GUI::Window( 39 | -name => "GF", 40 | -title => $winTitle, 41 | -pos => [ $winX,$winY ], 42 | -size => [ $winWidth+10, $winHeight+50 ], 43 | ); 44 | $self->{Window}->Show(); 45 | $self->{font} = Win32::GUI::Font->new( 46 | -name => "Arial", 47 | -size => 16, 48 | ); 49 | &setupContent($self, $self->{Window} ); 50 | 51 | $self->{Window}->Show(); 52 | return $self; 53 | }; 54 | 55 | sub MainLoop{ 56 | Win32::GUI::Dialog(); 57 | }; 58 | 59 | sub GF_Terminate { return -1; } 60 | 61 | # setupContent sets up the initial content before Mainloop can be run. 62 | sub setupContent{ 63 | my ($self, $canvas)=@_; 64 | $self ->{"menubar"}=undef; 65 | my $currentMenu; 66 | foreach my $widget (@widgets){ 67 | my @params=@$widget; 68 | my $wtype=shift @params; 69 | if ($wtype eq "btn") {aBt($self, $canvas, @params);} 70 | elsif ($wtype eq "textctrl") {aTC($self, $canvas, @params);} 71 | elsif ($wtype eq "stattext") {aST($self, $canvas, @params);} 72 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 73 | elsif ($wtype eq "combo") {aCB($self, $canvas, @params);} 74 | elsif ($wtype eq "sp") {aSP($self, $canvas, @params);} 75 | elsif ($wtype eq "mb") 76 | { 77 | if (! $self->{"menubar"}){ 78 | $self ->{"menubar"} = Win32::GUI::Menu->new();; 79 | $canvas->SetMenu($self ->{"menubar"}); 80 | } 81 | $currentMenu=aMB($self,$canvas,$currentMenu,@params) 82 | } 83 | } 84 | foreach my $timerID (keys %timers){ 85 | $timers{$timerID}{timer} = new Win32::GUI::Timer( $canvas, $timerID, $timers{$timerID}{interval} ); 86 | *{$timerID."_Timer")=$timers{$timerID}{function} 87 | } 88 | 89 | # these functions convert the parameters of the widget into actual widgets 90 | sub aBt{ # creates buttons 91 | my ($self,$frame, $id, $label, $location, $size, $action)=@_; 92 | $self->{"btn$id"}=$frame->AddButton( 93 | -name => "btn$id", 94 | -text => $label, 95 | -pos => $location, 96 | -size => $size, 97 | -onClick => $action, 98 | ); 99 | # button id are "btn".$id, action is generally also a function called "btn".$id 100 | # referenced by $frame->{"btn".$id} 101 | } 102 | sub aTC{ # single line text entry 103 | my ($self,$frame, $id, $text, $location, $size, $action)=@_; 104 | $self->{"textctrl$id"} = $frame->AddTextfield( 105 | -text => $text, 106 | -pos => $location, 107 | -size => $size, 108 | ); 109 | } 110 | sub aST{ #static texts 111 | my ($self,$frame, $id, $text, $location)=@_; 112 | $self->{"stattext$id"} = $frame->AddLabel( 113 | -text => $text, 114 | -font => $self->{font}, 115 | -pos => $location, 116 | -wrap => 0, 117 | -truncate => 0, 118 | -foreground => [255, 0, 0], 119 | ); 120 | } 121 | sub aCB{ 122 | my ($self,$canvas, $id, $label, $location, $size, $action)=@_; 123 | $self->{"combo$id"}=$canvas->AddCombobox( 124 | -name => "combo_box1", 125 | -size => $size, 126 | -pos => $location, 127 | -dropdownlist=> 0, 128 | -onChange =>$action, 129 | ); 130 | my @strings2 = split(",",$oVars{$label}); 131 | $iVars{"combo$id"}=$strings2[0]; 132 | foreach (@strings2){ $self->{"combo$id"}->InsertItem($_);} 133 | 134 | } 135 | sub aKB{ 136 | 137 | } 138 | sub aMB{ #parses the menu items into a menu. menus may need to be a child of main window 139 | my ($self,$canvas,$currentMenu, $id, $label, $type, $action)=@_; 140 | if (($lastMenuLabel) &&($label eq $lastMenuLabel)){return $currentMenu} # bug workaround 141 | else {$lastMenuLabel=$label}; # in menu generator 142 | 143 | 144 | if ($type eq "menuhead"){ #the label of the menu 145 | $currentMenu="menu".$id; 146 | $self ->{$currentMenu} = $self ->{"menubar"}->AddMenuButton( -text, $label); 147 | } 148 | elsif ($type eq "radio"){ #menu items which are radio buttons in tk there is no function called 149 | 150 | } 151 | elsif ($type eq "check"){ #menu items which are check boxes in tk there is no function called 152 | 153 | } 154 | elsif ($type eq "separator"){ #separators 155 | 156 | } 157 | else{ 158 | if($currentMenu!~m/$label/){ 159 | $self ->{"menu$id"} = $self ->{$currentMenu}->AddMenuItem( 160 | -text => $label, 161 | -id =>$id, 162 | -name => "menu$id", 163 | -onClick => $action, 164 | ); 165 | } 166 | 167 | } 168 | $canvas->SetMenu($self ->{"menubar"}); 169 | return $currentMenu; 170 | } 171 | sub aSP{ 172 | my ($self,$frame, $id, $panelType, $content, $location, $size)=@_; ##image Id must endup $id+1 173 | if ($panelType eq "I"){ # Image panels start with I 174 | $content=~s/^\s+|\s+$//g; 175 | $self->{"Image$id"} = $frame->AddLabel( 176 | -text => "GFPic", 177 | -style => '14', 178 | -visible => '1', 179 | -background => [255,255,255], 180 | -foreground => [0,0,0], 181 | -pos => $location, 182 | ); 183 | # $self->{"Image$id"}->SetImage( new Win32::GUI::Bitmap("GFtmp.bmp") ); 184 | if (-e $content){ 185 | my $image = Imager->new; 186 | $image->read(file=>"$content"); 187 | my $newimg = $image->scale(xpixels=>${$size}[0], ypixels=>${$size}[1],type=>'nonprop'); 188 | $newimg->write(file=>"GFtmp.bmp"); 189 | $self->{"Image$id"}->SetImage( new Win32::GUI::Bitmap("GFtmp.bmp") ); 190 | } 191 | } 192 | 193 | elsif ($panelType eq "T"){ # text entry panels start with T 194 | $content=~s/^\s+|\s+$//g; 195 | $id++; 196 | $self->{"TextCtrl$id"} = $frame->AddTextfield( 197 | -text => $content, 198 | -multiline => 1, 199 | -autohscroll => 1, 200 | -autovscroll => 1, 201 | -pos => $location, 202 | -size => $size, 203 | ); 204 | } 205 | } 206 | } 207 | 208 | #functions for GUIDeFATE to load the widgets into the backend 209 | sub addWidget{ 210 | push (@widgets,shift ); 211 | } 212 | sub addStyle{ 213 | my ($name,$style)=@_; 214 | $styles{$name}=$style; 215 | } 216 | sub addVar{ 217 | my ($varName,$value)=@_; 218 | $oVars{$varName}=$value; 219 | } 220 | 221 | # Functions for internal use 222 | sub getSize{ 223 | my ($self,$id)=@_; 224 | my $found=getItem($self,$id); 225 | return ( $found!=-1) ? $widgets[$found][5]:0; 226 | 227 | } 228 | sub getLocation{ 229 | my ($self,$id)=@_; 230 | my $found=getItem($self,$id); 231 | return ( $found!=-1) ? $widgets[$found][3]:0; 232 | 233 | } 234 | sub getItem{ 235 | my ($self,$id)=@_; 236 | $id=~s/[^\d]//g; 237 | my $i=0; my $found=-1; 238 | while ($i<@widgets){ 239 | if ($widgets[$i][1]==$id) { 240 | $found=$i; 241 | } 242 | $i++; 243 | } 244 | return $found; 245 | } 246 | 247 | sub setScale{ 248 | $winScale=shift; 249 | }; 250 | 251 | sub getFrame{ 252 | my $self=shift; 253 | return $self; 254 | }; 255 | 256 | # The functions for GUI Interactions 257 | # Static Text functions 258 | sub setLabel{ 259 | my ($self,$id,$text)=@_; 260 | $self->{$id}->Text(""); 261 | # label persists...but not contains empty string? how to delete? 262 | my $location=getLocation($self,$id,\@widgets); 263 | $self->{$id} = $self->{Window}->AddLabel( 264 | -text => $text, 265 | -font => $self->{font}, 266 | -pos => $location, 267 | ) 268 | } 269 | 270 | #Image functions 271 | sub setImage{ 272 | my ($self,$id,$file)=@_; 273 | my $size=getSize($self,$id,\@widgets); 274 | my $location=getLocation($self,$id,\@widgets); 275 | my $image = Imager->new; 276 | $image->read(file=>"$file"); 277 | my $newimg = $image->scale(xpixels=>${$size}[0], ypixels=>${$size}[1],type=>'nonprop'); 278 | $newimg->write(file=>"GFtmp.bmp"); 279 | $self->{"$id"}->SetImage( new Win32::GUI::Bitmap("GFtmp.bmp") );; 280 | }; 281 | 282 | #Text input functions 283 | sub getValue{ 284 | my ($self,$id)=@_; 285 | return $self->{$id}->Text(); 286 | # function to get value of an input box 287 | } 288 | sub setValue{ 289 | my ($self,$id,$text)=@_; 290 | $self->{$id}->Text( $text ); 291 | } 292 | sub appendValue{ 293 | my ($self,$id,$text)=@_; 294 | $self->{$id}->Append( $text ); 295 | } 296 | 297 | #Message box, Fileselector and Dialog Boxes 298 | sub showFileSelectorDialog{ 299 | 300 | my ($self, $message,$load) = @_; 301 | my $filename; 302 | if ($load){ 303 | $filename = Win32::GUI::GetOpenFileName ( 304 | -owner => $self->{Window}, 305 | -title =>$message, 306 | -directory => ".", 307 | ) ; 308 | warn "Opened $filename\n"; 309 | } 310 | else{ 311 | $filename = Win32::GUI::GetSaveFileName ( 312 | -title=>$message, 313 | ); 314 | warn "Saved $filename\n"; 315 | } 316 | return $filename; 317 | }; 318 | sub showDialog{ 319 | my ($self, $title, $message,$response,$icon) = @_; 320 | #http://search.cpan.org/~robertmay/Win32-GUI-1.06/docs/GUI/UserGuide/FAQ.pod#What_are_the_icon,_button_and_modality_values_for_MessageBox? 321 | my %responses=( YNC=>3, 322 | YN =>4, 323 | OK =>0, 324 | OKC=>1 ); 325 | 326 | my %icons= ( "!"=>16, 327 | "?"=>32, 328 | "E"=>48, 329 | "H"=>48, 330 | "I"=>64); 331 | $response=$response?$responses{$response}:0; 332 | $icon=$icon?$icons{$icon}:64; 333 | my $answer= $self-> Win32::GUI::MessageBox( 334 | $message, 335 | $title, 336 | $icon+$response, 337 | ); 338 | return (($answer == 1)||($answer == 6)) 339 | }; 340 | 341 | # Quit 342 | sub quit{ 343 | my ($self) = @_; 344 | $self ->GF_Terminate; 345 | } 346 | 1; 347 | -------------------------------------------------------------------------------- /Examples/scripts/logo.ext: -------------------------------------------------------------------------------- 1 | logoVars=>{ 2 | version => 0.01, 3 | dir => 180, 4 | fmTLX => 0, 5 | fmTLY => 0, 6 | fmWidth => 1000, 7 | fmHeight => 1000, 8 | font => "italic 40px sans-serif", 9 | xPos => 500, 10 | yPos => 500, 11 | font => { family => "sans-serif", 12 | size => "80px", 13 | style => "italic", 14 | fill => "black", 15 | rotate => 0, 16 | anchor => 'start', 17 | }, 18 | colour => 'black', 19 | thickness => 3, 20 | pen => 1, 21 | fill => "", 22 | mode => "line", 23 | minX => 100, 24 | minY => 100, 25 | maxX => 100, 26 | maxY => 100, 27 | logs => "", 28 | svg => "", 29 | groups => {}, 30 | clippaths => {}, 31 | pointArray => [], 32 | directions => { north => 180, 33 | east => 90, 34 | south => 0, 35 | west => -90, 36 | northeast => 135, 37 | northwest => -135, 38 | southeast => 45, 39 | southeast => -45, 40 | }, 41 | }, 42 | 43 | commands=>{ 44 | fd=>sub{ 45 | my $distance=shift; 46 | $distance=evaluate($distance); 47 | my $oldX=$extensions{logo}{logoVars}{xPos}; 48 | my $oldY=$extensions{logo}{logoVars}{yPos}; 49 | my $colour=$extensions{logo}{logoVars}{colour}; 50 | my $thickness=$extensions{logo}{logoVars}{thickness}; 51 | my $newX= sin($functions{rad}->($extensions{logo}{logoVars}{dir}))*$distance+$oldX ; 52 | my $newY= cos($functions{rad}->($extensions{logo}{logoVars}{dir}))*$distance+$oldY; 53 | 54 | $extensions{logo}{commands}{minmax}->($newX,$newY); 55 | 56 | $extensions{logo}{logoVars}{xPos}=$newX; 57 | $extensions{logo}{logoVars}{yPos}=$newY; 58 | 59 | my $mode= $extensions{logo}{logoVars}{mode}; 60 | $oldX=int($oldX);$oldY=int($oldY);$newX=int($newX);$newY=int($newY); 61 | if ($mode=~ /(poly(gon|line))/){ 62 | $extensions{logo}{commands}{addpoints}->( " ".$newX.",".$newY." "); 63 | } 64 | elsif ($mode eq "path"){ 65 | if($extensions{logo}{logoVars}{pen}==1){ 66 | $extensions{logo}{commands}{addpoints}->("L ".$newX.",".$newY." "); 67 | } 68 | } 69 | else { 70 | if($extensions{logo}{logoVars}{pen}==1){ 71 | $extensions{logo}{logoVars}{svg}.=qq(\n); 72 | } 73 | } 74 | }, 75 | 76 | bk =>sub{ 77 | my $distance=shift; 78 | $distance=evaluate($distance); 79 | $distance=-1*$distance; 80 | $extensions{logo}{commands}{fd}($distance) 81 | }, 82 | 83 | forward=> sub{ 84 | my $delta=shift; 85 | $extensions{logo}{commands}{fd}($delta); 86 | }, 87 | 88 | backward=> sub{ 89 | my $delta=shift; 90 | $extensions{logo}{commands}{bk}($delta); 91 | }, 92 | 93 | lt=>sub{ 94 | my $delta=shift; 95 | $delta= ($delta eq '')? 90:evaluate($delta); 96 | $extensions{logo}{logoVars}{dir}+=$delta; 97 | }, 98 | 99 | left=> sub{ 100 | my $delta=shift; 101 | $extensions{logo}{commands}{lt}($delta); 102 | }, 103 | 104 | rt=>sub{ 105 | my $delta=shift; 106 | $delta= ($delta eq '')? 90:evaluate($delta); 107 | $extensions{logo}{logoVars}{dir}-=$delta; 108 | }, 109 | 110 | right=> sub{ 111 | my $delta=shift; 112 | $extensions{logo}{commands}{rt}($delta); 113 | }, 114 | 115 | addpoints=>sub{ 116 | my $additions=shift; 117 | my @svglines=split ("\n", $extensions{logo}{logoVars}{svg}); 118 | $svglines[-2].= $additions; 119 | $extensions{logo}{logoVars}{svg}=join("\n",@svglines)."\n"; 120 | }, 121 | 122 | center => sub { 123 | my $target=shift; 124 | if ($target=~/all/){ 125 | $extensions{logo}{logoVars}{fmTLX}=($extensions{logo}{logoVars}{minX}+$extensions{logo}{logoVars}{maxX} - $extensions{logo}{logoVars}{fmWidth} )/2; 126 | $extensions{logo}{logoVars}{fmTLY}=($extensions{logo}{logoVars}{minY}+$extensions{logo}{logoVars}{maxY} - $extensions{logo}{logoVars}{fmHeight})/2; 127 | 128 | } 129 | else{ 130 | $extensions{logo}{logoVars}{xPos}=($extensions{logo}{logoVars}{fmWidth} + $extensions{logo}{logoVars}{fmTLX})/2; 131 | $extensions{logo}{logoVars}{yPos}=($extensions{logo}{logoVars}{fmHeight} + $extensions{logo}{logoVars}{fmTLY})/2; 132 | } 133 | }, 134 | 135 | circle => sub { 136 | my $radius=shift; 137 | $radius=evaluate($radius); 138 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 139 | $extensions{logo}{logoVars}{svg}.="\n"; 143 | }, 144 | 145 | clear=>sub{ 146 | $extensions{logo}{logoVars}{svg} = ""; 147 | $extensions{logo}{logoVars}{mode} = "line "; 148 | $extensions{logo}{logoVars}{fmTLX} = 0; 149 | $extensions{logo}{logoVars}{fmTLY} = 0; 150 | $extensions{logo}{logoVars}{fmWidth} = 1000; 151 | $extensions{logo}{logoVars}{fmHeight}= 1000; 152 | $extensions{logo}{logoVars}{minX} = 500; 153 | $extensions{logo}{logoVars}{minY} = 500; 154 | $extensions{logo}{logoVars}{maxX} = 500; 155 | $extensions{logo}{logoVars}{maxY} = 500; 156 | $extensions{logo}{logoVars}{xPos} = 500; 157 | $extensions{logo}{logoVars}{yPos} = 500; 158 | }, 159 | 160 | closepath=>sub{ 161 | if ($extensions{logo}{logoVars}{mode} eq "path"){ 162 | my @svglines=split ("\n", $extensions{logo}{logoVars}{svg}); 163 | if ( $svglines[-2]!~/Z\s*$/i){ $svglines[-2].= " Z\n" ; 164 | $extensions{logo}{logoVars}{svg}=join("\n",@svglines)."\n"; 165 | } 166 | } 167 | }, 168 | 169 | colour =>sub{ 170 | my $colour=shift; 171 | if ($colour =~m/random/){ 172 | $colour="rgb(".int(rand(256)).",".int(rand(256)).",".int(rand(256)).")"; 173 | } 174 | $extensions{logo}{logoVars}{colour}=$colour; 175 | }, 176 | 177 | dir=>sub{ 178 | my $newDir=shift; 179 | if (defined $extensions{logo}{logoVars}{directions}{$newDir}){ 180 | $extensions{logo}{logoVars}{dir}=$extensions{logo}{logoVars}{directions}{$newDir} 181 | } 182 | else { 183 | $extensions{logo}{logoVars}{dir}=evaluate($newDir); 184 | } 185 | }, 186 | 187 | font => sub{ 188 | my $params=shift; 189 | foreach (split(",",$params) ){ 190 | $_=~/\s*([a-z]+)\s*=\s*(\S*)\s*$/; 191 | $extensions{logo}{logoVars}{font}{$1}=$2; 192 | } 193 | }, 194 | 195 | group => sub{ 196 | my $gpName = shift; 197 | $extensions{logo}{logoVars}{groups}{$gpName} = "\n". 198 | $extensions{logo}{logoVars}{svg} . 199 | ""; 200 | $extensions{logo}{logoVars}{svg}=""; 201 | }, 202 | 203 | minmax=>sub{ 204 | my ($newX,$newY)=@_; 205 | if ($newX>$extensions{logo}{logoVars}{maxX}) { 206 | $extensions{logo}{logoVars}{maxX}=int($newX);} 207 | elsif ($newX<$extensions{logo}{logoVars}{minX}) { 208 | $extensions{logo}{logoVars}{minX}=int($newX);}; 209 | if ($newY>$extensions{logo}{logoVars}{maxY}) { 210 | $extensions{logo}{logoVars}{maxY}=int($newY);} 211 | elsif ($newY<$extensions{logo}{logoVars}{minY}) { 212 | $extensions{logo}{logoVars}{minY}=int($newY);} 213 | }, 214 | 215 | move=>sub{ 216 | my $newPos=shift; 217 | my ($x,$y)=split (",",$newPos); 218 | $x=evaluate($x); $y=evaluate($y); 219 | if ($extensions{logo}{logoVars}{mode} eq "path "){ 220 | $extensions{logo}{commands}{closepath} 221 | } 222 | else { 223 | $extensions{logo}{logoVars}{xPos}=$x; 224 | $extensions{logo}{logoVars}{yPos}=$y; 225 | } 226 | }, 227 | 228 | text=>sub{ 229 | my $text=shift; 230 | $text=evaluate($text); 231 | my %font=%{$extensions{logo}{logoVars}{font}}; 232 | my $style=qq{style="font-size:$font{size};font-family:$font{family}; font-style:$font{style}; fill:$font{fill}; " }; 233 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 234 | my $anchor=qq(text-anchor="$font{anchor}"); 235 | my $transform=qq{transform="rotate($font{rotate},$x,$y)"}; 236 | $extensions{logo}{logoVars}{svg}.=qq{$text\n}; 237 | }, 238 | 239 | pan=>sub{ 240 | my ($dir,$distance)=@_; 241 | if (!$distance) {$distance=10}; 242 | if ($dir eq "up") { $extensions{logo}{logoVars}{fmTLY}+=$distance } 243 | elsif ($dir eq "down") { $extensions{logo}{logoVars}{fmTLY}-=$distance } 244 | elsif ($dir eq "left") { $extensions{logo}{logoVars}{fmTLX}-=$distance } 245 | elsif ($dir eq "right"){ $extensions{logo}{logoVars}{fmTLX}+=$distance } 246 | else {logline("Pan Direction $dir not recognised\n")} 247 | }, 248 | 249 | pen=>sub{ 250 | my $ud=shift; 251 | $ud=($ud=~/up|1/)?0:1; 252 | $extensions{logo}{logoVars}{pen}=$ud; 253 | if ($extensions{logo}{logoVars}{mode} eq "path"){ 254 | if (!$ud) { $extensions{logo}{commands}{closepath}->() } # close path if pen raised 255 | else { 256 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 257 | $extensions{logo}{commands}{addpoints}->("M $x $y "); 258 | }; 259 | } 260 | }, 261 | 262 | fill=>sub{ 263 | my $colour=shift; 264 | if ($colour =~m/random/){ 265 | $colour="rgb(".int(rand(256)).",".int(rand(256)).",".int(rand(256)).")"; 266 | } 267 | $extensions{logo}{logoVars}{fill}=$colour; 268 | }, 269 | 270 | mode =>sub{ 271 | my $mode=shift; 272 | my $colour=$extensions{logo}{logoVars}{colour}; 273 | my $thickness=$extensions{logo}{logoVars}{thickness}; 274 | my $fill=$extensions{logo}{logoVars}{fill}; 275 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 276 | if ($mode=~ /(path|polyline|polygon|line)/) { 277 | $mode=$1; 278 | $extensions{logo}{logoVars}{mode}=$mode; 279 | if ($mode=~ /(poly(gon|line))/){ 280 | $extensions{logo}{logoVars}{svg}.=qq(<$1 points="\n 281 | $x,$y 282 | " style="stroke:$colour;stroke-width:$thickness;fill:$fill" />\n); 283 | } 284 | elsif ($mode eq "path"){ 285 | 286 | $extensions{logo}{logoVars}{svg}.=qq(\n); 289 | } 290 | } 291 | }, 292 | 293 | nl =>sub{ 294 | my $spacing=shift; 295 | $spacing=evaluate($spacing) // 1; 296 | 297 | $extensions{logo}{logoVars}{yPos}+=($extensions{logo}{logoVars}{font}{size}*$spacing) 298 | }, 299 | 300 | nextline=>sub{ 301 | $extensions{logo}{commands}{nl} 302 | }, 303 | 304 | 305 | rectangle => sub{ 306 | my $wh=shift; 307 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 308 | my ($width,$height,$rx,$ry)=split(",", $wh); 309 | ($width,$height,$rx,$ry)=map {($_ ne undef) ? evaluate($_) : 0}($width,$height,$rx,$ry); 310 | $extensions{logo}{logoVars}{svg}.="\n"; 314 | 315 | }, 316 | 317 | thickness => sub { 318 | my $thickness=shift; 319 | $extensions{logo}{logoVars}{thickness}=evaluate($thickness); 320 | }, 321 | 322 | transform => sub{ 323 | 324 | }, 325 | 326 | svgout=>sub{ 327 | my $svgFile=shift; 328 | $svgFile=~s/^\s+|\s+$//g; 329 | if ($svgFile!~/\.svg$/){$svgFile.='.svg'}; 330 | logLine( "saving file to $svgFile\n"); 331 | open (my $svg,'>',$svgFile); 332 | print $svg "\n". 335 | $extensions{logo}{logoVars}{svg}. 336 | " "; 337 | close $svg; 338 | }, 339 | 340 | pngout=>sub{ 341 | 342 | 343 | }, 344 | 345 | zoom=>sub { 346 | my $zoom=shift; 347 | $zoom=~/\s*(all|in|out)\s*(-?\d*)\s*$/; 348 | my ($zoom,$zf)=($1,$2); 349 | if (!$zf) {$zf=10}; 350 | if ($zoom eq "all"){ 351 | $extensions{logo}{logoVars}{fmTLX} = $extensions{logo}{logoVars}{minX}; 352 | $extensions{logo}{logoVars}{fmTLY} = $extensions{logo}{logoVars}{minY}; 353 | $extensions{logo}{logoVars}{fmWidth} = $extensions{logo}{logoVars}{maxX} - $extensions{logo}{logoVars}{minX}; 354 | $extensions{logo}{logoVars}{fmHeight} = $extensions{logo}{logoVars}{maxY} - $extensions{logo}{logoVars}{minY}; 355 | } 356 | elsif ($zoom eq "in"){ 357 | $extensions{logo}{logoVars}{fmTLX} = int($extensions{logo}{logoVars}{fmTLX}+($extensions{logo}{logoVars}{fmWidth}) *($zf/200) ); 358 | $extensions{logo}{logoVars}{fmTLY} = int($extensions{logo}{logoVars}{fmTLY}+($extensions{logo}{logoVars}{fmHeight})*($zf/200) ); 359 | $extensions{logo}{logoVars}{fmHeight}= int($extensions{logo}{logoVars}{fmHeight}*(1-$zf/100)); 360 | $extensions{logo}{logoVars}{fmWidth} = int($extensions{logo}{logoVars}{fmWidth}*(1-$zf/100)); 361 | } 362 | elsif ($zoom eq "out"){ 363 | $extensions{logo}{commands}{zoom}->("in -$zf"); 364 | } 365 | }, 366 | }, 367 | -------------------------------------------------------------------------------- /lib/Language/SIMPLE/logo.ext: -------------------------------------------------------------------------------- 1 | logoVars=>{ 2 | version => 0.03, 3 | dir => 180, 4 | fmTLX => 0, 5 | fmTLY => 0, 6 | fmWidth => 1000, 7 | fmHeight => 1000, 8 | font => "italic 40px sans-serif", 9 | xPos => 500, 10 | yPos => 500, 11 | font => { family => "sans-serif", 12 | size => "80px", 13 | style => "italic", 14 | fill => "black", 15 | rotate => 0, 16 | anchor => 'start', 17 | }, 18 | colour => 'black', 19 | thickness => 3, 20 | pen => 1, 21 | fill => "", 22 | mode => "line", 23 | minX => 100, 24 | minY => 100, 25 | maxX => 100, 26 | maxY => 100, 27 | logs => "", 28 | svg => "", 29 | targetName => 'svg', 30 | layers => {}, 31 | groups => {}, 32 | clippaths => {}, 33 | pointArray => [], 34 | directions => { north => 180, 35 | east => 90, 36 | south => 0, 37 | west => -90, 38 | northeast => 135, 39 | northwest => -135, 40 | southeast => 45, 41 | southeast => -45, 42 | }, 43 | }, 44 | 45 | commands=>{ 46 | fd=>sub{ 47 | my $distance=shift; 48 | $distance=evaluate($distance); 49 | my $oldX=$extensions{logo}{logoVars}{xPos}; 50 | my $oldY=$extensions{logo}{logoVars}{yPos}; 51 | my $colour=$extensions{logo}{logoVars}{colour}; 52 | my $thickness=$extensions{logo}{logoVars}{thickness}; 53 | my $newX= sin($functions{rad}->($extensions{logo}{logoVars}{dir}))*$distance+$oldX ; 54 | my $newY= cos($functions{rad}->($extensions{logo}{logoVars}{dir}))*$distance+$oldY; 55 | 56 | $extensions{logo}{commands}{minmax}->($newX,$newY); 57 | 58 | $extensions{logo}{logoVars}{xPos}=$newX; 59 | $extensions{logo}{logoVars}{yPos}=$newY; 60 | 61 | my $mode= $extensions{logo}{logoVars}{mode}; 62 | $oldX=int($oldX);$oldY=int($oldY);$newX=int($newX);$newY=int($newY); 63 | if ($mode=~ /(poly(gon|line))/){ 64 | $extensions{logo}{commands}{addpoints}->( " ".$newX.",".$newY." "); 65 | } 66 | elsif ($mode eq "path"){ 67 | if($extensions{logo}{logoVars}{pen}==1){ 68 | $extensions{logo}{commands}{addpoints}->("L ".$newX.",".$newY." "); 69 | } 70 | } 71 | else { 72 | if($extensions{logo}{logoVars}{pen}==1){ 73 | my $line=qq(\n); 74 | $extensions{logo}{logoVars}{svg}.=$line; 75 | } 76 | } 77 | }, 78 | 79 | bk =>sub{ 80 | my $distance=shift; 81 | $extensions{logo}{commands}{fd}("-1*".$distance) 82 | }, 83 | 84 | forward=> sub{ 85 | my $distance=shift; 86 | $extensions{logo}{commands}{fd}($distance); 87 | }, 88 | 89 | backward=> sub{ 90 | my $distance=shift; 91 | $extensions{logo}{commands}{fd}("-1*".$distance); 92 | }, 93 | 94 | lt=>sub{ 95 | my $delta=shift; 96 | $delta= ($delta eq '')? 90:evaluate($delta); 97 | $extensions{logo}{logoVars}{dir}+=$delta; 98 | 99 | }, 100 | 101 | left=> sub{ 102 | my $delta=shift; 103 | $extensions{logo}{commands}{lt}($delta); 104 | }, 105 | 106 | rt=>sub{ 107 | my $delta=shift; 108 | $delta= ($delta eq '')? 90:evaluate($delta); 109 | $extensions{logo}{logoVars}{dir}-=$delta; 110 | }, 111 | 112 | right=> sub{ 113 | my $delta=shift; 114 | $extensions{logo}{commands}{rt}($delta); 115 | }, 116 | 117 | addpoints=>sub{ 118 | my $additions=shift; 119 | my @svglines=split ("\n", $extensions{logo}{logoVars}{svg}); 120 | $svglines[-2].= $additions; 121 | $extensions{logo}{logoVars}{svg}=join("\n",@svglines)."\n"; 122 | }, 123 | 124 | center => sub { 125 | my $target=shift; 126 | if ($target=~/all/){ 127 | $extensions{logo}{logoVars}{fmTLX}=($extensions{logo}{logoVars}{minX}+$extensions{logo}{logoVars}{maxX} - $extensions{logo}{logoVars}{fmWidth} )/2; 128 | $extensions{logo}{logoVars}{fmTLY}=($extensions{logo}{logoVars}{minY}+$extensions{logo}{logoVars}{maxY} - $extensions{logo}{logoVars}{fmHeight})/2; 129 | 130 | } 131 | else{ 132 | $extensions{logo}{logoVars}{xPos}=($extensions{logo}{logoVars}{fmWidth} + $extensions{logo}{logoVars}{fmTLX})/2; 133 | $extensions{logo}{logoVars}{yPos}=($extensions{logo}{logoVars}{fmHeight} + $extensions{logo}{logoVars}{fmTLY})/2; 134 | } 135 | }, 136 | 137 | circle => sub { 138 | my $radius=shift; 139 | $radius=evaluate($radius); 140 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 141 | my $line="\n"; 145 | $extensions{logo}{logoVars}{svg}.=$line; 146 | }, 147 | 148 | clear=>sub{ 149 | logs("clear"); 150 | $extensions{logo}{logoVars}{svg} = ""; 151 | $extensions{logo}{logoVars}{mode} = "line "; 152 | $extensions{logo}{logoVars}{fmTLX} = 0; 153 | $extensions{logo}{logoVars}{fmTLY} = 0; 154 | $extensions{logo}{logoVars}{fmWidth} = 1000; 155 | $extensions{logo}{logoVars}{fmHeight}= 1000; 156 | $extensions{logo}{logoVars}{minX} = 500; 157 | $extensions{logo}{logoVars}{minY} = 500; 158 | $extensions{logo}{logoVars}{maxX} = 500; 159 | $extensions{logo}{logoVars}{maxY} = 500; 160 | $extensions{logo}{logoVars}{xPos} = 500; 161 | $extensions{logo}{logoVars}{yPos} = 500; 162 | }, 163 | 164 | closepath=>sub{ 165 | if ($extensions{logo}{logoVars}{mode} eq "path"){ 166 | my @svglines=split ("\n", $extensions{logo}{logoVars}{svg}); 167 | if ( $svglines[-2]!~/Z\s*$/i){ $svglines[-2].= " Z\n" ; 168 | $extensions{logo}{logoVars}{svg}=join("\n",@svglines)."\n"; 169 | } 170 | } 171 | }, 172 | 173 | colour =>sub{ 174 | my $colour=shift; 175 | if ($colour =~m/random/){ 176 | $colour="rgb(".int(rand(256)).",".int(rand(256)).",".int(rand(256)).")"; 177 | } 178 | $extensions{logo}{logoVars}{colour}=$colour; 179 | }, 180 | 181 | dir=>sub{ 182 | my $newDir=shift; 183 | if (defined $extensions{logo}{logoVars}{directions}{$newDir}){ 184 | $extensions{logo}{logoVars}{dir}=$extensions{logo}{logoVars}{directions}{$newDir} 185 | } 186 | else { 187 | $extensions{logo}{logoVars}{dir}=evaluate($newDir); 188 | } 189 | }, 190 | 191 | drawTo=>sub{ 192 | 193 | 194 | }, 195 | 196 | font => sub{ 197 | my $params=shift; 198 | foreach (split(",",$params) ){ 199 | $_=~/\s*([a-z]+)\s*=\s*(\S*)\s*$/; 200 | $extensions{logo}{logoVars}{font}{$1}=$2; 201 | } 202 | }, 203 | 204 | group => sub{ 205 | my $gpName = shift; 206 | $extensions{logo}{logoVars}{groups}{$targetName} ="group $gpName"; 207 | $extensions{logo}{logoVars}{groups}{$gpName} = ""; 208 | }, 209 | 210 | 211 | 212 | image => sub{ 213 | qr{} 214 | }, 215 | 216 | 217 | minmax=>sub{ 218 | my ($newX,$newY)=@_; 219 | if ($newX>$extensions{logo}{logoVars}{maxX}) { 220 | $extensions{logo}{logoVars}{maxX}=int($newX);} 221 | elsif ($newX<$extensions{logo}{logoVars}{minX}) { 222 | $extensions{logo}{logoVars}{minX}=int($newX);}; 223 | if ($newY>$extensions{logo}{logoVars}{maxY}) { 224 | $extensions{logo}{logoVars}{maxY}=int($newY);} 225 | elsif ($newY<$extensions{logo}{logoVars}{minY}) { 226 | $extensions{logo}{logoVars}{minY}=int($newY);} 227 | }, 228 | 229 | move=>sub{ 230 | my $newPos=shift; 231 | my ($x,$y)=split (",",$newPos); 232 | $x=evaluate($x); $y=evaluate($y); 233 | if ($extensions{logo}{logoVars}{mode} eq "path "){ 234 | $extensions{logo}{commands}{closepath} 235 | } 236 | else { 237 | $extensions{logo}{logoVars}{xPos}=$x; 238 | $extensions{logo}{logoVars}{yPos}=$y; 239 | } 240 | }, 241 | 242 | text=>sub{ 243 | my $text=shift; 244 | $text=evaluate($text); 245 | my %font=%{$extensions{logo}{logoVars}{font}}; 246 | my $style=qq{style="font-size:$font{size};font-family:$font{family}; font-style:$font{style}; fill:$font{fill}; " }; 247 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 248 | my $anchor=qq(text-anchor="$font{anchor}"); 249 | my $transform=qq{transform="rotate($font{rotate},$x,$y)"}; 250 | my $line=qq{$text\n}; 251 | $extensions{logo}{logoVars}{svg}.=$line; 252 | }, 253 | 254 | pan=>sub{ 255 | my ($dir,$distance)=@_; 256 | if (!$distance) {$distance=10}; 257 | if ($dir eq "up") { $extensions{logo}{logoVars}{fmTLY}+=$distance } 258 | elsif ($dir eq "down") { $extensions{logo}{logoVars}{fmTLY}-=$distance } 259 | elsif ($dir eq "left") { $extensions{logo}{logoVars}{fmTLX}-=$distance } 260 | elsif ($dir eq "right"){ $extensions{logo}{logoVars}{fmTLX}+=$distance } 261 | else {logline("Pan Direction $dir not recognised\n")} 262 | }, 263 | 264 | pen=>sub{ 265 | my $ud=shift; 266 | $ud=($ud=~/up|1/)?0:1; 267 | $extensions{logo}{logoVars}{pen}=$ud; 268 | if ($extensions{logo}{logoVars}{mode} eq "path"){ 269 | if (!$ud) { $extensions{logo}{commands}{closepath}->() } # close path if pen raised 270 | else { 271 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 272 | $extensions{logo}{commands}{addpoints}->("M $x $y "); 273 | }; 274 | } 275 | }, 276 | 277 | fill=>sub{ 278 | my $colour=shift; 279 | if ($colour =~m/random/){ 280 | $colour="rgb(".int(rand(256)).",".int(rand(256)).",".int(rand(256)).")"; 281 | } 282 | $extensions{logo}{logoVars}{fill}=$colour; 283 | }, 284 | 285 | mode =>sub{ 286 | my $mode=shift; 287 | my $colour=$extensions{logo}{logoVars}{colour}; 288 | my $thickness=$extensions{logo}{logoVars}{thickness}; 289 | my $fill=$extensions{logo}{logoVars}{fill}; 290 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 291 | my $line; 292 | if ($mode=~ /(path|polyline|polygon|line)/) { 293 | $mode=$1; 294 | $extensions{logo}{logoVars}{mode}=$mode; 295 | if ($mode=~ /(poly(gon|line))/){ 296 | $line=qq(<$1 points=" 297 | $x,$y 298 | " style="stroke:$colour;stroke-width:$thickness;fill:$fill" />\n); 299 | } 300 | elsif ($mode eq "path"){ 301 | $line=qq(\n); 304 | } 305 | $extensions{logo}{logoVars}{svg}.=$line; 306 | } 307 | }, 308 | 309 | nl =>sub{ 310 | my $spacing=shift; 311 | $spacing=evaluate($spacing) // 1; 312 | 313 | $extensions{logo}{logoVars}{yPos}+=($extensions{logo}{logoVars}{font}{size}*$spacing) 314 | }, 315 | 316 | nextline=>sub{ 317 | $extensions{logo}{commands}{nl} 318 | }, 319 | 320 | rectangle => sub{ 321 | my $wh=shift; 322 | my ($x,$y)= (int ($extensions{logo}{logoVars}{xPos}), int($extensions{logo}{logoVars}{yPos}) ); 323 | my ($width,$height,$rx,$ry)=split(",", $wh); 324 | ($width,$height,$rx,$ry)=map {($_ ne undef) ? evaluate($_) : 0}($width,$height,$rx,$ry); 325 | my $line="\n"; 329 | $extensions{logo}{logoVars}{svg}.=$line; 330 | 331 | }, 332 | 333 | resetlogo => sub{ 334 | $extensions{logo}{commands}{clear}->(); 335 | $commands{reset}->(); 336 | }, 337 | 338 | target =>sub{ # set the destination of newly created elements 339 | my ($tg,$line)=@_; 340 | if ($tg=~/svg/) { $extensions{logo}{logoVars}{svg}.=$line } 341 | elsif ($tg =~ /group\s+(\w+)\s*\$/) { $extensions{logo}{logoVars}{groups}{$1}.=$line } 342 | elsif ($tg =~ /clip\s+(\w+)\s*\$/) { $extensions{logo}{logoVars}{clippaths}{$1}.=$line } 343 | 344 | }, 345 | 346 | thickness => sub { 347 | my $thickness=shift; 348 | $extensions{logo}{logoVars}{thickness}=evaluate($thickness); 349 | }, 350 | 351 | transform => sub{ 352 | 353 | }, 354 | 355 | svgout=>sub{ 356 | my $svgFile=shift; 357 | $svgFile=~s/^\s+|\s+$//g; 358 | if ($svgFile!~/\.svg$/){$svgFile.='.svg'}; 359 | logLine( "saving file to $svgFile\n"); 360 | open (my $svg,'>',$svgFile); 361 | print $svg "\n". 364 | $extensions{logo}{logoVars}{svg}. 365 | " "; 366 | close $svg; 367 | }, 368 | 369 | pngout=>sub{ 370 | 371 | 372 | }, 373 | 374 | zoom=>sub { 375 | my $zoom=shift; 376 | $zoom=~/\s*(all|in|out)\s*(-?\d*)\s*$/; 377 | my ($zoom,$zf)=($1,$2); 378 | if (!$zf) {$zf=10}; 379 | if ($zoom eq "all"){ 380 | $extensions{logo}{logoVars}{fmTLX} = $extensions{logo}{logoVars}{minX}; 381 | $extensions{logo}{logoVars}{fmTLY} = $extensions{logo}{logoVars}{minY}; 382 | $extensions{logo}{logoVars}{fmWidth} = $extensions{logo}{logoVars}{maxX} - $extensions{logo}{logoVars}{minX}; 383 | $extensions{logo}{logoVars}{fmHeight} = $extensions{logo}{logoVars}{maxY} - $extensions{logo}{logoVars}{minY}; 384 | } 385 | elsif ($zoom eq "in"){ 386 | $extensions{logo}{logoVars}{fmTLX} = int($extensions{logo}{logoVars}{fmTLX}+($extensions{logo}{logoVars}{fmWidth}) *($zf/200) ); 387 | $extensions{logo}{logoVars}{fmTLY} = int($extensions{logo}{logoVars}{fmTLY}+($extensions{logo}{logoVars}{fmHeight})*($zf/200) ); 388 | $extensions{logo}{logoVars}{fmHeight}= int($extensions{logo}{logoVars}{fmHeight}*(1-$zf/100)); 389 | $extensions{logo}{logoVars}{fmWidth} = int($extensions{logo}{logoVars}{fmWidth}*(1-$zf/100)); 390 | } 391 | elsif ($zoom eq "out"){ 392 | $extensions{logo}{commands}{zoom}->("in -$zf"); 393 | } 394 | }, 395 | 396 | functions=>{ 397 | 398 | 399 | 400 | }, 401 | }, 402 | 403 | 404 | -------------------------------------------------------------------------------- /lib/GUIDeFATE.pm: -------------------------------------------------------------------------------- 1 | package GUIDeFATE; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '0.14'; 7 | 8 | use Exporter 'import'; 9 | 10 | our @EXPORT_OK = qw<$frame availableToolkits>; # allows manipulation of frame from main. 11 | our $target=""; 12 | our $AppObject; 13 | our $winX=30; 14 | our $winY=30; 15 | our $winWidth; 16 | our $winHeight; 17 | our $winTitle; 18 | our $winScale=6.5; 19 | my $autoGen=""; 20 | my $log=""; 21 | 22 | sub new{ 23 | (my $class,my $textGUI,$target,my $assist, my $port)=@_; 24 | no warnings; 25 | if ((!$target)||($target=~/^wx/i)){ 26 | $target="wx"; 27 | die "Failed to load Wx backend: $@" unless eval { require GUIDeFATE::GFwx} ; GFwx->import; 28 | convert($textGUI,$assist); 29 | return GFwx->new(); ; 30 | } 31 | elsif ($target =~m/^gtk2/i){## ADDED OPTION 'gtk2' FOR Gtk2 IN CASE USERS DONT HAVE Gtk3... 32 | $target="gtk2"; 33 | open my $fh, '>', "/dev/null"; 34 | local *STDERR = $fh; 35 | die "Failed to load Gtk2 backend: $@" unless eval { require GUIDeFATE::GFgtk2} ; 36 | close $fh; 37 | GFgtk2->import; 38 | convert($textGUI, $assist); 39 | return GFgtk2->new(); 40 | } 41 | elsif ($target =~m/^gtk/i){ 42 | $target="gtk"; 43 | open my $fh, '>', "/dev/null"; 44 | local *STDERR = $fh; 45 | die "Failed to load Gtk3 backend: $@" unless eval {require GUIDeFATE::GFgtk} ; 46 | close $fh; 47 | GFgtk->import; 48 | convert($textGUI, $assist); 49 | return GFgtk->new(); 50 | 51 | } 52 | elsif ($target =~m/^tk/i){ 53 | $target="tk"; 54 | die "Failed to load Tk backend: $@" unless eval { require GUIDeFATE::GFtk }; 55 | GFtk->import; 56 | convert($textGUI, $assist); 57 | return GFtk->new(); 58 | } 59 | elsif ($target =~m/^prima/i){ 60 | $target="prima"; 61 | die "Failed to load Prima backend: $@" unless eval { require GUIDeFATE::GFprima }; 62 | GFprima->import; 63 | convert($textGUI, $assist); 64 | return GFprima->new(); 65 | } 66 | elsif ($target =~m/^qt/i){ 67 | $target="qt"; 68 | die "Failed to load Qt backend: $@" unless eval { require GUIDeFATE::GFqt }; 69 | GFqt->import; 70 | convert($textGUI, $assist); 71 | my $qtWin=GFqt->new(); 72 | return $qtWin; 73 | } 74 | elsif ($target =~m/^win32/i){ 75 | $target="win32"; 76 | die "Failed to load Win32 backend: $@" unless eval { require GUIDeFATE::GFwin32 }; 77 | GFwin32->import; 78 | convert($textGUI, $assist); 79 | return GFwin32->new(); 80 | } 81 | elsif ($target =~m/^html/i){ 82 | $target="html"; 83 | die "Failed to load HTML backend: $@" unless eval { require GUIDeFATE::GFhtml }; 84 | GFhtml->import; 85 | convert($textGUI, $assist); 86 | return GFhtml->new(); 87 | } 88 | elsif ($target =~m/^web$/i){ 89 | $target="web"; 90 | die "Failed to load WebSocket backend: $@" unless eval {require GUIDeFATE::GFweb }; 91 | GFweb->import; 92 | convert($textGUI, $assist); 93 | return GFweb->new($port,($assist=~/d/i)); 94 | } 95 | } 96 | 97 | sub convert{ 98 | my($textGUI,$assist)=@_; 99 | my @lines=(split /\n/ ,$textGUI) ; 100 | if (!$assist){$assist="q"}; 101 | 102 | my $verbose= $assist=~/^v/i; 103 | my $debug= $assist=~/^d/i; 104 | my $auto= $assist=~/^a/i; 105 | 106 | if (!exists &{"setScale"}){print "Error exists in GF$target\n"; return;} 107 | setScale($winScale); # makes scaling in the two modules match 108 | 109 | if ($lines[0] =~ /\-(\d+)x(\d+)-/){ 110 | $winWidth=$1; 111 | $winHeight=$2; 112 | } 113 | else{ 114 | $winWidth=$winScale*(2*(length $lines[0])-2); 115 | } 116 | shift @lines; 117 | if ($lines[0]=~/\|T\s*(\S.*\S)\s*\|/){ 118 | $winTitle=$1; 119 | if ($verbose){print "Title=".$winTitle."\n"}; 120 | shift @lines; 121 | } 122 | my $l=0;my $bid=0; 123 | 124 | 125 | foreach my $line (@lines){ 126 | last if ($line eq ""); # blank line determines end of window 127 | while ($line =~m/(\+([A-z]?)[A-z\-]+\+)/){ 128 | my $ps=length($`); my $fl=length($1)-2;my $fh=1; my $panelType=$2; 129 | $lines[$l]=~s/(\+([A-z]?)[A-z\-]+\+)/" " x ($fl+2)/e; 130 | my $reg=qr/^.{$ps}\K(\|.{$fl}\|)/;my $content=""; #\K operator protects the previous match from the deletion to follow 131 | while ($ps && ($lines[$l+$fh] =~m/$reg/g)){ 132 | my $tmp=$1; 133 | $tmp=~s/^\||\|//g; 134 | $content.=$tmp; 135 | $lines[$l+$fh]=~s/$reg/" " x ($fl+2)/e; #delete the frame by overwriting with spaces 136 | $fh++; 137 | } 138 | $fh++; 139 | if ($ps && ($fh-2)) { 140 | $content=~s/^\s+|\s+$//g; 141 | $log="SubPanel '$panelType' Id ".($bid+1)." found position $ps height $fh width $fl at row $l with content $content \n";## 142 | if ($verbose){ print $log; } 143 | if ($auto){ $autoGen.="#".$log; } 144 | addWidget(["sp",$bid,$panelType,$content,[$winScale*($ps*2-1),$winScale*$l*4],[$winScale*($fl*2+3),$winScale*$fh*4]]); 145 | $bid+=2; # id goes up by 2, one for the panel and one for the content; 146 | }; 147 | } 148 | 149 | while ($line =~m/(\^([A-z]+)\s*\^)/g){ #ComboBoxes 150 | my $ps=length($`);my $label=$2; my $len=length ($label);$label=~s/^(\s+)|(\s+)$//g; 151 | $line=~s/(\^([A-z]+)\s*\^)/" " x length($1)/e; 152 | $log= "combobox calls function &combo$bid\n"; ## 153 | if ($verbose){ print $log; } 154 | if ($auto){ $autoGen.=makeSub("combo$bid", "combobox with data from \@$label"); } 155 | addWidget(["combo",$bid,$label,[$winScale*($ps*2-1),$winScale*$l*4],[$winScale*($len*2+3),$winScale*4], \&{"main::combo".$bid}]); 156 | $bid++; 157 | } 158 | while ($line =~m/(\{([^}]*)\})/g){ # buttons are made from {