see plug-ins/perl/Changes

plug-ins/perl/Changes

@@ -1,5 +1,6 @@
 Revision history for Gimp-Perl extension.
 
+1.052 Tue Feb  9 18:16:15 CET 1999
 	- moved the xlfd_size function from Gimp::Fu into Gimp
           (and maybe later into Gimp::Util?)
 	- functions in Gimp::Util are now treated in the same way
@@ -9,6 +10,8 @@ Revision history for Gimp-Perl extension.
         - enabled full testsuite (keep your fingers crossed)
 	- PDL examples no longer cause errors at startup
         - more compatibility fixes for 5.005_54
+        - bangpaths are now replaced by $PERL at configuration time
+        - fixed a few quirks in scm2scm and added it to the package
 
 1.051 Tue Jan 19 21:10:20 CET 1999
 	- corrected a minor typoe found by Stefan Traby <stefan@sime.com>

plug-ins/perl/Gimp.pm

@@ -174,7 +174,7 @@ sub import($;@) {
       } elsif ($_ ne "") {
          push(@export,$_);
       } elsif ($_ eq "") {
-         #nop #d#FIXME
+         #nop #d#FIXME, Perl-Server requires this!
       } else {
          croak "$_ is not a valid import tag for package $pkg";
       }
@@ -798,6 +798,8 @@ invocation.
 
 write trace to FILEHANDLE instead of STDERR.
 
+=back
+
 =head1 SUPPORTED GIMP DATA TYPES
 
 Gimp supports different data types like colors, regions, strings. In

plug-ins/perl/Gimp/PDL.pm

@@ -116,8 +116,9 @@ Some exmaples:
 
  $region = $drawable->pixel_rgn (0,0, 100,100, 1,0);
  $pixel = $region->get_pixel (5,7);	# fetches the pixel from (5|7)
- print $pixel;
+ print $pixel;				# outputs something like
- -> [255, 127, 0]			# RGB format ;)
+ 					# [255, 127, 0], i.e. in
+ 					# RGB format ;)
  $region->set_pixel ($pixel * 0.5, 5, 7);# darken the pixel
  $rect = $region->get_rect (3,3,70,20);	# get a horizontal stripe
  $rect = $rect->hclip(255/5)*5;		# clip and multiply by 5

plug-ins/perl/Gimp/Util.pm

@@ -1,6 +1,6 @@
 =head1 NAME
 
- Gimp::Util - some handy routines for Gimp.Perl users
+ Gimp::Util - some handy routines for Gimp-Perl users
 
 =head1 SYNOPSIS
 
@@ -23,7 +23,7 @@ you end up with them and the user cannot see them or delete them. So we
 always attach our created layers to an image here, too avoid memory leaks
 and debugging times.
 
-These functions preserve the current settings like colors.
+These functions try to preserve the current settings like colors.
 
 Also: these functions are handled in exactly the same way as
 PDB-Functions, i.e. the (hypothetical) function C<gimp_image_xyzzy> can be
