diff --git a/experiments/gui_basic/.gitignore b/experiments/gui_basic/.gitignore new file mode 100644 index 0000000..b6bf89b --- /dev/null +++ b/experiments/gui_basic/.gitignore @@ -0,0 +1,5 @@ +/database.db +/web/webperl.js +/web/emperl.* +/gui_basic +/gui_basic.exe diff --git a/experiments/gui_basic/README.md b/experiments/gui_basic/README.md new file mode 100644 index 0000000..bbf851b --- /dev/null +++ b/experiments/gui_basic/README.md @@ -0,0 +1,50 @@ + +WebPerl Basic GUI Example +========================= + +This is a demo of a very basic GUI using WebPerl. It consists of a +local web server, which includes code to access an SQLite database, +and this web server also serves up WebPerl code to a browser, where +the GUI is implemented as HTML with Perl. + +To get this to work, you will need to copy the `webperl.js` and three +`emperl.*` files from the main `web` directory to the `web` +subdirectory in this project. + +Note that this should not be considered production-ready, as there +are several key features missing, such as HTTPS or access control. + +Also, a limitation is that the server does not know when the browser +window is closed, so it must be stopped manually. + +You can pack this application into a single executable using: + + DOING_PAR_PACKER=1 pp -o gui_basic -z 9 -x -a gui_basic_app.psgi -a web gui_basic.pl + +Note: I'm not yet sure why, but sometimes this fails with errors such +as *"error extracting info from -c/-x file"*, in that case just try +the above command again. + + +Author, Copyright, and License +============================== + +**WebPerl - ** + +Copyright (c) 2019 Hauke Daempfling (haukex@zero-g.net) +at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB), +Berlin, Germany, + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl 5 itself: either the GNU General Public +License as published by the Free Software Foundation (either version 1, +or, at your option, any later version), or the "Artistic License" which +comes with Perl 5. + +This program is distributed in the hope that it will be useful, but +**WITHOUT ANY WARRANTY**; without even the implied warranty of +**MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE**. +See the licenses for details. + +You should have received a copy of the licenses along with this program. +If not, see . diff --git a/experiments/gui_basic/gui_basic.pl b/experiments/gui_basic/gui_basic.pl new file mode 100755 index 0000000..b23006d --- /dev/null +++ b/experiments/gui_basic/gui_basic.pl @@ -0,0 +1,50 @@ +#!/usr/bin/env perl +use warnings; +use 5.018; +use FindBin; +use File::Spec::Functions qw/catdir/; +use Plack::Runner (); +use Starman (); +use Browser::Open qw/open_browser/; + +# This just serves up gui_basic_app.psgi in the Starman web server. +# You can also say "plackup gui_basic_app.psgi" instead. + +BEGIN { + my $dir = $ENV{PAR_TEMP} ? catdir($ENV{PAR_TEMP},'inc') : $FindBin::Bin; + chdir $dir or die "chdir $dir: $!"; +} + +my $SERV_PORT = 5000; +my $THE_APP = 'gui_basic_app.psgi'; + +# AFAICT, both Plack::Runner->new(@args) and ->parse_options(@argv) set +# options, and these options are shared between "Starman::Server" +# (documented in "starman") and "Plack::Runner" (documented in "plackup"). +my @args = ( + server => 'Starman', loader => 'Delayed', env => 'development', + version_cb => sub { print "Starman $Starman::VERSION\n" } ); +my @argv = ( '--listen', "localhost:$SERV_PORT", $THE_APP ); +my $runner = Plack::Runner->new(@args); +$runner->parse_options(@argv); +$runner->set_options(argv => \@argv); +die "loader shouldn't be Restarter" if $runner->{loader} eq 'Restarter'; + +if ($ENV{DOING_PAR_PACKER}) { + require Plack::Util; + Plack::Util::load_psgi($THE_APP); # for dependency resolution + # arrange to have the server shut down in a few moments + my $procpid = $$; + my $pid = fork(); + if (!defined $pid) { die "fork failed" } + elsif ($pid==0) { sleep 5; kill 'INT', $procpid; exit; } # child + print "====> Please wait a few seconds...\n"; +} +else { + # There's a small chance here that the browser could open before the server + # starts up. In that case, a reload of the browser window is needed. + print "Attempting to open in browser: http://localhost:$SERV_PORT/\n"; + open_browser("http://localhost:$SERV_PORT/"); +} + +$runner->run; diff --git a/experiments/gui_basic/gui_basic_app.psgi b/experiments/gui_basic/gui_basic_app.psgi new file mode 100644 index 0000000..d75a32a --- /dev/null +++ b/experiments/gui_basic/gui_basic_app.psgi @@ -0,0 +1,67 @@ +#!/usr/bin/env perl +use warnings; +use 5.018; +use Plack::MIME; +use Plack::Builder qw/builder enable mount/; +use Plack::Request (); +use Plack::Response (); # declare compile-time dependency +use Cpanel::JSON::XS qw/decode_json encode_json/; +use DBI (); +use DBD::SQLite (); # declare compile-time dependency +use HTML::Tiny (); + +# This is the server-side code. + +# note we rely on gui_basic.pl to set the working directory correctly +my $SERV_ROOT = 'web'; +my $DB_FILE = 'database.db'; + +my $dbh = DBI->connect("DBI:SQLite:dbname=$DB_FILE", + undef, undef, { RaiseError=>1, AutoCommit=>1 }); + +$dbh->do(q{ CREATE TABLE IF NOT EXISTS FooBar ( + foo VARCHAR(255), bar VARCHAR(255) ) }); + +# This sends HTML to the browser, but we could also send JSON +# and build the HTML table dynamically in the browser. +my $app_select = sub { + state $html = HTML::Tiny->new; + state $sth_select = $dbh->prepare(q{ SELECT rowid,foo,bar FROM FooBar }); + $sth_select->execute; + my $data = $sth_select->fetchall_arrayref; + my $out = $html->table( + [ \'tr', + [ \'th', 'rowid', 'foo', 'bar' ], + map { [ \'td', @$_ ] } @$data + ] ); + return [ 200, [ "Content-Type"=>"text/html" ], [ $out ] ]; +}; + +# This is an example of one way to communicate with JSON. +my $app_insert = sub { + my $req = Plack::Request->new(shift); + state $sth_insert = $dbh->prepare(q{ INSERT INTO FooBar (foo,bar) VALUES (?,?) }); + my $rv = eval { # catch errors and return as 500 Server Error + my $content = decode_json( $req->content ); + $sth_insert->execute($content->{foo}, $content->{bar}); + { ok=>1 }; # return value from eval, sent to client as JSON + }; my $e = $@||'unknown error'; + my $res = $req->new_response($rv ? 200 : 500); + $res->content_type($rv ? 'application/json' : 'text/plain'); + $res->body($rv ? encode_json($rv) : 'Server Error: '.$e); + return $res->finalize; +}; + +Plack::MIME->add_type(".js" => "application/javascript"); +Plack::MIME->add_type(".data" => "application/octet-stream"); +Plack::MIME->add_type(".mem" => "application/octet-stream"); +Plack::MIME->add_type(".wasm" => "application/wasm"); + +builder { + enable 'SimpleLogger'; + enable 'Static', + path => sub { s#\A/\z#/index.html#; /\.(?:html?|js|css|data|mem|wasm|pl)\z/i }, + root => $SERV_ROOT; + mount '/select' => $app_select; + mount '/insert' => $app_insert; +} diff --git a/experiments/gui_basic/web/index.html b/experiments/gui_basic/web/index.html new file mode 100644 index 0000000..89acfa1 --- /dev/null +++ b/experiments/gui_basic/web/index.html @@ -0,0 +1,32 @@ + + + + + WebPerl GUI Demo + + + + +

