Commit 1826ed29 authored by Michael Gray's avatar Michael Gray
Browse files

Merge branch 'mg13/app_support'

parents 2eeef957 f7ef0689
......@@ -14,7 +14,7 @@ use Tk::Optionmenu;
use Tk::Entry;
use Tk::Label;
use Zircon::TkZMQ::Context;
use Zircon::Context::ZMQ::Tk;
use Zircon::Connection;
use sigtrap qw/handler signal_handler USR1/;
......@@ -40,7 +40,7 @@ $main_window->title(
my $handler = Handler->new;
my $context = Zircon::TkZMQ::Context->new(
my $context = Zircon::Context::ZMQ::Tk->new(
'-widget' => $main_window);
my $connection = Zircon::Connection->new(
......
......@@ -7,7 +7,7 @@ use IO::Handle;
use Getopt::Long;
use Tk;
use Zircon::TkZMQ::Context;
use Zircon::Context::ZMQ::Tk;
use Zircon::Connection;
use Zircon::Trace;
......@@ -35,7 +35,7 @@ Reads from STDIN, writes to STDOUT.\n" unless 2 == @ARGV;
$M->title("$0 pid=$$");
$M->Entry(-text => "$local_endpoint => $remote_endpoint")->pack;
my $context = Zircon::TkZMQ::Context->new(-widget => $M);
my $context = Zircon::Context::ZMQ::Tk->new(-widget => $M);
my $handler = My::Handler->new();
my $reader = My::StdinReader->new($M);
......
#!/usr/bin/env perl
use strict;
use warnings;
use feature qw( switch );
use Getopt::Long;
use POSIX;
use Try::Tiny;
use Tk;
use Zircon::Protocol;
use Zircon::Context::ZMQ::Tk;
my $app_id = 'Zircon Protocol (Master)';
# create the main window
my $main_window = Tk::MainWindow->new;
$main_window->title($app_id);
# create the Zircon connection
my $context = Zircon::Context::ZMQ::Tk->new(
'-widget' => $main_window);
my $server = ServerApp->new(
'-app_id' => $app_id,
'-context' => $context,
);
my $protocol = $server->protocol;
# create the GUI
my $zircon_message = '';
my $button_frame =
$main_window->Frame->pack('-fill' => 'both');
sub wrap {
my ($callback) = @_;
$zircon_message = '';
try { $callback->(); }
catch {
chomp $_;
$zircon_message = "Error: $_";
};
return;
}
sub ping {
wrap(
sub {
$protocol->send_ping(
sub {
my ($result) = @_;
$zircon_message =
sprintf 'Client: ping: %s', _message($result);
});
});
return;
}
sub shutdown {
wrap(
sub {
$protocol->send_shutdown_clean(
sub {
my ($result) = @_;
$zircon_message =
sprintf 'Client: shutdown: %s', _message($result);
});
});
return;
}
sub goodbye {
wrap(
sub {
$protocol->send_goodbye_exit(
sub { POSIX::_exit(0); }); # to avoid triggering DESTROY on ServerApp which will send shutdown.
});
return;
}
Tk::grid(
$button_frame->Button(
'-text' => 'Ping',
'-command' => \&ping),
$button_frame->Button(
'-text' => 'Goodbye',
'-command' => \&goodbye),
$button_frame->Button(
'-text' => 'Shutdown',
'-command' => \&shutdown),
$button_frame->Button(
'-text' => 'Exit',
'-command' => \&exit),
'-sticky' => 'nsew');
$button_frame->gridColumnconfigure($_, '-weight' => 1) for 0..1;
$main_window
->Label(
'-width' => 50,
'-textvariable' => \$zircon_message,
'-relief' => 'sunken')
->pack('-fill' => 'both');
$server->launch_app;
MainLoop();
exit;
sub _message {
my ($result) = @_;
for ($result) {
when ($_->isa('Zircon::Protocol::Result::Reply')) {
return $result->success ? 'succeeded' : 'failed';
}
when ($_->isa('Zircon::Protocol::Result::Timeout')) {
return 'timeout';
}
when (ref) {
return sprintf 'unknown result: class: %s', ref;
}
}
return 'unknown result';
}
package ServerApp;
our $ZIRCON_TRACE_KEY = 'ZIRCON_PM_TRACE';
use base qw(
Zircon::Protocol::Server::AppLauncher
);
sub new {
my ($pkg, %arg_hash) = @_;
return $pkg->SUPER::new(
-program => 'zircon_protocol_test',
-peer_socket_opt => '--remote_endpoint',
-app_tag => 'zpm',
-serialiser => 'JSON',
-arg_list => [ '--app_tag=zpm', '--serialiser=JSON' ],
%arg_hash,
);
}
sub zircon_server_log {
my ($self, $message) = @_;
$zircon_message =
sprintf 'Server: %s', $message;
warn "$zircon_message\n";
return;
}
=head1 AUTHOR
Ana Code B<email> anacode@sanger.ac.uk
......@@ -8,12 +8,16 @@ use Getopt::Long;
use Try::Tiny;
use Tk;
use Zircon::Protocol;
use Zircon::TkZMQ::Context;
use Zircon::Context::ZMQ::Tk;
# parse the command line
my $app_tag;
my $remote_endpoint;
my $serialiser;
GetOptions(
'app_tag=s' => \$app_tag,
'remote_endpoint=s' => \$remote_endpoint,
'serialiser=s' => \$serialiser,
) or die 'command line error';
my $is_child =
defined $remote_endpoint
......@@ -29,11 +33,13 @@ $main_window->title($app_id);
# create the Zircon connection
my $server = Server->new;
my $context = Zircon::TkZMQ::Context->new(
my $context = Zircon::Context::ZMQ::Tk->new(
'-widget' => $main_window);
my $protocol = Zircon::Protocol->new(
'-app_id' => $app_id,
'-app_tag' => $app_tag,
'-context' => $context,
'-serialiser' => $serialiser,
'-server' => $server,
);
......
package Zircon::ZMap::Core;
package Zircon::App;
# The transport/protocol independent code to manage ZMap processes.
# Transport/protocol-independent application forking support.
use strict;
use warnings;
use Carp;
use Scalar::Util qw( weaken refaddr );
use POSIX ();
use Try::Tiny;
use base qw( Zircon::Trace );
our $ZIRCON_TRACE_KEY = 'ZIRCON_ZMAP_TRACE';
use parent qw( Zircon::Trace );
our $ZIRCON_TRACE_KEY = 'ZIRCON_APP_TRACE';
my @_list = ( );
sub new {
my ($pkg, $program, @arg_list) = @_;
sub list {
my ($pkg) = @_;
# filter the list because weak references may become undef
my $list = [ grep { defined } @_list ];
return $list;
}
my $new = { };
bless($new, $pkg);
my $_string_zmap_hash = { };
$new->_init($program, \@arg_list);
sub from_string {
my ($pkg, $string) = @_;
my $zmap = $_string_zmap_hash->{$string};
return $zmap;
}
sub new {
my ($pkg, %arg_hash) = @_;
my $new = {
'_program' => 'zmap',
};
bless($new, $pkg);
push @_list, $new;
weaken $_list[-1];
$_string_zmap_hash->{"$new"} = $new;
weaken $_string_zmap_hash->{"$new"};
$new->_init(\%arg_hash);
$new->launch_zmap;
return $new;
}
sub _init {
my ($self, $arg_hash) = @_;
my $program = $arg_hash->{'-program'};
$self->{'_program'} = $program if $program;
$self->{'_arg_list'} = [@{
$arg_hash->{'-arg_list'} || []
}]; # copy now because list is modified by subclass _init
$self->{'_id_view_hash'} = { };
$self->{'_view_list'} = [ ];
my ($self, $program, $arg_list) = @_;
$self->{'_program'} = $program or croak 'missing program argument';
$self->{'_arg_list'} = $arg_list;
return;
}
sub launch_zmap {
sub launch {
my ($self) = @_;
my @e = $self->zmap_command;
my @e = $self->app_command;
warn "Running: @e\n";
my $pid = fork;
confess "Error: couldn't fork()\n" unless defined $pid;
if ($pid) { # parent
warn "Started $e[0], pid $pid\n";
$self->pid($pid);
return $pid;
}
{ exec @e; }
......@@ -82,23 +56,40 @@ sub launch_zmap {
return; # unreached, quietens perlcritic
}
sub zmap_command {
sub is_running {
my ($self) = @_;
my @zmap_command = ( $self->program );
my $arg_list = $self->arg_list;
push @zmap_command, @{$arg_list} if $arg_list;
return @zmap_command;
}
sub add_view {
my ($self, $id, $view) = @_;
$self->id_view_hash->{$id} = $view;
weaken $self->id_view_hash->{$id};
push @{$self->_view_list}, $view;
weaken $self->_view_list->[-1];
my $pid = $self->pid;
return unless $pid;
# Nicked from Proc::Launcher
#
if ( kill 0 => $pid ) {
if ( $!{EPERM} ) {
# if process id isn't owned by us, it is assumed to have
# been recycled, i.e. our process died and the process id
# was assigned to another process.
$self->zircon_trace("Process $pid active but owned by someone else");
}
else {
return $pid;
}
}
warn __PACKAGE__, ": process $pid has gone away.\n";
$self->pid(undef);
return;
}
sub app_command {
my ($self) = @_;
my @app_command = ( $self->program );
my $arg_list = $self->arg_list;
push @app_command, @{$arg_list} if $arg_list;
return @app_command;
}
# attributes
sub program {
......@@ -113,31 +104,11 @@ sub arg_list {
return $arg_list;
}
sub id_view_hash {
my ($self) = @_;
my $id_view_hash = $self->{'_id_view_hash'};
return $id_view_hash;
}
sub view_list {
my ($self) = @_;
# filter the list because weak references may become undef
my $view_list = [ grep { defined } @{$self->_view_list} ];
return $view_list;
}
sub _view_list {
my ($self) = @_;
my $view_list = $self->{'_view_list'};
return $view_list;
}
# tracing
sub zircon_trace_prefix {
my ($self) = @_;
return 'Z:ZMap';
sub pid {
my ($self, @args) = @_;
($self->{'pid'}) = @args if @args;
my $pid = $self->{'pid'};
return $pid;
}
1;
......@@ -148,3 +119,4 @@ __END__
Ana Code B<email> anacode@sanger.ac.uk
# EOF
......@@ -293,6 +293,11 @@ sub state {
return $self->{'state'};
}
sub DESTROY {
my ($self) = @_;
$self->zircon_trace;
}
1;
=head1 NAME - Zircon::Connection
......@@ -317,7 +322,7 @@ An opaque object that provides an interface to the transport layer
and the application's event loop.
Perl/Tk applications create this object by calling
C<Zircon::TkZMQ::Context-E<gt>new()>.
C<Zircon::Context::ZMQ::Tk-E<gt>new()>.
=item C<$handler> (mandatory)
......
package Zircon::TkZMQ::Context;
package Zircon::Context::ZMQ;
use strict;
use warnings;
use feature 'state';
use Carp qw( croak cluck );
use Errno qw(EAGAIN ENODATA);
use Carp qw( croak );
use Errno qw( EAGAIN ENODATA );
use Readonly;
use Scalar::Util qw( weaken refaddr );
use Time::HiRes qw( gettimeofday );
use ZMQ::LibZMQ3;
......@@ -30,10 +29,6 @@ sub new {
sub _init {
my ($self, $args) = @_;
$self->{'_waitVariable_hash'} = { };
my $widget = $args->{'-widget'};
defined $widget or die 'missing -widget argument';
$self->{'widget'} = $widget;
my $trace_prefix = $args->{'-trace_prefix'};
$self->trace_prefix($trace_prefix) if $trace_prefix;
$self->zircon_trace;
......@@ -75,8 +70,8 @@ sub transport_init {
my $fh = zmq_getsockopt($responder, ZMQ_FD);
$fh or die "failed to get socket fd: $!";
open my $dup_fh, '<&', $fh or die "failed to dup socket fd: $!";
$self->recv_fh($dup_fh);
$self->register_recv_fh($fh);
$self->connect_recv_callback;
return;
......@@ -214,7 +209,7 @@ sub _server_callback {
$self->connect_recv_callback;
if ($error) {
warn "Zircon::TkZMQ::Context::_server_callback: $error";
warn "Zircon::Context::ZMQ::_server_callback: $error";
return;
}
}
......@@ -251,26 +246,6 @@ sub _process_server_request {
return;
}
sub connect_recv_callback {
my ($self) = @_;
$self->widget->fileevent(
$self->recv_fh,
'readable',
sub { return $self->_server_callback; },
);
return;
}
sub disconnect_recv_callback {
my ($self) = @_;
$self->widget->fileevent(
$self->recv_fh,
'readable',
'',
);
return;
}
# platform
sub platform { return 'ZMQ'; }
......@@ -345,7 +320,7 @@ sub send {
callback => sub {
my ($header, $error);
($header, $reply_msg, $error) = $self->_get_two_part($requester);
warn "Zircon::TkZMQ::Context::send: zmq_recvmsg failed: $error" if $error;
warn "Zircon::Context::ZMQ::send: zmq_recvmsg failed: $error" if $error;
return;
},
);
......@@ -457,56 +432,35 @@ sub _parse_request_header {
};
}
# timeouts
# event-loop specific
sub timeout {
my ($self, @args) = @_;
croak "subclass must provide timeout()";
}
my $w = $self->widget;
Tk::Exists($w)
or croak "Attempt to set timeout with destroyed widget";
my $timeout_handle = $w->after(@args);
$self->zircon_trace('configured (%d millisec)', $args[0]);
return $timeout_handle;
}
# waiting
sub waitVariable {
my ($self, $var) = @_;
$self->_waitVariable_hash->{$var} = $var;
weaken $self->_waitVariable_hash->{$var};
my $w = $self->widget;
Tk::Exists($w)
or croak "Attempt to waitVariable with destroyed widget";
$self->zircon_trace('startWAIT(0x%x) for %s=%s', refaddr($self), $var, $$var);
$w->waitVariable($var); # traced
$self->zircon_trace('stopWAIT(0x%x) with %s=%s', refaddr($self), $var, $$var);
Tk::Exists($w)
or cluck "Widget $w destroyed during waitVariable";
return;
sub cancel_timeout {
my ($self, @args) = @_;
croak "subclass must provide cancel_timeout()";
}
sub _close_waitVariables {
my ($self, $reason) = @_;
my $_waitVariable_hash = $self->_waitVariable_hash;
return unless $_waitVariable_hash;
foreach my $ref (values %{$_waitVariable_hash}) {
defined $ref or next;
${$ref} = $reason;
}
return;
sub register_recv_fh {
my ($self, $fh, $callback) = @_;
croak "subclass must provide register_recv_fh()";
}
# attributes
sub connect_recv_callback {
my ($self) = @_;
croak "subclass must provide connect_recv_callback()";
}
sub widget {
sub disconnect_recv_callback {
my ($self) = @_;
my $widget = $self->{'widget'};
return $widget;
croak "subclass must provide disconnect_recv_callback()";
}
# attributes
sub recv_fh {
my ($self, @args) = @_;
($self->{'recv_fh'}) = @args if @args;
......@@ -514,12 +468,6 @@ sub recv_fh {
return $recv_fh;
}
sub _waitVariable_hash {
my ($self) = @_;
my $_waitVariable_hash = $self->{'_waitVariable_hash'};
return $_waitVariable_hash;
}
sub _request_header {
my ($self, @args) = @_;
($self->{'_request_header'}) = @args if @args;
......@@ -652,10 +600,6 @@ sub timeout_list {
sub zircon_trace_prefix {
my ($self) = @_;
my $path = $self->trace_prefix;
unless ($path) {
my $w = $self->widget;
$path = sprintf('widget=%s', Tk::Exists($w) ? $w->PathName : '(destroyed)');
}
return sprintf('Z:T:Context: %s', $path);
}
......@@ -685,7 +629,6 @@ sub DESTROY {
my ($self) = @_;
$self->zircon_trace;
$self->disconnect;