@@ -236,6 +236,8 @@ sub gimp_text_wh {
 
 =pod
 
+=back
+
 =head1 AUTHOR
 
 Various, version 1.000 written mainly by Tels (http://bloodgate.com/). The author

plug-ins/perl/MANIFEST

@@ -1,4 +1,3 @@
-scm2perl
 README
 NEWS
 Changes
@@ -12,6 +11,8 @@ Makefile.PL
 typemap
 Gimp.pm
 Gimp.xs
+scm2perl
+scm2scm
 t/load.t
 t/loadlib.t
 t/run.t

plug-ins/perl/Makefile.PL

@@ -4,13 +4,13 @@ use ExtUtils::MakeMaker;
 use Config;
 
 $topdir=".";
+$|=1;
 
 if ($ARGV[0] ne "--writemakefile") {
    for(@ARGV) {
       s/^prefix=/--prefix=/i;
    }
    
-   $|=1;
    do './config.pl';
    if(defined $EXTENSIVE_TESTS) {
       print "\nFetched some defaults from an earlier Makefile.PL run.\n";
@@ -53,18 +53,20 @@ $] >= 5.005 or print <<EOF;
 WARNING: you are using a version of perl older than 5.005. While this
          extension should run on older versions (and I try to keep source
          compatibility), some people get spurious errors that go away
-         after upgrading to 5.005. Since 5.005 is much better and has many
+         after upgrading to 5.005 (or to gimp-1.1). Therefore, some
-         many bugs fixed, an upgrade wpuld come in handy...
+         features of Gimp DO NOT WORK WITH 5.004 or gimp-1.0. Since 5.005
+         is much better and has many many bugs fixed, an upgrade would
+         come in handy...
 
 EOF
 
 $GTK or print <<EOF;
 
-WARNING: unable to use the Perl-Gtk interface.  Some features (like
+WARNING: unable to use the Perl-Gtk interface. Most features (like
          Gimp::Fu) rely on this extension. You can try to build without
-         it, but it's better to install it (version 0.3 or higher is
+         it (and many scripts won't work), but it's better to install
-         required, you can get it from ftp://ftp.gimp.org/pub/gtk/perl/ or
+         it (version 0.3 or higher is required, you can get it from
-         any CPAN mirror.
+         ftp://ftp.gimp.org/pub/gtk/perl/ or any CPAN mirror.
 
 EOF
 
@@ -72,9 +74,9 @@ $PDL or print <<EOF;
 
 WARNING: unable to use PDL (the perl data language). This means that
          Gimp::PDL is non-functional. Unless you plan to use Tile/PixelRgn
-         functions together with PDL, this is harmless.  Gimp::PDL will be
+         functions together with PDL, this is harmless. Gimp::PDL will
-         installed, just in case you later install PDL.  The plug-ins using
+         be installed, just in case you later install PDL. The plug-ins
-         PDL, however, will NOT BE INSTALLED.  You can get PDL from any CPAN
+         using PDL, however, will NOT WORK. You can get PDL from any CPAN
          mirror.
 
 EOF
@@ -112,6 +114,17 @@ WARNING: version 0.3 of Gtk is _required_ for this module to
 EOF
 }
 
+@examples =
+   qw(windy.pl prep4gif.pl webify.pl PDB alpha2color.pl tex-to-float ditherize.pl
+      border.pl view3d.pl feedback.pl xachlego.pl xachshadow.pl);
+@shebang = (map("examples/$_",@examples),
+   qw(Perl-Server scm2perl scm2scm examples/example-net.pl));
+
+for(@shebang) {
+   print "updating bangpath in $_\n";
+   system ($PERL,"-pi","-e","\$. == 1 and \$_ = '#!$PERL\n'",$_);
+}
+
 sub MY::postamble {
    (my $GIMPTOOL2 = $GIMPTOOL) =~ s/^\.\./..\/../;
    my $postamble=<<"EOF";
@@ -130,9 +143,7 @@ install :: install-plugins
 install-plugins:
 EOF
 
-   $postamble.join("",map "	-cd examples && $GIMPTOOL2 --install-admin-bin $_\n",
+   $postamble.join("",map "	-cd examples && $GIMPTOOL2 --install-admin-bin $_\n", @examples);
-      qw(windy.pl prep4gif.pl webify.pl PDB alpha2color.pl tex-to-float ditherize.pl
-         border.pl view3d.pl feedback.pl xachlego.pl xachshadow.pl));
 }
 
 WriteMakefile(

plug-ins/perl/Perl-Server

@@ -1,4 +1,4 @@
-#!/usr/bin/perl
+#!/usr/app/bin/perl
 
 #
 # you can enable unix sockets, tcp sockets, or both (or neither...)

plug-ins/perl/TODO

@@ -10,14 +10,15 @@ make test TEST_VERBOSE=1
 
 bugs
 
-  * auto-edit shebang
+[DONE]  * auto-edit shebang
-  * only install plug-ins that really work
+[XXXX]  * only install plug-ins that really work
   * perl_fu_webify in homepage-logo.pl
   * wait for working gimp_file_load (or do it myself?)
-  * Gimp::import should croak on importing "garbage".
+[DONE]  * Gimp::import should croak on importing "garbage".
   
 important issues
 
+  * register dummy function to calm gimp down
   * gimp->object_id, drawable_object_id remove!
   * PF_CUSTOM
   * gimp_display_image

plug-ins/perl/examples/PDB

@@ -1,4 +1,4 @@
-#!/usr/bin/perl
+#!/usr/app/bin/perl
 
 #BEGIN {$^W=1};
 

plug-ins/perl/examples/alpha2color.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl 
+#!/usr/app/bin/perl
 
 use Gimp qw( :auto );
 use Gimp::Fu;

plug-ins/perl/examples/border.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl -w
+#!/usr/app/bin/perl
 
 #BEGIN {$^W=1};
 

plug-ins/perl/examples/ditherize.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl
+#!/usr/app/bin/perl
 
 use strict 'subs';
 use Gimp;

plug-ins/perl/examples/example-net.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl
+#!/usr/app/bin/perl
 
 # example for the gimp-perl-server (also called Net-Server)
 

plug-ins/perl/examples/prep4gif.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl 
+#!/usr/app/bin/perl
 
 use Gimp;
 use Gimp::Fu;

plug-ins/perl/examples/tex-to-float

@@ -1,4 +1,4 @@
-#!/usr/local/bin/perl
+#!/usr/app/bin/perl
 ######################################################################
 #  A Perl::Fu plugin for converting TeX strings to floating layers.
 #

plug-ins/perl/examples/view3d.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl -w
+#!/usr/app/bin/perl
 
 BEGIN { $^W=1 }
 use strict;

plug-ins/perl/examples/webify.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl -w
+#!/usr/app/bin/perl
 
 use Gimp;
 use Gimp::Fu;

plug-ins/perl/examples/windy.pl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl
+#!/usr/app/bin/perl
 
 # sent to me by Seth Burgess <sjburges@ou.edu>
 # small changes my Marc Lehmann <pcg@goof.com>

plug-ins/perl/scm2perl

@@ -1,4 +1,4 @@
-#!/usr/bin/perl
+#!/usr/app/bin/perl
 
 #require 5.005;
 

plug-ins/perl/scm2scm

@@ -0,0 +1,280 @@
+#!/usr/app/bin/perl
+
+#require 5.005;
+
+# Copyright Marc Lehmann <pcg@goof.com>
+#
+# This is distributed under the GPL.
+
+=cut
+
+=head1 NAME
+
+scm2scm - convert script-fu to script-fu
+
+=head1 SYNOPSIS
+
+ scm2scm [-d] [-t translation]... filename.scm...
+
+=head1 DESCRIPTION
+
+This perl-script can be used to upgrade existing script-fu-scripts to
+newer gimp API's.
+
+=head1 EXAMPLES
+
+Convert all script-fu scripts in the current directory from the
+1.0 to the current API:
+
+ scm2scm *.scm
+
+Convert C<weird.scm> from the 1.0 api to the 1.2 api:
+
+ scm2scm -t 1.2 weird.scm
+
+Generate a diff containing the required changes from the 1.0
+to the 1.1-API:
+
+ scm2scm -d -t 1.1 test.scm
+
+=head1 SWITCHES
+
+=over 4
+
+=item -d
+
+generate a unified diff on stdout
+
+=item -t translation id
+
+specify a translation id, can be one of (run scm2scm without arguments
+to see the full list)
+
+I<api1>	api-mega-break-patch #1
+
+I<1.1>	1.0 -> 1.1 (not fully implemented)
+
+I<1.2>	1.0 -> 1.2 (not fully implemented)
+
+=back
+
+=head1 AUTHOR
+
+Marc Lehmann <pcg@goof.com>
+
+=head1 SEE ALSO
+
+gimp(1), L<Gimp>.
+
+=cut
+
+# drop the first argument, while preserving correct whitespace(!)
+sub drop_1st {
+  my($a,$f,$t1,$t2,@t)=@_;
+  ($a,$f,new token($t1->[0],$t2->[1],$t2->[2]),@t);
+}
+
+# every hash value consists of an array of specifications, each
+# one has the form ["regexp", codref_to_call], or a string (another translation
+# name)
+%translation = (
+   'api1' =>
+      [[
+        "^(gimp-airbrush|gimp-blend|gimp-brightness-contrast|gimp-bucket-fill|".
+        "gimp-by-color-select|gimp-channel-ops-offset|gimp-clone|gimp-color-balance|".
+        "gimp-color-picker|gimp-convolve|gimp-curves-explicit|gimp-curves-spline|".
+        "gimp-desaturate|gimp-edit-clear|gimp-edit-copy|gimp-edit-cut|gimp-edit-fill|".
+        "gimp-edit-paste|gimp-edit-stroke|gimp-equalize|gimp-eraser|".
+        "gimp-eraser-extended|gimp-flip|gimp-fuzzy-select|gimp-histogram|".
+        "gimp-hue-saturation|gimp-invert|gimp-levels|gimp-paintbrush|".
+        "gimp-paintbrush-extended|gimp-pencil|gimp-perspective|gimp-posterize|".
+        "gimp-rotate|gimp-scale|gimp-selection-float|gimp-selection-layer-alpha|".
+        "gimp-selection-load|gimp-shear|gimp-threshold)\$",
+        \&drop_1st
+      ]],
+   '1.1' => ['api1'],
+   '1.2' => ['api1'],
+);
+
+$gen_diff=0;
+@trans = ();
+
+package token;
+
+sub new {
+   my $type = shift;
+   bless [@_],$type;
+}
+
+package main;
+
+my $stream;	# the stream to tokenize from
+my $word;	# the current token-word
+my $tok;	# current token
+
+# parses a new token [ws, tok, ws]
+sub get() {
+   my $ws1,$ws1,$ctok;
+   # could be wrapped into one regex
+   $ws1 = $stream=~s/^((?:\s*(?:(;[^\n]*\n))?)*)// ? $1 : die;
+   $ctk = $stream=~s/^(\(
+                      |\)
+                      |"(?:[^"]+|\\")*"
+                      |'(?:[^()]+)
+                      |[^ \t\r\n()]+
+                      )
+                      (?:[ \t]*(?=\n))?//x ? $1 : undef;
+   $ws2 = $stream=~s/^([ \t]*;[^\n]*\n)// ? $1 : "";
+   $word=$ctk;
+   
+#   print "TOKEN:$ws1:$ctk:$ws2\n";
+   $tok=new token($ws1,$ctk,$ws2);
+}
+
+# returns a parse tree, which is an array
+# of [token, token...] refs.
+sub parse() {
+   my @toks;
+   $depth++;
+   for(;;) {
+#      print "$depth: $word\n";
+      if ($word eq "(") {
+         my $t = $tok; get;
+         my @t = &parse;
+         $word eq ")" or die "missing right paranthese (got $word)\n";
+         push(@toks,[$t,@t,$tok]); get;
+      } elsif ($word eq ")") {
+         $depth--;
+         return @toks;
+      } elsif (!defined $word) {
+         $depth--;
+         return @toks;
+      } else {
+         push(@toks,$tok);
+         get;
+      }
+   }
+}
+
+sub parse_scheme {
+   get;
+   my @t = parse;
+   (@t,$tok);
+}
+
+# dumb dump of the tree structure
+sub dump_tree {
+   my $d=shift;
+   print "$d",scalar@_;
+   for(@_) {
+      if (isa($_,token)) {
+         print " [$_->[1]]";
+      } else {
+         print " *";
+      }
+   }
+   print "\n";
+   for(@_) {
+      if(!isa($_,token)) {
+         dump_tree ("$d   ",@$_);
+      }
+   }
+}
+
+sub toks2scheme {
+   my $func = shift;
+   if ($func->[1] eq "(") {
+      my $close = shift;
+#      func2scheme @_;
+   } else {
+   }
+   while(@_) {
+      my @toks = shift;
+      my ($ws1,$t,$ws1)=$toks[0]
+   }
+   
+}
+
+sub tree2scheme {
+   join ("",map isa($_,token) ? @$_ : tree2scheme(@$_),@_);
+}
+
+# translate functions, sorry folks, this function is write-only!
+sub translate {
+   my $v=shift;
+   my @t=@_;
+   if (isa($t[0],token)) {
+      for(@$v) {
+         if ($t[1][1] =~ $_->[0]) {
+            @t=$_->[1]->(@t);
+         }
+      }
+   }
+   for(@t) {
+      $_=[translate($v,@$_)] unless isa($_,token);
+   }
+   @t;
+}
+
+sub dofile {
+   my($in,$out)=@_;
+   
+   open IN,"$in"   or die "unable to open '$in' for reading: $!";
+   { local $/; $stream = <IN> }
+   close IN;
+   
+   my @prog = parse_scheme;
+   
+   if (@trans) {
+      my $changed;
+      do {
+         $changed=0;
+         @trans = map {
+            if (!ref $_) {
+               $changed=1;
+               @{$translation{$_}};
+            } else {
+               $_;
+            }
+         } @trans;
+      } while($changed);
+      @prog = translate ([@trans],@prog);
+   }
+   
+   open OUT,"$out" or die "unable to open '$out' for writing: $!";
+   print OUT tree2scheme(@prog);
+   close OUT;
+}
+
+*isa = \&UNIVERSAL::isa;
+
+sub usage {
+   print STDERR "Script-Fu to Script-Fu Translater 1.1\n";
+   print STDERR "Usage: $0 [-d] [-t translation] file.scm ...\n";
+   print STDERR "available translations are: @{[keys %translation]}\n";
+   exit(1);
+}
+
+while($ARGV[0]=~/^-(.)$/) {
+   shift;
+   if ($1 eq "d") {
+      $gen_diff=1;
+   } elsif ($1 eq "t") {
+      push(@trans,shift);
+   } else {
+     print STDERR "unknown switch '$1'\n";
+   }
+}
+@ARGV or usage;
+
+for $x (@ARGV) {
+   my $y;
+   if ($gen_diff) {
+      $y="| echo Index: '$x' && diff -u '$x' -";
+   } else {
+      ($y=$x)=~s/\.scm/.sc2/i or die "source file '$x' has no .scm extension";
+      $y=">$y\0";
+   }
+   dofile("<$x\0",$y);
+}
+