[gimp-perl] Implement add_listener.

[Ed J <edj src gnome org>]

commit 31ac26576f67c88d0f255eb35855ba25f537091c
Author: Ed J <edj src gnome org>
Date:   Mon May 5 03:47:07 2014 +0100

    Implement add_listener.

 Gimp/Extension.pm |   88 ++++++++++++++++++++++++++++++++++++++++++++++++++--
 Net/Net.pm        |   81 ++++++++++++++++++++----------------------------
 2 files changed, 118 insertions(+), 51 deletions(-)
---
diff --git a/Gimp/Extension.pm b/Gimp/Extension.pm
index a941eca..a43382a 100644
--- a/Gimp/Extension.pm
+++ b/Gimp/Extension.pm
@@ -5,6 +5,8 @@ use Carp qw(croak carp);
 use base 'Exporter';
 use Filter::Simple;
 use Gimp::Pod;
+use autodie;
+use Gtk2;
 
 # manual import
 sub __ ($) { goto &Gimp::__ }
@@ -18,7 +20,7 @@ FILTER {
    warn __PACKAGE__."::FILTER: found: '$1'" if $Gimp::verbose;
 };
 
-our @EXPORT = qw(podregister main);
+our @EXPORT = qw(podregister main add_listener register_temp);
 
 my @register_params;
 Gimp::on_query {
@@ -45,10 +47,30 @@ sub podregister (&) {
    };
    @register_params = (
       $function, $blurb, $help, $author, $copyright, $date, $menupath,
-      $imagetypes, Gimp::EXTENSION, $params, $results
+      $imagetypes, &Gimp::EXTENSION, $params, $results
    );
 }
 
+sub add_listener {
+   my ($listen_socket, $handler, $on_accept) = @_;
+   Glib::IO->add_watch(fileno($listen_socket), 'in', sub {
+      my ($fd, $condition, $fh) = @_;
+      my $h = $fh->accept;
+      $on_accept->($h) if $on_accept;
+      $h->autoflush;
+      Glib::IO->add_watch(fileno($h), 'in', sub {
+        my ($fd, $condition, $h) = @_;
+        undef $h if not $handler->(@_);
+        $h ? &Glib::SOURCE_CONTINUE : &Glib::SOURCE_REMOVE;
+      }, $h);
+      &Glib::SOURCE_CONTINUE;
+   }, $listen_socket);
+}
+
+sub register_temp ($$$&) {
+   my ($function, $params, $retvals, $callback) = @_;
+}
+
 1;
 __END__
 
@@ -93,7 +115,8 @@ verbatim.
 Another difference is that the C<run_mode> is passed on to your function,
 rather than being stripped off as with Gimp::Fu.
 
-Finally, before control is passed to your function, these procedures are called:
+Finally, before control is passed to your function, these procedures
+are called:
 
   Gimp::gtk_init; # sets up Gtk2, ready for event loop
   Gimp->extension_ack; # GIMP hangs till this is called
@@ -110,7 +133,7 @@ as with a plugin.
 
 One benefit of being an extension vs a plugin is that you can keep
 running, installing temporary procedures which are called by the user.
-When they are called, the procedure you have registered will be
+When they are called, the perl function you have registered will be
 called, possibly accessing your persistent data or at least benefiting
 from the fact that you have already started up.
 
@@ -120,6 +143,63 @@ such as network connections (this is how the Perl-Server is implemented).
 Additionally, if no parameters are specified, then the extension will
 be started as soon as GIMP starts up.
 
+=head1 FUNCTIONS AVAILABLE TO EXTENSIONS
+
+These are all exported by default.
+
+=head2 podregister
+
+As discussed above.
+
+=head2 add_listener
+
+This is a convenience wrapper around C<Glib::IO-E<gt>add_watch>. It
+takes parameters:
+
+=over 4
+
+=item $listen_socket
+
+This will be an L<IO::Socket> subclass object, a listener socket. When
+it becomes readable, its C<accept> method will be called.
+
+=item \&handler
+
+This mandatory parameter is a function that is installed as the new
+connection's Glib handler. Its parameters are: C<$fd, $condition, $fh> -
+in Glib terms, the file handle will be registered as the "data" parameter.
+When it returns false, the socket will be closed.
+
+=item \&on_accept
+
+This optional parameter will, if defined, be a function that is called
+one time with the new socket as a parameter, possibly logging and/or
+sending an initial message down that socket.
+
+=back
+
+=head2 register_temp
+
+This is a convenience wrapper around C<Gimp-E<gt>install_temp_proc>,
+supplying a number of parameters from information in the extension's
+POD. It takes parameters:
+
+=over 4
+
+=item $proc_name
+
+The name of the new PDB procedure.
+
+=item $params
+
+=item $retvals
+
+Both as per L<Gimp/Gimp-E<gt>install_procedure>.
+
+=item \&callback
+
+=back
+
 =head1 AUTHOR
 
 Ed J
diff --git a/Net/Net.pm b/Net/Net.pm
index 2b4cae7..5cf69e4 100644
--- a/Net/Net.pm
+++ b/Net/Net.pm
@@ -33,6 +33,7 @@ use base qw(DynaLoader);
 use IO::Socket;
 use Carp 'croak';
 use Fcntl qw(F_SETFD);
+use Gimp::Extension;
 
 $VERSION = 2.3002;
 bootstrap Gimp::Net $VERSION;
@@ -364,65 +365,52 @@ sub handle_request($) {
    return 1;
 }
 
