[Catalyst-commits] r13961 -
CatalystX-Restarter-GTK/trunk/lib/CatalystX/Restarter
t0m at dev.catalyst.perl.org
t0m at dev.catalyst.perl.org
Mon Feb 14 20:57:51 GMT 2011
Author: t0m
Date: 2011-02-14 20:57:51 +0000 (Mon, 14 Feb 2011)
New Revision: 13961
Removed:
CatalystX-Restarter-GTK/trunk/lib/CatalystX/Restarter/GTK/
Modified:
CatalystX-Restarter-GTK/trunk/lib/CatalystX/Restarter/GTK.pm
Log:
Merge everything to one class as pick_subclass can just return __PACKAGE__
Modified: CatalystX-Restarter-GTK/trunk/lib/CatalystX/Restarter/GTK.pm
===================================================================
--- CatalystX-Restarter-GTK/trunk/lib/CatalystX/Restarter/GTK.pm 2011-02-14 20:57:21 UTC (rev 13960)
+++ CatalystX-Restarter-GTK/trunk/lib/CatalystX/Restarter/GTK.pm 2011-02-14 20:57:51 UTC (rev 13961)
@@ -1,47 +1,481 @@
package CatalystX::Restarter::GTK;
use Moose;
+use MooseX::Types::Moose qw(Int Str);
+use Try::Tiny qw(try catch);
+use POSIX qw(SIGUSR1 SIGUSR2 WNOHANG);
+use IPC::Semaphore qw();
+use IPC::SysV qw(S_IRWXU IPC_PRIVATE IPC_CREAT);
+use Object::Destroyer qw();
+use Carp qw(croak);
+use Socket qw(AF_UNIX SOCK_STREAM);
+use IO::Handle qw();
use namespace::autoclean;
+our $VERSION = '0.01';
+
extends 'Catalyst::Restarter';
sub pick_subclass {
- my $subclass = ($^O eq 'MSWin32') ? 'Win32' : 'Forking';
-
- $subclass = 'CatalystX::Restarter::GTK::'.$subclass;
-
- eval "use $subclass";
- die "$@\n" if $@;
-
- return $subclass;
+ die "Win32 not supported" if ($^O eq 'MSWin32');
+
+ return __PACKAGE__;
}
+# stores forked catalyst server's PID
+has _child => (
+ is => 'rw',
+ isa => Int
+);
+
+# stores forked gtk window process' PID
+has win_pid => (
+ is => 'rw',
+ isa => Int,
+);
+
+# Port number of catalyst server
+has port => (
+ is => 'rw',
+ isa => Int,
+);
+
+# name of catalyst application.
+has application_name => (
+ is => 'rw',
+ isa => Str,
+);
+
+# Socket for communication with window process
+has parent_sock => (
+ is => 'rw',
+);
+
+# Pipe for retriving error messages from server process
+has srv_reader => (
+ is => 'rw'
+);
+
+sub run {
+ my ($self, $auto_restart) = @_;
+
+ my $sem = IPC::Semaphore->new(IPC_PRIVATE, 1, S_IRWXU | IPC_CREAT)
+ or croak "Can not create semaphore $!";
+
+ my $sentry = Object::Destroyer->new($sem, 'remove');
+
+ socketpair(my $parent_sock, my $win_sock, AF_UNIX, SOCK_STREAM, 0)
+ or croak "socketpair failed: $!";
+
+ # Fork GUI process
+ my $pid = fork;
+ croak $! unless defined $pid;
+
+ if ($pid) {
+ close $win_sock;
+ $parent_sock->autoflush(1);
+
+ require AnyEvent;
+
+ $self->win_pid($pid);
+ $self->parent_sock($parent_sock);
+
+ # Detect server process termination.
+ my $child_server = AnyEvent->child(
+ pid => $self->_child,
+ cb => sub {
+ $self->notify_win('stopped');
+ $self->_child(0);
+ }
+ );
+
+ # Detect window process termination
+ my $child_win = AnyEvent->child(
+ pid => $self->win_pid,
+ cb => sub {
+ $self->win_pid(0);
+ $self->_kill_child;
+ exit;
+ }
+ );
+
+ # Handle USR1 (Restart signal) from window
+ my $restart_watcher = AnyEvent->signal(
+ signal => SIGUSR1,
+ cb => sub {
+ $self->_kill_child;
+ $self->_fork_and_start;
+ }
+ );
+
+ if ($auto_restart) {
+ my $timer = AnyEvent->timer(
+ after => 1,
+ interval => 1,
+ cb => sub {
+ if (my @events = $self->_watcher->new_events) {
+ $self->_handle_events(@events);
+ }
+ }
+ );
+ }
+
+ # wait until window process sets up watchers.
+ $sem->op(0, -1, 0);
+ $sentry = undef;
+
+ $self->_fork_and_start;
+
+ # Wait for events infinitely.
+ AnyEvent->condvar->recv;
+ }
+ else {
+ $sentry->dismiss;
+ close $parent_sock;
+ $win_sock->autoflush(1);
+
+ # Use event loop of Gtk2 by loading it first.
+ require Gtk2;
+ Gtk2->init;
+ require AnyEvent::Socket;
+
+ my $win = WinMonitor->new($self->application_name);
+
+ $win->set_restart_handler(sub { kill SIGUSR1, getppid; });
+
+ my ($watcher, $start_timer);
+
+ # Creates event watcher for checking socket readiness of forked server.
+ $start_timer = sub {
+ $watcher = AnyEvent->timer(
+ after => 1,
+ cb => sub {
+ AnyEvent::Socket::tcp_connect('localhost', $self->port, sub {
+ if (shift) {
+ $watcher = undef;
+ $win->set_status('started');
+ }
+ else {
+ # Restart timer upon failure
+ $watcher = $start_timer->();
+ }
+ });
+ }
+ );
+ };
+
+ # SIGUSR1 - starting server
+ my $usr1_watcher = AnyEvent->signal(
+ signal => SIGUSR1,
+ cb => sub {
+ $win->clear_msg;
+ $win->set_status('starting');
+ $win_sock->say('1');
+ $start_timer->();
+ }
+ );
+
+ # SIGUSR2 - Server exited / killed
+ my $usr2_watcher = AnyEvent->signal(
+ signal => SIGUSR2,
+ cb => sub {
+ $win->set_status('stopped');
+ $watcher = undef;
+ $win_sock->say('1');
+ }
+ );
+
+ my $winsock_watcher = AnyEvent->io(
+ fh => $win_sock,
+ poll => 'r',
+ cb => sub {
+ # Unbuffered read from socket
+ return unless sysread($win_sock, my $msg, 256, 0);
+ $win->append_msg($msg);
+ }
+ );
+ $sem->op(0, 1, 0);
+
+ main Gtk2;
+ exit(0);
+ }
+}
+
+# Sends server status signal to window process.
+{
+ my %map = ('starting' => SIGUSR1, 'stopped' => SIGUSR2);
+
+ sub notify_win {
+ my ($self, $msg) = @_;
+ return unless exists $map{$msg};
+
+ if ($self->win_pid) {
+ kill $map{$msg}, $self->win_pid;
+ # Wait until signal is handled. This is for synchronizing signals.
+ $self->parent_sock->getline;
+ }
+ }
+}
+
+sub _fork_and_start {
+ my $self = shift;
+
+ pipe(my $reader, my $writer) or croak "$!";
+
+ my $sem = IPC::Semaphore->new(IPC_PRIVATE, 1, S_IRWXU | IPC_CREAT)
+ or croak "failed to create semaphore $!";
+ my $sentry = Object::Destroyer->new($sem, 'remove');
+
+ my $pid = fork;
+ return unless (defined $pid);
+
+ if($pid) {
+ close $writer;
+
+ $self->_child($pid);
+
+ # Read console output from forked server and send to win proc
+ $self->srv_reader(AnyEvent->io(
+ fh => $reader,
+
+ poll => 'r',
+
+ cb => sub {
+
+ if (my $bytes = sysread($reader, my $msg, 256, 0)) {
+
+ syswrite($self->parent_sock, $msg, $bytes);
+ }
+ }
+ ));
+
+ $self->notify_win('starting');
+
+ $sentry->dismiss;
+
+ $sem->op(0, 1, 0);
+ }
+ else {
+ close $reader;
+
+ $writer->autoflush(1);
+
+ $sem->op(0, -1, 0);
+ $sentry = undef;
+
+ open (STDERR, '>&', $writer) or croak "Failed to dup STDERR $!";
+ open (STDOUT, '>&', $writer) or croak "Failed to dup STDOUT $!";
+ STDOUT->autoflush(1);
+
+ try {
+
+ $self->start_sub->();
+
+ }
+
+ catch {
+
+ STDERR->print($_);
+ exit 1;
+ };
+ }
+}
+
+sub _kill_child {
+ my $self = shift;
+
+ if ($self->_child) {
+ kill 'INT', $self->_child;
+
+ waitpid($self->_child, 0);
+
+ $self->_child(0);
+
+ $self->notify_win('stopped');
+
+ }
+}
+
+__PACKAGE__->meta->make_immutable;
+
+no Moose;
+
+#--- Class WinMonitor for GUI ---
+
+package WinMonitor;
+use strict;
+use warnings;
+use Gtk2;
+use Glib qw(TRUE FALSE);
+use Carp;
+
+my %status_msg = (
+ starting => { msg => 'Starting', color => Gtk2::Gdk::Color->new(0, 0, 0x55 * 257) },
+ started => { msg => 'Started', color => Gtk2::Gdk::Color->new(0, 0x55 * 257, 0) },
+ stopped => { msg => 'Stopped', color => Gtk2::Gdk::Color->new(0x55 * 257, 0, 0) },
+);
+
+sub new {
+ my ($class, $app_name) = @_;
+
+ my $obj = {};
+
+ my $win = Gtk2::Window->new('toplevel');
+
+ $win->set_title($app_name);
+ $win->set_keep_above(1);
+
+ $win->set_position('center');
+
+ my $status = Gtk2::Label->new;
+
+ my $bt_restart = Gtk2::Button->new('Restart');
+
+ my $bt_console = Gtk2::Button->new('Console');
+
+ my $menu_bar = Gtk2::MenuBar->new;
+ my $view = Gtk2::MenuItem->new('_View');
+ my $mview = Gtk2::Menu->new;
+
+ my $console = Gtk2::MenuItem->new('Console');
+ $console->signal_connect('activate', sub { $obj->show_msg; });
+
+ $mview->append($console);
+ $view->set_submenu($mview);
+
+ my $restart = Gtk2::MenuItem->new('Restart');
+ my $mrestart = Gtk2::Menu->new;
+ $mrestart->append($restart);
+
+ my $tools = Gtk2::MenuItem->new('_Tools');
+ $tools->set_submenu($mrestart);
+
+ $menu_bar->append($view);
+ $menu_bar->append($tools);
+ $menu_bar->set_size_request(-1, 22);
+
+ my $vbox = Gtk2::VBox->new(FALSE, 0);
+ $vbox->pack_start($menu_bar, FALSE, FALSE, 0);
+
+ my $hbox = Gtk2::HBox->new(TRUE, 0);
+ $hbox->pack_start(Gtk2::Label->new($app_name.' Server'), TRUE, TRUE, 3);
+
+ $vbox->pack_start($hbox, TRUE, FALSE, 3);
+ $vbox->pack_start($status, TRUE, FALSE, 3);
+
+ $win->add($vbox);
+
+ $win->signal_connect(delete_event => sub { Gtk2->main_quit; });
+
+ $win->show_all;
+ my $buffer = Gtk2::TextBuffer->new;
+
+ $obj = { %$obj, win => $win, msg_buffer => $buffer, app_name => $app_name, lbstatus => $status,
+
+ bt_restart => $restart, bt_console => $console };
+
+ bless $obj, $class;
+}
+
+# Updates status message on window
+sub set_status {
+
+ my ($self, $st) = @_;
+
+ my $msg = $status_msg{$st};
+
+ $self->{lbstatus}->set_text($msg->{msg});
+ $self->{lbstatus}->modify_fg('normal', $msg->{color});
+
+ $self->{win}->set_title($self->{app_name}.'-'.$msg->{msg});
+ $self->{bt_restart}->set_sensitive($st ne 'starting');
+
+}
+
+# Collects console output received into text buffer
+sub append_msg {
+ my ($self, $msg) = @_;
+ my $buffer = $self->{msg_buffer};
+ $buffer->insert($buffer->get_end_iter, $msg);
+}
+
+sub get_msg_window {
+ my ($self) = @_;
+
+ my $win = Gtk2::Window->new;
+ $win->set_title($self->{app_name}.' - console output');
+
+ $win->set_position('center');
+ $win->signal_connect('delete_event' => sub { $win->hide; 1; });
+
+ my $textview = Gtk2::TextView->new_with_buffer($self->{msg_buffer});
+ $textview->set_editable(FALSE);
+ $textview->set_wrap_mode('word');
+
+ my $scrolled_win = Gtk2::ScrolledWindow->new;
+ $scrolled_win->add($textview);
+
+ $win->add($scrolled_win);
+ $win->set_default_size(800, 400);
+ $win->set_size_request(100, 100);
+ return $win;
+}
+
+# Shows collected messages in a new window
+sub show_msg {
+ my ($self) = @_;
+
+ unless ($self->{win_msg}) {
+
+ $self->{win_msg} = $self->get_msg_window;
+ }
+ $self->{win_msg}->show_all;
+}
+
+# Clears text buffer.
+
+sub clear_msg {
+
+ $_[0]->{msg_buffer}->set_text(q{});
+
+}
+
+sub set_restart_handler {
+ $_[0]->{bt_restart}->signal_connect('activate', $_[1]);
+}
1;
+=pod
+
=head1 NAME
-CatalystX::Restarter::GTK - Base class for GTK based forkers
+CatalystX::Restarter::GTK - GTK based Catalyst server restarter.
=head1 DESCRIPTION
-It overrides pick_subclass to provide gtk based subclass of CatalystX::Restarter::GTK.
+This module works with CatalystX::Script::Server::GTK and CatalystX::Restarter::GTK.
-=head1 METHODS
+CatalystX::Restarter::GTK selects this module as a Restarter. It instantiates this module with restarter arguments and calls run to pass control and wither to auto restart upon file changes.
-pick_subclass
+It shows a small GUI window for controlling catalyst server and notifying status. It also captures console output printed by application at run time, both STDERR and STDOUT.
-return GTK based of forker
+This module forks two processes. First child process creates GUI window and listens for incoming messages from parent.(console output and signals for notifying status change). Second child process runs the actual server and creates server socket by calling run() on application module.
-=head1 BUGS
+With this module Catalyst application developers do not need to use console to start or manage catalyst server or viewing console output. Window stays always on top by default. User can drag to any screen corner for convenience. When developer chagne any file of project, he can immediately check whether server is restarted successfuly or not before hitting refresh on web browser.
+=head1 NOTES
+
+This module extends CatalystX::Restarter::GTK which in turn extends Catalyst::Restarter. It depends upon inherited _watcher and _handle_events members of Catalyst::Restarter for monitoring files changes.
+
=head1 AUTHOR
-Dhaval Dhanani
+Dhaval Dhanani L<mailto:dhaval070 at gmail.com>, L<mailto:dhavald at farematrix.com>
-=head1 COPYRIGHT & LICENSE
+=head1 LICENCE
-Copyright 2009 the above author(s).
+This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself.
-This sofware is free software, and is licensed under the same terms as perl itself.
+=head1 COPYRIGHT
+This library is copyright (c) 2011 the above named AUTHOR and CONSTRIBUTOR(s).
+
=cut
-
More information about the Catalyst-commits
mailing list