[gimp-perl] Make Gimp::Fu scripts run right from command line. Bug 728545
- From: Ed J <edj src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [gimp-perl] Make Gimp::Fu scripts run right from command line. Bug 728545
- Date: Wed, 23 Apr 2014 05:13:01 +0000 (UTC)
commit 4e37f95941a8c341a8b6d69a9240b84a5b692ba1
Author: Ed J <m8r-35s8eo mailinator com>
Date: Sat Apr 19 07:37:34 2014 +0100
Make Gimp::Fu scripts run right from command line. Bug 728545
Gimp.pm | 43 ++++++++++++--
Gimp/Fu.pm | 132 +++++++++++++++++++++--------------------
MANIFEST | 1 +
Net/Net.pm | 6 +-
t/examples-api.pl | 168 +++++++++++++++++++++++++++++++++++++++++++++++++++++
t/netplugin.t | 79 +++++++++++++++++++++++++
t/supplied.t | 120 ++------------------------------------
7 files changed, 359 insertions(+), 190 deletions(-)
---
diff --git a/Gimp.pm b/Gimp.pm
index 3c76624..7213a1f 100644
--- a/Gimp.pm
+++ b/Gimp.pm
@@ -3,7 +3,7 @@ package Gimp;
use strict 'vars';
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD %EXPORT_TAGS @EXPORT_FAIL
$interface_pkg $interface_type
- @PREFIXES @GUI_FUNCTIONS
+ @PREFIXES
$function $basename $spawn_opts
$in_quit $in_run $in_net $in_init $in_query $no_SIG
$host $in_top);
@@ -24,10 +24,9 @@ BEGIN {
use Gimp::ColorDB;
use Carp qw(croak);
- GUI_FUNCTIONS = qw(
+our @GUI_FUNCTIONS = qw(
gimp_progress_init
gimp_progress_update
- gimp_displays_flush
gimp_display_new
gimp_display_delete
);
@@ -631,6 +630,40 @@ query) it will install temporary procedures.
If it has no parameters, then rather than being run when called, either
from a menu or a scripting interface, it is run at GIMP startup.
+An extension can receive and act on messages from GIMP, unlike a plugin,
+which can only initiate requests and get responses. This does mean the
+extension needs to fit in with GIMP's event loop (the L<Glib> event loop
+in fact - use this by using L<Gtk2>). This is easy. In its C<run> hook,
+the extension simply needs to run C<Gimp-E<gt>extension_ack> after it
+has initialised itself (including installing any temporary
+procedures). Then, if it wants to just respond to GIMP events:
+
+ # to deal only with GIMP events:
+ Gimp->extension_ack;
+ Gimp->extension_process(0) while 1;
+
+or also other event sources (including a GUI, or L<Glib::IO>):
+
+ # to deal with other events:
+ Gimp::gtk_init;
+ Gimp->extension_ack; # GIMP locks until this is done
+ Gimp->extension_enable; # adds a Glib handler for GIMP messages
+ my $tcp = IO::Socket::INET->new(
+ Type => SOCK_STREAM, LocalPort => $port, Listen => 5, ReuseAddr => 1,
+ ($host ? (LocalAddr => $host) : ()),
+ ) or die __"unable to create listening tcp socket: $!\n";
+ Glib::IO->add_watch(fileno($tcp), 'in', sub {
+ warn "$$-setup_listen_tcp WATCHER(@_)" if $Gimp::verbose;
+ my ($fd, $condition, $fh) = @_;
+ my $h = $fh->accept or die __"unable to accept tcp connection: $!\n";
+ my ($port,$host) = ($h->peerport, $h->peerhost);
+ new_connection($h);
+ slog __"accepted tcp connection from $host:$port";
+ &Glib::SOURCE_CONTINUE;
+ }, $tcp);
+ Gtk2->main; # won't return if GIMP quits, but
+ # GIMP will call your quit callback
+
A working, albeit trivial, example is provided in
examples/example-extension. A summarised example:
@@ -645,9 +678,7 @@ examples/example-extension. A summarised example:
[],
);
Gimp->extension_ack;
- while (1) {
- Gimp->extension_process(0);
- }
+ Gimp->extension_process(0) while 1;
};
Gimp::register_callback perl_fu_temp_demo => sub {
my ($run_mode) = @_;
diff --git a/Gimp/Fu.pm b/Gimp/Fu.pm
index 706f058..33d823a 100644
--- a/Gimp/Fu.pm
+++ b/Gimp/Fu.pm
@@ -70,7 +70,7 @@ my %pfname2info = (
PF_IMAGE => [ PF_IMAGE, 'image', ],
PF_LAYER => [ PF_LAYER, 'layer', ],
PF_CHANNEL => [ PF_CHANNEL, 'channel', ],
- PF_DRAWABLE => [ PF_DRAWABLE, 'drawable', ],
+ PF_DRAWABLE => [ PF_DRAWABLE, 'drawable (%number or %a = active)', ],
PF_COLORARRAY => [ PF_COLORARRAY, 'list of colours' ],
PF_VECTORS => [ PF_VECTORS, 'vectors' ],
PF_PARASITE => [ PF_PARASITE, 'parasite' ],
@@ -104,7 +104,7 @@ my @scripts;
# Some Standard Arguments
my @image_params = ([PF_IMAGE, "image", "Input image"],
- [PF_DRAWABLE, "drawable", "Input drawable"]);
+ [PF_DRAWABLE, "drawable", "Input drawable", '%a']);
my @load_params = ([PF_STRING, "filename", "Filename"],
[PF_STRING, "raw_filename", "User-given filename"]);
@@ -172,15 +172,38 @@ sub string2pf($$) {
Gimp::canonicalize_colour($s);
} elsif($pf2info{$type}->[0] eq 'boolean') {
$s?1:0;
- #} elsif($type == PF_IMAGE) {
+ } elsif($type == PF_IMAGE) {
+ my $image;
+ if ((my $arg) = $s =~ /%(.+)/) {
+ die "image % argument not integer - if file, put './' in front\n"
+ unless $arg eq int $arg;
+ $image = bless \$arg, 'Gimp::Image';
+ eval { $image->get_layers; };
+ die "'$arg' not a valid image - need to run Perl Server?\n" if $@;
+ } else {
+ $image = Gimp->file_load(Gimp::RUN_NONINTERACTIVE, $s, $s),
+ }
+ $latest_image = $image; # returned as well
+ } elsif($type == PF_DRAWABLE) {
+ if ((my $arg) = $s =~ /%(.+)/) {
+ if ($arg eq 'a') {
+ $latest_image->get_active_drawable;
+ } else {
+ # existing GIMP object - rely on autobless
+ die "drawable % argument not integer\n"
+ unless $arg eq int $arg;
+ $arg;
+ }
+ } else {
+ die "must specify drawable as %number or %a (active)\n";
+ }
+ } elsif($type == PF_GRADIENT) {
+ $s;
} else {
die __"conversion from string to type $pf2info{$type}->[0] is not yet implemented\n";
}
}
-# set options read from the command line
-my $outputfile;
-
# mangle argument switches to contain only a-z0-9 and the underscore,
# for easier typing.
sub mangle_key {
@@ -191,55 +214,54 @@ sub mangle_key {
}
Gimp::on_net {
- no strict 'refs';
+ require Getopt::Long;
my $this = this_script;
my(%mangleparam2index,@args);
- my $interact = 1;
- $outputfile = undef;
-
+ my ($interact, $outputfile) = 1;
my($perl_sub,$function,$blurb,$help,$author,$copyright,$date,
$menupath,$imagetypes,$params,$results,$code,$type)= $this;
-
@mangleparam2index{map mangle_key($_->[1]), @$params} = (0..$#{$params});
-
- # Parse the command line
- while(defined($_=shift @ARGV)) {
- if (/^-+(.*)$/) {
- if($1 eq "i" or $1 eq "interact") {
- $interact=1e6;
- } elsif($1 eq "o" or $1 eq "output") {
- $outputfile=shift @ARGV;
- } elsif($1 eq "info") {
- print __"no additional information available, use --help\n";
- exit 0;
- } else {
- my $arg=shift @ARGV;
- my $idx=$mangleparam2index{$1};
- die __"$_: illegal switch, try $0 --help\n" unless defined($idx);
- $args[$idx]=string2pf($arg,$params->[$idx]);
- $interact--;
- }
- } elsif (@args < @$params) {
- push(@args,string2pf($_,$params->[ args]));
- $interact--;
- } else {
- die __"too many arguments, use --help\n";
- }
- }
-
+ die "$0: error - try $0 --help\n" unless Getopt::Long::GetOptions(
+ 'interact|i' => sub { $interact = 1e6 },
+ 'output|o=s' => \$outputfile,
+ map {
+ ("$_=s"=>sub {$args[$mangleparam2index{$_[0]}] = $_[1]; $interact--;})
+ } keys %mangleparam2index,
+ );
+ die "$0: too many arguments. Try $0 --help\n" if @ARGV > @$params;
+ $interact -= @ARGV;
+ map { $args[$_] = $ARGV[$_] } (0..$#ARGV); # can mix & match --args and bare
# Fill in default arguments
foreach my $i (0 $params-1) {
next if defined $args[$i];
my $entry = $params->[$i];
- $args[$i] = $entry->[3]; # Default value
- die __"parameter '$entry->[1]' is not optional\n" unless defined $args[$i] || $interact>0;
+ $args[$i] = $entry->[3];
+ die __"parameter '$entry->[1]' is not optional\n"
+ unless defined $args[$i] or $interact>0;
}
-
- # Go for it
- $perl_sub->(
+ for my $i (0..$#args) { $args[$i] = string2pf($args[$i], $params->[$i]); }
+ my $input_image = $args[0] if ref $args[0] eq "Gimp::Image";
+ my @retvals = $perl_sub->(
($interact>0 ? RUN_FULLINTERACTIVE : Gimp::RUN_NONINTERACTIVE),
@args
);
+ if ($outputfile and $menupath !~ /^<Load>\//) {
+ my @images = grep { defined $_ and ref $_ eq "Gimp::Image" } @retvals;
+ if (@images) {
+ for my $i (0..$#images) {
+ my $path = sprintf $outputfile, $i;
+ if (@images > 1 and $path eq $outputfile) {
+ $path=~s/\.(?=[^.]*$)/$i./; # insert number before last dot
+ }
+ save_image($images[$i],$path);
+ $images[$i]->delete;
+ }
+ } elsif ($input_image) {
+ save_image($input_image, sprintf $outputfile, 0);
+ } else {
+ die "$0: outputfile specified but plugin returned no image and no input image\n";
+ }
+ }
};
sub datatype(@) {
@@ -338,7 +360,7 @@ sub register($$$$$$$$$;@) {
my $perl_sub = sub {
$run_mode = shift; # global!
- my(@pre,@defaults,@lastvals,$input_image);
+ my(@pre,@defaults,@lastvals);
Gimp::ignore_functions(@Gimp::GUI_FUNCTIONS)
unless $run_mode == Gimp::RUN_INTERACTIVE or
@@ -410,8 +432,6 @@ sub register($$$$$$$$$;@) {
} else {
die __"run_mode must be INTERACTIVE, NONINTERACTIVE or RUN_WITH_LAST_VALS\n";
}
- $input_image = $_[0] if ref $_[0] eq "Gimp::Image";
- $input_image = $pre[0] if ref $pre[0] eq "Gimp::Image";
if ($Gimp::verbose) {
require Data::Dumper;
@@ -419,28 +439,10 @@ sub register($$$$$$$$$;@) {
}
$Gimp::Data{"$function/_fu_data"}=[time, @_];
- print "$$-Gimp::Fu-generated sub: $function(",join(",",(@pre,@_)),")\n" if $Gimp::verbose;
+ warn "$$-Gimp::Fu-generated sub: $function(",join(",",(@pre,@_)),")\n"
+ if $Gimp::verbose;
my @retvals = $code->(@pre,@_);
-
- if ($outputfile and $menupath !~ /^<Load>\//) {
- my @images = grep { defined $_ and ref $_ eq "Gimp::Image" } @retvals;
- if (@images) {
- for my $i (0..$#images) {
- my $path = sprintf $outputfile, $i;
- if (@images > 1 and $path eq $outputfile) {
- $path=~s/\.(?=[^.]*$)/$i./; # insert number before last dot
- }
- save_image($images[$i],$path);
- $images[$i]->delete;
- }
- } elsif ($input_image) {
- save_image($input_image, sprintf $outputfile, 0);
- } else {
- die "$0: outputfile specified but plugin returned no image and no input image\n";
- }
- }
-
Gimp->displays_flush;
wantarray ? @retvals : $retvals[0];
};
diff --git a/MANIFEST b/MANIFEST
index da94810..ac537b5 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -140,6 +140,7 @@ pxgettext
t/import.t
t/loadlib.t
t/load.t
+t/netplugin.t
t/pdl.t
t/perlplugin.t
t/run.t
diff --git a/Net/Net.pm b/Net/Net.pm
index 91c5833..49a26cc 100644
--- a/Net/Net.pm
+++ b/Net/Net.pm
@@ -399,8 +399,7 @@ sub setup_listen_unix {
Glib::IO->add_watch(fileno($unix), 'in', sub {
warn "$$-setup_listen_unix WATCHER(@_)" if $Gimp::verbose;
my ($fd, $condition, $fh) = @_;
- my $h = $fh->accept
- or die __"unable to accept unix connection: $!\n";
+ my $h = $fh->accept or die __"unable to accept unix connection: $!\n";
new_connection($h);
slog __"accepted unix connection";
&Glib::SOURCE_CONTINUE;
@@ -420,8 +419,7 @@ sub setup_listen_tcp {
Glib::IO->add_watch(fileno($tcp), 'in', sub {
warn "$$-setup_listen_tcp WATCHER(@_)" if $Gimp::verbose;
my ($fd, $condition, $fh) = @_;
- my $h = $fh->accept
- or die __"unable to accept tcp connection: $!\n";
+ my $h = $fh->accept or die __"unable to accept tcp connection: $!\n";
my ($port,$host) = ($h->peerport, $h->peerhost);
new_connection($h);
slog __"accepted tcp connection from $host:$port";
diff --git a/t/examples-api.pl b/t/examples-api.pl
new file mode 100644
index 0000000..e2a27e4
--- /dev/null
+++ b/t/examples-api.pl
@@ -0,0 +1,168 @@
+sub newimage {
+ my $numlayers = shift;
+ my $i = Gimp::Image->new(200,200,RGB);
+ for my $layernum (1..$numlayers) {
+ my $l0 = $i->layer_new(200,200,RGBA_IMAGE,"layer $layernum",100,VALUE_MODE);
+ $i->insert_layer($l0,0,0);
+ }
+ $i;
+}
+
+use constant {
+ REQ_NONE => 0,
+ REQ_ALPHA => 1 << 0,
+ REQ_SEL => 1 << 1,
+ REQ_GUIDE => 1 << 2,
+ REQ_DIR => 1 << 3,
+ REQ_LAYER => 1 << 4,
+ REQ_FILE => 1 << 5,
+};
+
+my $color1 = 'blue';
+my $color2 = 'dark red';
+my $black = 'black';
+my $white = 'white';
+my $gradient1 = "Burning Paper";
+my $width = 10;
+my $height = 10;
+
+our @testbench = (
+["add_glow" , 2, REQ_ALPHA, [$color1, 5] ],
+["animate_cells" , 3, REQ_ALPHA, [0] ],
+["auto_red_eye" , 1, REQ_NONE , [] ],
+["blowinout" , 1, REQ_NONE , [ 30, 8, "30", 0, 0] ],
+["blur_2x2" , 1, REQ_NONE , [] ],
+["brushed_metal" , 1, REQ_NONE , [40,120,1,$gradient1] ],
+["burst" , 1, REQ_NONE , [0,0,14,30,50,80,140] ],
+["center_guide" , 1, REQ_NONE , [0] ],
+["center_layer" , 2, REQ_ALPHA, [] ],
+["contrast_enhance_2x2", 1, REQ_NONE , [] ],
+["ditherize" , 1, REQ_NONE , [1, 10] ],
+["do_bricks" , 0, REQ_NONE , ["Leather","unused yet","",'grey50',1,8,16,256,256,0] ],
+["dots" , 1, REQ_NONE , [8,$color1,80,20,16,0,0] ],
+["dust" , 1, REQ_NONE , [0.0005,0,50] ],
+["edge_detect_2x2" , 1, REQ_NONE , [] ],
+["file_dataurl_save" , 1, REQ_FILE , [32, 32, 0] ],
+["file_colorhtml_save" , 1, REQ_FILE , [2, "", "+1", 1, 1, 1] ],
+["glowing_steel" , 0, REQ_NONE , ["GET LOST","Bitstream Charter Bold 72",100,$color1,$black,4,0,0] ],
+["golden_mean" , 0, REQ_NONE , [233, 0] ],
+["guide_grid" , 1, REQ_NONE , [24,14,0,0,0] ],
+["guide_to_selection" , 1, REQ_GUIDE, [CHANNEL_OP_REPLACE,0,0] ],
+["highlight_edges" , 1, REQ_ALPHA, [ 10] ],
+["inner_bevel" , 0, REQ_NONE , ["URW Bookman L, Bold",80,"INNERBEVEL",$color1,$color2,132,30,7,2] ],
+["layer_apply" , 1, REQ_NONE , ['$d->gauss_rle($P*100+1,1,1)',""] ],
+["layer_reorder" , 3, REQ_ALPHA, [1,""] ],
+["make_bevel_logos" , 1, REQ_ALPHA, [$white,$color1,$color2,45,4,0] ],
+["make_trans_logos" , 1, REQ_ALPHA, [0,$gradient1,$color1] ],
+["map_to_gradient" , 1, REQ_NONE , [$gradient1] ],
+["mirror_split" , 1, REQ_NONE , [0] ],
+["perlotine" , 1, REQ_GUIDE|REQ_DIR, ["foo.html","t","png",0,"",1,0] ],
+["pixelgen" , 0, REQ_NONE , [$width,$height,RGB_IMAGE,'($x*$y*0.01)->slice("*$bpp")'] ],
+["pixelmap" , 1, REQ_NONE , ['($x*$y*0.01)->slice("*$bpp")'] ],
+["prep4gif" , 2, REQ_ALPHA, [64,1,0,1,255] ],
+["random_art_1" , 0, REQ_NONE , [$width,$height,20,10,1,30,0] ],
+["random_blends" , 1, REQ_NONE , [7] ],
+["red_eye" , 1, REQ_NONE , [0] ],
+["repdup" , 1, REQ_SEL , [3,50,50] ],
+["round_sel" , 1, REQ_SEL , [16] ],
+["scratches" , 1, REQ_NONE , [30,70,0.3,15,10] ],
+["selective_sharpen" , 1, REQ_NONE , [5.0,1.0,20] ],
+["seth_spin" , 2, REQ_LAYER, [16,$color1,40,1,1] ],
+["stamps" , 0, REQ_NONE , [90,$white,$color1,10,5] ],
+#["tex_string_to_float" , 1, REQ_NONE , ["","I can write \\\\TeX",72,6,4] ],
+#["view3d" , 1, REQ_NONE , [0,1,1] ],
+#["warp_sharp" ,
+["webify" , 1, REQ_NONE , [1,1,$white,3,32,1] ],
+["windify" , 1, REQ_NONE , [120,80,30,1] ],
+["xach_blocks" , 1, REQ_NONE , [10,40] ],
+["xach_shadows" , 1, REQ_NONE , [10] ],
+["xachvision" , 1, REQ_NONE , [$color1,25] ],
+["yinyang" , 0, REQ_NONE , [$width,$height,1,0,"","",1] ],
+);
+
+our %file2procs = (
+ animate_cells => [ qw(animate_cells) ],
+ blended2 => [ qw(make_bevel_logos) ],
+ blowinout => [ qw(blowinout) ],
+ bricks => [ qw(do_bricks) ],
+ burst => [ qw(burst) ],
+ centerguide => [ qw(center_guide) ],
+ colorhtml => [ qw(file_colorhtml_save) ],
+ dataurl => [ qw(file_dataurl_save) ],
+ ditherize => [ qw(ditherize) ],
+ dots => [ qw(dots) ],
+ dust => [ qw(dust gen_rand_1f) ],
+ frame_filter => [ qw(layer_apply) ],
+ frame_reshuffle => [ qw(layer_reorder) ],
+ glowing_steel => [ qw(highlight_edges brushed_metal add_glow glowing_steel) ],
+ goldenmean => [ qw(golden_mean) ],
+ gouge => [ qw(blur_2x2 contrast_enhance_2x2) ],
+ gouge => [ qw(edge_detect_2x2) ],
+ guidegrid => [ qw(guide_grid) ],
+ guides_to_selection => [ qw(guide_to_selection) ],
+ layerfuncs => [ qw(center_layer) ],
+ map_to_gradient => [ qw(map_to_gradient) ],
+ mirrorsplit => [ qw(mirror_split) ],
+ perlotine => [ qw(perlotine) ],
+ pixelmap => [ qw(pixelmap pixelgen) ],
+ prep4gif => [ qw(prep4gif) ],
+ randomart1 => [ qw(random_art_1) ],
+ randomblends => [ qw(random_blends) ],
+ redeye => [ qw(auto_red_eye red_eye) ],
+ repdup => [ qw(repdup) ],
+ roundsel => [ qw(round_sel) ],
+ scratches => [ qw(scratches) ],
+ selective_sharpen => [ qw(selective_sharpen) ],
+ sethspin => [ qw(seth_spin) ],
+ stamps => [ qw(stamps) ],
+ translogo => [ qw(make_trans_logos) ],
+ 'warp-sharp' => [ qw(warp_sharp) ],
+ webify => [ qw(webify) ],
+ windify => [ qw(windify) ],
+ xachlego => [ qw(xach_blocks) ],
+ xachshadow => [ qw(xach_shadows) ],
+ xachvision => [ qw(xachvision) ],
+);
+
+our %proc2file;
+while (my ($file, $procs) = each %file2procs) {
+ map { $proc2file{$_} = $file; } @$procs;
+}
+
+sub setup_args {
+ my ($name, $numlays, $flags, $params) = @_;
+ my @actualparams = @$params;
+ my ($tempdir, $tempfile);
+ if ($flags & REQ_FILE) {
+ $tempfile = File::Temp->newdir($DEBUG ? (CLEANUP => 0) : ());
+ # put 2 copies on input params - for use with export-handler!
+ # use a dir so any side-files created will get zapped on cleanup
+ unshift @actualparams, $tempfile.'/file.xcf', $tempfile.'/file.xcf';
+ }
+ if ($flags & REQ_DIR) {
+ $tempdir = File::Temp->newdir($DEBUG ? (CLEANUP => 0) : ());
+ unshift @actualparams, $tempdir.'';
+ }
+ if ($numlays > 0) {
+ my $img = newimage($numlays);
+ my $drw = $img->get_active_layer;
+ unshift @actualparams, ($img->get_layers)[1] if $flags & REQ_LAYER;
+ unshift @actualparams, $img, $drw;
+ if ($flags & REQ_ALPHA) {
+ $drw->add_alpha;
+ $img->select_rectangle(CHANNEL_OP_REPLACE,0.1*$height,0.1*$width,0.8*$height,0.8*$width);
+ $img->selection_invert;
+ $drw->edit_cut;
+ $img->selection_none;
+ }
+ $img->select_rectangle(
+ CHANNEL_OP_REPLACE,0.2*$height,0.2*$width,0.6*$height,0.6*$width
+ ) if $flags & REQ_SEL;
+ map {
+ $img->add_hguide($width * $_); $img->add_vguide($height * $_);
+ } (0.3, 0.6, 0.9) if $flags & REQ_GUIDE;
+ }
+ return (\ actualparams, $tempdir, $tempfile);
+}
+
+1;
diff --git a/t/netplugin.t b/t/netplugin.t
new file mode 100644
index 0000000..44aeab6
--- /dev/null
+++ b/t/netplugin.t
@@ -0,0 +1,79 @@
+use strict;
+use Test::More;
+our ($dir, $DEBUG);
+BEGIN {
+# $Gimp::verbose = 1;
+ $DEBUG = 0;
+ require 't/gimpsetup.pl';
+ # most minimal and elegant would be to symlink sandbox gimp-dir's
+ # plug-ins to our blib/plugins dir, but not portable to windows
+ my $blibdir = 'blib/plugins';
+ my @plugins = map { "$blibdir/$_" } qw(dots glowing_steel map_to_gradient);
+ map {
+ warn "inst $_\n" if $Gimp::verbose;
+ write_plugin($DEBUG, $_, io($_)->all);
+ } @plugins;
+ map { symlink_sysplugin($_) }
+ qw(
+ noise-rgb noise-solid blur-motion
+ );
+}
+use Gimp ':consts', "net_init=spawn/";
+use Gimp::Fu qw(save_image);
+use IPC::Open3;
+use Symbol 'gensym';
+use IO::Select; # needed because output can be big and it can block!
+#Gimp::set_trace(TRACE_ALL);
+
+our @testbench;
+our %proc2file;
+require 't/examples-api.pl';
+
+my %plug2yes = map { ($_=>1) } qw(dots ); # glowing_steel map_to_gradient
+ testbench = grep { $plug2yes{$_->[0]} } @testbench;
+my @duptest = @{$testbench[0]};
+$duptest[3] = [ @{$duptest[3]} ]; # don't change original
+pop @{$duptest[3]}; # remove last param - test default
+unshift @testbench, \ duptest;
+
+for my $test (@testbench) {
+ my ($actualparams, $tempdir, $tempfile) = setup_args(@$test);
+ my $scratchdir = File::Temp->newdir($DEBUG ? (CLEANUP => 0) : ());
+ my $name = $test->[0];
+ my $file = "./blib/plugins/$proc2file{$name}";
+ my $img = $actualparams->[0];
+ if (ref $img eq 'Gimp::Image') {
+ save_image($img, $actualparams->[0] = "$scratchdir/in.xcf");
+ $actualparams->[1] = '%a';
+ }
+ my $output = "$scratchdir/out.xcf";
+ unshift @$actualparams, '--output', $output;
+ unshift @$actualparams, '-v' if $Gimp::verbose;
+ my @perl = ($^X, '-Mblib');
+#use Data::Dumper;warn Dumper(Gimp->procedural_db_proc_info("perl_fu_$name"));
+ my ($wtr, $rdr, $err, @outlines, @errlines) = (undef, undef, gensym);
+ warn "Running @perl $file @$actualparams\n" if $Gimp::verbose;
+ my $pid = open3($wtr, $rdr, $err, @perl, $file, @$actualparams);
+ $wtr->close;
+ my $sel = IO::Select->new($rdr, $err);
+ while(my @ready = $sel->can_read) {
+ foreach my $fh (@ready) {
+ if (defined(my $l = $fh->getline)) {
+ push @{$fh == $rdr ? \ outlines : \ errlines}, $l;
+ } else {
+ $sel->remove($fh);
+ $fh->close;
+ }
+ }
+ }
+ is(join('', @errlines), '', "$name error empty");
+ is(join('', @outlines), '', "$name output empty");
+ waitpid($pid, 0);
+ is($? >> 8, 0, "$file exit=0");
+ ok(-f $output, "$file output exists");
+}
+
+Gimp::Net::server_quit;
+Gimp::Net::server_wait;
+
+done_testing;
diff --git a/t/supplied.t b/t/supplied.t
index 807afbf..9561deb 100644
--- a/t/supplied.t
+++ b/t/supplied.t
@@ -25,125 +25,15 @@ BEGIN {
use Gimp qw(:consts), "net_init=spawn/";
#Gimp::set_trace(TRACE_ALL);
-sub newimage {
- my $numlayers = shift;
- my $i = Gimp::Image->new(200,200,RGB);
- for my $layernum (1..$numlayers) {
- my $l0 = $i->layer_new(200,200,RGBA_IMAGE,"layer $layernum",100,VALUE_MODE);
- $i->insert_layer($l0,0,0);
- }
- $i;
-}
-
-use constant {
- REQ_NONE => 0,
- REQ_ALPHA => 1 << 0,
- REQ_SEL => 1 << 1,
- REQ_GUIDE => 1 << 2,
- REQ_DIR => 1 << 3,
- REQ_LAYER => 1 << 4,
- REQ_FILE => 1 << 5,
-};
-
-my $color1 = 'blue';
-my $color2 = 'dark red';
-my $black = 'black';
-my $white = 'white';
-my $gradient1 = "Burning Paper";
-my $width = 10;
-my $height = 10;
-
-my @testbench = (
-["add_glow" , 2, REQ_ALPHA, [$color1, 5] ],
-["animate_cells" , 3, REQ_ALPHA, [0] ],
-["auto_red_eye" , 1, REQ_NONE , [] ],
-["blowinout" , 1, REQ_NONE , [ 30, 8, "30", 0, 0] ],
-["blur_2x2" , 1, REQ_NONE , [] ],
-["brushed_metal" , 1, REQ_NONE , [40,120,1,$gradient1] ],
-["burst" , 1, REQ_NONE , [0,0,14,30,50,80,140] ],
-["center_guide" , 1, REQ_NONE , [0] ],
-["center_layer" , 2, REQ_ALPHA, [] ],
-["contrast_enhance_2x2", 1, REQ_NONE , [] ],
-["ditherize" , 1, REQ_NONE , [ 1, 10] ],
-["do_bricks" , 0, REQ_NONE , ["Leather","unused yet","",[0.5,0.5,0.5],1,8,16,256,256,0] ],
-["dots" , 1, REQ_NONE , [8,$color1,80,20,16,0,0] ],
-["dust" , 1, REQ_NONE , [0.0005,0,50] ],
-["edge_detect_2x2" , 1, REQ_NONE , [] ],
-["file_dataurl_save" , 1, REQ_FILE , [32, 32, 0] ],
-["file_colorhtml_save" , 1, REQ_FILE , [2, "", "+1", 1, 1, 1] ],
-["glowing_steel" , 0, REQ_NONE , ["GET LOST","Bitstream Charter Bold 72",100,$color1,$black,4,0,0] ],
-["golden_mean" , 0, REQ_NONE , [233, 0] ],
-["guide_grid" , 1, REQ_NONE , [24,14,0,0,0] ],
-["guide_to_selection" , 1, REQ_GUIDE, [CHANNEL_OP_REPLACE,0,0] ],
-["highlight_edges" , 1, REQ_ALPHA, [ 10] ],
-["inner_bevel" , 0, REQ_NONE , ["URW Bookman L, Bold",80,"INNERBEVEL",$color1,$color2,132,30,7,2] ],
-["layer_apply" , 1, REQ_NONE , ['$d->gauss_rle($P*100+1,1,1)',""] ],
-["layer_reorder" , 3, REQ_ALPHA, [1,""] ],
-["make_bevel_logos" , 1, REQ_ALPHA, [$white,$color1,$color2,45,4,0] ],
-["make_trans_logos" , 1, REQ_ALPHA, [0,$gradient1,$color1] ],
-["map_to_gradient" , 1, REQ_NONE , [$gradient1] ],
-["mirror_split" , 1, REQ_NONE , [0] ],
-["perlotine" , 1, REQ_GUIDE|REQ_DIR, ["foo.html","t","png",0,"",1,0] ],
-["pixelgen" , 0, REQ_NONE , [$width,$height,RGB_IMAGE,'($x*$y*0.01)->slice("*$bpp")'] ],
-["pixelmap" , 1, REQ_NONE , ['($x*$y*0.01)->slice("*$bpp")'] ],
-["prep4gif" , 2, REQ_ALPHA, [64,1,0,1,255] ],
-["random_art_1" , 0, REQ_NONE , [$width,$height,20,10,1,30,0] ],
-["random_blends" , 1, REQ_NONE , [7] ],
-["red_eye" , 1, REQ_NONE , [0] ],
-["repdup" , 1, REQ_SEL , [3,50,50] ],
-["round_sel" , 1, REQ_SEL , [16] ],
-["scratches" , 1, REQ_NONE , [30,70,0.3,15,10] ],
-["selective_sharpen" , 1, REQ_NONE , [5.0,1.0,20] ],
-["seth_spin" , 2, REQ_LAYER, [16,$color1,40,1,1] ],
-["stamps" , 0, REQ_NONE , [90,$white,$color1,10,5] ],
-#["tex_string_to_float" , 1, REQ_NONE , ["","I can write \\\\TeX",72,6,4] ],
-#["view3d" , 1, REQ_NONE , [0,1,1] ],
-#["warp_sharp" ,
-["webify" , 1, REQ_NONE , [1,1,$white,3,32,1] ],
-["windify" , 1, REQ_NONE , [120,80,30,1] ],
-["xach_blocks" , 1, REQ_NONE , [10,40] ],
-["xach_shadows" , 1, REQ_NONE , [10] ],
-["xachvision" , 1, REQ_NONE , [$color1,25] ],
-["yinyang" , 0, REQ_NONE , [$width,$height,1,0,"","",1] ],
-);
+our @testbench;
+require 't/examples-api.pl';
for my $test (@testbench) {
- my ($name, $numlays, $flags, $params) = @$test;
- my @actualparams = @$params;
- my ($tempdir, $tempfile);
- if ($flags & REQ_FILE) {
- $tempfile = File::Temp->newdir($DEBUG ? (CLEANUP => 0) : ());
- # put 2 copies on input params - for use with export-handler!
- # use a dir so any side-files created will get zapped on cleanup
- unshift @actualparams, $tempfile.'/file.xcf', $tempfile.'/file.xcf';
- }
- if ($flags & REQ_DIR) {
- $tempdir = File::Temp->newdir($DEBUG ? (CLEANUP => 0) : ());
- unshift @actualparams, $tempdir.'';
- }
- if ($numlays > 0) {
- my $img = newimage($numlays);
- my $drw = $img->get_active_layer;
- unshift @actualparams, ($img->get_layers)[1] if $flags & REQ_LAYER;
- unshift @actualparams, $img, $drw;
- Gimp::Display->new($img);
- if ($flags & REQ_ALPHA) {
- $drw->add_alpha;
- $img->select_rectangle(CHANNEL_OP_REPLACE,0.1*$height,0.1*$width,0.8*$height,0.8*$width);
- $img->selection_invert;
- $drw->edit_cut;
- $img->selection_none;
- }
- $img->select_rectangle(
- CHANNEL_OP_REPLACE,0.2*$height,0.2*$width,0.6*$height,0.6*$width
- ) if $flags & REQ_SEL;
- map {
- $img->add_hguide($width * $_); $img->add_vguide($height * $_);
- } (0.3, 0.6, 0.9) if $flags & REQ_GUIDE;
- }
+ my ($actualparams, $tempdir, $tempfile) = setup_args(@$test);
+ my $name = $test->[0];
warn "Running $name\n" if $Gimp::verbose;
#use Data::Dumper;warn Dumper(Gimp->procedural_db_proc_info("perl_fu_$name"));
- my $img = eval { Gimp::Plugin->$name(@actualparams); };
+ my $img = eval { Gimp::Plugin->$name(@$actualparams); };
is($@, '', "plugin $name");
$img->delete if defined $img;
}
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
