Perl-Server - metacpan.org

#!/usr/bin/perl

# you can enable unix sockets, tcp sockets, or both (or neither...)
#
# enabling tcp sockets can be a security risk. If you don't understand why,
# you shouldn't enable it!
#
$use_unix	= 1;
$use_tcp	= 1;	# tcp is enabled only when authorization is available

use Socket;

use strict;
use vars qw($use_unix $use_tcp $trace_res $server_quit $max_pkt $unix $tcp $ps_flags
            $auth @authorized $exclusive $rm $saved_rm %stats);
use Gimp qw(__ N_);
use Gimp::Net ();

N_"/Xtns/Perl"; # workaround for i18n weirdnesses

Gimp::set_trace(\$trace_res);
Gimp::ignore_functions(qw(gimp_progress_init gimp_progress_update));

#
# the protocol is quite easy ;)
# at connect() time the server returns
# PERL-SERVER protocolversion [AUTH]
#
# length_of_packet cmd
#
# cmd			response		description
# AUTH password		ok [message]		authorize yourself
# QUIT						quit server
# EXEC in-args		status out-args		run simple command
# TRCE trace in-args	trace status out-args	run simple command (with tracing)
# TEST procname		bool			check for procedure existance
# DTRY in-args					destroy all argument objects
# LOCK lock? shared?				lock or unlock
# RSET						reset server (NYI)
#
# args is "number of arguments" arguments preceded by length
# type is first character
# Sscalar-value
# Aelem1\0elem2...
# Rclass\0scalar-value
#

$server_quit = 0;

my $max_pkt = 1024*1024*8;
my $exclusive = 0;

sub slog {
  return if $ps_flags & &Gimp::_PS_FLAG_QUIET;
  print time(),": ",@_,"\n";
}

sub destroy_objects {
   Gimp::Net::destroy_objects(@_);
}

# this is hardcoded into handle_request!
sub reply {
   my $fh=shift;
   my $data=Gimp::Net::args2net(0,@_);
   print $fh pack("N",length($data)).$data;
}

sub handle_request($) {
   my($fh)=@_;
   my($length,$req,$data,@args,$trace_level);
   
   eval {
      local $SIG{ALRM}=sub { die "1\n" };
      #alarm(6) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
      read($fh,$length,4) == 4 or die "2\n";
      $length=unpack("N",$length);
      $length>0 && $length<$max_pkt or die "3\n";
      #alarm(6) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
      read($fh,$req,4) == 4 or die "4\n";
      #alarm(20) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
      read($fh,$data,$length-4) == $length-4 or die "5\n";
      #alarm(0);
   };
   return 0 if $@;
   
   if(!$auth or $authorized[fileno($fh)]) {
      if($req eq "EXEC") {
         no strict 'refs';
         ($req,@args)=Gimp::Net::net2args(1,$data);
         @args=eval { Gimp->$req(@args) };
         $data=Gimp::Net::args2net(1,$@,@args);
         print $fh pack("N",length($data)).$data;
      } elsif ($req eq "TEST") {
         no strict 'refs';
         print $fh (defined(*{"Gimp::Lib::$data"}{CODE}) || Gimp::_gimp_procedure_available($data)) ? "1" : "0";
      } elsif ($req eq "DTRY") {
         Gimp::Net::destroy_objects Gimp::Net::net2args 0,$data;
         print $fh pack("N",0); # fix to work around using non-sysread/write functions
      } elsif($req eq "TRCE") {
         no strict 'refs';
         ($trace_level,$req,@args)=Gimp::Net::net2args 1,$data;
         Gimp::set_trace($trace_level);
         $trace_res="";
         @args=eval { Gimp->$req(@args) };
         $data=Gimp::Net::args2net(1,$trace_res,$@,@args);
         print $fh pack("N",length($data)).$data;
         Gimp::set_trace(0);
      } elsif ($req eq "QUIT") {
         slog __"received QUIT request";
         $server_quit = 1;
      } elsif($req eq "AUTH") {
         $data=Gimp::Net::args2net(0,1,__"authorization unnecessary");
         print $fh pack("N",length($data)).$data;
      } elsif($req eq "LOCK") {
         my($lock,$shared)=unpack("N*",$data);
         slog __"WARNING: shared locking requested but not implemented" if $shared;
         if($lock) {
            unless($exclusive) {
               $saved_rm=$rm;
               undef $rm; vec($rm,fileno($fh),1)=1;
            }
            $exclusive++;
         } else {
            if ($exclusive) {
               $exclusive--;
               $rm = $saved_rm unless $exclusive;
            } else {
               slog __"WARNING: client tried to unlock without holding a lock";
            }
         }
      } else {
         print $fh pack("N",0);
         slog __"illegal command received, aborting connection";
         return 0;
      }
   } else {
      if($req eq "AUTH") {
         my($ok,$msg);
         if($data eq $auth) {
            $ok=1;
            $authorized[fileno($fh)]=1;
         } else {
            $ok=0;
            $msg=__"wrong authorization, aborting connection";
            slog $msg;
            sleep 5; # safety measure
         }
         $data=Gimp::Net::args2net(0,$ok,$msg);
         print $fh pack("N",length($data)).$data;
         return $ok;
      } else {
         print $fh pack("N",0);
         slog __"unauthorized command received, aborting connection";
         return 0;
      }
   }
   return 1;
}