-sub new_connection {
-  warn "$$-new_connection(@_)" if $Gimp::verbose;
-  my $fh = shift;
-  $fh->autoflush;
-  reply $fh, "PERL-SERVER", $PROTOCOL_VERSION, ($auth ? "AUTH" : ());
-  $stats{fileno($fh)}=[0,time];
-  Glib::IO->add_watch(fileno($fh), 'in', sub {
-    warn "$$-new_connection WATCHER(@_)" if $Gimp::verbose;
-    my ($fd, $condition, $fh) = @_;
-    if(handle_request($fh)) {
-      $stats{$fd}[0]++;
-    } else {
-      slog sprintf __"closing connection %d (%d requests in %g seconds)", $fd, $stats{$fd}[0], 
time-$stats{$fd}[1];
-      undef $fh;
-    }
-    $fh ? &Glib::SOURCE_CONTINUE : &Glib::SOURCE_REMOVE;
-  }, $fh);
+sub on_accept {
+  warn "$$-on_accept(@_)" if $Gimp::verbose;
+  my $h = shift;
+  slog sprintf __"new connection(%d)%s",
+    $h->fileno,
+    $h->isa('IO::Socket::INET') ? ' from '.$h->peerport.':'.$h->peerhost : '';
+  reply $h, "PERL-SERVER", $PROTOCOL_VERSION, ($auth ? "AUTH" : ());
+  $stats{fileno($h)}=[0,time];
+}
+
+sub on_input {
+  warn "$$-on_input(@_)" if $Gimp::verbose;
+  my ($fd, $condition, $fh) = @_;
+  if (handle_request($fh)) {
+    return ++$stats{$fd}[0]; # non-false!
+  } else {
+    slog sprintf __"closing connection %d (%d requests in %g seconds)", $fd, $stats{$fd}[0], 
time-$stats{$fd}[1];
+    return;
+  }
 }
 
 sub setup_listen_unix {
   warn "$$-setup_listen_unix(@_)" if $Gimp::verbose;
+  use autodie;
   use File::Basename;
   my $host = shift;
   my $dir = dirname($host);
-  mkdir $dir, 0700 or die "mkdir $dir: $!" unless -d $dir;
+  mkdir $dir, 0700 unless -d $dir;
   unlink $host if -e $host;
-  my $unix = IO::Socket::UNIX->new(
+  add_listener(IO::Socket::UNIX->new(
     Type => SOCK_STREAM, Local => $host, Listen => 5
-  ) or die __"unable to create listening unix socket: $!\n";
+  ), \&on_input, \&on_accept);
   slog __"accepting connections in $host";
-  Glib::IO->add_watch(fileno($unix), 'in', sub {
-    warn "$$-setup_listen_unix WATCHER(@_)" if $Gimp::verbose;
-    my ($fd, $condition, $fh) = @_;
-    my $h = $fh->accept or die __"unable to accept unix connection: $!\n";
-    new_connection($h);
-    slog __"accepted unix connection";
-    &Glib::SOURCE_CONTINUE;
-  }, $unix);
 }
 
 sub setup_listen_tcp {
   warn "$$-setup_listen_tcp(@_)" if $Gimp::verbose;
+  use autodie;
   my $host = shift;
   ($host, my $port)=split /:/,$host;
   $port = $DEFAULT_TCP_PORT unless $port;
-  my $tcp = IO::Socket::INET->new(
+  add_listener(IO::Socket::INET->new(
     Type => SOCK_STREAM, LocalPort => $port, Listen => 5, ReuseAddr => 1,
     ($host ? (LocalAddr => $host) : ()),
-  ) or die __"unable to create listening tcp socket: $!\n";
+  ), \&on_input, \&on_accept);
   slog __"accepting connections on port $port";
-  Glib::IO->add_watch(fileno($tcp), 'in', sub {
-    warn "$$-setup_listen_tcp WATCHER(@_)" if $Gimp::verbose;
-    my ($fd, $condition, $fh) = @_;
-    my $h = $fh->accept or die __"unable to accept tcp connection: $!\n";
-    my ($port,$host) = ($h->peerport, $h->peerhost);
-    new_connection($h);
-    slog __"accepted tcp connection from $host:$port";
-    &Glib::SOURCE_CONTINUE;
-  }, $tcp);
 }
 
 sub perl_server_run {
@@ -432,13 +420,14 @@ sub perl_server_run {
      if ($ps_flags & PS_FLAG_BATCH) {
        die __"unable to open Gimp::Net communications socket: $!\n"
           unless open my $fh,"+<&$extra";
-        new_connection($fh);
+       $fh->autoflush;
+       on_accept($fh);
+       Glib::IO->add_watch(fileno($fh), 'in', \&on_input, $fh);
        Gtk2->main;
         Gimp->quit(0);
         exit(0);
      }
   } else {
-     $run_mode=&Gimp::RUN_INTERACTIVE;
      $ps_flags=0;
   }
   my $host = $ENV{'GIMP_HOST'};
@@ -456,12 +445,9 @@ sub perl_server_run {
         setup_listen_tcp($host);
      }
   } else {
-     if ($use_unix) {
-        setup_listen_unix($unix_path = $DEFAULT_UNIX_DIR.$DEFAULT_UNIX_SOCK);
-     }
-     if ($use_tcp && $auth) {
-        setup_listen_tcp(":$DEFAULT_TCP_PORT");
-     }
+     setup_listen_unix($unix_path = $DEFAULT_UNIX_DIR.$DEFAULT_UNIX_SOCK)
+        if $use_unix;
+     setup_listen_tcp(":$DEFAULT_TCP_PORT") if $use_tcp && $auth;
   }
   Gtk2->main;
 }
@@ -470,6 +456,7 @@ sub perl_server_quit {
   return unless $unix_path;
   unlink $unix_path or die "failed to unlink '$unix_path': $!\n";
   rmdir $DEFAULT_UNIX_DIR if $unix_path eq $DEFAULT_UNIX_DIR.$DEFAULT_UNIX_SOCK;
+  slog "server quitting";
 }
 
 1;