mirror of https://github.com/GNOME/gimp.git
353 lines
12 KiB
Perl
Executable File
353 lines
12 KiB
Perl
Executable File
#!/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);
|
|
# the '' might be required (i.e. no ()). why??
|
|
use Gimp ();
|
|
use Gimp::Net ();
|
|
|
|
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 "\n" };
|
|
#alarm(6) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
|
|
read($fh,$length,4) == 4 or die "\n";
|
|
$length=unpack("N",$length);
|
|
$length>0 && $length<$max_pkt or die "\n";
|
|
#alarm(6) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
|
|
read($fh,$req,4) == 4 or die "\n";
|
|
#alarm(20) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
|
|
read($fh,$data,$length-4) == $length-4 or die "\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;
|
|
} 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)
|
|
&& bind($tcp,sockaddr_in $port,INADDR_ANY)
|
|
&& setsockopt($tcp,SOL_SOCKET,SO_REUSEADDR,1)
|
|
&& 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)
|
|
&& bind($tcp,sockaddr_in $Gimp::Net::default_tcp_port,INADDR_ANY)
|
|
&& setsockopt($tcp,SOL_SOCKET,SO_REUSEADDR,1)
|
|
&& 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 "closing connection ",$f," ($stats{$f}[0] requests in ",time-$stats{$f}[1]," seconds)";
|
|
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;
|
|
}
|
|
}
|
|
|
|
sub 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", "1998-07-22",
|
|
"<Toolbox>/Xtns/Perl/Server", "*",&Gimp::PROC_EXTENSION,
|
|
[
|
|
[&Gimp::PARAM_INT32, "run_mode", "Interactive, [non-interactive]"],
|
|
[&Gimp::PARAM_INT32, "flags", "internal flags (must be 0)"],
|
|
[&Gimp::PARAM_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, "*",&Gimp::PROC_EXTENSION,
|
|
[
|
|
[&Gimp::PARAM_STRING, "procedure", "The name of the function that uses this constant"],
|
|
[&Gimp::PARAM_STRING, "arg_num", "The name of the argument that this constant is used for"],
|
|
[&Gimp::PARAM_STRING, "constant_name", "The name of the constant, should be all-uppercase"],
|
|
[&Gimp::PARAM_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, "*",&Gimp::PROC_EXTENSION,
|
|
[
|
|
[&Gimp::PARAM_STRING, "procedure", "The name of the function that uses this constant"],
|
|
[&Gimp::PARAM_STRING, "arg_num", "The name of the argument that this constant is used for"],
|
|
[&Gimp::PARAM_INT32, "default_value", "The default value for this constant"],
|
|
],[]);
|
|
}
|
|
|
|
sub quit {
|
|
}
|
|
|
|
exit &Gimp::main;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|