sub extension_perl_server {
  my $run_mode=$_[0];
  $ps_flags=$_[1];
  my $extra=$_[2];
  
  if ($run_mode == &Gimp::RUN_NONINTERACTIVE) {
     if ($ps_flags & &Gimp::_PS_FLAG_BATCH) {
        my($fh) = local *FH;
        open $fh,"+<&$extra" or die __"unable to open Gimp::Net communications socket: $!\n";
        select $fh; $|=1; select STDOUT;
        reply $fh,"PERL-SERVER",$Gimp::_PROT_VERSION;
        while(!$server_quit and !eof($fh)) {
           last unless handle_request($fh);
        }
#        Gimp::gimp_quit(0);	# borken in libgimp #d#FIXME#
        kill 'KILL',getppid();	# borken do not do this.. #d#FIXME#
        exit(0);
#        close $fh;
        return;
     }
  } else {
     $run_mode=&Gimp::RUN_INTERACTIVE;
     $ps_flags=0;
  }
  
  my $host = $ENV{'GIMP_HOST'};
  $auth = $host=~s/^(.*)\@// ? $1 : undef;	# get authorization
  
  slog __"server version $Gimp::VERSION started".($auth ? __", authorization required" : "");
  
  $SIG{PIPE}='IGNORE'; # may not work, since libgimp (eech) overwrites it.        
  my($unix_path)=$Gimp::Net::default_unix_dir.$Gimp::Net::default_unix_sock;
  my(%handles,$r,$fh,$f);
  
  if ($host ne "") {
     if ($host=~s{^spawn/}{}) {
        die __"invalid GIMP_HOST: 'spawn' is not a valid connection method for the server";
     } elsif ($host=~s{^unix/}{/}) {
        $unix = local *FH;
        socket($unix,AF_UNIX,SOCK_STREAM,PF_UNSPEC)
          && bind($unix,sockaddr_un $host)
          && listen($unix,5)
            or die __"unable to create listening unix socket: $!\n";
        slog __"accepting connections in $host";
        vec($rm,fileno($unix),1)=1;
     } else {
        $host=~s{^tcp/}{};
        my($host,$port)=split /:/,$host;
        $port=$Gimp::Net::default_tcp_port unless $port;
        $tcp = local *FH;
        socket($tcp,PF_INET,SOCK_STREAM,scalar getprotobyname('tcp') || 6)
           && setsockopt($tcp,SOL_SOCKET,SO_REUSEADDR,1)
           && bind($tcp,sockaddr_in $port,INADDR_ANY)
           && listen($tcp,5)
             or die __"unable to create listening tcp socket: $!\n";
        slog __"accepting connections on port $port";
        vec($rm,fileno($tcp),1)=1;
     }
  } else {
     if ($use_unix) {
        unlink $unix_path;
        rmdir $Gimp::Net::default_unix_dir;
        mkdir $Gimp::Net::default_unix_dir,0700 or die "$!";
        $unix = local *FH;
        socket($unix,AF_UNIX,SOCK_STREAM,PF_UNSPEC)
           && bind($unix,sockaddr_un $unix_path)
           && listen($unix,5)
             or die __"unable to create listening unix socket: $!\n";
        slog __"accepting connections on $unix_path";
        vec($rm,fileno($unix),1)=1;
     }
     if ($use_tcp && $auth) {
        $tcp = local *FH;
        socket($tcp,PF_INET,SOCK_STREAM,scalar getprotobyname('tcp') || 6)
           && setsockopt($tcp,SOL_SOCKET,SO_REUSEADDR,1)
           && bind($tcp,sockaddr_in $Gimp::Net::default_tcp_port,INADDR_ANY)
           && listen($tcp,5)
             or die __"unable to create listening tcp socket: $!\n";
        slog __"accepting connections on port $Gimp::Net::default_tcp_port";
        vec($rm,fileno($tcp),1)=1;
    }
  }
  
  !$tcp || $auth or die __"authorization required for tcp connections";
  
  sub new_connection {
     my $fh = shift;
     select $fh; $|=1; select STDOUT;
     $handles{fileno($fh)}=$fh;
     my @r = ("PERL-SERVER",$Gimp::_PROT_VERSION);
     push(@r,"AUTH") if $auth;
     reply $fh,@r;
     vec($rm,fileno($fh),1)=1;
     $stats{fileno($fh)}=[0,time];
  }

  while(!$server_quit) {
    if(select($r=$rm,undef,undef,undef)>0) {
      if ($tcp && vec($r,fileno($tcp),1)) {
        my $h = local *FH;
        my ($port,$host) = sockaddr_in (accept ($h,$tcp)) or die __"unable to accept tcp connection: $!\n";
        new_connection($h);
        slog __"accepted tcp connection from ",inet_ntoa($host),":$port";
      }
      if ($unix && vec($r,fileno($unix),1)) {
        my $h = local *FH;
        accept ($h,$unix) or die __"unable to accept unix connection: $!\n";
        new_connection($h);
        slog __"accepted unix connection";
      }
      for $f (keys(%handles)) {
        if(vec($r,$f,1)) {
          $fh=$handles{$f};
          if(handle_request($fh)) {
            $stats{$f}[0]++;
          } else {
            slog sprintf __"closing connection %d (%d requests in %g seconds)", $f, $stats{$f}[0], time-$stats{$f}[1];
            if ($exclusive) {
               $rm = $saved_rm;
               $exclusive = 0;
               slog __"WARNING: client disconnected while holding an active lock\n";
            }
            vec($rm,$f,1)=0;
            delete $handles{$f};
            undef $fh;
          }
          last; # this is because the client might have called lock()
        }
      }
    }
  }
  
  slog __"server going down...";
  if ($use_tcp) {
    undef $tcp;
  }
  if ($use_unix) {
    undef $unix;
    unlink $unix_path;
    rmdir $Gimp::Net::default_unix_dir;
  }
}

