diff --git a/plug-ins/perl/Changes b/plug-ins/perl/Changes index b4be974bee..743da0a81d 100644 --- a/plug-ins/perl/Changes +++ b/plug-ins/perl/Changes @@ -6,8 +6,18 @@ Revision history for Gimp-Perl extension. - preliminary and support (arguments are automatically supplied). - enabled limited pixel access functions even when PDL was not found. - - added examples/miff (a save filter for miff images). + - implemented and added examples/miff (a save filter for miff images). - close DATA in Gimp unconditionally, saves one open filehandle. + - fixed the longstanding preview bug in Gimp::UI by reversing the + order of calls to draw_row. => something in gtk+ is really broken. + - fixed a longstanding (but never seen ;) bug in old_pdl: pdls that + were not sever'ed created garbage. + - allow dummy dimension in grayscale pdls, i.e. pdl(1,width,height) + instead of pdl(width,height). + - improved gimpdoc. + - removed debugging code from gouge. ouch! + - bug fixed: PDL::Core was not automatically required when not + already loaded. 1.0981 Wed Jul 28 00:09:50 CEST 1999 - improved gouge ;) In a sense, it's actually pretty code now! diff --git a/plug-ins/perl/Gimp.pm b/plug-ins/perl/Gimp.pm index 972f799b77..7e19037080 100644 --- a/plug-ins/perl/Gimp.pm +++ b/plug-ins/perl/Gimp.pm @@ -328,15 +328,15 @@ unless ($no_SIG) { die_msg $_[0]; initialized() ? &quiet_die : exit quiet_main(); } else { - die $_[0]; + die $_[0]; } }; $SIG{__WARN__} = sub { unless ($in_quit) { - warn $_[0]; + warn $_[0]; } else { - logger(message => substr($_[0],0,-1), fatal => 0, function => 'WARNING'); + logger(message => substr($_[0],0,-1), fatal => 0, function => 'WARNING'); } }; } @@ -465,7 +465,7 @@ sub AUTOLOAD { my $ref = \&{"Gimp::Util::$sub"}; *{$AUTOLOAD} = sub { shift unless ref $_[0]; - goto &$ref; # does not always work, PERLBUG! #FIXME + #goto &$ref; # does not always work, PERLBUG! #FIXME my @r = eval { &$ref }; _croak $@ if $@; wantarray ? @r : $r[0]; @@ -475,7 +475,7 @@ sub AUTOLOAD { my $ref = \&{"$interface_pkg\::$sub"}; *{$AUTOLOAD} = sub { shift unless ref $_[0]; - goto &$ref; # does not always work, PERLBUG! #FIXME + #goto &$ref; # does not always work, PERLBUG! #FIXME my @r = eval { &$ref }; _croak $@ if $@; wantarray ? @r : $r[0]; diff --git a/plug-ins/perl/Gimp/Lib.xs b/plug-ins/perl/Gimp/Lib.xs index e8c116b99d..751389c13a 100644 --- a/plug-ins/perl/Gimp/Lib.xs +++ b/plug-ins/perl/Gimp/Lib.xs @@ -22,12 +22,8 @@ #define PDL_clean_namespace #include #undef croak -#ifdef Perl_croak_nocontext -#define croak Perl_croak_nocontext -#else #define croak Perl_croak #endif -#endif /* various functions allocate static buffers, STILL. */ #define MAX_STRING 4096 @@ -77,6 +73,8 @@ static int trace = TRACE_NONE; #if HAVE_PDL +typedef GPixelRgn GPixelRgn_PDL; + /* hack, undocumented, argh! */ static Core* PDL; /* Structure hold core C functions */ @@ -88,11 +86,12 @@ static void need_pdl (void) if (!PDL) { /* the perl-server can't be bothered to do this itself! */ - perl_require_pv ("PDL::Core"); + perl_eval_pv ("require PDL::Core", TRUE); /* Get pointer to structure of core shared C routines */ - if (!(CoreSV = perl_get_sv("PDL::SHARE",FALSE))) - Perl_croak("gimp-perl-pixel functions require the PDL::Core module"); + CoreSV = perl_get_sv("PDL::SHARE", FALSE); + if (!CoreSV) + croak("gimp-perl-pixel functions require the PDL::Core module, which was not found"); PDL = (Core*) SvIV(CoreSV); } @@ -117,14 +116,17 @@ static pdl *new_pdl (int a, int b, int c) static void old_pdl (pdl **p, short ndims, int dim0) { - PDL->converttype (p, PDL_B, PDL_PERM); PDL->make_physical (*p); + PDL->converttype (p, PDL_B, PDL_PERM); - if ((*p)->ndims != ndims + (dim0 > 1)) - croak ("dimension mismatch, pdl has dimension %d but %d dimensions required", (*p)->ndims, ndims + (dim0 > 1)); + if ((*p)->ndims < ndims + (dim0 > 1)) + croak ("dimension mismatch, pdl has dimension %d but at least %d dimensions allowed", (*p)->ndims, ndims + (dim0 > 1)); - if (dim0 > 1 && (*p)->dims[0] != dim0) - croak ("pixel size mismatch, pdl has %d byte pixels but %d bytes are required", (*p)->dims[0], dim0); + if ((*p)->ndims > ndims + 1) + croak ("dimension mismatch, pdl has dimension %d but at most %d dimensions required", (*p)->ndims, ndims + 1); + + if ((*p)->ndims > ndims && (*p)->dims[0] != dim0) + croak ("pixel size mismatch, pdl has %d channel pixels but %d channels are required", (*p)->dims[0], dim0); } static void pixel_rgn_pdl_delete_data (pdl *p, int param) @@ -216,12 +218,6 @@ static SV *new_gdrawable (gint32 id) if (!gdr) croak ("unable to convert Gimp::Drawable into Gimp::GDrawable (id %d)", id); -#if HAVE_PDL - /* this needs to be called once before ANY pdl functions can be called. */ - /* placing this here will suffice. */ - need_pdl (); -#endif - if (!stash) stash = gv_stashpv (PKG_GDRAWABLE, 1); @@ -315,6 +311,14 @@ static GPixelRgn *old_pixelrgn (SV *sv) return (GPixelRgn *)SvPV_nolen(SvRV(sv)); } +static GPixelRgn *old_pixelrgn_pdl (SV *sv) +{ +#if HAVE_PDL + need_pdl (); +#endif + return old_pixelrgn (sv); +} + /* tracing stuff. */ static SV *trace_var = 0; static PerlIO *trace_file = 0; /* FIXME: unportable. */ @@ -2008,6 +2012,7 @@ gimp_drawable_get_tile(gdrawable, shadow, row, col) gint row gint col CODE: + need_pdl (); RETVAL = new_tile (gimp_drawable_get_tile (old_gdrawable (gdrawable), shadow, row, col), gdrawable); OUTPUT: RETVAL @@ -2019,13 +2024,14 @@ gimp_drawable_get_tile2(gdrawable, shadow, x, y) gint x gint y CODE: + need_pdl (); RETVAL = new_tile (gimp_drawable_get_tile2 (old_gdrawable (gdrawable), shadow, x, y), gdrawable); OUTPUT: RETVAL pdl * gimp_pixel_rgn_get_pixel(pr, x, y) - GPixelRgn * pr + GPixelRgn_PDL * pr int x int y CODE: @@ -2036,7 +2042,7 @@ gimp_pixel_rgn_get_pixel(pr, x, y) pdl * gimp_pixel_rgn_get_row(pr, x, y, width) - GPixelRgn * pr + GPixelRgn_PDL * pr int x int y int width @@ -2048,7 +2054,7 @@ gimp_pixel_rgn_get_row(pr, x, y, width) pdl * gimp_pixel_rgn_get_col(pr, x, y, height) - GPixelRgn * pr + GPixelRgn_PDL * pr int x int y int height @@ -2060,7 +2066,7 @@ gimp_pixel_rgn_get_col(pr, x, y, height) pdl * gimp_pixel_rgn_get_rect(pr, x, y, width, height) - GPixelRgn * pr + GPixelRgn_PDL * pr int x int y int width @@ -2073,7 +2079,7 @@ gimp_pixel_rgn_get_rect(pr, x, y, width, height) void gimp_pixel_rgn_set_pixel(pr, pdl, x, y) - GPixelRgn * pr + GPixelRgn_PDL * pr pdl * pdl int x int y @@ -2083,7 +2089,7 @@ gimp_pixel_rgn_set_pixel(pr, pdl, x, y) void gimp_pixel_rgn_set_row(pr, pdl, x, y) - GPixelRgn * pr + GPixelRgn_PDL * pr pdl * pdl int x int y @@ -2093,7 +2099,7 @@ gimp_pixel_rgn_set_row(pr, pdl, x, y) void gimp_pixel_rgn_set_col(pr, pdl, x, y) - GPixelRgn * pr + GPixelRgn_PDL * pr pdl * pdl int x int y @@ -2103,7 +2109,7 @@ gimp_pixel_rgn_set_col(pr, pdl, x, y) void gimp_pixel_rgn_set_rect(pr, pdl, x, y) - GPixelRgn * pr + GPixelRgn_PDL * pr pdl * pdl int x int y @@ -2113,8 +2119,8 @@ gimp_pixel_rgn_set_rect(pr, pdl, x, y) pdl * gimp_pixel_rgn_data(pr,newdata=0) - GPixelRgn * pr - pdl * newdata + GPixelRgn_PDL * pr + pdl * newdata CODE: if (newdata) { @@ -2167,6 +2173,7 @@ SV * gimp_tile_get_data(tile) GTile * tile CODE: + need_pdl; croak ("gimp_tile_get_data is not yet implemented\n"); gimp_tile_ref (tile); gimp_tile_unref (tile, 0); diff --git a/plug-ins/perl/Gimp/OO.pod b/plug-ins/perl/Gimp/OO.pod index b7e23e3d35..4c1cbfe67a 100644 --- a/plug-ins/perl/Gimp/OO.pod +++ b/plug-ins/perl/Gimp/OO.pod @@ -176,18 +176,6 @@ that are checked are shown as well (the null prefix "" is implicit). gimp_brushes_ -=item Edit - - gimp_edit_ - -=item Gradients - - gimp_gradients_ - -=item Selection - - gimp_selection_ - =item Patterns gimp_patterns_ diff --git a/plug-ins/perl/Gimp/UI.pm b/plug-ins/perl/Gimp/UI.pm index 0a5f4fee3f..766fe05367 100644 --- a/plug-ins/perl/Gimp/UI.pm +++ b/plug-ins/perl/Gimp/UI.pm @@ -185,6 +185,7 @@ sub GTK_OBJECT_INIT { $button = new Gtk::Button "Cancel"; signal_connect $button "clicked", sub {hide $w}; $w->action_area->pack_start($button,1,1,0); + can_default $button 1; show $button; $self->signal_connect("clicked",sub {show $w}); @@ -223,12 +224,12 @@ sub set_preview { hide $cp; hide $gp; my $p = $bpp == 1 ? $gp : $cp; - show $p; $p->size ($w, $h); - while(--$h) { - $p->draw_row (substr ($mask, $w*$bpp*$h), 0, $h, $w); + for(0..$h-1) { + $p->draw_row (substr ($mask, $w*$bpp*$_), 0, $_, $w); } $p->draw(undef); + show $p; $name; } @@ -267,8 +268,8 @@ sub set_preview { hide $p; my $l=length($mask); $p->size ($w, $h); - while(--$h) { - $p->draw_row (substr ($mask, $w*$h) ^ $xor, 0, $h, $w); + for(0..$h-1) { + $p->draw_row (substr ($mask, $w*$_) ^ $xor, 0, $_, $w); } $p->draw(undef); show $p; diff --git a/plug-ins/perl/MANIFEST b/plug-ins/perl/MANIFEST index 4cf98da1d8..ae17f48b68 100644 --- a/plug-ins/perl/MANIFEST +++ b/plug-ins/perl/MANIFEST @@ -15,12 +15,15 @@ Gimp.xs scm2perl scm2scm gimpdoc -t/load.t -t/loadlib.t -t/run.t +xcftopnm +embedxpm +logo.xpm extradefs.h gppport.h Perl-Server +t/load.t +t/loadlib.t +t/run.t etc/configure etc/configure.in etc/aclocal.m4 @@ -100,8 +103,6 @@ examples/oneliners examples/randomart1 examples/colourtoalpha examples/pixelmap -embedxpm -logo.xpm examples/frame_reshuffle examples/frame_filter examples/gouge diff --git a/plug-ins/perl/TODO b/plug-ins/perl/TODO index 991cfd8b1e..8bda816e7a 100644 --- a/plug-ins/perl/TODO +++ b/plug-ins/perl/TODO @@ -16,6 +16,9 @@ script-fu 4.9 vs. 3.3 bugs + * perl_require_pv with _59? + * scroll behaviour, use clist instead of list? +[DONE] * can_Default for oter OK-buttons * document Gimp::PDL and rect2, ...2 functions! [DONE] * MJH: glib-config(!!!) [KILL] * empty desfiption -> no display in PDB?` diff --git a/plug-ins/perl/examples/border.pl b/plug-ins/perl/examples/border.pl index 01036615b4..6b09506aef 100755 --- a/plug-ins/perl/examples/border.pl +++ b/plug-ins/perl/examples/border.pl @@ -14,7 +14,7 @@ register "border_average", "calulcates the average border colour", "Marc Lehmann", "Marc Lehmann", - "0.2.1", + "0.2.2", "/Filters/Misc/Border Average", "RGB", [ @@ -58,13 +58,13 @@ register "border_average", }; Gimp->progress_init("Border Average", 0); - add_new_colour ($drawable->get->pixel_rgn ($bounds[0] ,$bounds[1] , $thickness,$height, 0, 0) + add_new_colour ($drawable->pixel_rgn ($bounds[0] ,$bounds[1] , $thickness,$height, 0, 0) ->get_rect(0,0, $thickness,$height)); - add_new_colour ($drawable->get->pixel_rgn ($bounds[2]-$thickness,$bounds[1] , $thickness,$height, 0, 0) + add_new_colour ($drawable->pixel_rgn ($bounds[2]-$thickness,$bounds[1] , $thickness,$height, 0, 0) ->get_rect(0,0, $thickness,$height)); - add_new_colour ($drawable->get->pixel_rgn ($bounds[0] ,$bounds[1] , $width ,$thickness, 0, 0) + add_new_colour ($drawable->pixel_rgn ($bounds[0] ,$bounds[1] , $width ,$thickness, 0, 0) ->get_rect(0,0, $width, $thickness)); - add_new_colour ($drawable->get->pixel_rgn ($bounds[0] ,$bounds[3]-$thickness, $width ,$thickness, 0, 0) + add_new_colour ($drawable->pixel_rgn ($bounds[0] ,$bounds[3]-$thickness, $width ,$thickness, 0, 0) ->get_rect(0,0, $width, $thickness)); # now find the colour diff --git a/plug-ins/perl/examples/colourtoalpha b/plug-ins/perl/examples/colourtoalpha index 071d45ae1a..e5c3a94c13 100755 --- a/plug-ins/perl/examples/colourtoalpha +++ b/plug-ins/perl/examples/colourtoalpha @@ -12,7 +12,7 @@ register "colour_to_alpha", ."amount of alpha, then readjusts the colour accordingly.", "Marc Lehmann", "Marc Lehmann ", - "19990517", + "19990729", "/Filters/Colors/Colour To Alpha", "RGB*", [ @@ -30,8 +30,8 @@ register "colour_to_alpha", { # $src and $dst must either be scoped or explicitly undef'ed # before merge_shadow. - my $src = new PixelRgn ($drawable->get,@bounds,0,0); - my $dst = new PixelRgn ($drawable->get,@bounds,1,1); + my $src = new PixelRgn $drawable,@bounds,0,0; + my $dst = new PixelRgn $drawable,@bounds,1,1; $iter = Gimp->pixel_rgns_register ($src, $dst); diff --git a/plug-ins/perl/examples/gimpmagick b/plug-ins/perl/examples/gimpmagick index e77b9146d7..b4e1ce2178 100644 --- a/plug-ins/perl/examples/gimpmagick +++ b/plug-ins/perl/examples/gimpmagick @@ -6,7 +6,7 @@ use Gimp::Fu; use Gtk; BEGIN { eval "use Image::Magick 1.45"; $@ and Gimp::Feature::missing ("Image::Magick version 1.45 or higher") }; -$VERSION = '0.1'; +$VERSION = '0.2'; $preview_size = 160; # max. size for image preview @@ -115,7 +115,7 @@ sub read_pixels { open TEMP,">$temp\0" or die "unable to open temporary file '$temp' for writing\n"; my ($empty,$x1,$y1,$x2,$y2) = $drawable->mask_bounds; $x2-=$x1; $y2-=$y1; - my $region = $drawable->get->pixel_rgn ($x1, $y1, $x2, $y2, 0, 0); + my $region = $drawable->pixel_rgn ($x1, $y1, $x2, $y2, 0, 0); Gimp->progress_init ("transferring image data"); for(my $y=0; $y<$y2; $y+=$th) { diff --git a/plug-ins/perl/examples/gouge b/plug-ins/perl/examples/gouge index bd0b5db28c..cdeee75cf7 100755 --- a/plug-ins/perl/examples/gouge +++ b/plug-ins/perl/examples/gouge @@ -21,8 +21,8 @@ sub iterate { $bounds[2]-- if $bounds[0]+$bounds[2] >= ($drawable->offsets)[0]+$drawable->width; $bounds[3]-- if $bounds[1]+$bounds[3] >= ($drawable->offsets)[1]+$drawable->height; { - my $src = new PixelRgn ($drawable->get,@bounds[0,1],$bounds[2]+1,$bounds[3]+1,0,0); - my $dst = new PixelRgn ($drawable->get,@bounds,1,1); + my $src = new PixelRgn ($drawable,@bounds[0,1],$bounds[2]+1,$bounds[3]+1,0,0); + my $dst = new PixelRgn ($drawable,@bounds,1,1); my $bpp = $src->bpp > 1 ? ":," : ""; @@ -30,15 +30,12 @@ sub iterate { my $area = $bounds[2]*$bounds[3]; my $progress = 0; - use Time::HiRes 'time'; - $s=time; do { my ($x,$y,$w,$h)=($dst->x,$dst->y,$dst->w,$dst->h); $dst->data($kernel->($bpp,$src->get_rect($x,$y,$w+1,$h+1)->convert(short))); $progress += $w*$h/$area; Gimp->progress_update ($progress); } while (Gimp->pixel_rgns_process ($iter)); - print time-$s; } Gimp->progress_update (1); diff --git a/plug-ins/perl/examples/logulator b/plug-ins/perl/examples/logulator index c12d5209c9..78ac2d2df4 100755 --- a/plug-ins/perl/examples/logulator +++ b/plug-ins/perl/examples/logulator @@ -93,7 +93,7 @@ sub gimp_text_fontname { my $newlay; if ($layer == -1) { $newlay=$image->layer_new($global_drawable->width,$global_drawable->height, - $image->layertype(1), $text, 100, NORMAL_MODE); + $image->layertype(1), $text || "--text--", 100, NORMAL_MODE); $newlay->drawable_fill(TRANS_IMAGE_FILL); $newlay->add_layer(0); $newlay->edit_paste(0)->floating_sel_anchor; diff --git a/plug-ins/perl/examples/miff b/plug-ins/perl/examples/miff index 9821c773d7..5136bf5440 100755 --- a/plug-ins/perl/examples/miff +++ b/plug-ins/perl/examples/miff @@ -26,12 +26,13 @@ register "file_miff_save", "Saves images in the miff (Magick Interchange File Format) format used by the ImageMagick package", "Marc Lehmann", "Marc Lehmann ", - "1999-07-27", + "1999-07-29", "/MIFF", "RGB, RGBA, GRAY, INDEXED-NOT-YET", # weird, but no matte for !DirectColour [], sub { my($img,$drawable,$filename) =@_; + my @layers = $img->get_layers; sysopen FILE,$filename,O_CREAT|O_TRUNC|O_WRONLY or die "Unable to open '$filename' for writing: $!\n"; my $hdr = eval { $img->find_parasite("gimp-comment")->data }; $hdr = " COMMENT: $hdr\n" if $hdr; @@ -41,14 +42,16 @@ id=ImageMagick CREATOR: file_miff_save gimp plug-in, see http://www.gimp.org/ $hdr} EOF + init Progress "Saving '$filename' as MIFF..."; my $scene = 0; - for ($img->get_layers) { + for (@layers) { print FILE $hdr, "scene=$scene\n", "class=", $_->color ? "DirectClass" : "PseudoClass", "\n"; #"gamma=", Gimp->gamma, "\n"; write_layer(*FILE,$_); $scene++; + update Progress $scene/@layers; } close FILE; (); diff --git a/plug-ins/perl/examples/pixelmap b/plug-ins/perl/examples/pixelmap index c51e56cf28..1989e0d603 100755 --- a/plug-ins/perl/examples/pixelmap +++ b/plug-ins/perl/examples/pixelmap @@ -6,50 +6,54 @@ use Gimp::Fu; use Gimp::Util; use PDL; +use constant PI => 4 * atan2 1,1; + register "pixelmap", "Maps Pixel values and coordinates through general Perl expressions", "=pod(DESCRIPTION)", "Marc Lehmann", "Marc Lehmann ", - "19990528", + "19990729", "/Filters/Map/Pixelmap", "*", [ - [PF_TEXT, "expression" , "The perl expression to use", '$p=outer($x,$y)->slice("*$bpp")'] + [PF_TEXT, "expression" , "The perl expression to use", "outer(\$x*0.1,\$y*0.2)\n->slice(\"*\$bpp\")"] ], sub { # es folgt das eigentliche Skript... - my($image,$drawable,$expr)=@_; + my($image,$drawable,$_expr)=@_; Gimp->progress_init ("Mapping pixels..."); my $init=""; - $expr =~ /\$p/ and $init.='$p = $src->data;'; - $expr =~ /\$x/ and $init.='$x = sequence(byte,$src->w); $x+=$src->x;'; - $expr =~ /\$y/ and $init.='$y = sequence(byte,$src->h); $y+=$src->y;'; - $expr =~ /\$bpp/ and $init.='$bpp = $src->bpp;'; + $_expr =~ /\$p/ and $init.='$p = $src->data;'; + $_expr =~ /\$x/ and $init.='$x = sequence(long,$w); $x+=$_dst->x;'; + $_expr =~ /\$y/ and $init.='$y = sequence(long,$h); $y+=$_dst->y;'; + $_expr =~ /\$bpp/ and $init.='$bpp = $_dst->bpp;'; - $expr = "sub{$init\n#line 1\n$expr;\n\$p}"; + my($p,$x,$y,$bpp,$w,$h); - my @bounds = $drawable->mask; + $_expr = "sub{$init\n#line 1\n$_expr\n;}"; + + my @_bounds = $drawable->mask; { # $src and $dst must either be scoped or explicitly undef'ed # before merge_shadow. - my $src = new PixelRgn ($drawable->get,@bounds,0,0); - my $dst = new PixelRgn ($drawable->get,@bounds,1,1); - my($p,$x,$y,$bpp); + my $src = new PixelRgn $drawable,@_bounds,0,0; + my $_dst = new PixelRgn $drawable,@_bounds,1,1; - $expr = eval $expr; die "$@" if $@; + $_expr = eval $_expr; die "$@" if $@; - $iter = Gimp->pixel_rgns_register ($src, $dst); + $_iter = Gimp->pixel_rgns_register ($src, $_dst); + my $_area = 0; do { - $dst->data(&$expr); - - Gimp->progress_update (($src->y-$bounds[1])/$bounds[2]); - } while (Gimp->pixel_rgns_process ($iter)); + ($w,$h)=($src->w,$src->h); + $_area += $w*$h/($_bounds[2]*$_bounds[3]); + $_dst->data(&$_expr); + Gimp->progress_update ($_area); + } while (Gimp->pixel_rgns_process ($_iter)); } - Gimp->progress_update (1); $drawable->merge_shadow (1); $drawable->update ($drawable->mask); diff --git a/plug-ins/perl/gimpdoc b/plug-ins/perl/gimpdoc index 52ea8e86df..12e208c592 100755 --- a/plug-ins/perl/gimpdoc +++ b/plug-ins/perl/gimpdoc @@ -85,29 +85,122 @@ lw20 lw20 lw60. TYPE NAME DESCRIPTION EOF +sub gen_va(\@\@) { + my @vals = @{+shift}; + my @args = @{+shift}; + my($vals,$args); + + if (@vals == 0) { + $vals = ""; + } elsif (@vals == 1) { + $vals = "$vals[0][1]\\ =\\ "; + } else { + $vals = "(".join(",",map $_->[1],@vals).")\\ =\\ "; + } + + if (@args == 0) { + $args = ""; + } else { + $args = "\\ (".join(",",map $_->[1],@args).")"; + } + + ($vals,$args); +} + +sub isarray { + return 1 if $_[0] == &PARAM_INT8ARRAY; + return 1 if $_[0] == &PARAM_INT16ARRAY; + return 1 if $_[0] == &PARAM_INT32ARRAY; + return 1 if $_[0] == &PARAM_FLOATARRAY; + return 1 if $_[0] == &PARAM_STRINGARRAY; + return 0; +} + +sub killcounts(\@) { + my $a = shift; + my $roa=0; + for(local $_=0; $_<$#$a; $_++) { + if (isarray ($a->[$_+1][0]) && $a->[$_][0] == &PARAM_INT32) { + splice @$a, $_, 1; + $roa=1; + } + } + $roa; +} + +sub weight { + my ($v,$n,$a)=@$_; + my $w = $#$v + $#$a; + $w-- if $n =~ s/^\$\w+//; + $w += 1-1/(1+length $n); + if ($n =~ / ([A-Z][a-z]+)$/) { + $w += 1 unless $1 eq ucfirst $a->[0][1]; + } + $w; +} + +sub gen_alternatives(\@$\@) { + my @new = [@_]; + my @res; + do { + my @prev = @new; + @new = (); + for my $alt (@prev) { + my @vals = @{$alt->[0]}; + my $name = $alt->[1]; + my @args = @{$alt->[2]}; + # try to get rid of array counts + push @new, [\@vals,$name,\@args] if killcounts(@vals) | killcounts(@args); + unless ($name =~ /[$ ]/) { + for my $class (qw( + Gimp Layer Image Drawable Selection Channel Display + Palette Plugin Gradients Edit Progress Region Tile + PixelRgn GDrawable Patterns Parasite + )) { + my @pre = @{$class."::PREFIXES"}; + for (@pre) { + my $n2 = $name; + if ($_ && $n2 =~ s/^$_//) { + if ($class eq "Drawable" && @args && $args[0][0] == &PARAM_DRAWABLE) { + push @new, [\@vals,"\$drawable->$n2",[@args[1..$#args]]]; + } elsif ($class eq "Layer" && @args && $args[0][0] == &PARAM_LAYER) { + push @new, [\@vals,"\$layer->$n2",[@args[1..$#args]]]; + } elsif ($class eq "Channel" && @args && $args[0][0] == &PARAM_CHANNEL) { + push @new, [\@vals,"\$channel->$n2",[@args[1..$#args]]]; + } elsif ($class eq "Image" && @args && $args[0][0] == &PARAM_IMAGE) { + push @new, [\@vals,"\$image->$n2",[@args[1..$#args]]]; + } else { + push @new, [\@vals,"$n2\\ $class",\@args]; + } + } + } + } + } + if (@args && $args[0][0] == &PARAM_INT32 && $args[0][1] eq "run_mode") { + push @new, [\@vals,,$name,[@args[1..$#args]]]; + } + if (@args>1 && $args[0][0] == &PARAM_IMAGE && $args[1][0] == &PARAM_DRAWABLE) { + push @new, [\@vals,,$name,[@args[1..$#args]]]; + } + } + push @res, @new; + } while @new; + map { + my($vals,$args)=gen_va(@{$_->[0]},@{$_->[2]}); + "$vals\\fB$_->[1]\\fR$args"; + } map $_->[1], sort { + $a->[0] <=> $b->[0] + } map [weight($_),$_], @res; +} + for $name (@matches) { my ($blurb, $help, $author, $copyright, $date, $type, $nargs, $nvals) = Gimp->procedural_db_proc_info ($name); my @args = map [Gimp->procedural_db_proc_arg ($name, $_)],0..($nargs-1); my @vals = map [Gimp->procedural_db_proc_val ($name, $_)],0..($nvals-1); - my $args; - my $vals; + my($vals,$args)=gen_va(@vals,@args); - if ($nvals == 0) { - $vals = ""; - } elsif ($nvals == 1) { - $vals = "$vals[0][1]\\ =\\ "; - } else { - $vals = "(".join(",",map $_->[1],@vals).")\\ =\\ "; - } - - if ($nargs == 0) { - $args = ""; - } else { - $args = "\\ (".join(",",map $_->[1],@args).")"; - } - print PAGER < 6; + print PAGER ".SH SOME SYNTAX ALTERNATIVES\n", join("\n.br\n", @alts), "\n"; + } print PAGER < + +Select the Cth layer, instead of flattening the whole image. + +=back + +=cut + +$layer=(shift,shift) if $ARGV[0] =~ /^-(l|-?layer)$/; + +if (@ARGV>1) { + print "Usage: xcftopnm [-layer N] [xcffile]\n"; + exit(1); +} + +$tmpfile = "xcftopnm$$~"; +END { unlink $tmpfile } + +if (@ARGV==0) { + my $buff; + open TMP,">$tmpfile" or die "Unable to open temporary file '$tmpfile' for writing: $!\n"; + binmode STDIN; binmode TMP; + print TMP $buff while sysread STDIN,$buff,16384; + close TMP; + @ARGV = $tmpfile; +} + +Gimp::init("spawn/no-data"); + +$image = Gimp->xcf_load(0,($ARGV[0])x2); +$layer = defined $layer ? ($image->get_layers)[$layer] : $image->flatten; +$layer->file_pnm_save(($tmpfile)x2,1); + +Gimp::deinit; + +open TMP,"<$tmpfile" or die "Unable to open temporary file '$tmpfile' for reading: $!\n"; +binmode STDOUT; binmode TMP; +print STDOUT $buff while sysread TMP,$buff,16384; +close TMP; +