#
# This package is loaded by the Gimp, and is !private!, so don't
# use it standalone, it won't work.
#
package Gimp::Net;

use strict 'vars';
use vars qw(
   $VERSION
   $default_tcp_port $default_unix_dir $default_unix_sock
   $server_fh $trace_level $trace_res $auth $gimp_pid
);
use subs qw(gimp_call_procedure);
use base qw(DynaLoader);

use Socket; # IO::Socket is _really_ slow, so don't use it!

use Gimp ('croak','__');
use Fcntl qw(F_SETFD);

require DynaLoader;

$VERSION = 1.21;

bootstrap Gimp::Net $VERSION;

$default_tcp_port  = 10009;
$default_unix_dir  = "/tmp/gimp-perl-serv-uid-$>/";
$default_unix_sock = "gimp-perl-serv";

$trace_res = *STDERR;
$trace_level = 0;

my $initialized = 0;

sub initialized { $initialized }

sub import {
   my $pkg = shift;

   return if @_;

   # overwrite some destroy functions
   *Gimp::Tile::DESTROY=
   *Gimp::PixelRgn::DESTROY=
   *Gimp::GDrawable::DESTROY=sub {
      my $req="DTRY".args2net(0,@_);
      print $server_fh pack("N",length($req)).$req;

      # make this synchronous to avoid deadlock due to using non sys*-type functions
      my $len;
      read($server_fh,$len,4) == 4 or die "protocol error (11)";
   };
}

sub _gimp_procedure_available {
   my $req="TEST".$_[0];
   print $server_fh pack("N",length($req)).$req;
   read($server_fh,$req,1);
   return $req;
}

# this is hardcoded into gimp_call_procedure!
sub response {
   my($len,$req);
   read($server_fh,$len,4) == 4 or die "protocol error (1)";
   $len=unpack("N",$len);
   read($server_fh,$req,$len) == $len or die "protocol error (2)";
   net2args(0,$req);
}

# this is hardcoded into gimp_call_procedure!
sub command {
   my $req=shift;
   $req.=args2net(0,@_);
   print $server_fh pack("N",length($req)).$req;
}

my($len,@args,$trace,$req); # small speedup, these are really local to gimp_call_procedure

sub gimp_call_procedure {
   if ($trace_level) {
      $req="TRCE".args2net(0,$trace_level,@_);
      print $server_fh pack("N",length($req)).$req;
      do {
         read($server_fh,$len,4) == 4 or die "protocol error (3)";
         $len=unpack("N",$len);
         read($server_fh,$req,abs($len)) == $len or die "protocol error (4)";
         if ($len<0) {
            ($req,@args)=net2args(0,$req);
            print "ignoring callback $req\n";
            redo;
         }
         ($trace,$req,@args)=net2args(0,$req);
         if (ref $trace_res eq "SCALAR") {
            $$trace_res = $trace;
         } else {
            print $trace_res $trace;
         }
      } while 0;
   } else {
      $req="EXEC".args2net(0,@_);
      print $server_fh pack("N",length($req)).$req;
      do {
         read($server_fh,$len,4) == 4 or die "protocol error (5)";
         $len=unpack("N",$len);
         read($server_fh,$req,abs($len)) == $len or die "protocol error (6)";
         if ($len<0) {
            ($req,@args)=net2args(0,$req);
            print "ignoring callback $req\n";
            redo;
         }
         ($req,@args)=net2args(0,$req);
      } while 0;
   }
   croak $req if $req;
   wantarray ? @args : $args[0];
}

sub server_quit {
   print $server_fh pack("N",4)."QUIT";
   undef $server_fh;
}

sub lock {
   print $server_fh pack("N",12)."LOCK".pack("N*",1,0);
}

sub unlock {
   print $server_fh pack("N",12)."LOCK".pack("N*",0,0);
}

sub set_trace {
   my($trace)=@_;
   my $old_level = $trace_level;
   if(ref $trace) {
      $trace_res=$trace;
   } elsif (defined $trace) {
      $trace_level=$trace;
   }
   $old_level;
}

