From 9bccbdff05bf4fc25cc13ded0117fb9a8aee0803 Mon Sep 17 00:00:00 2001 From: Marc Lehmann Date: Thu, 28 Oct 1999 22:47:12 +0000 Subject: [PATCH] Remove, add, etc... --- plug-ins/perl/Net/Net.pm | 385 --------------------------------------- 1 file changed, 385 deletions(-) delete mode 100644 plug-ins/perl/Net/Net.pm diff --git a/plug-ins/perl/Net/Net.pm b/plug-ins/perl/Net/Net.pm deleted file mode 100644 index fd1fd814cd..0000000000 --- a/plug-ins/perl/Net/Net.pm +++ /dev/null @@ -1,385 +0,0 @@ -# -# 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','__'); - -require DynaLoader; - -$VERSION = 1.15; - -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; - }; -} - -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; -} - -sub gimp_call_procedure { - my($len,@args,$trace,$req); - - 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; - delete $ENV{GIMP_HOST}; - unless ($Gimp::verbose) { - open STDIN,"/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,"-n") 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", - @args, - "-b", - "(extension-perl-server $args)", - "(gimp_quit 0)", - "(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,PF_UNIX,SOCK_STREAM,AF_UNIX) - && 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</Perl-Server> -then it is probably installed. - -The Perl-Server can either be started from the C<> 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 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. 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 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 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 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 - -=head1 SEE ALSO - -perl(1), L. - -=cut