WebPerl GUI Demo

+ +
No data loaded yet...
+
+ +
+
+ + +
+
+ + +
+
+ +
+
+ +

Powered by WebPerl (beta)

+ + + diff --git a/experiments/gui_basic/web/web.pl b/experiments/gui_basic/web/web.pl new file mode 100644 index 0000000..d4fb476 --- /dev/null +++ b/experiments/gui_basic/web/web.pl @@ -0,0 +1,69 @@ +#!perl +use warnings; +use 5.028; +use WebPerl qw/js js_new sub1 encode_json/; + +# This is the code that WebPerl runs in the browser. It is loaded by index.html. + +sub do_xhr { + my %args = @_; + die "must specify a url" unless $args{url}; + $args{fail} ||= sub { js('window')->alert(shift) }; + my $xhr = js_new('XMLHttpRequest'); + $xhr->addEventListener("error", sub1 { + $args{fail}->("XHR Error on $args{url}: ".(shift->{textContent}||"unknown")); + return; + }); + $xhr->addEventListener("load", sub1 { + if ($xhr->{status}==200) { + $args{done}->($xhr->{response}) if $args{done}; + } + else { + $args{fail}->("XHR Error on $args{url}: ".$xhr->{status}." ".$xhr->{statusText}); + } + return; + }); + $xhr->addEventListener("loadend", sub1 { + $args{always}->() if $args{always}; + return; + }); + # when given data, default to POST (JSON), otherwise GET + if ($args{data}) { + $xhr->open($args{method}||'POST', $args{url}); + $xhr->setRequestHeader('Content-Type', 'application/json'); + $xhr->send(encode_json($args{data})); + } + else { + $xhr->open($args{method}||'GET', $args{url}); + $xhr->send(); + } + return; +} + +my $document = js('document'); + +my $btn_reload = $document->getElementById('reload_data'); +sub do_reload { + state $dtbl = $document->getElementById('datatable'); + $btn_reload->{disabled} = 1; + do_xhr(url => 'select', + done => sub { $dtbl->{innerHTML} = shift; }, + always => sub { $btn_reload->{disabled} = 0; } ); + return; +} +$btn_reload->addEventListener("click", \&do_reload); + +my $btn_insert = $document->getElementById('do_insert'); +sub do_insert { + state $txt_foo = $document->getElementById('input_foo'); + state $txt_bar = $document->getElementById('input_bar'); + $btn_insert->{disabled} = 1; + do_xhr(url => 'insert', + data => { foo=>$txt_foo->{value}, bar=>$txt_bar->{value} }, + always => sub { $btn_insert->{disabled} = 0; do_reload; } ); + return; +} +$btn_insert->addEventListener("click", \&do_insert); + +do_reload; # initial load +