mirror of
https://gitlab.gnome.org/GNOME/gimp
synced 2024-10-23 04:51:44 +00:00
337 lines
9.7 KiB
Perl
Executable file
337 lines
9.7 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 IO::Handle;
|
|
use IO::Socket;
|
|
|
|
use strict;
|
|
use vars qw($use_unix $use_tcp $trace_res $server_quit $max_pkt $unix $tcp $ps_flags
|
|
%object_dynamic $object_uid %objects $auth @authorized $exclusive
|
|
$rm $saved_rm);
|
|
# the '' might be required (i.e. no ())
|
|
use Gimp '';
|
|
use Gimp::Net qw(:server);
|
|
|
|
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";
|
|
}
|
|
|
|
# which objects are dynamic and mustn't be destroyed at will
|
|
%object_dynamic = (
|
|
'Gimp::Tile' => 1,
|
|
'Gimp::PixelRgn' => 1,
|
|
'Gimp::GDrawable' => 1,
|
|
);
|
|
|
|
$object_uid=0;
|
|
|
|
# convert objects to, well... networkable objects
|
|
sub deobjectify {
|
|
my(@args)=@_;
|
|
for(@args) {
|
|
if($object_dynamic{ref $_}) {
|
|
$objects{++$object_uid}=$_;
|
|
$_=bless \(my $x=$object_uid),ref $_;
|
|
}
|
|
}
|
|
@args;
|
|
}
|
|
|
|
# make real objects again
|
|
sub objectify {
|
|
my(@args)=@_;
|
|
for(@args) {
|
|
if($object_dynamic{ref $_}) {
|
|
$_=$objects{$$_};
|
|
}
|
|
}
|
|
@args;
|
|
}
|
|
|
|
sub destroy_objects {
|
|
delete @objects{map $$_,@_};
|
|
}
|
|
|
|
# this is hardcoded into handle_request!
|
|
sub reply {
|
|
my $fh=shift;
|
|
my $data=Gimp::Net::args2net(@_);
|
|
print $fh pack("N",length($data)).$data;
|
|
}
|
|
|
|
sub handle_request($) {
|
|
my($fh)=@_;
|
|
my($length,$req,$data,@args,$trace_level);
|
|
|
|
$fh->timeout(6) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
|
|
$fh->read($length,4) == 4 or return 0;
|
|
$length=unpack("N",$length);
|
|
$length>0 && $length<$max_pkt or return 0;
|
|
$fh->read($req,4) == 4 or return 0;
|
|
$fh->read($data,$length-4) == $length-4 or return 0;
|
|
|
|
if(!$auth or $authorized[fileno($fh)]) {
|
|
if($req eq "EXEC") {
|
|
no strict 'refs';
|
|
($req,@args)=Gimp::Net::net2args($data);
|
|
@args=deobjectify(eval { Gimp->$req(objectify(@args)) });
|
|
$data=Gimp::Net::args2net($@,@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") {
|
|
destroy_objects Gimp::Net::net2args($data);
|
|
} elsif($req eq "TRCE") {
|
|
no strict 'refs';
|
|
($trace_level,$req,@args)=Gimp::Net::net2args($data);
|
|
Gimp::set_trace($trace_level);
|
|
$trace_res="";
|
|
@args=deobjectify(eval { Gimp->$req(objectify(@args)) });
|
|
$data=Gimp::Net::args2net($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(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);
|
|
($req)=Gimp::Net::net2args($data);
|
|
if($req eq $auth) {
|
|
$ok=1;
|
|
$authorized[fileno($fh)]=1;
|
|
} else {
|
|
$ok=0;
|
|
$msg="wrong authorization, aborting connection";
|
|
slog $msg;
|
|
sleep 10; # safety measure
|
|
}
|
|
$data=Gimp::Net::args2net($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)=new_from_fd IO::Handle $extra,"r+";
|
|
$fh or die "unable to open Gimp::Net communications socket\n";
|
|
$fh->autoflush(1); # compatibility for old perls
|
|
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 = new IO::Socket::UNIX (Local => $host, Listen => 5) or die "$!";
|
|
slog "accepting connections in $host";
|
|
vec($rm,$unix->fileno,1)=1;
|
|
} else {
|
|
$host=~s{^tcp/}{};
|
|
my($host,$port)=split /:/,$host;
|
|
$port=$Gimp::Net::default_tcp_port unless $port;
|
|
$tcp = new IO::Socket::INET (LocalPort => $port, Listen => 5, Reuse => 1) or die "$!";
|
|
slog "accepting connections on port $port";
|
|
vec($rm,$tcp->fileno,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 = new IO::Socket::UNIX (Local => $unix_path, Listen => 5) or die "$!";
|
|
slog "accepting connections on $unix_path";
|
|
vec($rm,$unix->fileno,1)=1;
|
|
}
|
|
if ($use_tcp && $auth) {
|
|
$tcp = new IO::Socket::INET (LocalPort => $Gimp::Net::default_tcp_port, Listen => 5,
|
|
Reuse => 1) or die "$!";
|
|
slog "accepting connections on port $Gimp::Net::default_tcp_port";
|
|
vec($rm,$tcp->fileno,1)=1;
|
|
}
|
|
}
|
|
|
|
!$tcp || $auth or die "authorization required for tcp connections";
|
|
|
|
sub new_connection {
|
|
my $fh = shift;
|
|
$fh->autoflush (1); # for compatibility with old perls..
|
|
$handles{fileno($fh)}=$fh;
|
|
my @r = ("PERL-SERVER",$Gimp::_PROT_VERSION);
|
|
push(@r,"AUTH") if $auth;
|
|
reply $fh,@r;
|
|
vec($rm,$fh->fileno,1)=1;
|
|
}
|
|
|
|
while(!$server_quit) {
|
|
if(select($r=$rm,undef,undef,undef)>0) {
|
|
if ($tcp && vec($r,$tcp->fileno,1)) {
|
|
my $h=$tcp->accept;
|
|
new_connection($h);
|
|
slog("accepted tcp connection from ",$h->peerhost);
|
|
}
|
|
if ($unix && vec($r,$unix->fileno,1)) {
|
|
new_connection($unix->accept);
|
|
slog("accepted unix connection");
|
|
}
|
|
for $f (keys(%handles)) {
|
|
if(vec($r,$f,1)) {
|
|
$fh=$handles{$f};
|
|
unless(handle_request($fh)) {
|
|
slog "closing connection ",$f;
|
|
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 ;)"],
|
|
],[]);
|
|
}
|
|
|
|
sub quit {
|
|
}
|
|
|
|
exit &Gimp::main;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|