[gimp-perl] Make Gimp::Fu scripts run right from command line. Bug 728545



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]