diff --git a/plug-ins/perl/Changes b/plug-ins/perl/Changes index f18daeda9b..ef4517d273 100644 --- a/plug-ins/perl/Changes +++ b/plug-ins/perl/Changes @@ -1,13 +1,18 @@ Revision history for Gimp-Perl extension. -1.09 +1.09 Fri May 21 14:12:02 CEST 1999 + - added gimpdoc, a simple man-like help viewer. - corrected PDL version check to work with version 2.001. - - new file Net.xs, containing protocol serializer + - new file Net.xs, containing protocol serializer. - new, faster and leaner protocol (bumped protocol version number). - added SvPV_nolen to ppport.h and made use of it everywhere. - renamed nolib => Module. - streamlined warning messages as not to scare the people away. - fixed a bug in check_for_typoe (correct TRUE and FALSE). + - zero-copy piddle support should generally work now. Tile + functions and network support is still missing, but... + - experimental enhancements to the spawn/ hosttype. + - Gimp::Feature no longer counts dos as unix-like. 1.089 Tue May 18 19:55:25 CEST 1999 - added colourtoalpha. @@ -21,7 +26,7 @@ Revision history for Gimp-Perl extension. - re-added PARASITE_*-constants (including UNDOABLE variants). - temporarily disabled the module for political reasons. - made my first attempt at implementing XS-PDL support. - - transform obnjects ids of -1 into undef and vice versa. + - transform objects ids of -1 into undef and vice versa. - Gimp::Fu did not properly supply a default value for PF_COLOUR. 1.083 Wed May 12 03:36:10 CEST 1999 diff --git a/plug-ins/perl/Gimp.pm b/plug-ins/perl/Gimp.pm index a7937c9c00..ca4df99141 100644 --- a/plug-ins/perl/Gimp.pm +++ b/plug-ins/perl/Gimp.pm @@ -5,7 +5,7 @@ use Carp; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD %EXPORT_TAGS @EXPORT_FAIL @_consts @_procs $interface_pkg $interface_type @_param @_al_consts @PREFIXES $_PROT_VERSION - @gimp_gui_functions $function $basename + @gimp_gui_functions $function $basename $spawn_opts $in_quit $in_run $in_net $in_init $in_query $no_SIG $help $verbose $host); use subs qw(init end lock unlock canonicalize_color); @@ -120,6 +120,8 @@ sub import($;@) { push(@export,@_param); } elsif (/^interface=(\S+)$/) { croak "interface=... tag is no longer supported\n"; + } elsif ($_=~/spawn_options=(\S+)/) { + $spawn_opts = $1; } elsif ($_ ne "") { push(@export,$_); } elsif ($_ eq "") { @@ -202,6 +204,8 @@ sub canonicalize_colour { ($basename = $0) =~ s/^.*[\\\/]//; +$spawn_opts = ""; + # extra check for Gimp::Feature::import $in_query=0 unless defined $in_query; # perl -w is SOOO braindamaged $in_quit=$in_run=$in_net=$in_init=0; # perl -w is braindamaged @@ -575,6 +579,10 @@ Import PARAM_* constants (PARAM_INT32, PARAM_STRING etc.) only. All constants from gimpenums.h (BG_IMAGE_FILL, RUN_NONINTERACTIVE, NORMAL_MODE, PARAM_INT32 etc.). +=item spawn_options=I + +Set default spawn options to I, see L. + =back The default (unless '' is specified) is C
. diff --git a/plug-ins/perl/Gimp/Feature.pm b/plug-ins/perl/Gimp/Feature.pm index 912ab49c79..de4bd5235f 100644 --- a/plug-ins/perl/Gimp/Feature.pm +++ b/plug-ins/perl/Gimp/Feature.pm @@ -85,6 +85,7 @@ sub present { MacOS => 1, MSWin32 => 1, os2 => 1, + dos => 1, VMS => 1, }->{$^O}; } elsif ($_ eq "never") { diff --git a/plug-ins/perl/Gimp/Net.pm b/plug-ins/perl/Gimp/Net.pm index 0b6d84dbe7..359b9c2327 100644 --- a/plug-ins/perl/Gimp/Net.pm +++ b/plug-ins/perl/Gimp/Net.pm @@ -135,7 +135,9 @@ sub set_trace { } sub start_server { - print "trying to start gimp\n" if $Gimp::verbose; + my $opt = shift; + $opt = $Gimp::spawn_opts unless $opt; + print "trying to start gimp with options \"$opt\"\n" if $Gimp::verbose; $server_fh=local *FH; my $gimp_fh=local *FH; socketpair $server_fh,$gimp_fh,PF_UNIX,SOCK_STREAM,AF_UNIX @@ -159,8 +161,15 @@ sub start_server { fileno($gimp_fh); { # block to suppress warning with broken perls (e.g. 5.004) require Gimp::Config; + my @args; + push(@args,"--no-data") if $opt=~s/(^|:)no-?data//; + push(@args,"-n") unless $opt=~s/(^|:)gui//; + push(@args,"--verbose") if $Gimp::verbose; exec $Gimp::Config{GIMP_PATH}, - "-n","-b","(extension-perl-server $args)", + "--no-splash", + @args, + "-b", + "(extension-perl-server $args)", "(extension_perl_server $args)", "(gimp_quit 0)", "(gimp-quit 0)"; @@ -177,7 +186,7 @@ sub try_connect { $auth = s/^(.*)\@// ? $1 : ""; # get authorization if ($_ ne "") { if (s{^spawn/}{}) { - return start_server; + return start_server($_); } elsif (s{^unix/}{/}) { my $server_fh=local *FH; return socket($server_fh,PF_UNIX,SOCK_STREAM,AF_UNIX) @@ -295,13 +304,15 @@ 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. +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 @@ -321,6 +332,8 @@ and spawn/ for a private gimp instance. Examples are: 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 diff --git a/plug-ins/perl/MANIFEST b/plug-ins/perl/MANIFEST index 2f8b372725..35b77a5de8 100644 --- a/plug-ins/perl/MANIFEST +++ b/plug-ins/perl/MANIFEST @@ -13,6 +13,7 @@ Gimp.pm Gimp.xs scm2perl scm2scm +gimpdoc t/load.t t/loadlib.t t/run.t diff --git a/plug-ins/perl/Makefile.PL b/plug-ins/perl/Makefile.PL index 0fb1287ca4..a4eac1d8ab 100644 --- a/plug-ins/perl/Makefile.PL +++ b/plug-ins/perl/Makefile.PL @@ -283,7 +283,7 @@ WriteMakefile( 'LIBS' => [''], 'INC' => "$INC1 $GIMP_INC_NOUI $CPPFLAGS $CFLAGS", 'DEFINE' => "$DEFINE1 $DEFS", - 'EXE_FILES' => ['scm2perl','scm2scm'], + 'EXE_FILES' => ['scm2perl','scm2scm','gimpdoc'], 'macro' => \%cfg, 'realclean' => { FILES => "config.status config.cache config.log config.pl config.h Gimp/Config.pm" }, 'clean' => { FILES => "Makefile.old stamp-h" }, diff --git a/plug-ins/perl/Net/Net.xs b/plug-ins/perl/Net/Net.xs index 46b0dc6e39..f35b7dd4a9 100644 --- a/plug-ins/perl/Net/Net.xs +++ b/plug-ins/perl/Net/Net.xs @@ -37,18 +37,35 @@ static void need_pdl (void) #endif -#define is_dynamic(sv) \ - (sv_derived_from (sv, "Gimp::Tile") \ - || sv_derived_from (sv, "Gimp::PixelRgn") \ - || sv_derived_from (sv, "Gimp::GDrawable")) +#define is_dynamic(sv) \ + (strEQ ((sv), "Gimp::Tile") \ + || strEQ ((sv), "Gimp::PixelRgn") \ + || strEQ ((sv), "Gimp::GDrawable")) static GHashTable *object_cache; +static gint object_id = 1000; #define init_object_cache if (!object_cache) object_cache = g_hash_table_new (g_int_hash, g_int_equal) -static void destroy (gint id) +static void destroy_object (SV *sv) { - init_object_cache; + if (object_cache && sv_isobject (sv)) + { + if (is_dynamic (HvNAME(SvSTASH(SvRV(sv))))) + { + gint id = SvIV(SvRV(sv)); + SV *cv = (SV*)g_hash_table_lookup (object_cache, &id); + if (cv) + { + SvREFCNT_dec (cv); + g_hash_table_remove (object_cache, &id); + } + } + else + croak ("Internal error: Gimp::Net #101, please report!"); + } + else + croak ("Internal error: Gimp::Net #100, please report!"); } /* allocate this much as initial length */ @@ -83,9 +100,15 @@ static void sv2net (int deobjectify, SV *s, SV *sv) sv_catpvf (s, "b%x:%s", strlen (name), name); - if (is_dynamic (sv)) + if (deobjectify && is_dynamic (name)) { - //return; + object_id++; + + SvREFCNT_inc(sv); + g_hash_table_insert (object_cache, &object_id, (gpointer)sv); + + sv_catpvf (s, "i%d:", object_id); + return; /* well... */ } } else @@ -96,7 +119,7 @@ static void sv2net (int deobjectify, SV *s, SV *sv) AV *av = (AV*)rv; int i; - sv_catpvf (s, "a%x:", (int)av_len(av)); + sv_catpvf (s, "a%x:", (I32)av_len(av)); for (i = 0; i <= av_len(av); i++) sv2net (deobjectify, s, *av_fetch(av,i,0)); } @@ -130,6 +153,7 @@ static SV *net2sv (int objectify, char **_s) SV *sv; AV *av; unsigned int ui, n; + I32 i32,i33; long l; char str[64]; @@ -161,15 +185,30 @@ static SV *net2sv (int objectify, char **_s) memcpy (str, s, ui); s += ui; str[ui] = 0; - sv = sv_bless (newRV_noinc (net2sv (objectify, &s)), gv_stashpv (str, 1)); + + if (objectify && is_dynamic (str)) + { + gint id; + + sscanf (s, "i%ld:%n", &l, &n); s += n; + + sv = (SV*)g_hash_table_lookup (object_cache, (id=l,&id)); + if (!sv) + croak ("Internal error: asked to deobjectify an object not in the cache, please report!"); + } + else + sv = net2sv (objectify, &s); + + sv = sv_bless (newRV_noinc (sv), gv_stashpv (str, 1)); + break; case 'a': - sscanf (s, "%x:%n", &ui, &n); s += n; + sscanf (s, "%x:%n", &i32, &n); s += n; av = newAV (); - av_extend (av, ui); - for (n = 0; n <= ui; n++) - av_store (av, n, net2sv (objectify, &s)); + av_extend (av, i32); + for (i33 = 0; i33 <= i32; i33++) + av_store (av, i33, net2sv (objectify, &s)); sv = (SV*)av; break; @@ -201,7 +240,7 @@ args2net(deobjectify,...) for (index = 1; index < items; index++) sv2net (deobjectify, RETVAL, ST(index)); - /*printf (">>>>%s\n",SvPV_nolen(RETVAL));*/ + /*printf (">>>>%s\n",SvPV_nolen(RETVAL));*//*D*/ OUTPUT: RETVAL @@ -211,10 +250,18 @@ net2args(objectify,s) char * s PPCODE: - /*printf ("<<<<%s\n",s);*/ + /*printf ("<<<<%s\n",s);*//*D*/ if (objectify) init_object_cache; /* this depends on a trailing zero! */ while (*s) XPUSHs (sv_2mortal (net2sv (objectify, &s))); +void +destroy_objects(...) + CODE: + int index; + + for (index = 0; index < items; index++) + destroy_object (ST(index)); + diff --git a/plug-ins/perl/Perl-Server b/plug-ins/perl/Perl-Server index 36a5c0ff34..2a2b8706b3 100755 --- a/plug-ins/perl/Perl-Server +++ b/plug-ins/perl/Perl-Server @@ -13,8 +13,7 @@ use 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); + $auth @authorized $exclusive $rm $saved_rm %stats); # the '' might be required (i.e. no ()). why?? use Gimp (); use Gimp::Net (); @@ -56,47 +55,15 @@ sub slog { 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 $$_,@_}; + 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; + my $fh=shift; + my $data=Gimp::Net::args2net(0,@_); + print $fh pack("N",length($data)).$data; } sub handle_request($) { @@ -121,20 +88,20 @@ sub handle_request($) { if($req eq "EXEC") { no strict 'refs'; ($req,@args)=Gimp::Net::net2args(1,$data); - @args=deobjectify(eval { Gimp->$req(objectify(@args)) }); + @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") { - destroy_objects Gimp::Net::net2args(0,$data); + 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); + ($trace_level,$req,@args)=Gimp::Net::net2args 1,$data; Gimp::set_trace($trace_level); $trace_res=""; - @args=deobjectify(eval { Gimp->$req(objectify(@args)) }); + @args=eval { Gimp->$req(@args) }; $data=Gimp::Net::args2net(1,$trace_res,$@,@args); print $fh pack("N",length($data)).$data; Gimp::set_trace(0); @@ -283,6 +250,7 @@ sub extension_perl_server { push(@r,"AUTH") if $auth; reply $fh,@r; vec($rm,fileno($fh),1)=1; + $stats{fileno($fh)}=[0,time]; } while(!$server_quit) { @@ -302,8 +270,10 @@ sub extension_perl_server { for $f (keys(%handles)) { if(vec($r,$f,1)) { $fh=$handles{$f}; - unless(handle_request($fh)) { - slog "closing connection ",$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; diff --git a/plug-ins/perl/TODO b/plug-ins/perl/TODO index cda9598b41..53259f2cb0 100644 --- a/plug-ins/perl/TODO +++ b/plug-ins/perl/TODO @@ -10,6 +10,7 @@ make test TEST_VERBOSE=1 bugs + * don't start gimp in cmdline mode and error. * KILL :auto from default(!) * auto-flush of gdrawable when merge_shadow(?) * gimp-piddle must be written back automatically on destroy, if changed @@ -30,8 +31,9 @@ bugs important issues + * gimp_progress_done * pdb_proc_renameto - * gimp_progress_init (1 & 2 args) +[DONE] * gimp_progress_init (1 & 2 args) * gimp_default_display (...) for libgimp * Gimp::Module for modules (!) * gimp_progress_close @@ -49,18 +51,16 @@ important issues * --ui and --noui for Gimp::Fu * Gimp::ping * allow plug-ins to register with only a drawable argument(!) - (fix this in Gimp) * gradient button * implement Perl-Server RSET and shared lock(!) * use Gimp qw(GIMP_HOST=jfjf)??? [DONE] * zero-copy PDL support * weighted movement in drawing tools - * -DMIN_PERL_DEFINE +[KILL] * -DMIN_PERL_DEFINE * --function localfunc to select one of the registered scripts - * brush etc. buttons (maybe use gimp's interface, but - only when local(?)) +[DONE] * brush etc. buttons (maybe use gimp's interface, but only when local(?)) * create working progress when Net and $verbose - * require Storable soon(!) +[KILL] * require Storable soon(!) * Gimp::Fu::command(?) * default parameters at end(!) * try to deduce default parameters