Skip to content

Commit 993d24d

Browse files
haukexhaukex
committed
Added gui_sweet example
1 parent 1c26897 commit 993d24d

File tree

7 files changed

+244
-2
lines changed

7 files changed

+244
-2
lines changed

‎experiments/gui_basic/README.md

+2-2
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,8 @@ local web server, which includes code to access an SQLite database,
77
and this web server also serves up WebPerl code to a browser, where
88
the GUI is implemented as HTML with Perl.
99

10-
To get this to work, you will need to copy the `webperl.js` and three
11-
`emperl.*` files from the main `web` directory to the `web`
10+
To get this to work, you will need to copy the `webperl.js` and the
11+
three `emperl.*` files from the main `web` directory to the `web`
1212
subdirectory in this project.
1313

1414
Note that this should not be considered production-ready, as there

‎experiments/gui_sweet/.gitignore

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
/public/webperl.js
2+
/public/emperl.*
3+
/gui_sweet
4+
/gui_sweet.exe

‎experiments/gui_sweet/README.md

+44
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
2+
WebPerl Advanced GUI Example
3+
============================
4+
5+
Similar to the "WebPerl Basic GUI Example", this is a demo of a GUI
6+
using WebPerl, but using [Bootstrap](https://getbootstrap.com/)
7+
and [jQuery](https://jquery.com/) instead of plain JavaScript,
8+
and [Mojolicious](https://mojolicious.org/) instead of plain Plack.
9+
10+
To get this to work, you will need to copy the `webperl.js` and the
11+
three `emperl.*` files from the main `web` directory to the `public`
12+
subdirectory in this project.
13+
14+
Also, a limitation is that the server does not know when the browser
15+
window is closed, so it must be stopped manually.
16+
17+
You can pack this application into a single executable using `do_pp.pl`.
18+
Note: I'm not yet sure why, but sometimes this fails with errors such
19+
as *"error extracting info from -c/-x file"*, in that case just try
20+
the command again.
21+
22+
23+
Author, Copyright, and License
24+
==============================
25+
26+
**WebPerl - <http://webperl.zero-g.net>**
27+
28+
Copyright (c) 2019 Hauke Daempfling ([email protected])
29+
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
30+
Berlin, Germany, <http://www.igb-berlin.de>
31+
32+
This program is free software; you can redistribute it and/or modify
33+
it under the same terms as Perl 5 itself: either the GNU General Public
34+
License as published by the Free Software Foundation (either version 1,
35+
or, at your option, any later version), or the "Artistic License" which
36+
comes with Perl 5.
37+
38+
This program is distributed in the hope that it will be useful, but
39+
**WITHOUT ANY WARRANTY**; without even the implied warranty of
40+
**MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE**.
41+
See the licenses for details.
42+
43+
You should have received a copy of the licenses along with this program.
44+
If not, see <http://perldoc.perl.org/index-licence.html>.

‎experiments/gui_sweet/do_pp.pl

+23
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
#!/usr/bin/env perl
2+
use warnings;
3+
use strict;
4+
use File::Basename qw/fileparse/;
5+
use File::Spec::Functions qw/catfile/;
6+
use File::Temp qw/tempfile/;
7+
8+
# this attempts to locate Mojo's default server.crt/server.key files
9+
chomp( my $dir = `perldoc -l Mojo::IOLoop::Server` );
10+
die "perldoc -l failed, \$?=$?" if $? || !-e $dir;
11+
(undef, $dir) = fileparse($dir);
12+
13+
# set up a file for pp's -A switch
14+
my ($tfh, $tfn) = tempfile(UNLINK=>1);
15+
print {$tfh} catfile($dir,'resources','server.crt'),";server.crt\n";
16+
print {$tfh} catfile($dir,'resources','server.key'),";server.key\n";
17+
close $tfh;
18+
19+
my @args = (qw/ -a public -a templates -A /, $tfn);
20+
21+
local $ENV{DOING_PAR_PACKER}=1;
22+
system(qw/ pp -o gui_sweet -z 9 -x /,@args,'gui_sweet.pl')==0
23+
or die "pp failed, \$?=$?";

‎experiments/gui_sweet/gui_sweet.pl

+77
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,77 @@
1+
#!/usr/bin/env perl
2+
use Mojolicious::Lite;
3+
use Mojo::Util qw/md5_sum/;
4+
use FindBin;
5+
use File::Spec::Functions qw/catdir/;
6+
use Browser::Open qw/open_browser/;
7+
8+
# This is the server-side code.
9+
10+
my $SERV_PORT = 3000;
11+
12+
my ($SSLCERTS,$HOMEDIR);
13+
BEGIN {
14+
$HOMEDIR = $ENV{PAR_TEMP} ? catdir($ENV{PAR_TEMP},'inc') : $FindBin::Bin;
15+
chdir $HOMEDIR or die "chdir $HOMEDIR: $!";
16+
# do_pp.pl pulls the default Mojo SSL certs into the archive for us
17+
$SSLCERTS = $ENV{PAR_TEMP} ? '?cert=./server.crt&key=./server.key' : '';
18+
}
19+
20+
app->static->paths([catdir($HOMEDIR,'public')]);
21+
app->renderer->paths([catdir($HOMEDIR,'templates')]);
22+
app->secrets(['Hello, Perl World!']);
23+
app->types->type(js => "application/javascript");
24+
app->types->type(data => "application/octet-stream");
25+
app->types->type(mem => "application/octet-stream");
26+
app->types->type(wasm => "application/wasm");
27+
28+
# Authentication and browser-launching stuff (optional)
29+
my $TOKEN = md5_sum(rand(1e15).time);
30+
hook before_server_start => sub {
31+
my ($server, $app) = @_;
32+
my @urls = map {Mojo::URL->new($_)->query(token=>$TOKEN)} @{$server->listen};
33+
my $url = shift @urls or die "No urls?";
34+
if ($ENV{DOING_PAR_PACKER}) {
35+
# arrange to have the server shut down in a few moments
36+
my $procpid = $$;
37+
my $pid = fork();
38+
if (!defined $pid) { die "fork failed" }
39+
elsif ($pid==0) { sleep 5; kill 'USR1', $procpid; exit; } # child
40+
print "====> Please wait a few seconds...\n";
41+
$SIG{USR1} = sub { $server->stop; exit };
42+
}
43+
else {
44+
print "Attempting to open in browser: $url\n";
45+
open_browser($url);
46+
}
47+
};
48+
under sub {
49+
my $c = shift;
50+
return 1 if ($c->param('token')//'') eq $TOKEN;
51+
$c->render(text => 'Bad token!', status => 403);
52+
return undef;
53+
};
54+
55+
get '/' => sub { shift->render } => 'index';
56+
57+
post '/example' => sub {
58+
my $c = shift;
59+
my $data = $c->req->json;
60+
# can do anything here, this is just an example
61+
$data->{string} = reverse $data->{string};
62+
$c->render(json => $data);
63+
};
64+
65+
app->start('daemon', '-l', "https://localhost:$SERV_PORT$SSLCERTS");
66+
67+
__DATA__
68+
69+
@@ index.html.ep
70+
% layout 'main', title => 'WebPerl GUI Demo';
71+
<main role="main" class="container">
72+
<div>
73+
<h1>WebPerl Advanced GUI Demo</h1>
74+
<p class="lead">Hello, Perl World!</p>
75+
<div id="buttons"></div>
76+
</div>
77+
</main>

‎experiments/gui_sweet/public/web.pl

+44
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
#!perl
2+
use warnings;
3+
use 5.028;
4+
use WebPerl qw/js sub1 encode_json/;
5+
6+
# This is the code that WebPerl runs in the browser. It is loaded by index.html.
7+
8+
my $window = js('window');
9+
my $document = js('document');
10+
my $jq = js('jQuery');
11+
12+
sub do_ajax {
13+
my %args = @_;
14+
die "must specify a url" unless $args{url};
15+
$args{fail} ||= sub { $window->alert(shift) };
16+
$jq->ajax( $args{url}, {
17+
$args{data} # when given data, default to POST (JSON), otherwise GET
18+
? ( method=>$args{method}||'POST',
19+
data=>encode_json($args{data}) )
20+
: ( method=>$args{method}||'GET' ),
21+
} )->done( sub1 {
22+
$args{done}->(shift) if $args{done};
23+
} )->fail( sub1 {
24+
my ($jqXHR, $textStatus, $errorThrown) = @_;
25+
$args{fail}->("AJAX Failed! ($errorThrown)");
26+
} )->always( sub1 {
27+
$args{always}->() if $args{always};
28+
} );
29+
return;
30+
}
31+
32+
# slightly hacky way to get the access token, but it works fine
33+
my ($token) = $window->{location}{search}=~/\btoken=([a-fA-F0-9]+)\b/;
34+
35+
my $btn = $jq->('<button>', { text=>"Click me!" } );
36+
$btn->click(sub {
37+
$btn->prop('disabled',1);
38+
do_ajax( url=>"/example?token=$token",
39+
data => { string=>"rekcaH lreP rehtonA tsuJ" },
40+
done => sub { $window->alert("The server says: ".shift->{string}) },
41+
always => sub { $btn->prop('disabled',0); } );
42+
} );
43+
$btn->appendTo( $jq->('#buttons') );
44+

‎experiments/gui_sweet/templates/layouts/main.html.ep

+50
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,50 @@
1+
<!doctype html>
2+
<html lang="en-us">
3+
<head>
4+
<meta charset="utf-8">
5+
<title><%= title %></title>
6+
<meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
7+
<link rel="stylesheet" href="https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css" integrity="sha384-ggOyR0iXCbMQv3Xipma34MD+dH/1fQ784/j6cY/iJTQUOhcWr7x9JvoRxT2MZw1T" crossorigin="anonymous">
8+
<style>
9+
body { padding-top: 5rem; }
10+
</style>
11+
</head>
12+
<body>
13+
<nav class="navbar navbar-expand-md navbar-dark fixed-top bg-dark">
14+
<a class="navbar-brand" href="#"><%= title %></a>
15+
<button class="navbar-toggler" type="button" data-toggle="collapse" data-target="#navbarCollapse" aria-controls="navbarCollapse" aria-expanded="false" aria-label="Toggle navigation">
16+
<span class="navbar-toggler-icon"></span>
17+
</button>
18+
<div class="collapse navbar-collapse" id="navbarCollapse">
19+
<ul class="navbar-nav mr-auto">
20+
<li class="nav-item active">
21+
<a class="nav-link" href="#">Home <span class="sr-only">(current)</span></a>
22+
</li>
23+
<li class="nav-item">
24+
<a class="nav-link" href="#">Link</a>
25+
</li>
26+
<li class="nav-item">
27+
<a class="nav-link disabled" href="#" tabindex="-1" aria-disabled="true">Disabled</a>
28+
</li>
29+
<li class="nav-item dropdown">
30+
<a class="nav-link dropdown-toggle" href="#" id="dropdown01" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false">Dropdown</a>
31+
<div class="dropdown-menu" aria-labelledby="dropdown01">
32+
<a class="dropdown-item" href="#">Action</a>
33+
<a class="dropdown-item" href="#">Another action</a>
34+
<a class="dropdown-item" href="#">Something else here</a>
35+
</div>
36+
</li>
37+
</ul>
38+
</div>
39+
</nav>
40+
41+
<%= content %>
42+
43+
<!-- Bootstrap wants its script tags at the end of the body element, so we'll put everything here: -->
44+
<script src="https://code.jquery.com/jquery-3.3.1.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
45+
<script src="https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.14.7/umd/popper.min.js" integrity="sha384-UO2eT0CpHqdSJQ6hJty5KVphtPhzWj9WO1clHTMGa3JDZwrnQq4sF86dIHNDz0W1" crossorigin="anonymous"></script>
46+
<script src="https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/js/bootstrap.min.js" integrity="sha384-JjSmVgyd0p3pXB1rRibZUAYoIIy6OrQ6VrjIEaFf/nJGzIxFDsf4x0xIM+B07jRM" crossorigin="anonymous"></script>
47+
<script src="webperl.js"></script>
48+
<script type="text/perl" src="web.pl"></script>
49+
</body>
50+
</html>

0 commit comments

Comments
 (0)