sub start_server {
   my $opt = shift;
   $opt = $Gimp::spawn_opts unless $opt;
   print __"trying to start gimp with options \"$opt\"\n" if $Gimp::verbose;
   $server_fh=local *SERVER_FH;
   my $gimp_fh=local *CLIENT_FH;
   socketpair $server_fh,$gimp_fh,AF_UNIX,SOCK_STREAM,PF_UNSPEC
      or socketpair $server_fh,$gimp_fh,AF_LOCAL,SOCK_STREAM,PF_UNSPEC
      or croak __"unable to create socketpair for gimp communications: $!";

   # do it here so it i done only once
   require Gimp::Config;
   $gimp_pid = fork;
   if ($gimp_pid > 0) {
      Gimp::ignore_functions(@Gimp::gimp_gui_functions) unless $opt=~s/(^|:)gui//;
      return $server_fh;
   } elsif ($gimp_pid == 0) {
      close $server_fh;
      fcntl $gimp_fh, F_SETFD, 0;
      delete $ENV{GIMP_HOST};
      unless ($Gimp::verbose) {
         open STDIN,"</dev/null";
         open STDOUT,">/dev/null";
         open STDERR,">&1";
      }
      my @args;
      my $args = &Gimp::RUN_NONINTERACTIVE." ".
                 (&Gimp::_PS_FLAG_BATCH | &Gimp::_PS_FLAG_QUIET)." ".
                 fileno($gimp_fh);
      push(@args,"--no-data") if $opt=~s/(^|:)no-?data//;
      push(@args,"-i") unless $opt=~s/(^|:)gui//;
      push(@args,"--verbose") if $Gimp::verbose;
      { # block to suppress warning with broken perls (e.g. 5.004)
         exec $Gimp::Config{GIMP},
              "--no-splash",
              "--no-splash-image",
              "--enable-stack-trace", "never",
              "--console-messages",
              @args,
              "-b",
              "(extension-perl-server $args)",
              "(gimp-quit 0)";
      }
      exit(255);
   } else {
      croak __"unable to fork: $!";
   }
}

sub try_connect {
   local $_=$_[0];
   my $fh;
   $auth = s/^(.*)\@// ? $1 : "";	# get authorization
   if ($_ ne "") {
      if (s{^spawn/}{}) {
         return start_server($_);
      } elsif (s{^unix/}{/}) {
         my $server_fh=local *FH;
         return ((socket($server_fh,AF_UNIX,SOCK_STREAM,PF_UNSPEC)
                 || socket $server_fh,AF_LOCAL,SOCK_STREAM,PF_UNSPEC)
                && connect($server_fh,sockaddr_un $_)
                ? $server_fh : ());
      } else {
         s{^tcp/}{};
         my($host,$port)=split /:/,$_;
         $port=$default_tcp_port unless $port;
         my $server_fh=local *FH;
         return socket($server_fh,PF_INET,SOCK_STREAM,scalar getprotobyname('tcp') || 6)
                && connect($server_fh,sockaddr_in $port,inet_aton $host)
                ? $server_fh : ();
      }
   } else {
      return $fh if $fh = try_connect ("$auth\@unix$default_unix_dir$default_unix_sock");
      return $fh if $fh = try_connect ("$auth\@tcp/127.1:$default_tcp_port");
      return $fh if $fh = try_connect ("$auth\@spawn/");
   }
   undef $auth;
}

sub gimp_init {
   $Gimp::in_top=1;
   if (@_) {
      $server_fh = try_connect ($_[0]);
   } elsif (defined($Gimp::host)) {
      $server_fh = try_connect ($Gimp::host);
   } elsif (defined($ENV{GIMP_HOST})) {
      $server_fh = try_connect ($ENV{GIMP_HOST});
   } else {
      $server_fh = try_connect ("");
   }
   defined $server_fh or croak __"could not connect to the gimp server (make sure Perl-Server is running)";
   { my $fh = select $server_fh; $|=1; select $fh }
   
   my @r = response;
   
   die __"expected perl-server at other end of socket, got @r\n"
      unless $r[0] eq "PERL-SERVER";
   shift @r;
   die __"expected protocol version $Gimp::_PROT_VERSION, but server uses $r[0]\n"
      unless $r[0] eq $Gimp::_PROT_VERSION;
   shift @r;
   
   for(@r) {
      if($_ eq "AUTH") {
         die __"server requests authorization, but no authorization available\n"
            unless $auth;
         my $req = "AUTH".$auth;
         print $server_fh pack("N",length($req)).$req;
         my @r = response;
         die __"authorization failed: $r[1]\n" unless $r[0];
         print __"authorization ok, but: $r[1]\n" if $Gimp::verbose and $r[1];
      }
   }

   $initialized = 1;
   Gimp::_initialized_callback;
}

