Commit 12cd1a5c authored by Marc Lehmann's avatar Marc Lehmann
Browse files

see plug-ins/perl/Changes

parent a4fd7b62
......@@ -14,6 +14,16 @@ Revision history for Gimp-Perl extension.
system without authorization. argh). This required a
protocol change, so old clients are unable to connect using
password-authenticitation.
- new function Gimp::initialized that returns true whenever its
safe to call gimp functins.
- added the Gimp::Feature module, allowing for easy feature checks.
See examples/gimpmagick or examples/parasite-editor for example
usage.
- added perlcc, the perl control center. Only displays log messages
at the moment.
- Data::Dumper is now longer required to run the scripts, some
buttons and RUN_WITH_LAST_VALS won't work, though.
- removed POSIX dependency in examples/gimpmagick.
1.06 Sat Mar 6 19:36:12 CET 1999
- Gimp::Fu does no longer display the returned image when it
......
......@@ -152,7 +152,7 @@ sub import($;@) {
my $pkg = shift;
my $up = caller();
my @export;
# make a quick but dirty guess ;)
@_=qw(main xlfd_size :auto) unless @_;
......@@ -192,6 +192,13 @@ sub xlfd_size($) {
: ($pt*0.1,&Gimp::POINTS);
}
# internal utility function for Gimp::Fu and others
sub wrap_text {
my $x=$_[0];
$x=~s/(\G.{1,$_[1]})(\s+|$)/$1\n/g;
$x;
}
my %rgb_db;
my $rgb_db_path;
......@@ -261,6 +268,30 @@ EOF
}
}
my @log;
sub _initialized_callback {
if (@log) {
Gimp->_gimp_append_data ('gimp-perl-log', map join("\1",@$_)."\0",@log);
@log=();
}
}
# message
# function
# fatal
sub logger {
my %args = @_;
my $file=$0;
$file=~s/^.*[\\\/]//;
$args{message} = "unknown message" unless defined $args{message};
$args{function} = "" unless defined $args{function};
$args{fatal} = 1 unless defined $args{fatal};
print STDERR "$file: $args{message} (for function $args{function})\n" if $verbose || $interface_type eq 'net';
push(@log,[$file,@args{'function','message','fatal'}]);
_initialized_callback if initialized();
}
if ($interface_type=~/^lib$/i) {
$interface_pkg="Gimp::Lib";
} elsif ($interface_type=~/^net$/i) {
......@@ -273,7 +304,7 @@ eval "require $interface_pkg" or croak "$@";
$interface_pkg->import;
# create some common aliases
for(qw(_gimp_procedure_available gimp_call_procedure set_trace)) {
for(qw(_gimp_procedure_available gimp_call_procedure set_trace initialized)) {
*$_ = \&{"${interface_pkg}::$_"};
}
......@@ -430,7 +461,9 @@ package Gimp; # for __DATA__
Gimp - Perl extension for writing Gimp Extensions/Plug-ins/Load & Save-Handlers
This is mostly a reference manual. For a quick intro, look at L<Gimp::Fu>.
This is mostly a reference manual. For a quick intro, look at
L<Gimp::Fu>. For more information, including tutorials, look at the
Gimp-Perl pages at http://gimp.pages.de.
=head1 RATIONALE
......@@ -791,6 +824,11 @@ invocation.
write trace to FILEHANDLE instead of STDERR.
=item initialized ()
this function returns true whenever it is safe to clal gimp functions. This is
usually only the case after gimp_main or gimp_init have been called.
=back
=head1 SUPPORTED GIMP DATA TYPES
......@@ -839,12 +877,12 @@ Marc Lehmann <pcg@goof.com>
=head1 SEE ALSO
perl(1), gimp(1), L<Gimp::OO>, L<Gimp::Data>, L<Gimp::Pixel>, L<Gimp::PDL>, L<Gimp::UI>, L<Gimp::Net> and L<Gimp::Lib>.
perl(1), gimp(1), L<Gimp::OO>, L<Gimp::Data>, L<Gimp::Pixel>, L<Gimp::PDL>, L<Gimp::Util>, L<Gimp::UI>, L<Gimp::Feature>, L<Gimp::Net>,
L<Gimp::Lib>, L<scm2perl> and L<scm2scm>.
=cut
__DATA__
! $XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp $
255 250 250 snow
248 248 255 ghost white
248 248 255 GhostWhite
......
......@@ -33,6 +33,9 @@ extern "C" {
# define GIMP_PARASITE 1
#endif
/* expect iso-c here. */
#include <signal.h>
/* Shamelesssly stolen from IO.xs. See perlguts, this is only for
* 5.004 compatibility.
*/
......@@ -74,6 +77,18 @@ MODULE = Gimp PACKAGE = Gimp
PROTOTYPES: ENABLE
void
_exit()
CODE:
#ifdef HAVE__EXIT
_exit(0);
#elif defined(SIGKILL)
raise(SIGKILL);
#else
raise(9);
#endif
abort();
BOOT:
{
HV *stash = gv_stashpvn("Gimp", 4, TRUE);
......
package Gimp::Feature;
use Carp;
use Gimp ();
use base qw(Exporter);
require Exporter;
@EXPORT = ();
my($gtk,$gtk_10,$gtk_11);
sub _check_gtk {
return if defined $gtk;
eval { require Gtk }; $gtk = $@ eq "";
if ($gtk) {
$gtk_10 = (Gtk->major_version==1 && Gtk->minor_version==0);
$gtk_11 = (Gtk->major_version==1 && Gtk->minor_version>=1) || Gtk->major_version>1;
$gtk_12 = (Gtk->major_version==1 && Gtk->minor_version>=2) || Gtk->major_version>1;
}
}
my %description = (
'gtk' => 'the gtk perl module',
'gtk-1.1' => 'gtk+ version 1.1 or higher',
'gtk-1.2' => 'gtk+ version 1.2 or higher',
'gimp-1.1' => 'gimp version 1.1 or higher',
'gimp-1.2' => 'gimp version 1.2 or higher',
'perl-5.005' => 'perl version 5.005 or higher',
'pdl' => 'PDL (the Perl Data Language), version 1.9906 or higher',
'gnome' => 'the gnome perl module',
'gtkxmhtml' => 'the Gtk::XmHTML module',
);
# calm down the gimp module
sub net {}
sub query {}
sub import {
my $pkg = shift;
my $feature;
while(@_) {
$_=shift;
s/^:// and need($_);
}
}
sub missing {
my ($msg,$function)=@_;
Gimp::logger(message => "$_[0] is required but not found", function => $function);
}
sub need {
my ($feature,$function)=@_;
unless (present($feature)) {
missing($description{$feature},$function);
Gimp::initialized() ? die "BE QUIET ABOUT THIS DIE\n" : exit eval { Gimp::main() };
}
}
sub describe {
$description{$_[0]};
}
sub Gimp::Feature::list {
keys %description;
}
sub present {
$_ = shift;
if ($_ eq "gtk") {
_check_gtk; $gtk;
} elsif ($_ eq "gtk-1.1") {
_check_gtk; $gtk_11;
} elsif ($_ eq "gtk-1.2") {
_check_gtk; $gtk_11;
} elsif ($_ eq "gimp-1.1") {
(Gimp->major_version==1 && Gimp->minor_version>=1) || Gimp->major_version>1;
} elsif ($_ eq "gimp-1.2") {
(Gimp->major_version==1 && Gimp->minor_version>=2) || Gimp->major_version>1;
} elsif ($_ eq "perl-5.005") {
$] >= 5.005;
} elsif ($_ eq "pdl") {
eval { require PDL }; $@ eq "" && $PDL::VERSION>=1.9906;
} elsif ($_ eq "gnome") {
eval { require Gnome }; $@ eq "";
} elsif ($_ eq "gtkxmhtml") {
eval { require Gtk::XmHTML }; $@ eq "";
}
}
1;
__END__
=head1 NAME
Gimp::Features - check for specific features to be present before registering the script.
=head1 SYNOPSIS
use Gimp::Features;
or
use Gimp::Features qw(:feature1 :feature2 ...);
=head1 DESCRIPTION
This module can be used to check for specific features to be present. This
can be used to deny running the script when neccessary features are not
present. While some features can be checked for at any time, the Gimp::Fu
module offers a nicer way to check for them.
=over 4
=item C<gtk>
checks for the presence of the gtk interface module.
=item C<gtk-1.1>, C<gtk-1.2>
checks for the presence of gtk-1.1 (1.2) or higher.
=item C<perl-5.005>
checks for perl version 5.005 or higher.
=item C<pdl>
checks for the presence of a suitable version of PDL (>=1.9906).
=item C<gnome>
checks for the presence of the Gnome-Perl module.
=item C<gtkxmhtl>
checks for the presence of the Gtk::XmHTML module.
=back
The following features can only be checked B<after> C<Gimp->main> has been
called (usually found in the form C<exit main>). See L<Gimp::Fu> on how to
check for these.
=over 4
=item C<gimp-1.1>, C<gimp-1.2>
checks for the presense of gimp in at least version 1.1 (1.2).
=back
=head2 FUNCTIONS
=over 4
=item present(feature)
=item need(feature,[function-name])
=item describe(feature)
=item missing(feature-description,[function-name])
=item list()
=back
=head1 AUTHOR
Marc Lehmann <pcg@goof.com>
=head1 SEE ALSO
perl(1), Gimp(1).
=cut
......@@ -7,13 +7,22 @@ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS
use Gimp qw(:param);
use Gimp::Data;
use File::Basename;
use Data::Dumper;
use base qw(Exporter);
require Exporter;
require DynaLoader;
require AutoLoader;
eval {
require Data::Dumperx;
import Data::Dumper;
};
if ($@) {
*Dumper = sub {
"()";
};
}
=cut
=head1 NAME
......@@ -130,12 +139,6 @@ sub import {
# the old value of the trace flag
my $old_trace;
sub wrap_text {
my $x=$_[0];
$x=~s/(\G.{$_[1]}\S*)\s+/$1\n/g;
$x;
}
sub _new_adjustment {
my @adj = eval { @{$_[1]} };
......@@ -155,6 +158,7 @@ sub _find_digits {
sub interact($$$@) {
local $^W=0;
my($function)=shift;
my($blurb)=shift;
my($help)=shift;
my(@types)=@{shift()};
......@@ -168,7 +172,10 @@ sub interact($$$@) {
require Gtk; import Gtk;
init Gtk; # gross hack...
};
die "The Gtk perl module is required to run perl-scripts in interactive mode!\n" if $@;
if ($@) {
Gimp::logger(message => 'the gtk perl module is required to run in interactive mode', function => $function);
die "The Gtk perl module is required to run this function ($function) in interactive mode!\n";
}
parse Gtk::Rc Gimp->gtkrc;
......@@ -183,7 +190,7 @@ sub interact($$$@) {
set_title $w $0;
my $h = new Gtk::HBox 0,2;
$h->add(new Gtk::Label wrap_text($blurb,40));
$h->add(new Gtk::Label Gimp::wrap_text($blurb,40));
$w->vbox->pack_start($h,1,1,0);
realize $w;
my $l = logo($w);
......@@ -412,8 +419,8 @@ sub interact($$$@) {
signal_connect $button "clicked", sub {
my $helpwin = new Gtk::Dialog;
set_title $helpwin $0;
$helpwin->vbox->add(new Gtk::Label "Blurb:\n".wrap_text($blurb,40)
."\n\nHelp:\n".wrap_text($help,40));
$helpwin->vbox->add(new Gtk::Label "Blurb:\n".Gimp::wrap_text($blurb,40)
."\n\nHelp:\n".Gimp::wrap_text($help,40));
my $button = new Gtk::Button "Close";
signal_connect $button "clicked",sub { hide $helpwin };
$helpwin->action_area->add($button);
......@@ -574,9 +581,20 @@ sub net {
sub query {
my($type);
script:
for(@scripts) {
my($function,$blurb,$help,$author,$copyright,$date,
$menupath,$imagetypes,$params,$results,$code)=@$_;
$menupath,$imagetypes,$params,$results,$features,$code)=@$_;
if(@$features) {
require Gimp::Feature;
for(@$features) {
unless (Gimp::Feature::present($_)) {
Gimp::Feature::missing(Gimp::Feature::describe($_),$function);
next script;
}
}
}
if ($menupath=~/^<Image>\//) {
$type=&Gimp::PROC_PLUG_IN;
......@@ -607,6 +625,8 @@ sub query {
$_;
} @$params],
$results);
Gimp::logger(message => 'OK', function => $function, fatal => 0);
}
}
......@@ -624,11 +644,12 @@ sub query {
[
[PF_TYPE,name,desc,optional-default,optional-extra-args],
[PF_TYPE,name,desc,optional-default,optional-extra-args],
etc...
# etc...
],
[
like above, but for return values
# like above, but for return values (optional)
],
['feature1', 'feature2'...], # optionally check for features
sub { code };
=over 2
......@@ -692,7 +713,13 @@ See the section PARAMETER TYPES for the supported types.
This is just like the parameter array, just that it describes the return
values. Of course, default values don't make much sense here. (Even if they
did, it's not implemented anyway..)
did, it's not implemented anyway..). This argument is optional.
=item the features requirements
See L<Gimp::Features> for a description of which features can be checked
for. This argument is optional (but remember to specify an empty return
value array, C<[]>, if you want to specify it).
=item the code
......@@ -803,10 +830,15 @@ commandline.
sub register($$$$$$$$$;@) {
no strict 'refs';
my($function,$blurb,$help,$author,$copyright,$date,
$menupath,$imagetypes,$params,$results,$code)=@_;
$menupath,$imagetypes,$params)=splice(@_,0,9);
my($results,$features,$code);
$code or ($results,$code)=([],$results);
$results = (ref $_[0] eq "ARRAY") ? shift : [];
$features = (ref $_[0] eq "ARRAY") ? shift : [];
$code = shift;
@_==0 or die "register called with too many or wrong arguments\n";
for my $p (@$params,@$results) {
int($p->[0]) eq $p->[0] or croak "Argument/return value '$p->[1]' has illegal type '$p->[0]'";
}
......@@ -842,12 +874,12 @@ sub register($$$$$$$$$;@) {
local $^W=0; # perl -w is braindamaged
my $VAR1; # Data::Dumper is braindamaged
# gimp is braindamaged, is doesn't deliver useful values!!
($res,@_)=interact($blurb,$help,$params,@{eval $Gimp::Data{"$function/_fu_data"}});
($res,@_)=interact($function,$blurb,$help,$params,@{eval $Gimp::Data{"$function/_fu_data"}});
return unless $res;
}
} elsif ($run_mode == &Gimp::RUN_FULLINTERACTIVE) {
my($res);
($res,@_)=interact($blurb,$help,[@image_params,@{$params}],[@pre,@_]);
($res,@_)=interact($function,$blurb,$help,[@image_params,@{$params}],[@pre,@_]);
undef @pre;
return unless $res;
} elsif ($run_mode == &Gimp::RUN_NONINTERACTIVE) {
......@@ -894,7 +926,7 @@ sub register($$$$$$$$$;@) {
wantarray ? @imgs : $imgs[0];
};
push(@scripts,[$function,$blurb,$help,$author,$copyright,$date,
$menupath,$imagetypes,$params,$results,$code]);
$menupath,$imagetypes,$params,$results,$features,$code]);
}
=cut
......
......@@ -12,6 +12,7 @@ $VERSION = $Gimp::VERSION;
use subs qw(
gimp_call_procedure gimp_main gimp_init
_gimp_procedure_available set_trace gimp_end
initialized
);
sub gimp_init {
......@@ -78,6 +79,11 @@ sub Gimp::PixelRgn::DESTROY {
if $self->dirty;
};
# this is here to be atomic over the perl-server
sub _gimp_append_data($$) {
gimp_set_data ($_[0], gimp_get_data ($_[0]) . $_[1]);
}
1;
__END__
......
......@@ -72,6 +72,9 @@ static char pkg_anyable[] = PKG_DRAWABLE ", " PKG_LAYER " or " PKG_CHANNEL;
static int trace = TRACE_NONE;
/* set when its safe to call gimp functions. */
static int gimp_is_initialized = 0;
typedef gint32 IMAGE;
typedef gint32 LAYER;
typedef gint32 CHANNEL;
......@@ -777,11 +780,13 @@ destroy_paramdefs (GParamDef *arg, int count)
/* first check wether the procedure exists at all. */
static void try_call (char *name, int req)
{
dSP;
CV *cv = perl_get_cv (name, 0);
PUSHMARK(sp); perl_call_pv ("Gimp::_initialized_callback", G_DISCARD | G_NOARGS);
/* it's not an error if the callback doesn't exist. */
if (cv) {
dSP;
PUSHMARK(sp);
perl_call_sv ((SV *)cv, G_DISCARD | G_NOARGS);
} else if (req)
......@@ -812,6 +817,8 @@ static void pii_run(char *name, int nparams, GParam *param, int *xnreturn_vals,
int _nparams;
GParamDef *params;
PUSHMARK(sp); perl_call_pv ("Gimp::_initialized_callback", G_DISCARD | G_NOARGS);
if (return_vals) /* the libgimp is soooooooo braindamaged. */
{
destroy_params (return_vals, nreturn_vals);
......@@ -862,7 +869,19 @@ static void pii_run(char *name, int nparams, GParam *param, int *xnreturn_vals,
}
if (SvTRUE (ERRSV))
err_msg = g_strdup (SvPV (ERRSV, dc));
{
if (strEQ ("BE QUIET ABOUT THIS DIE\n", SvPV (ERRSV, dc)))
{
nreturn_vals = 1;
return_vals = g_new (GParam, 1);
return_vals->type = PARAM_STATUS;
return_vals->data.d_status = STATUS_SUCCESS;
*xnreturn_vals = nreturn_vals;
*xreturn_vals = return_vals;
}
else
err_msg = g_strdup (SvPV (ERRSV, dc));
}
else
{
int i;
......@@ -1015,13 +1034,22 @@ gimp_main(...)
else
croak ("arguments to main not yet supported!");
gimp_is_initialized = 1;
RETVAL = gimp_main (argc, argv);
gimp_is_initialized = 0;
}
OUTPUT:
RETVAL
PROTOTYPES: ENABLE
int
initialized()
CODE:
RETVAL = gimp_is_initialized;
OUTPUT:
RETVAL
int
gimp_major_version()
CODE:
......
......@@ -22,8 +22,15 @@ $default_unix_sock = "gimp-perl-serv";
$trace_res = *STDERR;
$trace_level = 0;
my $initialized = 0;
sub initialized { $initialized }
sub import {
return if @_>1;
my $pkg = shift;
return if @_;
*Gimp::Tile::DESTROY=
*Gimp::PixelRgn::DESTROY=
*Gimp::GDrawable::DESTROY=sub {
......@@ -213,9 +220,14 @@ sub gimp_init {
print "authorization ok, but: $r[1]\n" if $Gimp::verbose and $r[1];
}
}
$initialized = 1;
Gimp::_initialized_callback;
}
sub gimp_end {
$initialized = 0;
undef $server_fh;
kill 'KILL',$gimp_pid if $gimp_pid;
undef $gimp_pid;
......@@ -241,16 +253,6 @@ END {
gimp_end;
}