Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine

comment on

( [id://3333] : superdoc . print w/replies, xml ) Need Help??

Although the following is probably overkill - plus it won't run as-is as a CGI script - I've wanted to test out code like this for a while now so I took this oppertunity to write this example up using Mojolicious. And in the process, hopefully show some of the advantages of modern web technologies and frameworks over :-) This can be run as a standalone server in development mode via morbo, and as a simple server via perl daemon.

#!/usr/bin/env perl use 5.028; use Mojolicious::Lite -signatures; use Mojo::JSON qw/encode_json/; use Mojo::Util qw/sha1_sum/; # NOTICE: This script is designed to work in a single-threaded, # single-process server only! (morbo or Mojolicious::Command::daemon) get '/' => sub ($c) { $c->render(template => 'index') } => 'index'; my %runningprocs; post '/submit' => sub ($c) { # form variables my $foo = $c->param('foo'); my $bar = $c->param('bar'); # set up the event dispatcher my $ee = Mojo::EventEmitter->new; # hash collisions theoretically possible but very unlikely (could +check `exists $runningprocs{$id}`) my $id = sha1_sum( time."\0".rand."\0".(0+$ee) ); $runningprocs{$id} = $ee; $c->render(json => { eventurl=>$c->url_for('status', id=>$id) }); # set up and run the subprocess my $subproc = Mojo::IOLoop->subprocess; $subproc->on(spawn => sub ($sp) { $ee->emit(status => { progress=>"Subprocess spawned in PID + ".$sp->pid }) }); $subproc->on(progress => sub ($sp, @data) { $ee->emit(status => { progress=>\@data }) }); # give client a second to connect to event source Mojo::IOLoop->timer(1 => sub { $subproc->run( sub ($sp) { return long_running_subprocess($sp, $foo, $bar +) }, sub ($sp, $err, @results) { if ($err) { $ee->emit(status => { error=>"$err", done= +>"Error: $err" }) } else { $ee->emit(status => { done=>\@results }) } # don't clobber the event listener immediately (in cas +e client took longer to re/connect) Mojo::IOLoop->timer(10 => sub { delete $runningprocs{$ +id} }); }); }); } => 'formsubmit'; get '/status/:id' => sub ($c) { my $id = $c->stash('id'); my $ee = $runningprocs{$id} or return $c->reply->not_found; $c->inactivity_timeout(300); $c->res->headers->content_type('text/event-stream'); $c->write; my $timerid = Mojo::IOLoop->recurring(10 => sub { $c->write(":\n\n") }); # comment as keepalive my $cb = $ee->on(status => sub ($ev, $data) { my $json = encode_json($data) =~ s/\n//gr; $c->write("event: status\ndata: $json\n\n"); }); $c->on(finish => sub ($c) { $ee->unsubscribe(status => $cb); Mojo::IOLoop->remove($timerid); }); } => 'status'; sub long_running_subprocess { my ($subproc, $foo, $bar) = @_; # this code is now running in the subprocess! $subproc->progress("Beginning work on Foo='$foo'"); sleep 5; # $subproc->progress("Finished work on Foo"); if ( length $bar ) { $subproc->progress("Beginning work on Bar='$bar'"); sleep 5; # $subproc->progress("Finished work on Bar"); } return "All done!"; } app->start; __DATA__ @@ index.html.ep % layout 'main', title => 'Hello, World!'; <div> %= form_for formsubmit => ( method=>'post', id=>'myform' ) => begin <div> %= label_for foo => 'Foo' %= text_field foo => ( placeholder=>"Foo", required=>'required' ) </div><div> %= label_for bar => 'Bar' %= text_field bar => ( placeholder=>"Bar" ) </div><div> %= submit_button 'Process' </div> %= end </div> <pre id="myoutput" style="padding:3px 5px;border:1px solid black;"> Output will display here. </pre> <script> "use strict"; function addmsg(txt) { $(document.createTextNode(txt)).appendTo($('#myoutput')); } function getevents(url) { addmsg("Listening on "+JSON.stringify(url)+"\n"); var events = new EventSource(url); events.onerror = function(err) { // the event apparently doesn't contain any details var errmsg = "Error connecting to EventSource"; addmsg(errmsg); alert(errmsg); $("#myform :input").prop("disabled", false); }; events.addEventListener('status', function (event) { var data = JSON.parse(; if ( 'progress' in data ) { addmsg("Progress: "+JSON.stringify(data.progress)+"\n"); } if ( 'error' in data ) { addmsg("Error: "+JSON.stringify(data.error)+"\n"); alert(data.error); } if ( 'done' in data ) { addmsg("Done: "+JSON.stringify(data.done)+"\n"); events.close(); $("#myform :input").prop("disabled", false); } }, false); } $(function () { $('#myform').on('submit', function (e) { e.preventDefault(); $("#myoutput").text("Submitting form\n"); var thedata = $('#myform').serialize(); // before disabling! $("#myform :input").prop("disabled", true); $.ajax({ type: 'post', url: '<%= url_for 'formsubmit' %>', data: thedata }) .done( function( data ) { getevents(data.eventurl); }) .fail( function( jqXHR, textStatus, errorThrown ) { var errmsg = "Form submission error: "+textStatus +" / "+jqXHR.status+" "+errorThrown; addmsg(errmsg); alert(errmsg); $("#myform :input").prop("disabled", false); }) }); }); </script> @@ layouts/main.html.ep <!DOCTYPE html> <html> <head> <title><%= title %></title> <meta name="viewport" content="width=device-width, initial-scale=1 +.0"> <link rel="stylesheet" href=" +ormalize.min.css" integrity="sha512-NhSC1YmyruXifcj/KFRWoC561YpHpc5Jtzgvbuzx5Voz +KpWvQ+4nXhPdFgmx8xqexRcpAglTj9sIBWINXa8x5w==" crossorigin="anonymous" referrerpolicy="no-referrer" /> <script src="" integrity="sha256-/xUj+3OJU5yExlq6GSYGSHk7tPXikynS7ogEvDej/m4= +" crossorigin="anonymous"></script> </head> <body> %= content </body> </html>

If this needed to run in a threaded/multiprocess HTTP server, it would even be possible to replace the communication via EventEmitter objects with a system like Redis - it's pretty simple to spin up a server via Docker and connect to it using e.g. Mojo::Redis::PubSub.

In reply to Re: Can I have a Perl script, initiated from a browser, fork itself, and not wait for the child to end? by haukex
in thread Can I have a Perl script, initiated from a browser, fork itself, and not wait for the child to end? by bartender1382

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.