Compare commits
No commits in common. 'master' and 'v0.01-beta' have entirely different histories.
master
...
v0.01-beta
@ -1,4 +0,0 @@
|
||||
# See http://bitbucket.org/haukex/htools/src/HEAD/htmlrescache
|
||||
# Set up via: htmlrescache -cweb/_cache init
|
||||
/web/*.html filter=htmlrescache
|
||||
/web/**/*.html filter=htmlrescache
|
||||
@ -1,28 +0,0 @@
|
||||
---
|
||||
name: Bug report
|
||||
about: Create a report to help us improve
|
||||
|
||||
---
|
||||
|
||||
**Describe the bug**
|
||||
A clear and concise description of what the bug is.
|
||||
|
||||
**To Reproduce**
|
||||
Steps to reproduce the issue, including any relevant code in the form of a representative [Short, Self Contained, Correct (Compilable), Example](http://sscce.org/), and sample input.
|
||||
|
||||
**Expected behavior vs. actual behavior**
|
||||
A clear and concise description of what you expected to happen, and what actually happened instead. Include expected output for the sample input given above, and the actual output you're getting including exact copies of any error messages.
|
||||
|
||||
**Versions**
|
||||
- Device: [desktop or mobile; specify model]
|
||||
- OS: [e.g. Ubuntu Linux 16.04, Windows 10, etc.]
|
||||
- Browser and version: [e.g. Firefox 61, Chrome 68, etc.]
|
||||
- WebPerl: [e.g. v0.01-beta]
|
||||
|
||||
If building:
|
||||
- Perl: [e.g. v5.26.2]
|
||||
- Emscripten: [e.g. 1.38.10]
|
||||
- Any other versions that may be relevant, such as compiler, libraries, etc.
|
||||
|
||||
**Additional context**
|
||||
Add any other context about the problem here. If applicable, add screenshots to help explain your problem.
|
||||
@ -1,59 +0,0 @@
|
||||
|
||||
WebPerl Changelog
|
||||
=================
|
||||
|
||||
|
||||
2019-08-03: v0.11-beta
|
||||
----------------------
|
||||
|
||||
- Updated for Emscripten 1.38.31 / latest Fastcomp (1.38.40) and Perl v5.30.0
|
||||
|
||||
|
||||
2019-03-03: v0.09-beta
|
||||
----------------------
|
||||
|
||||
- Updated for Emscripten 1.38.28 and Perl v5.28.1
|
||||
- Added experimental Perl 6 support
|
||||
- Added modules Future, Digest::MD5, and Digest::SHA
|
||||
- Added Perl.exitStatus
|
||||
- Updated regex_tester.html
|
||||
- Added "Code Demo Editor" in web/democode/
|
||||
- Added "cpanfile"s for dependencies
|
||||
- Minor fixes and updates to build.pl
|
||||
|
||||
|
||||
2018-09-04: v0.07-beta
|
||||
----------------------
|
||||
|
||||
- Updated regex_tester.html (improvements and bugfixes)
|
||||
- Added WebPerl::JSObject::jscode()
|
||||
|
||||
|
||||
2018-09-02: v0.05-beta
|
||||
----------------------
|
||||
|
||||
- Added Perl.addStateChangeListener and deprecated Perl.stateChanged
|
||||
- Added WebPerl::js_new()
|
||||
- Added regex_tester.html
|
||||
- Added Perl.noMountIdbfs
|
||||
- A few other minor fixes and updates
|
||||
|
||||
|
||||
2018-08-14: v0.03-beta
|
||||
----------------------
|
||||
|
||||
- Fixed an issue with WebPerl::JSObject::toperl()
|
||||
where JS objects were not being converted properly.
|
||||
- Added AJAX demo
|
||||
- Added WebPerl autoloading for script tags
|
||||
- Various small changes, bugfixes and enhancements
|
||||
(mostly not user-visible)
|
||||
- Added `runtests.html` and `experiments` dir
|
||||
|
||||
|
||||
2018-08-12: v0.01-beta
|
||||
----------------------
|
||||
|
||||
- First public release
|
||||
|
||||
|
||||
@ -0,0 +1,31 @@
|
||||
|
||||
WebPerl TODOs
|
||||
=============
|
||||
|
||||
<http://webperl.zero-g.net>
|
||||
|
||||
1. Documentation (Website)
|
||||
|
||||
- Using WebPerl
|
||||
- the user must explicitly "unregister" anonymous Perl subs (or show alternatives) to prevent %CodeTable from growing too large
|
||||
- the user shouldn't mess with the symbol table (delete subs, redefine them, etc.)
|
||||
- <http://kripken.github.io/emscripten-site/docs/compiling/Deploying-Pages.html>
|
||||
- Building WebPerl
|
||||
- test out perl -Mlazy to install all the deps (and if it works well, document)
|
||||
|
||||
2. Testing
|
||||
|
||||
- Continue work on `WebPerl.t`
|
||||
- More tests for Unicode support (Perl/JS interface, Perl.eval(), plus Emscripten's virtual FS)
|
||||
- I should focus on getting the tests running in the browser instead of node.js
|
||||
- How to package tests? How does `make test` find&handle all the various modules' `t`s?
|
||||
- How to best disable individual tests that we know won't work? (qx etc.)
|
||||
- How to handle the many tests that call an external Perl?
|
||||
- patching t/test.pl's runperl() seems easiest at the moment, and we can use the iframe method from the IDE
|
||||
|
||||
3. Misc
|
||||
|
||||
- Test if a CDN would work
|
||||
|
||||
See also: "TODO" tags in code (use `findtodo.sh`)
|
||||
|
||||
@ -1,15 +0,0 @@
|
||||
|
||||
# Install the dependencies for "build" via:
|
||||
# $ cpanm --installdeps .
|
||||
|
||||
requires 'Data::Dump';
|
||||
requires 'Path::Class';
|
||||
requires 'IPC::Run3::Shell', '0.56';
|
||||
requires 'URI';
|
||||
requires 'Net::SSLeay', 1.49;
|
||||
requires 'IO::Socket::SSL', '1.56';
|
||||
requires 'Cpanel::JSON::XS';
|
||||
requires 'File::Copy::Recursive';
|
||||
requires 'File::Replace', '0.08';
|
||||
requires 'Pod::Strip';
|
||||
requires 'Archive::Zip';
|
||||
@ -1,20 +0,0 @@
|
||||
--- library.js.orig 2019-03-02 16:08:24.404047130 +0100
|
||||
+++ library.js 2019-03-02 16:19:30.588047130 +0100
|
||||
@@ -291,7 +291,7 @@
|
||||
// pid_t fork(void);
|
||||
// http://pubs.opengroup.org/onlinepubs/000095399/functions/fork.html
|
||||
// We don't support multiple processes.
|
||||
- ___setErrNo({{{ cDefine('EAGAIN') }}});
|
||||
+ ___setErrNo({{{ cDefine('ENOTSUP') }}});
|
||||
return -1;
|
||||
},
|
||||
vfork: 'fork',
|
||||
@@ -817,7 +817,7 @@
|
||||
// int system(const char *command);
|
||||
// http://pubs.opengroup.org/onlinepubs/000095399/functions/system.html
|
||||
// Can't call external programs.
|
||||
- ___setErrNo({{{ cDefine('EAGAIN') }}});
|
||||
+ ___setErrNo({{{ cDefine('ENOTSUP') }}});
|
||||
return -1;
|
||||
},
|
||||
|
||||
@ -1,19 +0,0 @@
|
||||
--- library.js.orig 2020-05-18 17:14:18.682328912 +0200
|
||||
+++ library.js 2020-05-18 17:14:48.366639562 +0200
|
||||
@@ -271,7 +271,7 @@
|
||||
// pid_t fork(void);
|
||||
// http://pubs.opengroup.org/onlinepubs/000095399/functions/fork.html
|
||||
// We don't support multiple processes.
|
||||
- setErrNo({{{ cDefine('EAGAIN') }}});
|
||||
+ setErrNo({{{ cDefine('ENOTSUP') }}});
|
||||
return -1;
|
||||
},
|
||||
vfork: 'fork',
|
||||
@@ -696,7 +696,7 @@
|
||||
// http://pubs.opengroup.org/onlinepubs/000095399/functions/system.html
|
||||
// Can't call external programs.
|
||||
if (!command) return 0; // no shell available
|
||||
- setErrNo({{{ cDefine('EAGAIN') }}});
|
||||
+ setErrNo({{{ cDefine('ENOTSUP') }}});
|
||||
return -1;
|
||||
},
|
||||
@ -1,8 +0,0 @@
|
||||
|
||||
# Install the dependencies for "web" via:
|
||||
# $ cpanm --installdeps .
|
||||
|
||||
requires 'Cpanel::JSON::XS';
|
||||
requires 'Plack';
|
||||
requires 'Plack::Middleware::CrossOrigin';
|
||||
requires 'Plack::Middleware::Auth::Digest';
|
||||
@ -1,20 +0,0 @@
|
||||
use warnings;
|
||||
use 5.026;
|
||||
use Time::HiRes qw/gettimeofday tv_interval/;
|
||||
|
||||
my $t0 = [gettimeofday];
|
||||
my @primes = join ',', grep {prime($_)} 1..1000000;
|
||||
my $elapsed = tv_interval($t0);
|
||||
printf "%.3f\n", $elapsed;
|
||||
|
||||
# http://www.rosettacode.org/wiki/Primality_by_trial_division#Perl
|
||||
sub prime {
|
||||
my $n = shift;
|
||||
$n % $_ or return for 2 .. sqrt $n;
|
||||
$n > 1
|
||||
}
|
||||
|
||||
# A quick test: This program, when run
|
||||
# from WebPerl (Firefox): ~7.4s
|
||||
# natively (same machine): ~2.3s
|
||||
# => roughly 3.2 times slower
|
||||
@ -1,8 +0,0 @@
|
||||
|
||||
# Install the dependencies for "experiments" via:
|
||||
# $ cpanm --installdeps .
|
||||
|
||||
requires 'Data::Dump';
|
||||
requires 'Graph';
|
||||
requires 'MetaCPAN::Client';
|
||||
requires 'Path::Class';
|
||||
@ -1,111 +0,0 @@
|
||||
#!/usr/bin/env perl
|
||||
use warnings;
|
||||
use 5.026;
|
||||
use Getopt::Long qw/ HelpMessage :config posix_default gnu_compat
|
||||
bundling auto_version auto_help /;
|
||||
use Graph ();
|
||||
use Memoize 'memoize';
|
||||
use Memoize::Storable ();
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
depend.pl MODULE(s)
|
||||
OPTIONS:
|
||||
-v | --verbose - more output
|
||||
-t | --want-test - include modules needed for test phase
|
||||
-p | --perl-ver VER - Perl version for corelist (default: 5.026)
|
||||
-c | --cache-file FILE - cache file for MetaCPAN API requests
|
||||
(default: /tmp/.metacpan_deps_cache)
|
||||
-C | --clear-cache - clear cache before running
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A test of resolving module dependences, currently via the MetaCPAN API.
|
||||
(The list of dependencies that MetaCPAN knows about may not always be complete.)
|
||||
|
||||
Outputs a possible install order that should satisfy dependencies.
|
||||
Note this order can change across runs, but theoretically it should
|
||||
always be a valid install order.
|
||||
|
||||
Notes for WebPerl:
|
||||
Could be used in F<build.pl>.
|
||||
I don't really need C<is_installed>.
|
||||
Perhaps instead of C<is_core> I should check if the module exists
|
||||
in the Perl source tree and is enabled in F<config.sh>...
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '0.01-beta';
|
||||
|
||||
GetOptions(
|
||||
'v|verbose' => \(my $VERBOSE),
|
||||
't|want-test' => \(my $WANT_TEST),
|
||||
'p|perl-ver=s' => \(my $PERL_VER='5.026'),
|
||||
'c|cache-file=s' => \(my $CACHE_FILE='/tmp/.metacpan_deps_cache'),
|
||||
'C|clear-cache' => \(my $NO_CACHE),
|
||||
) or HelpMessage(-exitval=>255);
|
||||
HelpMessage(-msg=>'Not enough arguments',-exitval=>255) unless @ARGV;
|
||||
|
||||
|
||||
if ($NO_CACHE && -e $CACHE_FILE)
|
||||
{ unlink($CACHE_FILE)==1 or die "Failed to unlink $CACHE_FILE: $!" }
|
||||
tie my %get_deps_cache, 'Memoize::Storable', $CACHE_FILE;
|
||||
memoize 'get_deps', SCALAR_CACHE=>[HASH=>\%get_deps_cache], LIST_CACHE=>'FAULT';
|
||||
memoize 'is_core';
|
||||
memoize 'is_installed';
|
||||
|
||||
|
||||
my $dep_graph = Graph->new(directed => 1);
|
||||
resolve_deps($_, $dep_graph) for @ARGV;
|
||||
my @topo = $dep_graph->topological_sort;
|
||||
say for reverse @topo;
|
||||
warn "No (non-core) dependencies\n" unless @topo;
|
||||
|
||||
|
||||
use MetaCPAN::Client ();
|
||||
sub get_deps { # will be memoized (and persisted)
|
||||
my ($module) = @_;
|
||||
state $mcpan = MetaCPAN::Client->new();
|
||||
$VERBOSE and say STDERR "Fetching dependencies of $module from MetaCPAN API";
|
||||
return $mcpan->release($mcpan->module($module)->distribution)->dependency;
|
||||
}
|
||||
|
||||
use Module::CoreList ();
|
||||
sub is_core { # will be memoized
|
||||
my ($module,$version) = @_;
|
||||
return Module::CoreList::is_core($module,$version,$PERL_VER);
|
||||
}
|
||||
|
||||
use Module::Load::Conditional ();
|
||||
sub is_installed { # will be memoized
|
||||
my ($module,$version) = @_;
|
||||
return Module::Load::Conditional::check_install(module=>$module,version=>$version);
|
||||
}
|
||||
|
||||
sub resolve_deps {
|
||||
my $module = shift;
|
||||
my $graph = @_ ? shift : Graph->new(directed => 1);
|
||||
for my $dep ( get_deps($module)->@* ) {
|
||||
next if is_core( $dep->{module}, $dep->{version} ); # ignore core modules
|
||||
next if $dep->{module} eq 'perl'; # ignore perl dist itself
|
||||
next unless $dep->{relationship} eq 'requires'; # ignore 'recommends' and 'suggests'
|
||||
die "Unknown relationship '$dep->{relationship}'"
|
||||
unless $dep->{relationship}=~/\A(?:requires|recommends|suggests)\z/;
|
||||
next if $dep->{phase} eq 'develop'; # ignore phase 'develop'
|
||||
next if !$WANT_TEST && $dep->{phase} eq 'test'; # ignore phase 'test' unless user wants it
|
||||
next if $dep->{phase}=~/\Ax_/; # ignore e.g. "x_Dist_Zilla"
|
||||
die "Unknown phase '$dep->{phase}'"
|
||||
unless $dep->{phase}=~/\A(?:configure|build|runtime|test)\z/;
|
||||
my $installed = is_installed( $dep->{module}, $dep->{version} ); # just for info
|
||||
$VERBOSE and say STDERR "$module requires $dep->{module}",
|
||||
$dep->{version} ? " (version $dep->{version})" : " (any version)",
|
||||
" for $dep->{phase}",
|
||||
$installed ? " (installed)" : " (not installed)";
|
||||
$graph->add_edge($module, $dep->{module});
|
||||
die "Fatal: Circular dependency detected (just added $module->$dep->{module})"
|
||||
if $graph->has_a_cycle;
|
||||
resolve_deps($dep->{module}, $graph)
|
||||
}
|
||||
return $graph;
|
||||
}
|
||||
|
||||
@ -1,5 +0,0 @@
|
||||
/database.db
|
||||
/web/webperl.js
|
||||
/web/emperl.*
|
||||
/gui_basic
|
||||
/gui_basic.exe
|
||||
@ -1,50 +0,0 @@
|
||||
|
||||
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 the
|
||||
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 - <http://webperl.zero-g.net>**
|
||||
|
||||
Copyright (c) 2019 Hauke Daempfling (haukex@zero-g.net)
|
||||
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
Berlin, Germany, <http://www.igb-berlin.de>
|
||||
|
||||
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 <http://perldoc.perl.org/index-licence.html>.
|
||||
@ -1,50 +0,0 @@
|
||||
#!/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;
|
||||
@ -1,67 +0,0 @@
|
||||
#!/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;
|
||||
}
|
||||
@ -1,32 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl GUI Demo</title>
|
||||
<script src="webperl.js"></script>
|
||||
<script type="text/perl" src="web.pl"></script>
|
||||
</head>
|
||||
<body style="font-family:sans-serif;">
|
||||
<h1>WebPerl GUI Demo</h1>
|
||||
|
||||
<div id="datatable"><i>No data loaded yet...</i></div>
|
||||
<div><button id="reload_data">Reload Data</button></div>
|
||||
|
||||
<div style="margin-top:1em">
|
||||
<div>
|
||||
<label for="input_foo">foo</label>
|
||||
<input type="text" id="input_foo">
|
||||
</div>
|
||||
<div>
|
||||
<label for="input_bar">bar</label>
|
||||
<input type="text" id="input_bar">
|
||||
</div>
|
||||
<div>
|
||||
<button id="do_insert">Insert Data</button>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<p>Powered by <a href="http://webperl.zero-g.net" target="_blank">WebPerl</a> (beta)</p>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
@ -1,69 +0,0 @@
|
||||
#!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
|
||||
|
||||
@ -1,4 +0,0 @@
|
||||
/public/webperl.js
|
||||
/public/emperl.*
|
||||
/gui_sweet
|
||||
/gui_sweet.exe
|
||||
@ -1,44 +0,0 @@
|
||||
|
||||
WebPerl Advanced GUI Example
|
||||
============================
|
||||
|
||||
Similar to the "WebPerl Basic GUI Example", this is a demo of a GUI
|
||||
using WebPerl, but using [Bootstrap](https://getbootstrap.com/)
|
||||
and [jQuery](https://jquery.com/) instead of plain JavaScript,
|
||||
and [Mojolicious](https://mojolicious.org/) instead of plain Plack.
|
||||
|
||||
To get this to work, you will need to copy the `webperl.js` and the
|
||||
three `emperl.*` files from the main `web` directory to the `public`
|
||||
subdirectory in this project.
|
||||
|
||||
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 `do_pp.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 command again.
|
||||
|
||||
|
||||
Author, Copyright, and License
|
||||
==============================
|
||||
|
||||
**WebPerl - <http://webperl.zero-g.net>**
|
||||
|
||||
Copyright (c) 2019 Hauke Daempfling (haukex@zero-g.net)
|
||||
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
Berlin, Germany, <http://www.igb-berlin.de>
|
||||
|
||||
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 <http://perldoc.perl.org/index-licence.html>.
|
||||
@ -1,23 +0,0 @@
|
||||
#!/usr/bin/env perl
|
||||
use warnings;
|
||||
use strict;
|
||||
use File::Basename qw/fileparse/;
|
||||
use File::Spec::Functions qw/catfile/;
|
||||
use File::Temp qw/tempfile/;
|
||||
|
||||
# this attempts to locate Mojo's default server.crt/server.key files
|
||||
chomp( my $dir = `perldoc -l Mojo::IOLoop::Server` );
|
||||
die "perldoc -l failed, \$?=$?" if $? || !-e $dir;
|
||||
(undef, $dir) = fileparse($dir);
|
||||
|
||||
# set up a file for pp's -A switch
|
||||
my ($tfh, $tfn) = tempfile(UNLINK=>1);
|
||||
print {$tfh} catfile($dir,'resources','server.crt'),";server.crt\n";
|
||||
print {$tfh} catfile($dir,'resources','server.key'),";server.key\n";
|
||||
close $tfh;
|
||||
|
||||
my @args = (qw/ -a public -a templates -A /, $tfn);
|
||||
|
||||
local $ENV{DOING_PAR_PACKER}=1;
|
||||
system(qw/ pp -o gui_sweet -z 9 -x /,@args,'gui_sweet.pl')==0
|
||||
or die "pp failed, \$?=$?";
|
||||
@ -1,77 +0,0 @@
|
||||
#!/usr/bin/env perl
|
||||
use Mojolicious::Lite;
|
||||
use Mojo::Util qw/md5_sum/;
|
||||
use FindBin;
|
||||
use File::Spec::Functions qw/catdir/;
|
||||
use Browser::Open qw/open_browser/;
|
||||
|
||||
# This is the server-side code.
|
||||
|
||||
my $SERV_PORT = 3000;
|
||||
|
||||
my ($SSLCERTS,$HOMEDIR);
|
||||
BEGIN {
|
||||
$HOMEDIR = $ENV{PAR_TEMP} ? catdir($ENV{PAR_TEMP},'inc') : $FindBin::Bin;
|
||||
chdir $HOMEDIR or die "chdir $HOMEDIR: $!";
|
||||
# do_pp.pl pulls the default Mojo SSL certs into the archive for us
|
||||
$SSLCERTS = $ENV{PAR_TEMP} ? '?cert=./server.crt&key=./server.key' : '';
|
||||
}
|
||||
|
||||
app->static->paths([catdir($HOMEDIR,'public')]);
|
||||
app->renderer->paths([catdir($HOMEDIR,'templates')]);
|
||||
app->secrets(['Hello, Perl World!']);
|
||||
app->types->type(js => "application/javascript");
|
||||
app->types->type(data => "application/octet-stream");
|
||||
app->types->type(mem => "application/octet-stream");
|
||||
app->types->type(wasm => "application/wasm");
|
||||
|
||||
# Authentication and browser-launching stuff (optional)
|
||||
my $TOKEN = md5_sum(rand(1e15).time);
|
||||
hook before_server_start => sub {
|
||||
my ($server, $app) = @_;
|
||||
my @urls = map {Mojo::URL->new($_)->query(token=>$TOKEN)} @{$server->listen};
|
||||
my $url = shift @urls or die "No urls?";
|
||||
if ($ENV{DOING_PAR_PACKER}) {
|
||||
# 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 'USR1', $procpid; exit; } # child
|
||||
print "====> Please wait a few seconds...\n";
|
||||
$SIG{USR1} = sub { $server->stop; exit };
|
||||
}
|
||||
else {
|
||||
print "Attempting to open in browser: $url\n";
|
||||
open_browser($url);
|
||||
}
|
||||
};
|
||||
under sub {
|
||||
my $c = shift;
|
||||
return 1 if ($c->param('token')//'') eq $TOKEN;
|
||||
$c->render(text => 'Bad token!', status => 403);
|
||||
return undef;
|
||||
};
|
||||
|
||||
get '/' => sub { shift->render } => 'index';
|
||||
|
||||
post '/example' => sub {
|
||||
my $c = shift;
|
||||
my $data = $c->req->json;
|
||||
# can do anything here, this is just an example
|
||||
$data->{string} = reverse $data->{string};
|
||||
$c->render(json => $data);
|
||||
};
|
||||
|
||||
app->start('daemon', '-l', "https://localhost:$SERV_PORT$SSLCERTS");
|
||||
|
||||
__DATA__
|
||||
|
||||
@@ index.html.ep
|
||||
% layout 'main', title => 'WebPerl GUI Demo';
|
||||
<main role="main" class="container">
|
||||
<div>
|
||||
<h1>WebPerl Advanced GUI Demo</h1>
|
||||
<p class="lead">Hello, Perl World!</p>
|
||||
<div id="buttons"></div>
|
||||
</div>
|
||||
</main>
|
||||
@ -1,44 +0,0 @@
|
||||
#!perl
|
||||
use warnings;
|
||||
use 5.028;
|
||||
use WebPerl qw/js sub1 encode_json/;
|
||||
|
||||
# This is the code that WebPerl runs in the browser. It is loaded by index.html.
|
||||
|
||||
my $window = js('window');
|
||||
my $document = js('document');
|
||||
my $jq = js('jQuery');
|
||||
|
||||
sub do_ajax {
|
||||
my %args = @_;
|
||||
die "must specify a url" unless $args{url};
|
||||
$args{fail} ||= sub { $window->alert(shift) };
|
||||
$jq->ajax( $args{url}, {
|
||||
$args{data} # when given data, default to POST (JSON), otherwise GET
|
||||
? ( method=>$args{method}||'POST',
|
||||
data=>encode_json($args{data}) )
|
||||
: ( method=>$args{method}||'GET' ),
|
||||
} )->done( sub1 {
|
||||
$args{done}->(shift) if $args{done};
|
||||
} )->fail( sub1 {
|
||||
my ($jqXHR, $textStatus, $errorThrown) = @_;
|
||||
$args{fail}->("AJAX Failed! ($errorThrown)");
|
||||
} )->always( sub1 {
|
||||
$args{always}->() if $args{always};
|
||||
} );
|
||||
return;
|
||||
}
|
||||
|
||||
# slightly hacky way to get the access token, but it works fine
|
||||
my ($token) = $window->{location}{search}=~/\btoken=([a-fA-F0-9]+)\b/;
|
||||
|
||||
my $btn = $jq->('<button>', { text=>"Click me!" } );
|
||||
$btn->click(sub {
|
||||
$btn->prop('disabled',1);
|
||||
do_ajax( url=>"/example?token=$token",
|
||||
data => { string=>"rekcaH lreP rehtonA tsuJ" },
|
||||
done => sub { $window->alert("The server says: ".shift->{string}) },
|
||||
always => sub { $btn->prop('disabled',0); } );
|
||||
} );
|
||||
$btn->appendTo( $jq->('#buttons') );
|
||||
|
||||
@ -1,50 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta charset="utf-8">
|
||||
<title><%= title %></title>
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
|
||||
<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">
|
||||
<style>
|
||||
body { padding-top: 5rem; }
|
||||
</style>
|
||||
</head>
|
||||
<body>
|
||||
<nav class="navbar navbar-expand-md navbar-dark fixed-top bg-dark">
|
||||
<a class="navbar-brand" href="#"><%= title %></a>
|
||||
<button class="navbar-toggler" type="button" data-toggle="collapse" data-target="#navbarCollapse" aria-controls="navbarCollapse" aria-expanded="false" aria-label="Toggle navigation">
|
||||
<span class="navbar-toggler-icon"></span>
|
||||
</button>
|
||||
<div class="collapse navbar-collapse" id="navbarCollapse">
|
||||
<ul class="navbar-nav mr-auto">
|
||||
<li class="nav-item active">
|
||||
<a class="nav-link" href="#">Home <span class="sr-only">(current)</span></a>
|
||||
</li>
|
||||
<li class="nav-item">
|
||||
<a class="nav-link" href="#">Link</a>
|
||||
</li>
|
||||
<li class="nav-item">
|
||||
<a class="nav-link disabled" href="#" tabindex="-1" aria-disabled="true">Disabled</a>
|
||||
</li>
|
||||
<li class="nav-item dropdown">
|
||||
<a class="nav-link dropdown-toggle" href="#" id="dropdown01" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false">Dropdown</a>
|
||||
<div class="dropdown-menu" aria-labelledby="dropdown01">
|
||||
<a class="dropdown-item" href="#">Action</a>
|
||||
<a class="dropdown-item" href="#">Another action</a>
|
||||
<a class="dropdown-item" href="#">Something else here</a>
|
||||
</div>
|
||||
</li>
|
||||
</ul>
|
||||
</div>
|
||||
</nav>
|
||||
|
||||
<%= content %>
|
||||
|
||||
<!-- Bootstrap wants its script tags at the end of the body element, so we'll put everything here: -->
|
||||
<script src="https://code.jquery.com/jquery-3.3.1.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
|
||||
<script src="https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.14.7/umd/popper.min.js" integrity="sha384-UO2eT0CpHqdSJQ6hJty5KVphtPhzWj9WO1clHTMGa3JDZwrnQq4sF86dIHNDz0W1" crossorigin="anonymous"></script>
|
||||
<script src="https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/js/bootstrap.min.js" integrity="sha384-JjSmVgyd0p3pXB1rRibZUAYoIIy6OrQ6VrjIEaFf/nJGzIxFDsf4x0xIM+B07jRM" crossorigin="anonymous"></script>
|
||||
<script src="webperl.js"></script>
|
||||
<script type="text/perl" src="web.pl"></script>
|
||||
</body>
|
||||
</html>
|
||||
@ -1,50 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl Perl 6 Demos (Experimental)</title>
|
||||
|
||||
<script src="webperl.js"></script>
|
||||
|
||||
<!-- Please see the documentation at http://webperl.zero-g.net/perl6.html -->
|
||||
|
||||
<!-- Example 1: A really basic script -->
|
||||
<script type="text/perl6">
|
||||
print "Hello, Perl 6 World!\n";
|
||||
</script>
|
||||
|
||||
<!-- Example 2: Accessing JavaScript -->
|
||||
<script type="text/perl6">
|
||||
my $document = EVAL(:lang<JavaScript>, 'return document');
|
||||
$document.getElementById('my_button')
|
||||
.addEventListener("click", -> $event {
|
||||
print "You clicked 'Testing!'\n";
|
||||
} );
|
||||
</script>
|
||||
|
||||
<!-- Optional STDOUT/STDERR text area (if you don't use this, output goes to Javascript console) -->
|
||||
<script>
|
||||
window.addEventListener("load", function () {
|
||||
document.getElementById('output')
|
||||
.appendChild( Raku.makeOutputTextarea() );
|
||||
});
|
||||
</script>
|
||||
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<p>This is a demo of the
|
||||
<a href="http://webperl.zero-g.net/perl6.html" target="_blank">experimental
|
||||
Perl 6 support</a> in
|
||||
<a href="http://webperl.zero-g.net" target="_blank">WebPerl</a>!</p>
|
||||
|
||||
<p><em>Currently only works in Chrome (needs BigInt support) and
|
||||
may take a few seconds to load.</em></p>
|
||||
|
||||
<div id="output"></div>
|
||||
<div id="buttons">
|
||||
<button id="my_button">Testing!</button>
|
||||
</div>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
@ -1,71 +0,0 @@
|
||||
#!/usr/bin/env perl
|
||||
use warnings;
|
||||
use strict;
|
||||
use FindBin;
|
||||
use Path::Class qw/dir/;
|
||||
use HTTP::Tiny;
|
||||
use File::Copy qw/copy/;
|
||||
$|++;
|
||||
|
||||
# Quick & dirty script to patch P6 into the "web" dir
|
||||
|
||||
# Note: To restore webperl.js to the original version:
|
||||
# $ git checkout web/webperl.js
|
||||
|
||||
my $p6url = 'https://perl6.github.io/6pad/gen/eval_code.js';
|
||||
|
||||
my $mydir = dir($FindBin::Bin);
|
||||
my $webdir = $mydir->parent->parent->subdir('web');
|
||||
|
||||
print "Patching experimental Perl 6 support into ",$webdir->relative,"...\n";
|
||||
|
||||
my $wpfile = $webdir->file('webperl.js');
|
||||
die "File structure not as I expected" unless -e $wpfile;
|
||||
|
||||
my $http = HTTP::Tiny->new();
|
||||
my $jsfile = $webdir->file('perl6.js');
|
||||
print "$p6url: ";
|
||||
my $resp = $http->mirror($p6url, "$jsfile");
|
||||
print "$resp->{status} $resp->{reason}\n";
|
||||
die unless $resp->{success};
|
||||
print "-> mirrored to ",$jsfile->relative,"\n";
|
||||
|
||||
my $wp = $wpfile->slurp(iomode=>'<:raw:encoding(UTF-8)');
|
||||
$wp =~ s{
|
||||
^ \N* \bbegin_webperl6_patch\b \N* $
|
||||
.*
|
||||
^ \N* \bend_webperl6_patch\b \N* $
|
||||
}{}msxi;
|
||||
die "I thought I clobbered the webperl6.js patch, why is there still a reference to Raku?"
|
||||
if $wp=~/\bRaku\./;
|
||||
my $wp6file = $mydir->file('webperl6.js');
|
||||
my $wp6 = $wp6file->slurp(iomode=>'<:raw:encoding(UTF-8)');
|
||||
1 while chomp($wp6);
|
||||
$wpfile->spew(iomode=>'>:raw:encoding(UTF-8)', $wp.$wp6);
|
||||
print "Patched ",$wp6file->relative," into ",$wpfile->relative,"\n";
|
||||
|
||||
for my $f ($mydir->children) {
|
||||
next unless $f->basename=~/(?:html?|css)\z/i;
|
||||
link_or_copy($f, $webdir);
|
||||
}
|
||||
|
||||
|
||||
sub link_or_copy {
|
||||
my ($src,$dest) = @_;
|
||||
die "Not a dir: $dest" unless -d $dest;
|
||||
$dest = $dest->file( $src->basename );
|
||||
if ( eval { symlink("",""); 1 } ) { # we have symlink support
|
||||
if (!-l $dest) {
|
||||
$dest->remove or die "$dest: $!" if -e $dest;
|
||||
my $targ = $src->relative( $dest->dir );
|
||||
symlink($targ,$dest) or die "symlink: $!";
|
||||
print "Linked ",$dest->relative," to $targ\n";
|
||||
}
|
||||
else { print "Link ",$dest->relative," exists\n"; }
|
||||
}
|
||||
else {
|
||||
$dest->remove or die "$dest: $!" if -e $dest;
|
||||
copy($src,$dest) or die "copy: $!";
|
||||
print "Copied ",$src->relative," to ",$dest->relative,"\n";
|
||||
}
|
||||
}
|
||||
@ -1,72 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl Perl 6 Experiments</title>
|
||||
|
||||
<script src="webperl.js"></script>
|
||||
|
||||
<!--
|
||||
The following is a demo of Perl 5 and Perl 6 calling each other via JavaScript.
|
||||
-->
|
||||
|
||||
<script>
|
||||
window.Foo = {
|
||||
set: function (x,y) { window.Foo[x]=y }, // workaround, see P6 below
|
||||
};
|
||||
</script>
|
||||
|
||||
<script type="text/perl">
|
||||
use warnings;
|
||||
use 5.028;
|
||||
|
||||
sub hello {
|
||||
my $x = shift;
|
||||
say "Hello from Perl 5! You said '$x'";
|
||||
}
|
||||
|
||||
my $Foo = js('window.Foo');
|
||||
$Foo->{p5} = \&hello;
|
||||
|
||||
js('document')->getElementById('btn_p5')
|
||||
->addEventListener("click", sub {
|
||||
say "This is Perl 5, attempting to call Perl 6...";
|
||||
$Foo->p6("I am Perl 5!");
|
||||
} );
|
||||
|
||||
say "Perl 5 is ready.";
|
||||
</script>
|
||||
|
||||
<script type="text/raku">
|
||||
|
||||
sub hello ($x) {
|
||||
say "Hello from Perl 6! You said '$x'"
|
||||
}
|
||||
|
||||
my $Foo = EVAL(:lang<JavaScript>, 'return window.Foo');
|
||||
# I'm not yet sure why the following doesn't work, Foo.set is a workaround
|
||||
#$Foo<p6> = &hello;
|
||||
$Foo.set("p6", &hello);
|
||||
|
||||
my $document = EVAL(:lang<JavaScript>, 'return document');
|
||||
$document.getElementById('btn_p6')
|
||||
.addEventListener("click", -> $event {
|
||||
say "This is Perl 6, attempting to call Perl 5...";
|
||||
$Foo.p5("I am Perl 6!");
|
||||
} );
|
||||
|
||||
say "Perl 6 is ready.";
|
||||
</script>
|
||||
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<p>See the JS console! Don't click the buttons until both languages are ready.</p>
|
||||
|
||||
<div id="buttons">
|
||||
<button id="btn_p5">Perl 5</button>
|
||||
<button id="btn_p6">Perl 6</button>
|
||||
</div>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
@ -1,148 +0,0 @@
|
||||
"use strict"; /* DO NOT EDIT THIS LINE! begin_webperl6_patch */
|
||||
|
||||
/***** NOTICE: This is part of the experimental WebPerl Perl 6 support.
|
||||
* This file (webperl6.js) is currently patched into webperl.js by 6init.pl.
|
||||
* There is currently a fair amount of duplication between the following code
|
||||
* and webperl.js that should probably be reduced.
|
||||
* This file should eventually be merged permanently into webperl.js.
|
||||
*/
|
||||
|
||||
/** ***** WebPerl - http://webperl.zero-g.net *****
|
||||
*
|
||||
* Copyright (c) 2018 Hauke Daempfling (haukex@zero-g.net)
|
||||
* at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
* Berlin, Germany, http://www.igb-berlin.de
|
||||
*
|
||||
* 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 http://perldoc.perl.org/index-licence.html
|
||||
**/
|
||||
|
||||
// I'm using "Raku" because the Hamming distance from Perl <-> Perl6 is too small for me,
|
||||
// it's too much of a risk for typos since webperl.js also provides the "Perl" object.
|
||||
// But the following functions are currently available on both the Raku.* and Perl6.* objects:
|
||||
// .init(), .eval(), .addStateChangeListener(), .makeOutputTextarea()
|
||||
// but everything else, such as Raku.state or Raku.output, needs to go via the Raku object.
|
||||
var Raku = {
|
||||
state: "Uninitialized", // user may read (only!) this
|
||||
// internal variables:
|
||||
stdout_buf: "", stderr_buf: "", // for our default Raku.output implementation
|
||||
};
|
||||
var Perl6 = {};
|
||||
|
||||
Raku.changeState = function (newState) {
|
||||
if (Raku.state==newState) return;
|
||||
var oldState = Raku.state;
|
||||
Raku.state = newState;
|
||||
for( var i=0 ; i<Raku.stateChangeListeners.length ; i++ )
|
||||
Raku.stateChangeListeners[i](oldState,newState);
|
||||
};
|
||||
Raku.stateChangeListeners = [ function (from,to) {
|
||||
console.debug("Raku: state changed from "+from+" to "+to);
|
||||
} ];
|
||||
Raku.addStateChangeListener = Perl6.addStateChangeListener = function (handler) {
|
||||
Raku.stateChangeListeners.push(handler);
|
||||
};
|
||||
|
||||
// chan: 1=STDOUT, 2=STDERR
|
||||
// implementations are free to ignore the "chan" argument if they want to merge the two streams
|
||||
Raku.output = function (str,chan) { // can be overridden by the user
|
||||
var buf = chan==2 ? 'stderr_buf' : 'stdout_buf';
|
||||
Raku[buf] += str;
|
||||
var pos = Raku[buf].indexOf("\n");
|
||||
while (pos>-1) {
|
||||
console.log( chan==2?"STDERR":"STDOUT", Raku[buf].slice(0,pos) );
|
||||
Raku[buf] = Raku[buf].slice(pos+1);
|
||||
pos = Raku[buf].indexOf("\n");
|
||||
}
|
||||
};
|
||||
|
||||
Raku.makeOutputTextarea = Perl6.makeOutputTextarea = function (id) {
|
||||
var ta = document.createElement('textarea');
|
||||
if (id) ta.id = id;
|
||||
ta.rows = 24; ta.cols = 80;
|
||||
ta.setAttribute("readonly",true);
|
||||
Raku.output = function (str) {
|
||||
ta.value = ta.value + str;
|
||||
ta.scrollTop = ta.scrollHeight;
|
||||
};
|
||||
return ta;
|
||||
};
|
||||
|
||||
Raku.init = Perl6.init = function (readyCallback) {
|
||||
if (Raku.state != "Uninitialized")
|
||||
throw "Raku: can't call init in state "+Raku.state;
|
||||
Raku.changeState("Initializing");
|
||||
var baseurl = Perl.Util.baseurl(getScriptURL()); // from webperl.js
|
||||
|
||||
// NOTE that NQP_STDOUT currently gets handed HTML,
|
||||
// so we jump through some hoops to decode it here:
|
||||
var decode_div = document.createElement('div');
|
||||
window.NQP_STDOUT = function (str) {
|
||||
str = str.replace(/[\<\>]/g,''); // declaw unexpected tags
|
||||
decode_div.innerHTML = str;
|
||||
str = decode_div.textContent;
|
||||
decode_div.textContent = '';
|
||||
Raku.output(str,1);
|
||||
};
|
||||
|
||||
console.debug("Raku: Fetching Perl6...");
|
||||
var script = document.createElement('script');
|
||||
script.async = true; script.defer = true;
|
||||
// Order is important here: 1. Add to DOM, 2. set onload, 3. set src
|
||||
document.getElementsByTagName('head')[0].appendChild(script);
|
||||
script.onload = function () {
|
||||
Raku.eval = Perl6.eval = window.evalP6;
|
||||
Raku.changeState("Ready");
|
||||
if (readyCallback) readyCallback();
|
||||
};
|
||||
script.src = baseurl+"/perl6.js";
|
||||
}
|
||||
|
||||
window.addEventListener("load", function () {
|
||||
var scripts = [];
|
||||
var script_src;
|
||||
document.querySelectorAll("script[type='text/perl6'],script[type='text/raku']")
|
||||
.forEach(function (el) {
|
||||
if (el.src) {
|
||||
if (script_src || scripts.length)
|
||||
console.error('Only a single Perl6 script may be loaded via "script src=", ignoring others');
|
||||
else
|
||||
script_src = el.src;
|
||||
}
|
||||
else {
|
||||
if (script_src)
|
||||
console.error('Only a single Perl6 script may be loaded via "script src=", ignoring others');
|
||||
else
|
||||
scripts.push(el.innerHTML);
|
||||
}
|
||||
});
|
||||
if (script_src) {
|
||||
console.debug("Raku: Found a script with src, fetching and running...", script_src);
|
||||
var xhr = new XMLHttpRequest();
|
||||
xhr.addEventListener("load", function () {
|
||||
var code = this.responseText;
|
||||
Raku.init(function () { Raku.eval(code); });
|
||||
});
|
||||
xhr.open("GET", script_src);
|
||||
xhr.send();
|
||||
}
|
||||
else if (scripts.length) {
|
||||
console.debug("Raku: Found",scripts.length,"embedded script(s), autorunning...");
|
||||
var code = scripts.join(";\n");
|
||||
Raku.init(function () { Raku.eval(code); });
|
||||
}
|
||||
else console.debug("Raku: No embedded scripts");
|
||||
});
|
||||
|
||||
/* DO NOT EDIT THIS LINE! end_webperl6_patch */
|
||||
@ -1,24 +0,0 @@
|
||||
#!/usr/bin/env perl
|
||||
use warnings;
|
||||
use strict;
|
||||
use Data::Dump;
|
||||
use IO::Socket;
|
||||
|
||||
# $ git clone https://github.com/novnc/websockify
|
||||
# $ cd websockify
|
||||
# $ ./run 2345 localhost:2346
|
||||
|
||||
my $serv = IO::Socket::INET->new(
|
||||
LocalAddr => 'localhost',
|
||||
LocalPort => 2346,
|
||||
Proto => 'tcp',
|
||||
Listen => 5,
|
||||
Reuse => 1 ) or die $@;
|
||||
|
||||
# really dumb server
|
||||
print "Listening...\n";
|
||||
while (my $client = $serv->accept()) {
|
||||
print "Got a client...\n";
|
||||
print $client "Hello, Perl!\n";
|
||||
}
|
||||
|
||||
@ -1,24 +0,0 @@
|
||||
use warnings;
|
||||
use 5.028;
|
||||
use Socket;
|
||||
use Fcntl qw/F_GETFL F_SETFL O_NONBLOCK/;
|
||||
use IO::Select;
|
||||
use Data::Dumper;
|
||||
$Data::Dumper::Useqq=1;
|
||||
|
||||
my $port = 2345;
|
||||
my $iaddr = inet_aton("localhost") || die "host not found";
|
||||
my $paddr = sockaddr_in($port, $iaddr);
|
||||
|
||||
# Note: Emscripten apparently doesn't like NONBLOCK being passed to socket(),
|
||||
# and I couldn't get setsockopt to work yet - but the following works.
|
||||
# https://github.com/kripken/emscripten/blob/d08bf13/tests/sockets/test_sockets_echo_client.c#L166
|
||||
# everything is async - need "our $sock" here so it doesn't go out of scope at end of file
|
||||
socket(our $sock, PF_INET, SOCK_STREAM, getprotobyname("tcp")) or die "socket: $!";
|
||||
my $flags = fcntl($sock, F_GETFL, 0) or die "get flags: $!";
|
||||
fcntl($sock, F_SETFL, $flags | O_NONBLOCK) or die "set flags: $!";
|
||||
connect $sock, $paddr or !$!{EINPROGRESS} && die "connect: $!";
|
||||
|
||||
# so far so good... but probably should just use something like IO::Async instead
|
||||
|
||||
|
||||
@ -1,42 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl XTerm.js Test</title>
|
||||
|
||||
<!--cacheable--><link rel="stylesheet" href="https://cdn.jsdelivr.net/npm/xterm@3.7.0/dist/xterm.css" integrity="sha256-OSfRj4jMeYVFSwgcvVvKj4V0+mwqSP9YJjyEJe7dmK0=" crossorigin="anonymous" />
|
||||
<!--cacheable--><script src="https://cdn.jsdelivr.net/npm/xterm@3.7.0/dist/xterm.js" integrity="sha256-gIILiZzLBFrmY1dzcKJC2Nmw4o9ISITTNsro2rf8svM=" crossorigin="anonymous"></script>
|
||||
|
||||
<script src="webperl.js"></script>
|
||||
|
||||
<script>
|
||||
"use strict";
|
||||
window.addEventListener('load', function () {
|
||||
var term = new Terminal();
|
||||
term.open(document.getElementById('terminal'));
|
||||
Perl.output = function (str) { term.write(str) };
|
||||
Module.preRun.push(function () { ENV.TERM = "xterm" });
|
||||
});
|
||||
</script>
|
||||
|
||||
<script type="text/perl">
|
||||
use warnings;
|
||||
use strict;
|
||||
use Term::ANSIColor qw/colored/;
|
||||
|
||||
print colored("Hello, Color World!\n", 'black on_yellow');
|
||||
|
||||
# Possible To-Do for Later: can we accept input from XTerm?
|
||||
# might not be so easy: https://github.com/xtermjs/xterm.js/issues/1546#issuecomment-402547923
|
||||
# (keypresses are events, but reading from STDIN is normally blocking...)
|
||||
|
||||
</script>
|
||||
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<div id="terminal"></div>
|
||||
<p><a href="http://xtermjs.org/" target="_blank">xterm.js</a></p>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
@ -1,208 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl Code Demo</title>
|
||||
|
||||
<!-- ##### WebPerl - http://webperl.zero-g.net #####
|
||||
|
||||
Copyright (c) 2018 Hauke Daempfling (haukex@zero-g.net)
|
||||
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
Berlin, Germany, http://www.igb-berlin.de
|
||||
|
||||
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 http://perldoc.perl.org/index-licence.html
|
||||
##### -->
|
||||
|
||||
<style>
|
||||
p {
|
||||
font-family: Calibri, Ubuntu, "Droid Sans", Tahoma, Arial, Helvetica, sans-serif;
|
||||
}
|
||||
pre,textarea,code {
|
||||
font-family: Consolas, "Ubuntu Mono", "Droid Sans Mono", "Lucida Console", "Courier New", Courier, monospace;
|
||||
}
|
||||
iframe.perleditor {
|
||||
display: block;
|
||||
border: 1px solid black;
|
||||
width: 100%;
|
||||
max-width: 50em;
|
||||
margin: 0.2em 0;
|
||||
}
|
||||
</style>
|
||||
<!-- Optional "IFrame Resizer": -->
|
||||
<!--cacheable--><!--script src="https://cdnjs.cloudflare.com/ajax/libs/iframe-resizer/3.6.2/iframeResizer.min.js" integrity="sha256-aYf0FZGWqOuKNPJ4HkmnMZeODgj3DVslnYf+8dCN9/k=" crossorigin="anonymous"></script-->
|
||||
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<p>
|
||||
This page demonstrates the embeddable
|
||||
<strong><a href="http://webperl.zero-g.net" target="_blank">WebPerl</a>
|
||||
Code Demo Editor</strong> (beta), which can be embedded using <code><iframe></code> elements, including
|
||||
<a href="https://developer.mozilla.org/en-US/docs/Web/HTML/Element/iframe#attr-sandbox" target="_blank">sandboxing</a>.
|
||||
The documentation is contained in the source of this page, please use
|
||||
the "View Source" function of your browser to view it, or have a look at
|
||||
<a href="https://github.com/haukex/webperl/tree/master/web/democode"
|
||||
target="_blank">the project sources on GitHub</a>.
|
||||
</p>
|
||||
|
||||
<!-- Thank you to LanX from PerlMonks for the inspiration! :-)
|
||||
https://www.perlmonks.org/?node_id=1223812 -->
|
||||
|
||||
<!-- First, you have to include the following hidden IFrame, which
|
||||
loads the "Perl runner". This is (currently) necessary because this
|
||||
IFrame needs to re-load itself in order to re-run Perl. This IFrame
|
||||
*must* have the "name='perlrunner'" attribute and must be embedded at
|
||||
the same level as the Perl editor IFrame(s). The frames communicate
|
||||
via the "window.postMessage()" mechanism, which is safe for
|
||||
cross-origin communications and sandboxing. Currently, in order to
|
||||
conserve memory, a single runner serves multiple "clients", that is,
|
||||
the "editor" IFrames below.
|
||||
|
||||
It is also possible to link to perleditor.html directly: if it
|
||||
detects that it is not running in an IFrame, it will load the runner
|
||||
on its own (after a very brief delay).
|
||||
-->
|
||||
|
||||
<iframe name="perlrunner" sandbox="allow-scripts" src="perlrunner.html" style="display:none;"></iframe>
|
||||
|
||||
<p>This is a simple example of running a oneliner:</p>
|
||||
|
||||
<!-- The following is a basic example showing a single input file and
|
||||
Perl oneliner.
|
||||
|
||||
All files are currently always encoded as UTF-8, which is why the
|
||||
"-CSD" switch is used below. This is not strictly necessary when the
|
||||
input files are pure ASCII, but it is important to remember that Perl
|
||||
does *not* default to UTF-8. Reading/writing binary data via the
|
||||
editor and runner is currently *not* supported.
|
||||
|
||||
Standard input/output redirection is currently not supported. It is
|
||||
also currently not supported to supply STDIN directly to the script,
|
||||
the workaround is to use input files, supply the filenames on the
|
||||
command line, and use Perl's magic ARGV operator "<>". Support for
|
||||
redirections may be added in a future version.
|
||||
|
||||
The JavaScript shown below is not strictly necessary, it is also
|
||||
possible to specify a "src='...'" attribute directly in the IFrame
|
||||
tag, for example using the "Copy Frame URL" link shown in the editor.
|
||||
|
||||
Note that implementing an automatic resize of the IFrame to fit its
|
||||
contents is nontrivial when sandboxing is enabled, which is why a
|
||||
fixed height is used below. However, see for example
|
||||
http://davidjbradshaw.github.io/iframe-resizer/ - examples of how
|
||||
to use this are included in the source files here.
|
||||
-->
|
||||
|
||||
<iframe id="perl1" sandbox="allow-scripts" class="perleditor" style="height:20em;"></iframe>
|
||||
<script>
|
||||
document.getElementById('perl1').src =
|
||||
"perleditor.html#" + encodeURIComponent(JSON.stringify( {
|
||||
inputs: [ { fn:"in.txt", text:"Foo\nBar\nQuz" } ],
|
||||
cmdline: "perl -CSD -pe 's/[aeiou]/_/g' in.txt",
|
||||
} ));
|
||||
// Example of how to use the Optional "IFrame Resizer":
|
||||
//iFrameResize({checkOrigin:false}, document.getElementById('perl1'));
|
||||
</script>
|
||||
|
||||
<p>This example includes several files:</p>
|
||||
|
||||
<!-- The following example demonstrates (almost) all of the possible
|
||||
options that can be passed to the editor.
|
||||
|
||||
The "cmdline" option and the corresponding input box in the editor
|
||||
only support very basic quoting constructs:
|
||||
- Strings in double quotes may contain whitespace, \\, and/or \",
|
||||
the latter two will be changed to \ and " respectively;
|
||||
- strings in single quotes may contain whitespace, \\, and/or \',
|
||||
the latter two will be changed to \ and ' respectively;
|
||||
- other strings (without whitespace) will not be modified.
|
||||
Note: As a consequence of these rules, inside of single or double
|
||||
quotes, both \\n and \n resolve to \n (for any character "n" that
|
||||
is not a backslash or single resp. double quote).
|
||||
|
||||
Instead of "cmdline", you may specify "argv" as an array ("cmdline"
|
||||
overrides "argv"). This array should *not* include "perl" as the
|
||||
first element; this is added automatically.
|
||||
|
||||
So that it can be displayed in the input box, the "argv" array
|
||||
will be encoded into a single string - this means that if you want
|
||||
full control over the formatting of the command line as it is
|
||||
displayed to the user in the editor, use "cmdline" instead. The
|
||||
"Copy JSON" data will include both "cmdline" and "argv" (so you
|
||||
can choose to delete whichever one you don't need), while "Copy
|
||||
URL" will include only "cmdline" (for brevity).
|
||||
|
||||
You may specify the text of a script via "script", or, alternatively,
|
||||
a "script_url" from which the script is to be fetched - however, be
|
||||
aware that cross-origin restrictions may limit your ability to fetch
|
||||
URLs from other origins. You can specify the script's filename with
|
||||
"script_fn".
|
||||
|
||||
Input files ("inputs") are specified as an array of objects; the
|
||||
properties of the object are similar to the script: filenames are
|
||||
specified with "fn", and the text of the file via "text", or
|
||||
alternatively, you may specify a "url" from which the content is to
|
||||
be fetched.
|
||||
|
||||
The output files ("outputs") are an array of filenames. After the
|
||||
script finishes, the "Perl runner" will attempt to read these files
|
||||
and display them to the user. It is also possible to specify output
|
||||
files with the same name as an input file, for example if Perl's "-i"
|
||||
option was used.
|
||||
|
||||
The current working directory of Perl defaults to the "home"
|
||||
directory in Emscripten's virtual file system, currently
|
||||
"/home/web_user", and all filenames are relative to this directory.
|
||||
You may also specify absolute filenames such as "/tmp/foo.txt".
|
||||
However, note that intermediate directories are currently not
|
||||
automatically created, so if you specify files with nonexistent
|
||||
directories like "/tmp/foo/bar.txt" or the relative "foo/bar.txt",
|
||||
this will not work.
|
||||
|
||||
Additional options: Setting "mergeStdOutErr" to a true value causes
|
||||
STDOUT and STDERR output to be output together, similar to the way
|
||||
they would be on the console. *However,* note that WebPerl
|
||||
currently doesn't think it's connected to a terminal, which means
|
||||
that perl defaults to block instead of line buffering STDOUT, so
|
||||
it may seem like you always see STDERR output before STDOUT. If you
|
||||
want to truly intermix the two, turn on autoflush ("$|=1;").
|
||||
|
||||
If you set the "autorun" option, the editor will attempt to run the
|
||||
script as soon as the runner is ready. *WARNING:* If you have
|
||||
multiple editors embedded in the page, *do not* enable "autorun"
|
||||
for more than one editor, as otherwise you will likely trigger a
|
||||
race condition, resulting in an error being shown to the user.
|
||||
-->
|
||||
|
||||
<iframe id="perl2" sandbox="allow-scripts" class="perleditor" style="height:42em;"></iframe>
|
||||
<script>
|
||||
document.getElementById('perl2').src =
|
||||
"perleditor.html#" + encodeURIComponent(JSON.stringify( {
|
||||
argv: ["devoweler.pl","mytext.txt","other.txt"],
|
||||
script: "use warnings;\nuse strict;\n\nopen my $vfh, '>', 'vowels.txt' or die $!;\n"
|
||||
+"while (<>) {\n\tprint $vfh $1 while s/([aeiou])/_/i;\n\tprint;\n}\nclose $vfh;",
|
||||
script_fn: "devoweler.pl",
|
||||
inputs: [
|
||||
{ fn: "mytext.txt", text: "Foo\nBar\nQuz\n" },
|
||||
{ fn: "other.txt", text: "Hello, World!" },
|
||||
],
|
||||
outputs: [ "vowels.txt" ],
|
||||
autorun: true,
|
||||
} ));
|
||||
//iFrameResize({checkOrigin:false}, document.getElementById('perl2'));
|
||||
</script>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
@ -1,83 +0,0 @@
|
||||
|
||||
body {
|
||||
margin: 0.4em;
|
||||
}
|
||||
.text {
|
||||
font-family: Calibri, Ubuntu, "Droid Sans", Tahoma, Arial, Helvetica, sans-serif;
|
||||
font-size: 0.9em;
|
||||
}
|
||||
pre,textarea,code,.code,.filename,.CodeMirror {
|
||||
font-family: Consolas, "Ubuntu Mono", "Droid Sans Mono", "Lucida Console", "Courier New", Courier, monospace;
|
||||
}
|
||||
pre {
|
||||
margin: 0;
|
||||
}
|
||||
a {
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.CodeMirror {
|
||||
border: 1px solid lightgrey;
|
||||
height: auto;
|
||||
}
|
||||
.CodeMirror-scroll {
|
||||
max-height: 12em;
|
||||
}
|
||||
|
||||
.codewithfn {
|
||||
margin-top: 0.4em;
|
||||
}
|
||||
.fnfuncs {
|
||||
cursor: default;
|
||||
}
|
||||
.filename {
|
||||
display: inline-block;
|
||||
border: 0;
|
||||
padding: 1px;
|
||||
min-width: 1em;
|
||||
cursor: auto;
|
||||
}
|
||||
.filefuncs {
|
||||
display: inline-block;
|
||||
padding-top: 2px;
|
||||
position: absolute;
|
||||
right: 0.2em;
|
||||
}
|
||||
.fakelink {
|
||||
color: darkblue;
|
||||
cursor: pointer;
|
||||
}
|
||||
.badfilename {
|
||||
background-color: rgba(255,200,200,255);
|
||||
/* also has a placeholder text */
|
||||
min-width: 10em;
|
||||
}
|
||||
|
||||
#perlctrl {
|
||||
margin-top: 0.3em;
|
||||
}
|
||||
|
||||
#misctools {
|
||||
display: inline-block;
|
||||
border: 1px solid grey;
|
||||
padding: 1px 0.8em 1px 0.5em;
|
||||
margin-top: 0.5em;
|
||||
}
|
||||
#runnerstate {
|
||||
margin-top: 0.2em;
|
||||
margin-bottom: 0.3em;
|
||||
}
|
||||
#runnererrors {
|
||||
background-color: rgba(255,200,200,255);
|
||||
margin-top: 0.3em;
|
||||
margin-bottom: 0.3em;
|
||||
padding: 0.1em 0.2em;
|
||||
}
|
||||
|
||||
#inputhere, #outputhere {
|
||||
text-align: right;
|
||||
}
|
||||
|
||||
#footer {
|
||||
margin-top: 0.5em;
|
||||
}
|
||||
@ -1,550 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl Perl Editor</title>
|
||||
|
||||
<!-- ##### WebPerl - http://webperl.zero-g.net #####
|
||||
|
||||
Copyright (c) 2018 Hauke Daempfling (haukex@zero-g.net)
|
||||
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
Berlin, Germany, http://www.igb-berlin.de
|
||||
|
||||
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 http://perldoc.perl.org/index-licence.html
|
||||
##### -->
|
||||
|
||||
<!-- Please see the documentation on how to use this in demo.html. -->
|
||||
|
||||
<!--cacheable--><link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/normalize/8.0.0/normalize.min.css" integrity="sha256-oSrCnRYXvHG31SBifqP2PM1uje7SJUyX0nTwO2RJV54=" crossorigin="anonymous" />
|
||||
<!--cacheable--><link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/codemirror/5.39.2/codemirror.min.css" integrity="sha256-I8NyGs4wjbMuBSUE40o55W6k6P7tu/7G28/JGUUYCIs=" crossorigin="anonymous" />
|
||||
<link rel="stylesheet" href="perleditor.css" />
|
||||
|
||||
<!-- Optional "IFrame Resizer": -->
|
||||
<!--cacheable--><!--script src="https://cdnjs.cloudflare.com/ajax/libs/iframe-resizer/3.6.2/iframeResizer.contentWindow.min.js" integrity="sha256-dEPtZVO6cj6PAmBeDzFskohUob+woyzF6TaNcYpAk84=" crossorigin="anonymous"></script-->
|
||||
<!--cacheable--><script src="https://cdnjs.cloudflare.com/ajax/libs/codemirror/5.39.2/codemirror.min.js" integrity="sha256-uRIJ6Wfou5cTtmcCvQNA9lvsYl8sUbZXxnfG+P79ssY=" crossorigin="anonymous"></script>
|
||||
<!--cacheable--><script src="https://cdnjs.cloudflare.com/ajax/libs/codemirror/5.39.2/mode/perl/perl.min.js" integrity="sha256-Uu9QBfi8gU6J/MzQunal8ewmY+i/BbCkBrcAXA5bcCM=" crossorigin="anonymous"></script>
|
||||
<!--cacheable--><script src="https://code.jquery.com/jquery-3.3.1.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
|
||||
<script>
|
||||
"use strict";
|
||||
|
||||
var mergeStdOutErr = false; // Possible To-Do for Later: could make an options hash
|
||||
var perlRunner; // the Perl runner iframe found by findPerlRunner()
|
||||
var buttonBlockers = {}; // for updateButtonState()
|
||||
var lastExitStatus; // for runnerState()
|
||||
var loadedRunnerIframe = false; // for findPerlRunner()
|
||||
var autoRunPerl = false; // for the message listener
|
||||
|
||||
function makeCM (textarea,plain,ro) {
|
||||
return CodeMirror.fromTextArea( textarea[0], {
|
||||
viewportMargin: Infinity, // so browser's search works, not good for long documents though
|
||||
lineNumbers:true, indentWithTabs:true,
|
||||
tabSize:4, indentUnit:4,
|
||||
mode: plain?"text/plain":"perl",
|
||||
readOnly: ro?true:false,
|
||||
} );
|
||||
}
|
||||
|
||||
function runnerState (text) {
|
||||
$('#runnerstate').text( text
|
||||
+ (lastExitStatus ? ' (last exit status was '+lastExitStatus+')'
|
||||
: '') );
|
||||
}
|
||||
|
||||
function updateButtonState () {
|
||||
$('#runperl').prop("disabled",
|
||||
Object.keys(buttonBlockers).length>0 );
|
||||
}
|
||||
|
||||
function stdOutput (which, data) { // which: 1=stdout, 2=stderr
|
||||
if (mergeStdOutErr) which = 1;
|
||||
var div = $(which==1?'#stdout':'#stderr');
|
||||
div.show();
|
||||
var cm = div.data('CodeMirrorInstance');
|
||||
if (!cm) {
|
||||
cm = makeCM($('textarea',div),1,1);
|
||||
div.data('CodeMirrorInstance', cm);
|
||||
}
|
||||
if (data && data.length)
|
||||
cm.setValue( cm.getValue() + data );
|
||||
}
|
||||
function clearStdOutput () {
|
||||
$('#stdout,#stderr').each(function (i) {
|
||||
var div = $(this);
|
||||
var cm = div.data('CodeMirrorInstance');
|
||||
if (cm) cm.setValue('');
|
||||
div.hide();
|
||||
});
|
||||
}
|
||||
|
||||
function findPerlRunner () {
|
||||
// assume calling this function means the runner isn't available
|
||||
buttonBlockers.runnerState = 1;
|
||||
updateButtonState();
|
||||
// poll for perlRunner, which gets set by the message listener
|
||||
var warnAt = Date.now() + 15*1000; // milliseconds
|
||||
var loadIframe = Date.now() + 3*1000; // milliseconds
|
||||
var pollId;
|
||||
pollId = window.setInterval( function () {
|
||||
if (perlRunner)
|
||||
window.clearInterval(pollId);
|
||||
else if (!loadedRunnerIframe && self===top && Date.now()>loadIframe) {
|
||||
console.debug("Perl Editor is attempting to load Perl Runner...");
|
||||
/* This is a special case: We appear to be the toplevel window,
|
||||
* and are unable to contact the runner within a fixed amount of time.
|
||||
* So we assume that someone has linked directly to this page instead
|
||||
* of loading it in an IFrame, so we'll load the runner ourselves. */
|
||||
$('<iframe/>',{name:"perlrunner",sandbox:"allow-scripts",
|
||||
src:"perlrunner.html",style:"display:none;"})
|
||||
.appendTo('body');
|
||||
loadedRunnerIframe = true;
|
||||
}
|
||||
else {
|
||||
if (window.parent && window.parent.frames["perlrunner"])
|
||||
window.parent.frames["perlrunner"].postMessage(
|
||||
{perlRunnerDiscovery:1}, '*');
|
||||
if ( Date.now()>warnAt ) {
|
||||
$('#runnererrors>pre').text("Perl does not appear to have loaded yet, still waiting...");
|
||||
$('#runnererrors').show();
|
||||
warnAt = Date.now() + 5*1000; // milliseconds
|
||||
}
|
||||
}
|
||||
}, 100);
|
||||
}
|
||||
|
||||
window.addEventListener('message', function (event) {
|
||||
var data = event.data;
|
||||
if (data["perlRunnerState"]) {
|
||||
if ( data.perlRunnerState=="Ready" ) {
|
||||
perlRunner = event.source;
|
||||
delete buttonBlockers.runnerState;
|
||||
updateButtonState();
|
||||
if (autoRunPerl) {
|
||||
autoRunPerl = false;
|
||||
$('#runperl').click();
|
||||
}
|
||||
}
|
||||
else if ( data.perlRunnerState=="Ended" ) {
|
||||
if ('exitStatus' in data)
|
||||
lastExitStatus = ''+data.exitStatus;
|
||||
// we know the runner will reload itself now
|
||||
perlRunner = null;
|
||||
findPerlRunner();
|
||||
}
|
||||
runnerState("Perl is "+data.perlRunnerState);
|
||||
}
|
||||
else if (data["perlOutput"])
|
||||
stdOutput(data.perlOutput.chan, data.perlOutput.data);
|
||||
else if (data["perlOutputFiles"]) {
|
||||
data.perlOutputFiles.forEach(function (outp) {
|
||||
setupOutputFile(outp.fn, outp.text);
|
||||
});
|
||||
}
|
||||
else if (data["perlRunnerError"]) {
|
||||
$('#runnererrors').show();
|
||||
$('#runnererrors>pre').append(data.perlRunnerError+"\n");
|
||||
}
|
||||
else if (data.substring(0,13)=="[iFrameSizer]") {} // ignore quietly
|
||||
else console.warn("Perl Editor ignoring unknown message:",data);
|
||||
});
|
||||
|
||||
function parseCmdLine(str) {
|
||||
// not the prettiest code but it works
|
||||
var re = /"((?:\\"|\\\\|[^"])*)"|'((?:\\'|\\\\|[^'])*)'|(\S+)/g;
|
||||
var argv = [];
|
||||
var match;
|
||||
while ((match = re.exec(str)) !== null) {
|
||||
if (typeof match[1] != 'undefined') argv.push(match[1].replace(/\\\\/g,"\\").replace(/\\"/g,"\""));
|
||||
else if (typeof match[2] != 'undefined') argv.push(match[2].replace(/\\\\/g,'\\').replace(/\\'/g,'\''));
|
||||
else if (typeof match[3] != 'undefined') argv.push(match[3]);
|
||||
else throw "Unexpected match "+match;
|
||||
}
|
||||
return argv;
|
||||
}
|
||||
function encodeCmdLine(arr) {
|
||||
var out = [];
|
||||
for (var i=0; i<arr.length; i++) {
|
||||
/* Note: we only *need* to encode strings if they contain /[\s'"\\]/,
|
||||
* but since we want to show the users a command line similar to a shell,
|
||||
* I've added $ */
|
||||
out.push( arr[i].match(/[\s'"\\\$]/)
|
||||
? "'"+arr[i].replace(/\\/g, "\\\\").replace(/'/g, "\\'")+"'"
|
||||
: arr[i] );
|
||||
}
|
||||
return out.join(' ');
|
||||
}
|
||||
|
||||
function fetchUrl(url,cm) { // fetch the contents of a URL into a CodeMirror instance
|
||||
cm.setValue("Fetching URL\n"+url+"\nPlease wait...");
|
||||
buttonBlockers["fetchUrls"]++;
|
||||
updateButtonState();
|
||||
$.get(url, function (data) {
|
||||
cm.setValue(data);
|
||||
},'text').fail(function (jqXHR,textStatus,errorThrown) {
|
||||
cm.setValue("Fetching URL\n"+url+"\nFailed!\n"+textStatus+"\n"+errorThrown);
|
||||
}).always(function () {
|
||||
buttonBlockers.fetchUrls--;
|
||||
if (!buttonBlockers.fetchUrls)
|
||||
delete buttonBlockers.fetchUrls;
|
||||
updateButtonState();
|
||||
});
|
||||
}
|
||||
|
||||
function makeCodeWithFn (fn,targ,ro,isscript) {
|
||||
var div = $('<div/>',{class:"codewithfn"});
|
||||
|
||||
var fnfuncs = $('<div/>',{class:"fnfuncs"}).appendTo(div);
|
||||
|
||||
var filename = $('<input/>',{class:"filename code",type:"text",
|
||||
placeholder:"Enter a filename!"})
|
||||
.appendTo(fnfuncs);
|
||||
filename.val(fn);
|
||||
// autosize the filename text box via a hidden span
|
||||
var fn_width = $('<span/>',
|
||||
{class:"code",style:"display:none;white-space:pre;"}
|
||||
).insertAfter(filename);
|
||||
filename.on('input', function () {
|
||||
var newfn = filename.val();
|
||||
fn_width.text( newfn );
|
||||
filename.width( fn_width.width()+10 );
|
||||
if (newfn.length)
|
||||
filename.removeClass("badfilename");
|
||||
else
|
||||
filename.addClass("badfilename");
|
||||
});
|
||||
/* we need to trigger this handler once when the input
|
||||
* field is added to the document, we do this below */
|
||||
|
||||
var filefuncs = $('<div/>',{class:"filefuncs text"})
|
||||
.appendTo(fnfuncs);
|
||||
|
||||
var conf = $('<span/>', {})
|
||||
.append(
|
||||
" ",
|
||||
"Are you sure?",
|
||||
" ",
|
||||
$('<span/>',{class:"fakelink",text:"Yes"})
|
||||
.click(function () {
|
||||
div.remove();
|
||||
if (isscript) $('#addscript').show();
|
||||
}),
|
||||
" ",
|
||||
$('<span/>',{class:"fakelink",text:"Cancel"})
|
||||
.click(function () { conf.hide(); }),
|
||||
);
|
||||
$('<span/>',{class:"fakelink",text:"Delete"})
|
||||
.appendTo(filefuncs).click(function () {
|
||||
conf.show();
|
||||
});
|
||||
conf.hide();
|
||||
conf.appendTo(filefuncs);
|
||||
|
||||
var ta = $('<textarea/>').appendTo(div);
|
||||
targ.before(div);
|
||||
filename.trigger('input'); // see above
|
||||
var cm = makeCM(ta, !(isscript||fn.match(/\.pl$/i)), ro);
|
||||
div.data('CodeMirrorInstance', cm);
|
||||
return {div:div,ta:ta,cm:cm};
|
||||
}
|
||||
|
||||
function pickNewFilename (inNotOut) {
|
||||
var x = inNotOut ? 'input' : 'output';
|
||||
for (var i=1; i<1000; i++) {
|
||||
var fn = x+i+".txt";
|
||||
var found = $('div.'+x+'s .filename')
|
||||
.filter(function(){ return $(this).val() == fn });
|
||||
if (!found.length)
|
||||
return fn;
|
||||
}
|
||||
$('#runnererrors>pre').text('Too many '+x+' files');
|
||||
$('#runnererrors').show();
|
||||
throw 'Too many '+x+' files';
|
||||
}
|
||||
|
||||
function setupOutputFile (fn, text) {
|
||||
var cm;
|
||||
if (fn) {
|
||||
var founddiv = $('div.outputs')
|
||||
.filter(function(){ return $('.filename',this).val() == fn });
|
||||
if (founddiv.length)
|
||||
cm = founddiv.data('CodeMirrorInstance');
|
||||
}
|
||||
else
|
||||
fn = pickNewFilename(false);
|
||||
if (!cm) {
|
||||
var cfn = makeCodeWithFn(fn, $('#outputhere'), 1);
|
||||
cfn.div.addClass("outputs");
|
||||
cm = cfn.cm;
|
||||
}
|
||||
cm.setValue( text ? text : '' );
|
||||
}
|
||||
|
||||
function setupInputFile (inp) {
|
||||
var fn = inp["fn"] ? inp.fn : pickNewFilename(true);
|
||||
var cfn = makeCodeWithFn(fn, $('#inputhere'), 0);
|
||||
cfn.div.addClass("inputs");
|
||||
if (inp["text"])
|
||||
cfn.cm.setValue(inp.text);
|
||||
else if (inp["url"])
|
||||
fetchUrl(inp.url, cfn.cm);
|
||||
}
|
||||
|
||||
function getFileData () {
|
||||
var filedata = {};
|
||||
// command-line args
|
||||
filedata.cmdline = $('#argv').val();
|
||||
var argv = parseCmdLine( filedata.cmdline );
|
||||
if ( argv.length<1 || argv[0]!="perl" ) {
|
||||
$('#runnererrors>pre').text('Invalid command line, command must be "perl"');
|
||||
$('#runnererrors').show();
|
||||
return;
|
||||
} // else
|
||||
argv.shift();
|
||||
$('#runnererrors>pre').text('');
|
||||
$('#runnererrors').hide();
|
||||
filedata.argv = argv;
|
||||
// script
|
||||
var scriptdiv = $('#script');
|
||||
if (scriptdiv.is(':visible')) {
|
||||
filedata.script = scriptdiv.data('CodeMirrorInstance').getValue();
|
||||
filedata.script_fn = scriptdiv.find('.filename').val();
|
||||
}
|
||||
// inputs
|
||||
$('.inputs').each(function () {
|
||||
var div = $(this);
|
||||
var fn = $('.filename',div).val();
|
||||
var text = div.data('CodeMirrorInstance').getValue();
|
||||
if (!filedata["inputs"]) filedata.inputs = [];
|
||||
filedata.inputs.push( { fn:fn, text:text } );
|
||||
});
|
||||
// outputs
|
||||
$('.outputs').each(function () {
|
||||
var fn = $(this).find('.filename').val();
|
||||
if (!filedata["outputs"]) filedata.outputs = [];
|
||||
filedata.outputs.push(fn);
|
||||
});
|
||||
return filedata;
|
||||
}
|
||||
|
||||
function copyit (what) {
|
||||
var pageurl = $('#pageurl');
|
||||
pageurl.val(what);
|
||||
pageurl.show();
|
||||
pageurl[0].select();
|
||||
document.execCommand("copy");
|
||||
pageurl.hide();
|
||||
}
|
||||
|
||||
$(function () {
|
||||
|
||||
var hashdata = window.location.hash.substr(1);
|
||||
var hash = hashdata.length>0 ? JSON.parse(decodeURIComponent(hashdata)) : {};
|
||||
|
||||
$('#showtools').click(function () {
|
||||
$('#thetools,#footer').toggle();
|
||||
$('#showtools').text( $('#thetools').is(':visible')
|
||||
? 'Hide Tools' : 'Show Tools' );
|
||||
});
|
||||
$('#webperllink').click(function () {
|
||||
$('#webperlurl').show();
|
||||
});
|
||||
|
||||
// script
|
||||
var addscript = $('#addscript');
|
||||
if ( hash["script"] || hash["script_url"] ) {
|
||||
var fn = hash["script_fn"] ? hash.script_fn : 'script.pl';
|
||||
var cfn = makeCodeWithFn(fn, $('#perlctrl'), 0, 1);
|
||||
cfn.div.attr("id", "script");
|
||||
if (hash["script"])
|
||||
cfn.cm.setValue(hash.script);
|
||||
else if (hash["script_url"])
|
||||
fetchUrl(hash.script_url, cfn.cm);
|
||||
addscript.hide();
|
||||
}
|
||||
else
|
||||
addscript.show();
|
||||
$('#addscript .fakelink').click(function () {
|
||||
addscript.hide();
|
||||
if ($('#script').length) return;
|
||||
var cfn = makeCodeWithFn('script.pl', $('#perlctrl'), 0, 1);
|
||||
cfn.div.attr("id", "script");
|
||||
cfn.cm.setValue("use warnings;\nuse strict;\n\n");
|
||||
});
|
||||
|
||||
// command line
|
||||
var argv_inp = $('#argv');
|
||||
var argv_autosize = $('<span/>',
|
||||
{class:"code",style:"display:none;white-space:pre;"}
|
||||
).insertAfter(argv_inp);
|
||||
argv_inp.on('input', function () {
|
||||
argv_autosize.text( argv_inp.val() );
|
||||
argv_inp.width( argv_autosize.width()+10 );
|
||||
});
|
||||
if (hash["cmdline"])
|
||||
argv_inp.val(hash.cmdline);
|
||||
else if (hash["argv"])
|
||||
argv_inp.val("perl "+encodeCmdLine(hash.argv));
|
||||
argv_inp.trigger('input');
|
||||
|
||||
// input files
|
||||
$('.inputs').remove();
|
||||
if ( hash["inputs"] ) hash.inputs.forEach(function(inp) {
|
||||
setupInputFile(inp);
|
||||
});
|
||||
$('#addinput').click(function () {
|
||||
setupInputFile( {} );
|
||||
});
|
||||
|
||||
// stdout/stderr
|
||||
var mergestdoe = $('#mergestdoe');
|
||||
var stdout_fn = $('#stdout .filename');
|
||||
if (hash["mergeStdOutErr"]) {
|
||||
mergeStdOutErr = true;
|
||||
stdout_fn.val("STDOUT+STDERR");
|
||||
mergestdoe.text("Split STDOUT+ERR");
|
||||
}
|
||||
else {
|
||||
mergeStdOutErr = false;
|
||||
stdout_fn.val("STDOUT");
|
||||
}
|
||||
clearStdOutput();
|
||||
mergestdoe.click(function () {
|
||||
clearStdOutput();
|
||||
mergeStdOutErr = !mergeStdOutErr;
|
||||
stdout_fn.val( mergeStdOutErr ? "STDOUT+STDERR" : "STDOUT" );
|
||||
mergestdoe.text( mergeStdOutErr ? "Split STDOUT+ERR" : "Merge STDOUT+ERR" );
|
||||
});
|
||||
|
||||
// output files
|
||||
$('.outputs').remove();
|
||||
if ( hash["outputs"] ) hash.outputs.forEach(function(outp) {
|
||||
setupOutputFile(outp);
|
||||
});
|
||||
$('#addoutput').click(function () {
|
||||
setupOutputFile();
|
||||
});
|
||||
|
||||
// autorun option
|
||||
if (hash["autorun"])
|
||||
autoRunPerl = true;
|
||||
var autorunstate = $('#autorunstate');
|
||||
$('#autoruntoggle').click(function () {
|
||||
// the text keeps state (bit of a hack, I know)
|
||||
autorunstate.text(
|
||||
autorunstate.text().match(/without/i)
|
||||
? "with" : "without" );
|
||||
});
|
||||
|
||||
// "run perl" button
|
||||
$('#runperl').click( function () {
|
||||
clearStdOutput();
|
||||
var rp_data = getFileData();
|
||||
if (!rp_data) return;
|
||||
delete rp_data.cmdline;
|
||||
// send message to runner
|
||||
buttonBlockers.runnerState = 1;
|
||||
updateButtonState();
|
||||
lastExitStatus = null;
|
||||
runnerState("Requesting Perl Run...");
|
||||
perlRunner.postMessage({ runPerl: rp_data }, '*');
|
||||
});
|
||||
|
||||
// "copy url / json" function
|
||||
$('#copyurl').click(function () {
|
||||
var data = getFileData();
|
||||
if (!data) return;
|
||||
delete data.argv;
|
||||
if (!autorunstate.text().match(/without/i)) data.autorun=true;
|
||||
if (mergeStdOutErr) data.mergeStdOutErr=true;
|
||||
var loc = new URL(window.location);
|
||||
loc.hash = encodeURIComponent(JSON.stringify(data));
|
||||
copyit(loc);
|
||||
});
|
||||
$('#copyjson').click(function () {
|
||||
var data = getFileData();
|
||||
if (!data) return;
|
||||
if (!autorunstate.text().match(/without/i)) data.autorun=true;
|
||||
if (mergeStdOutErr) data.mergeStdOutErr=true;
|
||||
copyit(JSON.stringify(data, null, "\t"));
|
||||
});
|
||||
|
||||
// start looking for the Perl runner
|
||||
findPerlRunner();
|
||||
});
|
||||
|
||||
</script>
|
||||
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<div id="inputhere" style="display:none;"></div>
|
||||
|
||||
<div id="perlctrl">
|
||||
<button id="runperl"><code>perl</code> ►</button>
|
||||
<input type="text" id="argv" class="code" value='perl' />
|
||||
</div>
|
||||
|
||||
<div id="runnerstate" class="text">
|
||||
Loading...
|
||||
</div>
|
||||
|
||||
<div id="runnererrors" style="display:none;">
|
||||
<pre></pre>
|
||||
</div>
|
||||
|
||||
<div id="stdout" class="codewithfn" style="display:none;">
|
||||
<input type="text" class="filename code" readonly="readonly" value="STDOUT" size="14" />
|
||||
<textarea></textarea>
|
||||
</div>
|
||||
|
||||
<div id="stderr" class="codewithfn" style="display:none;">
|
||||
<input type="text" class="filename code" readonly="readonly" value="STDERR" size="14" />
|
||||
<textarea></textarea>
|
||||
</div>
|
||||
|
||||
<div id="outputhere" style="display:none;"></div>
|
||||
|
||||
<div class="text">
|
||||
<textarea id="pageurl" style="display:none;"></textarea>
|
||||
<div id="misctools">
|
||||
<span id="showtools" class="fakelink">Show Tools</span>
|
||||
<span id="thetools" style="display:none;">
|
||||
|
||||
<span id="addscript" style="display:none;">•
|
||||
<span class="fakelink">Add Script</span>
|
||||
</span>
|
||||
•
|
||||
<span id="addinput" class="fakelink">Add Input File</span>
|
||||
•
|
||||
<span id="addoutput" class="fakelink">Add Output File</span>
|
||||
•
|
||||
<span id="mergestdoe" class="fakelink">Merge STDOUT+ERR</span>
|
||||
•
|
||||
<span id="copyurl" class="fakelink">Copy URL</span>
|
||||
/ <span id="copyjson" class="fakelink">JSON</span>
|
||||
(<span id="autorunstate">with</span>
|
||||
<span id="autoruntoggle" class="fakelink">autorun</span>)
|
||||
</span>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<div class="text" id="footer" style="display:none;">
|
||||
Powered by <a href="http://webperl.zero-g.net/" target="_blank" id="webperllink">WebPerl</a> (beta)
|
||||
<!-- Link with target="_blank" may not work in a sandboxed iframe, so provide URL: -->
|
||||
<span id="webperlurl" style="display:none;"> <code>http://webperl.zero-g.net/</code></span>
|
||||
</div>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
@ -1,178 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl Perl Runner</title>
|
||||
|
||||
<!-- ##### WebPerl - http://webperl.zero-g.net #####
|
||||
|
||||
Copyright (c) 2018 Hauke Daempfling (haukex@zero-g.net)
|
||||
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
Berlin, Germany, http://www.igb-berlin.de
|
||||
|
||||
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 http://perldoc.perl.org/index-licence.html
|
||||
##### -->
|
||||
|
||||
<!-- Please see the documentation on how to use this in demo.html. -->
|
||||
|
||||
<!-- Possible To-Do for Later: This whole thing could probably also be
|
||||
accomplished with a Web Worker, but that would probably require a
|
||||
stripped-down version of webperl.js (that loads things without
|
||||
using window.* and especially document.*
|
||||
https://developer.mozilla.org/en-US/docs/Web/API/Worker/Worker
|
||||
https://developer.mozilla.org/en-US/docs/Web/API/WorkerGlobalScope/importScripts
|
||||
|
||||
Of course, at some point I should investigate how difficult it really
|
||||
is to re-start an Emscripten program...
|
||||
-->
|
||||
|
||||
<script src="../webperl.js"></script>
|
||||
<!--script src="https://webperlcdn.zero-g.net/v0.09-beta/webperl.js"
|
||||
integrity="sha256-1RaYAh/WfDl3WZl+BDpSuSycg4x88pfkAFSxhWjBONk=" crossorigin="anonymous"></script-->
|
||||
<script>
|
||||
"use strict";
|
||||
|
||||
Perl.noMountIdbfs=true; // we're sandboxed
|
||||
Perl.endAfterMain=true; // act like command-line perl
|
||||
|
||||
var knownClients = [];
|
||||
var currentClient; // which client we're running Perl for, also keeps state
|
||||
var curOutputFiles;
|
||||
var stdbuf = [null,'',''];
|
||||
|
||||
function reportErr (err) {
|
||||
if (currentClient)
|
||||
currentClient.postMessage({ perlRunnerError: err },'*');
|
||||
else
|
||||
console.error(err);
|
||||
}
|
||||
|
||||
Perl.addStateChangeListener(function (from,to) {
|
||||
if (to=="Ended" && currentClient) {
|
||||
for (var chan=1;chan<=2;chan++) // flush buffers
|
||||
if (stdbuf[chan].length) {
|
||||
currentClient.postMessage({ perlOutput: { chan:chan, data:stdbuf[chan] } },'*');
|
||||
stdbuf[chan] = '';
|
||||
}
|
||||
currentClient.postMessage({ perlRunnerState: Perl.state,
|
||||
exitStatus: Perl.exitStatus },'*');
|
||||
for(var i=0; i<knownClients.length; i++)
|
||||
if (knownClients[i]!=currentClient)
|
||||
knownClients[i].postMessage({ perlRunnerState: Perl.state },'*');
|
||||
if (curOutputFiles) {
|
||||
var ofs = curOutputFiles.map(function (file) {
|
||||
//TODO Later: Support binary files as well?
|
||||
// {encoding:"binary"} => readFile returns Uint8Array
|
||||
// Should then also provide the same support on FS.writeFile() as well
|
||||
var of = { fn: file };
|
||||
if (!file) return of;
|
||||
try {
|
||||
of.text = FS.readFile(file, {encoding:"utf8"});
|
||||
}
|
||||
catch (e) {
|
||||
reportErr("couldn't read "+file+" because "+e);
|
||||
}
|
||||
return of;
|
||||
});
|
||||
currentClient.postMessage({ perlOutputFiles: ofs },'*');
|
||||
}
|
||||
}
|
||||
else {
|
||||
for(var i=0; i<knownClients.length; i++)
|
||||
knownClients[i].postMessage({ perlRunnerState: Perl.state },'*');
|
||||
}
|
||||
if (to=="Ended") {
|
||||
if (!currentClient)
|
||||
console.error("Internal Error: Perl state change to Ended with no client");
|
||||
window.location.reload(false);
|
||||
}
|
||||
});
|
||||
|
||||
Perl.output = function (str,chan) {
|
||||
stdbuf[chan] += str;
|
||||
var pos = stdbuf[chan].lastIndexOf("\n");
|
||||
if (pos<0) return;
|
||||
var lines = stdbuf[chan].slice(0,pos+1);
|
||||
if (currentClient)
|
||||
currentClient.postMessage({ perlOutput: { chan:chan, data:lines } },'*');
|
||||
else
|
||||
console.error("Internal Error: Output on",chan==1?"STDOUT":"STDERR","with no client:",lines);
|
||||
stdbuf[chan] = stdbuf[chan].slice(pos+1);
|
||||
};
|
||||
|
||||
function saveFile (fn, data) {
|
||||
if (fn.substring(0,1)!='/') // if relative, make absolute
|
||||
fn = FS.joinPath([FS.cwd(), fn]);
|
||||
try {
|
||||
FS.writeFile(fn, data);
|
||||
}
|
||||
catch (e) {
|
||||
reportErr("couldn't write "+fn+" because "+e);
|
||||
}
|
||||
}
|
||||
|
||||
window.addEventListener('message', function (event) {
|
||||
if (event.data["perlRunnerDiscovery"]) {
|
||||
if (!knownClients.includes(event.source))
|
||||
knownClients.push(event.source);
|
||||
event.source.postMessage({ perlRunnerState: Perl.state },'*');
|
||||
}
|
||||
else if (event.data["runPerl"]) {
|
||||
if (!knownClients.includes(event.source))
|
||||
knownClients.push(event.source);
|
||||
// check state
|
||||
if (currentClient && currentClient !== event.source) {
|
||||
console.error("Attempt to run Perl from",event.source,
|
||||
"but am already running Perl for",currentClient);
|
||||
reportErr("Attempt to run Perl (from "+event.origin
|
||||
+") but am already running Perl for someone else (see JavaScript console)");
|
||||
return;
|
||||
} // else
|
||||
currentClient = event.source;
|
||||
if (Perl.state!="Ready") {
|
||||
reportErr("Attempt to run Perl in state "+Perl.state);
|
||||
return;
|
||||
} // else
|
||||
// set up files and run perl
|
||||
var rp = event.data.runPerl;
|
||||
//TODO: we don't check for overlaps in filenames between script+input files (maybe the editor should do that)
|
||||
// one solution would be to just have the script be an input file (code mirror syntax highlighting based on filename?)
|
||||
// note overlaps of output filenames with input files is ok
|
||||
// we also don't check for duplicate filenames
|
||||
if (rp["script"])
|
||||
saveFile(rp["script_fn"] ? rp.script_fn : 'script.pl', rp.script);
|
||||
//TODO Later: can we support STDIN? (probably need to look at webperl.js)
|
||||
if (rp["inputs"])
|
||||
rp.inputs.forEach(function (inp) {
|
||||
if (!inp.fn) return;
|
||||
saveFile(inp.fn, inp.text);
|
||||
});
|
||||
curOutputFiles = rp["outputs"];
|
||||
Perl.start( rp["argv"] ? rp.argv : [] );
|
||||
}
|
||||
else console.warn("Perl Runner ignoring unknown message:", event.data);
|
||||
});
|
||||
|
||||
Perl.init(function () {
|
||||
Module['thisProgram'] = 'perl';
|
||||
FS.currentPath = ENV.HOME; // NOTE: https://github.com/kripken/emscripten/issues/5873
|
||||
});
|
||||
|
||||
</script>
|
||||
|
||||
</head>
|
||||
<body>
|
||||
</body>
|
||||
</html>
|
||||
@ -1,683 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl Regex Tester</title>
|
||||
|
||||
<!-- ##### WebPerl - http://webperl.zero-g.net #####
|
||||
|
||||
Copyright (c) 2018 Hauke Daempfling (haukex@zero-g.net)
|
||||
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
Berlin, Germany, http://www.igb-berlin.de
|
||||
|
||||
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 http://perldoc.perl.org/index-licence.html
|
||||
##### -->
|
||||
|
||||
<meta name="viewport" content="width=600" />
|
||||
<!--cacheable--><link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/normalize/8.0.0/normalize.min.css" integrity="sha256-oSrCnRYXvHG31SBifqP2PM1uje7SJUyX0nTwO2RJV54=" crossorigin="anonymous" />
|
||||
<style>
|
||||
body {
|
||||
margin: 0.4em;
|
||||
}
|
||||
div {
|
||||
font-family: Calibri, Ubuntu, "Droid Sans", Tahoma, Arial, Helvetica, sans-serif;
|
||||
}
|
||||
pre,kbd,var,code,samp,textarea {
|
||||
font-family: Consolas, "Ubuntu Mono", "Droid Sans Mono", "Lucida Console", "Courier New", Courier, monospace;
|
||||
}
|
||||
pre {
|
||||
margin: 0;
|
||||
}
|
||||
.sample {
|
||||
border: 1px solid black;
|
||||
margin: 0.2em;
|
||||
padding: 0.2em;
|
||||
min-width: 10em;
|
||||
min-height: 1em;
|
||||
display: flow-root;
|
||||
}
|
||||
.samptxt_outer {
|
||||
display: block;
|
||||
overflow: auto;
|
||||
}
|
||||
pre.samptxt {
|
||||
padding: 2px;
|
||||
display: inline-block;
|
||||
}
|
||||
textarea.samp_ta {
|
||||
min-width: 10em;
|
||||
min-height: 1em;
|
||||
width: calc(100% - 1.7em);
|
||||
height: 1.1em;
|
||||
border: 1px solid grey;
|
||||
padding: 1px;
|
||||
display: inline-block;
|
||||
resize: vertical;
|
||||
}
|
||||
.closebtn {
|
||||
float: right;
|
||||
margin-left: 5px;
|
||||
cursor: pointer;
|
||||
}
|
||||
.re_output {
|
||||
clear: both;
|
||||
background-color: rgba(234,234,234,255);
|
||||
}
|
||||
.re_warns {
|
||||
background-color: rgba(255,255,200,255);
|
||||
}
|
||||
.re_errors {
|
||||
background-color: rgba(255,200,200,255);
|
||||
}
|
||||
.nomatch {
|
||||
background-color: rgba(200,200,200,255);
|
||||
}
|
||||
.match {
|
||||
background-color: lightblue;
|
||||
border: 1px solid blue;
|
||||
}
|
||||
.capture {
|
||||
background-color: lightgreen;
|
||||
}
|
||||
.capture.zlen {
|
||||
border: 1px solid green;
|
||||
}
|
||||
.zlen:hover:after {
|
||||
content: " ";
|
||||
}
|
||||
</style>
|
||||
|
||||
<script src="webperl.js"></script>
|
||||
<!--script src="https://webperlcdn.zero-g.net/v0.09-beta/webperl.js"
|
||||
integrity="sha256-1RaYAh/WfDl3WZl+BDpSuSycg4x88pfkAFSxhWjBONk=" crossorigin="anonymous"></script-->
|
||||
<!--cacheable--><script src="https://code.jquery.com/jquery-3.3.1.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
|
||||
|
||||
<script type="text/perl">
|
||||
use warnings;
|
||||
use 5.028;
|
||||
use WebPerl qw/js/;
|
||||
use Data::Dumper ();
|
||||
my $jq = js('jQuery');
|
||||
|
||||
sub pp { Data::Dumper->new([@_])->Useqq(1)->Terse(1)->Pair('=>')
|
||||
->Sortkeys(1)->Quotekeys(0)->Indent(0)->Purity(1)->Dump }
|
||||
|
||||
our $RUN_CODE_IN_IFRAME=0;
|
||||
|
||||
# Possible To-Do for Later: Subs in preamble code produce "subroutine redefined" warnings.
|
||||
# I could think about whether there's a decent way around that.
|
||||
# Example: https://www.perlmonks.org/?node_id=1225457
|
||||
|
||||
my $run_code_body = <<'END_CODE';
|
||||
my (@warns,@output);
|
||||
|
||||
require File::Temp;
|
||||
my ($fh1,$fn1) = File::Temp::tempfile();
|
||||
open my $oldout, '>&', \*STDOUT or die "dup STDOUT: $!";
|
||||
open STDOUT, '>&', $fh1 or die "open STDOUT: $!";
|
||||
my ($fh2,$fn2) = File::Temp::tempfile();
|
||||
open my $olderr, '>&', \*STDERR or die "dup STDERR: $!";
|
||||
open STDERR, '>&', $fh2 or die "open STDERR: $!";
|
||||
|
||||
my $ok = do {
|
||||
local $SIG{__WARN__} = sub { push @warns, shift };
|
||||
eval "package RunCode {$code\n};1" };
|
||||
my $err = $ok ? undef : $@||"Unknown error";
|
||||
|
||||
open STDERR, '>&', $olderr or die "dup \$olderr: $!";
|
||||
close $fh2;
|
||||
open STDOUT, '>&', $oldout or die "dup \$oldout: $!";
|
||||
close $fh1;
|
||||
my $stdout = do { open my $fh, '<', $fn1 or die $!; local $/; <$fh> };
|
||||
my $stderr = do { open my $fh, '<', $fn2 or die $!; local $/; <$fh> };
|
||||
unlink($fn1,$fn2)==2 or warn "unlink('$fn1','$fn2'): $!";
|
||||
|
||||
defined && s/\bat .+? line \d+(?:\.$|,\h)//mg for (@warns,$err);
|
||||
chomp(@warns);
|
||||
my $rv = { ctx=>$context, warns=>\@warns,
|
||||
$ok ? (out=>\@output) : (err=>$err),
|
||||
stdout => $stdout, stderr => $stderr };
|
||||
END_CODE
|
||||
|
||||
my $runcode_iframe;
|
||||
my $runcode_message_callback; # assume a single callback for now
|
||||
if ($RUN_CODE_IN_IFRAME) { # https://www.html5rocks.com/en/tutorials/security/sandboxed-iframes/
|
||||
my $webperlurl;
|
||||
$jq->('script')->each(sub { $webperlurl=$_[1]->{src} if $_[1]->{src}=~/\bwebperl\.js\z/ });
|
||||
if (!$webperlurl) {
|
||||
warn "Warning: Could not determine URL of webperl.js\n";
|
||||
$webperlurl = 'webperl.js'; # probably won't work due to same-origin
|
||||
}
|
||||
my $iframe_html = <<~'END_IFRAME_HTML';
|
||||
<html>
|
||||
<head>
|
||||
<script src="__WEBPERLURL__"></scr__ipt>
|
||||
<!--script src="https://webperlcdn.zero-g.net/v0.09-beta/webperl.js"
|
||||
integrity="sha256-1RaYAh/WfDl3WZl+BDpSuSycg4x88pfkAFSxhWjBONk=" crossorigin="anonymous"></scr__ipt-->
|
||||
<script>
|
||||
Perl.noMountIdbfs=true; // we're sandboxed
|
||||
</scr__ipt>
|
||||
<script type="text/perl">
|
||||
use warnings;
|
||||
use 5.028;
|
||||
use WebPerl qw/js/;
|
||||
js('window')->addEventListener('message', sub {
|
||||
my ($event) = @_;
|
||||
my $data = $event->{data}->toperl;
|
||||
die "Bad arguments" unless ref $data eq 'ARRAY'
|
||||
&& @$data==3 && !grep {ref} @$data;
|
||||
my ($context,$code,$input) = @$data;
|
||||
__RUNCODEBODY__
|
||||
my $origin = $event->{origin} eq 'null' ? '*' : $event->{origin};
|
||||
$event->{source}->postMessage($rv, $origin);
|
||||
}, undef);
|
||||
</scr__ipt>
|
||||
</he__ad>
|
||||
<body></bo__dy>
|
||||
</ht__ml>
|
||||
END_IFRAME_HTML
|
||||
$iframe_html=~s#</\w+\K__(?=\w+>)##ig;
|
||||
$iframe_html=~s/__RUNCODEBODY__/$run_code_body/;
|
||||
$iframe_html=~s/__WEBPERLURL__/$webperlurl/g;
|
||||
my $iframe_blob_url = js('URL')->createObjectURL(
|
||||
WebPerl::js_new('Blob',[$iframe_html],{type=>"text/html;charset=utf-8"}) );
|
||||
#TODO Later: Why does the message passing not work when I remove the "sandbox" attr?
|
||||
my $iframe = $jq->('<iframe/>', {id=>'PerlEval_IFrame', sandbox=>'allow-scripts',
|
||||
src=>$iframe_blob_url} )->hide->appendTo('body');
|
||||
$runcode_iframe = $iframe->[0]{contentWindow};
|
||||
my $got_response;
|
||||
my $window = js('window');
|
||||
$window->addEventListener('message', sub {
|
||||
my ($event) = @_;
|
||||
state $compare = js('(function(x,y){return x===y})');
|
||||
return unless $event->{origin} eq 'null'
|
||||
&& $compare->($event->{source},$runcode_iframe);
|
||||
my $data = $event->{data}->toperl;
|
||||
die "Bad arguments" unless ref $data eq 'HASH'
|
||||
&& exists $data->{ctx} && !ref $data->{ctx}
|
||||
&& exists $data->{warns} && ref $data->{warns} eq 'ARRAY'
|
||||
&& ( exists $data->{out} && ref $data->{out} eq 'ARRAY'
|
||||
|| exists $data->{err} && !ref $data->{err} );
|
||||
$got_response = 1;
|
||||
if (!defined $runcode_message_callback)
|
||||
{ warn "recived runcode result without a callback" }
|
||||
else { $runcode_message_callback->($data) }
|
||||
}, undef);
|
||||
# poll until the iframe is loaded
|
||||
my $start_time = time;
|
||||
my $intid; $intid = $window->setInterval(sub {
|
||||
if (time-$start_time>10) {
|
||||
if ($window->confirm("Perl does not appear to have loaded yet, keep waiting?\n"
|
||||
."(If you are on a slow connection, click OK to keep waiting.)")) {
|
||||
$start_time = time;
|
||||
}
|
||||
else {
|
||||
$window->clearInterval($intid);
|
||||
}
|
||||
}
|
||||
elsif ($got_response)
|
||||
{ $window->clearInterval($intid) }
|
||||
else { update() }
|
||||
}, 500);
|
||||
}
|
||||
$jq->('#loading')->text('Loading (Stage 2/2)...');
|
||||
|
||||
sub sample_init {
|
||||
my $samp = shift;
|
||||
state $samp_id = 'a';
|
||||
$samp->attr('id',"samp_".$samp_id++) unless $samp->attr('id');
|
||||
my $samptxt = $samp->find(".samptxt");
|
||||
my $samptxt_outer = $jq->('<div/>',{class=>"samptxt_outer"});
|
||||
$samptxt->wrap($samptxt_outer);
|
||||
my $samp_ta = $jq->('<textarea/>', {class=>"samp_ta"});
|
||||
$samp_ta->hide();
|
||||
$samp_ta->appendTo($samp);
|
||||
my $closebtn = $jq->('<div/>', {html=>"❎",class=>"closebtn",
|
||||
title=>"Delete Sample"});
|
||||
$closebtn->prependTo($samp);
|
||||
$jq->('<pre/>', {class=>'re_output'})->appendTo($samp);
|
||||
$jq->('<pre/>', {class=>'re_warns'})->appendTo($samp);
|
||||
$jq->('<pre/>', {class=>'re_errors'})->appendTo($samp);
|
||||
$samp->click(sub {
|
||||
return if $samp_ta->is(':visible');
|
||||
$samp_ta->val($samptxt->text);
|
||||
my $th = $samptxt->height;
|
||||
$samptxt->hide;
|
||||
$samp_ta->show;
|
||||
my $sh = $samp_ta->[0]{scrollHeight}-2; # subtract padding
|
||||
# I'm not quite sure of the rounding that's happening in the browser yet...
|
||||
$samp_ta->height( int($sh) > int($th)+1 ? $sh : $th );
|
||||
$samp_ta->focus;
|
||||
});
|
||||
$samp_ta->focusout(sub {
|
||||
$samptxt->text($samp_ta->val);
|
||||
$samp_ta->hide;
|
||||
$samptxt->show;
|
||||
update();
|
||||
});
|
||||
$samp_ta->on('input', sub { # autoexpand for new lines
|
||||
$samp_ta->height($samp_ta->[0]{scrollHeight}-2); # subtract padding
|
||||
});
|
||||
$closebtn->click(sub { $samp->remove; update() });
|
||||
}
|
||||
$jq->(".sample")->each(sub{ sample_init($jq->($_[1])) });
|
||||
|
||||
my $addsamp = $jq->("#addsamp");
|
||||
sub newsamp {
|
||||
my $text = @_ ? shift : 'New Sample';
|
||||
my $samptxt = $jq->('<pre/>',{class=>"samptxt",text=>$text});
|
||||
my $samp = $jq->('<div/>',{class=>"sample"})->append($samptxt);
|
||||
$samp->insertBefore($addsamp->parent);
|
||||
sample_init($samp);
|
||||
update();
|
||||
return $samp;
|
||||
}
|
||||
#TODO: Adding samples causes the code table to grow, but not shrink when they are removed
|
||||
$addsamp->click(sub { newsamp('')->click });
|
||||
|
||||
# $re_debug is actually a parameter to update()/actual_update(), but since
|
||||
# we register &update as a event handler, it'll get passed varying parameters
|
||||
our $re_debug=0;
|
||||
$jq->('#re_debug')->click(sub { local $re_debug=1; update() });
|
||||
|
||||
my $sampcodebtn = $jq->('#sampcodebtn');
|
||||
my $codecopy = $jq->('#codecopy');
|
||||
my $samplecode_ta = $jq->('#samplecode');
|
||||
$sampcodebtn->click(sub{
|
||||
if ($samplecode_ta->is(':visible')) {
|
||||
$samplecode_ta->hide;
|
||||
$codecopy->hide;
|
||||
$sampcodebtn->text('Show Example Perl Code');
|
||||
update();
|
||||
}
|
||||
else { sampcode_show() }
|
||||
});
|
||||
sub sampcode_show {
|
||||
$samplecode_ta->show;
|
||||
$codecopy->show;
|
||||
$sampcodebtn->text('Hide Example Perl Code');
|
||||
update();
|
||||
}
|
||||
$codecopy->click(sub {
|
||||
$samplecode_ta->[0]->select;
|
||||
js(q{ document.execCommand("copy"); });
|
||||
});
|
||||
$samplecode_ta->hide;
|
||||
$codecopy->hide;
|
||||
|
||||
my $precodebtn = $jq->('#precodebtn');
|
||||
my $precode_ta = $jq->('#precode');
|
||||
$precodebtn->click(sub{
|
||||
if ($precode_ta->is(':visible')) {
|
||||
$precode_ta->hide;
|
||||
$precodebtn->text("Add Preamble Code");
|
||||
}
|
||||
else { precode_show() }
|
||||
update();
|
||||
});
|
||||
sub precode_show {
|
||||
$precode_ta->val(shift) if @_;
|
||||
$precode_ta->show;
|
||||
$precodebtn->text("Disable Preamble Code");
|
||||
}
|
||||
$precode_ta->hide;
|
||||
$precode_ta->change(\&update);
|
||||
$precode_ta->keyup( \&update);
|
||||
|
||||
my $thisurl_ta = $jq->("#thisurl");
|
||||
$jq->('#urlcopy')->click(sub {
|
||||
$thisurl_ta->[0]->select;
|
||||
js(q{ document.execCommand("copy"); });
|
||||
});
|
||||
|
||||
$jq->('#perlinfo')->text("perl $^V, WebPerl ".js('Perl.WebPerlVersion'));
|
||||
|
||||
my $ta_regex = $jq->("#regex");
|
||||
my $ta_flags = $jq->("#flags");
|
||||
$ta_regex->change(\&update);
|
||||
$ta_regex->keyup( \&update);
|
||||
$ta_flags->change(\&update);
|
||||
$ta_flags->keyup( \&update);
|
||||
|
||||
js('$(window)')->on('hashchange',\&hashchange);
|
||||
|
||||
#TODO: The auto-sizing causes the textarea to grow on Chrome mobile
|
||||
$ta_regex->on('input', sub { # autoexpand for new lines
|
||||
$ta_regex->height($ta_regex->[0]{scrollHeight});
|
||||
});
|
||||
|
||||
hashchange();
|
||||
update();
|
||||
|
||||
*run_code = eval( q{ sub {
|
||||
my ($context,$code,$input,$callback) = @_;
|
||||
if ($RUN_CODE_IN_IFRAME) {
|
||||
$runcode_message_callback = $callback; # assume a single callback for now
|
||||
$runcode_iframe->postMessage([$context,$code,$input], '*');
|
||||
return }
|
||||
__RUNCODEBODY__
|
||||
$callback->($rv);
|
||||
} } =~ s/__RUNCODEBODY__/$run_code_body/r ) || die( $@||"unknown error" );
|
||||
|
||||
sub update {
|
||||
state $timeout_id;
|
||||
state $window = js('window');
|
||||
$window->clearTimeout($timeout_id) if defined $timeout_id;
|
||||
if ($re_debug) { $timeout_id=undef; actual_update() }
|
||||
else { $timeout_id = $window->setTimeout(\&actual_update, 100) }
|
||||
}
|
||||
sub actual_update {
|
||||
my $regex = $ta_regex->val;
|
||||
my $flags = $ta_flags->val;
|
||||
my $precode = $precode_ta->is(':visible') ? $precode_ta->val : '';
|
||||
$precode .= "\n" if length $precode && substr($precode,-1) ne "\n";
|
||||
my $regex_str = 'm{'.$regex.'}'.$flags;
|
||||
|
||||
my $warn = '';
|
||||
if (not length $regex) {
|
||||
$warn .= "Notice: The empty pattern has special behavior, see perlop!\n"
|
||||
." Here, a workaround is used so it acts as a true empty pattern.\n";
|
||||
if ($re_debug) # https://www.perlmonks.org/?node_id=1221517
|
||||
{ $warn .= " The workaround uses /(?:)/, which you will see in the debug output.\n" }
|
||||
}
|
||||
$warn .= "\\n is recommended over literal newlines\n" if $regex=~/\n/ && $flags!~/x/;
|
||||
$warn .= "\\t is recommended over literal tabs\n" if $regex=~/\t/ && $flags!~/x/;
|
||||
state $warnmsgs = $jq->("#warnmsgs");
|
||||
$warnmsgs->text($warn);
|
||||
|
||||
my @samps;
|
||||
for my $sample (map {$jq->($_)} $jq->('.sample')->@*) {
|
||||
my $samptxt = $sample->find('.samptxt');
|
||||
my $text = $samptxt->text;
|
||||
push @samps, $text; # for use below
|
||||
my $code = $precode . ( $re_debug ? "use re \"debug\";\n" : '' )
|
||||
. ( length($regex) ? '' : "''=~/(?:)/$flags; # // workaround\n" )
|
||||
. 'push @output,[[@-],[@+]] ' . ($flags=~/g/?'while':'if') . ' $input=~'.$regex_str.";\n";
|
||||
$re_debug and
|
||||
$code = 'BEGIN{require Data::Dumper;'
|
||||
.'print(STDERR Data::Dumper->new([$input],["input"])->Indent(0)->Dump,'
|
||||
.'"\n-- Code --\n",' . pp($code) . ',"----\n")}' . "\n"
|
||||
. $code . "\n"
|
||||
. q{print STDERR "----\n",Data::Dumper->new([\@output],["*output"])->Indent(0)->Dump,"\n";};
|
||||
run_code($sample->attr('id'), $code, $text, \&run_code_callback);
|
||||
}
|
||||
|
||||
if ($samplecode_ta->is(':visible')) {
|
||||
my $sampcode = <<~'ENDCODE';
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
my @samples = (
|
||||
__SAMPLES__
|
||||
);
|
||||
|
||||
for my $input (@samples) {
|
||||
print '### Sample: "', $input, '"', "\n";
|
||||
ENDCODE
|
||||
$sampcode =~ s{__SAMPLES__}{ join ",\n", map {" ".pp($_)} @samps }e;
|
||||
$sampcode .= $precode=~s/^/ /mgr if length $precode;
|
||||
if ($flags=~/g/) {
|
||||
$sampcode .= <<~'ENDCODE';
|
||||
while ( $input =~ __REGEX__ ) {
|
||||
__BODY__
|
||||
}
|
||||
ENDCODE
|
||||
}
|
||||
else {
|
||||
$sampcode .= <<~'ENDCODE';
|
||||
if ( $input =~ __REGEX__ ) {
|
||||
__BODY__
|
||||
}
|
||||
else {
|
||||
print "No match!\n";
|
||||
}
|
||||
ENDCODE
|
||||
}
|
||||
chomp( my $matchbody = <<~'ENDCODE' );
|
||||
print 'Match! "', $&, '"', "\n";
|
||||
# (Note: $& has performance penalty on Perl <5.20)
|
||||
# You can use $1, $2, etc. here.
|
||||
ENDCODE
|
||||
$sampcode =~ s/__BODY__/$matchbody/;
|
||||
my $re = $regex_str;
|
||||
if ( $re=~/\n/ && $flags=~/x/ ) {
|
||||
$re =~ s/^/ /mg;
|
||||
$re = "\n".$re;
|
||||
}
|
||||
$sampcode =~ s/__REGEX__/$re/;
|
||||
$sampcode .= "}\n";
|
||||
$samplecode_ta->val($sampcode);
|
||||
}
|
||||
|
||||
my $i=1;
|
||||
my $hash = '#' . $jq->param( { regex=>$regex, flags=>$flags,
|
||||
( length $precode ? (pre=>$precode) : () ),
|
||||
( $samplecode_ta->is(':visible') ? (showsampcode=>1) : () ),
|
||||
map { "samp".$i++ => $_ } @samps } );
|
||||
my $baseurl = js('window.location')->{href} =~ s/#.*\z//r;
|
||||
$thisurl_ta->val( $baseurl . $hash );
|
||||
}
|
||||
sub run_code_callback {
|
||||
my $rv = shift;
|
||||
my $sample = $jq->('#'.$rv->{ctx});
|
||||
if (!$sample->{length}) {
|
||||
warn "got callback for nonexistent sample ".$rv->{context};
|
||||
return }
|
||||
my $samptxt = $sample->find('.samptxt');
|
||||
my $text = $samptxt->text;
|
||||
my $errs = '';
|
||||
if ( $rv->{out} && $rv->{out}->@* ) {
|
||||
$samptxt->removeClass('nomatch');
|
||||
my %hi;
|
||||
for my $i (0..$#{$rv->{out}}) {
|
||||
my ($s,$e) = $rv->{out}[$i]->@*;
|
||||
for my $j (0..$#$e) { # Use @+ to count all capture groups instead of @-!
|
||||
next if !defined($$s[$j]) && !defined($$e[$j]);
|
||||
my $name = "Match ".($i+1).($j?" Capture Group $j":"");
|
||||
if ($$s[$j]==$$e[$j]) {
|
||||
push @{ $hi{$$s[$j]}{
|
||||
$j==0 ? 'zlen_match' : 'zlen_cap' }
|
||||
}, $name }
|
||||
else {
|
||||
push @{ $hi{$$s[$j]}{ $j==0 ? 'match' : 'cap' } }, $name;
|
||||
push @{ $hi{$$e[$j]}{ $j==0 ? 'match_end' : 'cap_end' } }, $name;
|
||||
}
|
||||
}
|
||||
}
|
||||
my $html='';
|
||||
my $p=0;
|
||||
my (%active_match,%active_caps);
|
||||
for my $i (sort {$a<=>$b} keys %hi) {
|
||||
|
||||
$html .= escape_html(substr($text,$p,$i-$p));
|
||||
|
||||
$html .= "</span>" if keys %active_caps;
|
||||
delete $active_caps{$_} for @{ $hi{$i}{cap_end}//[] };
|
||||
|
||||
$html .= "</span>" if keys %active_match && $hi{$i}{match_end};
|
||||
delete $active_match{$_} for @{ $hi{$i}{match_end}//[] };
|
||||
|
||||
$html .= "<span class='zlen match' title='$_'></span>" for @{ $hi{$i}{zlen_match}//[] };
|
||||
$html .= "<span class='zlen capture' title='$_'></span>" for @{ $hi{$i}{zlen_cap}//[] };
|
||||
|
||||
$active_match{$_}++ for @{ $hi{$i}{match}//[] };
|
||||
$html .= "<span class='match' title='"
|
||||
.join(", ",sort keys %active_match)
|
||||
."'>" if keys %active_match && $hi{$i}{match};
|
||||
|
||||
$active_caps{$_}++ for @{ $hi{$i}{cap}//[] };
|
||||
$html .= "<span class='capture' title='"
|
||||
.join(", ",(sort keys %active_match),(sort keys %active_caps))
|
||||
."'>" if keys %active_caps;
|
||||
|
||||
# normally won't happen, unless the user does something pretty tricky
|
||||
push @{ $rv->{warns} }, "Overlapping matches ("
|
||||
.join(", ", sort keys %active_match)
|
||||
.") will not be highlighted correctly"
|
||||
if keys(%active_match)>1;
|
||||
|
||||
} continue { $p=$i }
|
||||
$html .= escape_html(substr($text,$p));
|
||||
$samptxt->html($html);
|
||||
}
|
||||
else {
|
||||
if ($rv->{out})
|
||||
{ $samptxt->addClass('nomatch') }
|
||||
else
|
||||
{ $errs = $rv->{err} }
|
||||
$samptxt->text($text);
|
||||
}
|
||||
my $stdoe = '';
|
||||
for my $s (qw/stdout stderr/) {
|
||||
next unless length $rv->{$s} && $rv->{$s}=~/\S/;
|
||||
$rv->{$s} =~ s/\A\n+|\n+\z//g;
|
||||
$stdoe .= "### ".uc($s)." ###\n".$rv->{$s}."\n";
|
||||
}
|
||||
$sample->children('.re_output')->text($stdoe);
|
||||
unshift @{ $rv->{warns} }, "### Warnings ###" if $rv->{warns}->@*;
|
||||
$sample->children('.re_warns')->text( join "\n", $rv->{warns}->@* );
|
||||
$errs = "### Errors ###\n$errs" if $errs=~/\S/;
|
||||
$sample->children('.re_errors')->text($errs);
|
||||
state $loading = 1; if ($loading) { $jq->('#loading')->remove; $loading=0 }
|
||||
}
|
||||
|
||||
sub escape_html { # apparently no built-in JS function for this (?), so do it manually
|
||||
state $m = { '&'=>'&', '<'=>'<', '>'=>'>', '"'=>'"', "'"=>''' };
|
||||
shift =~ s/([&<>"'])/$$m{$1}/gr;
|
||||
}
|
||||
|
||||
sub hashchange {
|
||||
my $hash = js('window.location')->{hash};
|
||||
return unless $hash=~/^#.*\bregex=/;
|
||||
my %res;
|
||||
my $decode = js('decodeURIComponent');
|
||||
for my $c (split /&/, substr $hash, 1) {
|
||||
my ($k,$v) = split /=/, $c;
|
||||
$res{ $decode->($k=~tr/+/ /r) } = $decode->($v=~tr/+/ /r);
|
||||
}
|
||||
if (exists $res{regex} && exists $res{flags}) {
|
||||
$ta_regex->val($res{regex});
|
||||
$ta_regex->height($ta_regex->[0]{scrollHeight});
|
||||
$ta_flags->val($res{flags});
|
||||
sampcode_show() if $res{showsampcode};
|
||||
precode_show($res{pre}) if exists $res{pre};
|
||||
if (exists $res{samp1}) {
|
||||
$jq->(".sample")->remove();
|
||||
for (my $i=1;exists $res{"samp$i"};$i++) {
|
||||
newsamp($res{"samp$i"});
|
||||
}
|
||||
}
|
||||
update();
|
||||
}
|
||||
else { js('window.location')->{hash}='' }
|
||||
}
|
||||
|
||||
</script>
|
||||
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<div style="margin-bottom:1em;font-size:1.2em;text-align:center;"><b>Perl Regex Tester</b>
|
||||
- powered by <a href="http://webperl.zero-g.net" target="_blank">WebPerl</a> (beta)</div>
|
||||
|
||||
<div id="loading" style="position:absolute;left:40%;font-size:1.2em;font-weight:bold;color:red;">Loading (Stage 1/2)...</div>
|
||||
|
||||
<div style="margin-bottom:1em;">
|
||||
<div>
|
||||
<button id="precodebtn">Add Preamble Code</button>
|
||||
</div>
|
||||
<div>
|
||||
<textarea id="precode" rows="3" cols="80" style="display:none;min-height:1.2em;min-width:10em;max-width:100%;">my $x = "foo"; # example</textarea>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<div style="margin-bottom:1em;white-space:nowrap;">
|
||||
<div><code style="vertical-align:top;">m{</code
|
||||
><textarea id="regex" rows="1" cols="60" style="height:1.2em;min-height:1.2em;min-width:10em;"
|
||||
title="Perl Regular Expression">wo(.)</textarea
|
||||
><code style="vertical-align:text-bottom;">}</code
|
||||
><textarea id="flags" rows="1" cols="7" style="height:1.2em;min-height:1.2em;min-width:3em;"
|
||||
title="Flags for Regular Expression">gi</textarea></div>
|
||||
<pre id="warnmsgs" class="re_warns"></pre>
|
||||
</div>
|
||||
|
||||
<div class="sample">
|
||||
<pre class="samptxt">Hello, World!</pre>
|
||||
</div>
|
||||
<div class="sample">
|
||||
<pre class="samptxt">Oh, what a wonderful world!</pre>
|
||||
</div>
|
||||
<div style="text-align:right;">
|
||||
<!-- note this is used as the insertion point for new samples, be careful when changing -->
|
||||
<button id="addsamp">Add Sample</button>
|
||||
</div>
|
||||
|
||||
<div style="margin-top:0.5em;">
|
||||
<div style="white-space:nowrap;">
|
||||
<button id="sampcodebtn">Show Example Perl Code</button>
|
||||
<span id="codecopy" style="cursor:pointer;" title="Copy to Clipboard">📋</span><br/>
|
||||
</div>
|
||||
<div>
|
||||
<textarea id="samplecode" rows="20" cols="80" style="display:none;font-size:0.8em;min-height:1.2em;min-width:10em;max-width:100%;" readonly="readonly"></textarea>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<div style="margin-top:0.5em;">
|
||||
<button id="re_debug"><code>use re "debug";</code></button>
|
||||
</div>
|
||||
|
||||
<div style="margin-top:0.5em;">
|
||||
<div style="white-space:nowrap;">
|
||||
URL:
|
||||
<span id="urlcopy" style="cursor:pointer;" title="Copy to Clipboard">📋</span>
|
||||
</div>
|
||||
<div>
|
||||
<textarea id="thisurl" rows="2" cols="80" style="font-size:0.8em;height:2.4em;min-height:1.2em;min-width:10em;max-width:100%;" readonly="readonly"></textarea>
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<pre id="perlinfo" style="margin-top:0.5em;">perl v?, WebPerl v?</pre>
|
||||
|
||||
<div style="margin-top:1em;font-size:0.8em;">
|
||||
Perl Regular Expression Documentation:
|
||||
<a href="http://perldoc.perl.org/perlretut.html" target="_blank">Tutorial</a>,
|
||||
<a href="http://perldoc.perl.org/perlrequick.html" target="_blank">Quick Start</a>,
|
||||
<a href="http://perldoc.perl.org/perlre.html" target="_blank">Main (perlre)</a>,
|
||||
<a href="http://perldoc.perl.org/perlop.html#Regexp-Quote-Like-Operators" target="_blank">Operators</a>,
|
||||
<a href="http://perldoc.perl.org/perlvar.html#Variables-related-to-regular-expressions" target="_blank">Special Variables</a>,
|
||||
<a href="http://perldoc.perl.org/perlrebackslash.html" target="_blank">Backslash Sequences and Escapes</a>,
|
||||
<a href="http://perldoc.perl.org/perlrecharclass.html" target="_blank">Character Classes</a>,
|
||||
<a href="http://perldoc.perl.org/perlfaq6.html" target="_blank">FAQs</a>,
|
||||
<a href="http://perldoc.perl.org/perlreref.html" target="_blank">Quick Reference</a>,
|
||||
<a href="http://perldoc.perl.org/re.html" target="_blank">re Pragma</a>,
|
||||
<a href="http://perldoc.perl.org/functions/split.html" target="_blank">split</a>,
|
||||
<a href="http://perldoc.perl.org/perlreguts.html" target="_blank">Guts</a>,
|
||||
<a href="http://perldoc.perl.org/perldebguts.html#Debugging-Regular-Expressions" target="_blank">Debugging</a>;
|
||||
I18N:
|
||||
<a href="http://perldoc.perl.org/perlunicode.html" target="_blank">Unicode</a>
|
||||
(<a href="http://perldoc.perl.org/perlunicook.html" target="_blank">Examples</a>),
|
||||
<a href="http://perldoc.perl.org/perllocale.html" target="_blank">Locales</a>.
|
||||
</div>
|
||||
|
||||
<div style="margin-top:1em;font-size:0.8em;font-style:italic;">
|
||||
Copyright © 2018 Hauke Daempfling (haukex@zero-g.net)
|
||||
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
||||
Berlin, Germany, <a href="http://www.igb-berlin.de" target="_blank">http://www.igb-berlin.de</a>.
|
||||
For details, please see
|
||||
<a href="https://github.com/haukex/webperl/blob/master/web/regex_tester.html" target="_blank">the source code of this file</a>.
|
||||
</div>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
@ -1,41 +0,0 @@
|
||||
<!doctype html>
|
||||
<html lang="en-us">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>WebPerl Tests</title>
|
||||
|
||||
<script src="webperl.js"></script>
|
||||
<script>
|
||||
"use strict";
|
||||
|
||||
window.onerror = function(event) {
|
||||
alert('Exception thrown, see JavaScript console'); };
|
||||
|
||||
window.addEventListener("load", function () {
|
||||
|
||||
document.getElementById('output')
|
||||
.appendChild( Perl.makeOutputTextarea() );
|
||||
|
||||
var status = document.getElementById("status");
|
||||
Perl.endAfterMain = true;
|
||||
Perl.addStateChangeListener( function (from,to) {
|
||||
if (from!="Ended" && to=="Ended")
|
||||
status.textContent = "Tests finished, see output:";
|
||||
} );
|
||||
Perl.init(function () {
|
||||
status.textContent = "Running tests...";
|
||||
window.setTimeout(function () {
|
||||
Perl.start(['/opt/perl/dev/WebPerl.t']);
|
||||
}, 1);
|
||||
});
|
||||
|
||||
});
|
||||
|
||||
</script>
|
||||
|
||||
</head>
|
||||
<body>
|
||||
<p id="status">Loading tests...</p>
|
||||
<div id="output"></div>
|
||||
</body>
|
||||
</html>
|
||||
Loading…
Reference in New Issue