Gimp::register_callback extension_perl_server => \&extension_perl_server;

Gimp::on_query {
   Gimp->install_procedure("extension_perl_server", "Start the Gimp-Perl Server",
                           "This is the server for plug-ins written using the Gimp::Net module",
                           "Marc Lehmann <pcg\@goof.com>", "Marc Lehmann", "1999-12-02",
                           N_"<Toolbox>/Xtns/Perl/Server", undef, &Gimp::EXTENSION,
                           [
                            [&Gimp::PDB_INT32, "run_mode", "Interactive, [non-interactive]"],
                            [&Gimp::PDB_INT32, "flags", "internal flags (must be 0)"],
                            [&Gimp::PDB_INT32, "extra", "multi-purpose ;)"],
                           ],[]);

   Gimp->install_procedure("gimp_procedural_db_constant_register", "Register a plug-in specific integer constant",
                           "Plug-ins should register their custom constants using this function, so".
                           "other plug-ins (notably script-languages) can access these using symbolic names",
                           "Marc Lehmann <pcg\@goof.com>", "Marc Lehmann", "1999-07-07",
                           undef, undef, &Gimp::EXTENSION,
                           [
                            [&Gimp::PDB_STRING, "procedure", "The name of the function that uses this constant"],
                            [&Gimp::PDB_STRING, "arg_num", "The name of the argument that this constant is used for"],
                            [&Gimp::PDB_STRING, "constant_name", "The name of the constant, should be all-uppercase"],
                            [&Gimp::PDB_INT32,  "constant_value", "The (integer) value for this constant"],
                           ],[]);
   Gimp->install_procedure("gimp_procedural_db_set_default", "Set the default value for a plug-in argument",
                           "Plug-ins should register default values for their arguments",
                           "Marc Lehmann <pcg\@goof.com>", "Marc Lehmann", "1999-07-07",
                           undef, undef, &Gimp::EXTENSION,
                           [
                            [&Gimp::PDB_STRING, "procedure", "The name of the function that uses this constant"],
                            [&Gimp::PDB_STRING, "arg_num", "The name of the argument that this constant is used for"],
                            [&Gimp::PDB_INT32,  "default_value", "The default value for this constant"],
                           ],[]);
};

exit Gimp::main;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)