sub gimp_end {
   $initialized = 0;

   #close $server_fh if $server_fh;
   undef $server_fh;
   kill 'KILL',$gimp_pid if $gimp_pid;
   undef $gimp_pid;
}

sub gimp_main {
   gimp_init;
   no strict 'refs';
   $Gimp::in_top=0;
   eval { Gimp::callback("-net") };
   if($@ && $@ ne "IGNORE THIS MESSAGE\n") {
      Gimp::logger(message => substr($@,0,-1), fatal => 1, function => 'DIE');
      gimp_end;
      -1;
   } else {
      gimp_end;
      0;
   }
}

sub get_connection() {
   [$server_fh,$gimp_pid];
}

sub set_connection($) {
   ($server_fh,$gimp_pid)=@{+shift};
}

END {
   gimp_end;
}

1;
__END__

=head1 NAME

Gimp::Net - Communication module for the gimp-perl server.

=head1 SYNOPSIS

  use Gimp;

=head1 DESCRIPTION

For Gimp::Net (and thus commandline and remote scripts) to work, you first have to
install the "Perl-Server" extension somewhere where Gimp can find it (e.g in
your .gimp/plug-ins/ directory). Usually this is done automatically while installing
the Gimp extension. If you have a menu entry C<<Xtns>/Perl-Server>
then it is probably installed.

The Perl-Server can either be started from the C<<Xtns>> menu in Gimp, or automatically
when a perl script can't find a running Perl-Server.

When started from within The Gimp, the Perl-Server will create a unix
domain socket to which local clients can connect. If an authorization
password is given to the Perl-Server (by defining the environment variable
C<GIMP_HOST> before starting The Gimp), it will also listen on a tcp port
(default 10009). Since the password is transmitted in cleartext, using the
Perl-Server over tcp effectively B<lowers the security of your network to
the level of telnet>. Even worse: the current Gimp::Net-protocol can be
used for denial of service attacks, i.e. crashing the Perl-Server. There
also *might* be buffer-overflows (although I do care a lot for these).

=head1 ENVIRONMENT

The environment variable C<GIMP_HOST> specifies the default server to
contact and/or the password to use. The syntax is
[auth@][tcp/]hostname[:port] for tcp, [auth@]unix/local/socket/path for unix
and spawn/ for a private gimp instance. Examples are:

 www.yahoo.com               # just kidding ;)
 yahoo.com:11100             # non-standard port
 tcp/yahoo.com               # make sure it uses tcp
 authorize@tcp/yahoo.com:123 # full-fledged specification
 
 unix/tmp/unx                # use unix domain socket
 password@unix/tmp/test      # additionally use a password
 
 authorize@                  # specify authorization only
 
 spawn/                      # use a private gimp instance
 spawn/nodata                # pass --no-data switch
 spawn/gui                   # don't pass -n switch

=head1 CALLBACKS

=over 4

=item net()

is called after we have succesfully connected to the server. Do your dirty
work in this function, or see L<Gimp::Fu> for a better solution.

=back

=head1 FUNCTIONS

=over 4

=item server_quit()

sends the perl server a quit command.

=item get_connection()

return a connection id which uniquely identifies the current connection.

=item set_connection(conn_id)

set the connection to use on subsequent commands. C<conn_id> is the
connection id as returned by get_connection().

=back

=head1 BUGS

(Ver 0.04) This module is much faster than it ought to be... Silly that I wondered
wether I should implement it in perl or C, since perl is soo fast.

=head1 AUTHOR

Marc Lehmann <pcg@goof.com>

=head1 SEE ALSO

perl(1), L<Gimp>.

=cut