mirror of https://github.com/GNOME/gimp.git
see plug-ins/perl/Changes
This commit is contained in:
Marc Lehmann
parent
edda8d6b98
commit
05fd826e46
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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<options>
|
||||
|
||||
Set default spawn options to I<options>, see L<Gimp::Net>.
|
||||
|
||||
=back
|
||||
|
||||
The default (unless '' is specified) is C<main xlfd_size :consts>.
|
||||
|
|
|
|||
|
|
@ -85,6 +85,7 @@ sub present {
|
|||
MacOS => 1,
|
||||
MSWin32 => 1,
|
||||
os2 => 1,
|
||||
dos => 1,
|
||||
VMS => 1,
|
||||
}->{$^O};
|
||||
} elsif ($_ eq "never") {
|
||||
|
|
|
|||
|
|
@ -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<<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>.
|
||||
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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@ Gimp.pm
|
|||
Gimp.xs
|
||||
scm2perl
|
||||
scm2scm
|
||||
gimpdoc
|
||||
t/load.t
|
||||
t/loadlib.t
|
||||
t/run.t
|
||||
|
|
|
|||
|
|
@ -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" },
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue