diff --git a/plug-ins/perl/Changes b/plug-ins/perl/Changes index c90baea772..b7b935dab0 100644 --- a/plug-ins/perl/Changes +++ b/plug-ins/perl/Changes @@ -6,6 +6,10 @@ Revision history for Gimp-Perl extension. - implemented PF_FILE, for selecting filesystem objects. - improved and fixed parasite support. - Gimp::Data now uses parasites when available. + - changed FIXIN, i.e. all scripts now are patched with the correct + bangpath. + - added font_map. re-added xachshadow.pl, which was mysteriously + missing. 1.07 Mon Mar 15 01:27:05 CET 1999 - added examples/yinyang, examples/image_tile, examples/stamps. diff --git a/plug-ins/perl/Gimp.pm b/plug-ins/perl/Gimp.pm index 0ff50176c7..92be953bdc 100644 --- a/plug-ins/perl/Gimp.pm +++ b/plug-ins/perl/Gimp.pm @@ -151,7 +151,7 @@ $_PROT_VERSION = "2"; # protocol version # we really abuse the import facility.. sub import($;@) { my $pkg = shift; - my $up = caller(); + my $up = caller; my @export; # make a quick but dirty guess ;) @@ -338,18 +338,19 @@ sub call_callback { sub callback { my $type = shift; - confess unless initialized(); - _initialized_callback; return () if $caller eq "Gimp"; if ($type eq "-run") { local $function = shift; local $in_run = 1; + _initialized_callback; call_callback 1,$function,@_; } elsif ($type eq "-net") { local $in_net = 1; + _initialized_callback; call_callback 1,"net"; } elsif ($type eq "-query") { local $in_query = 1; + _initialized_callback; call_callback 1,"query"; } elsif ($type eq "-quit") { local $in_quit = 1; @@ -529,9 +530,8 @@ package Gimp::Parasite; sub is_type($$) { $_[0]->[0] eq $_[1] } sub is_persistant($) { $_[0]->[1] & PARASITE_PERSISTANT } -sub is_error($) { !defined $_[0] } +sub is_error($) { !defined $_[0]->[0] } sub has_flag($$) { $_[0]->[1] & $_[1] } -sub error($) { undef } sub copy($) { [@{$_[0]}] } sub name($) { $_[0]->[0] } sub flags($) { $_[0]->[1] } diff --git a/plug-ins/perl/Gimp/Feature.pm b/plug-ins/perl/Gimp/Feature.pm index f5a9012188..4122876a5c 100644 --- a/plug-ins/perl/Gimp/Feature.pm +++ b/plug-ins/perl/Gimp/Feature.pm @@ -33,6 +33,7 @@ my %description = ( 'gtkxmhtml' => 'the Gtk::XmHTML module', 'dumper' => 'the Data::Dumper module', 'never' => '(for testing, will never be present)', + 'unix' => 'a unix-like operating system', ); sub import { @@ -50,6 +51,7 @@ sub missing { my ($msg,$function)=@_; require Gimp; Gimp::logger(message => "$_[0] is required but not found", function => $function); + Gimp::initialized() ? die "BE QUIET ABOUT THIS DIE\n" : exit Gimp::quiet_main(); } sub need { @@ -93,6 +95,13 @@ sub present { eval { require Gtk::XmHTML }; $@ eq ""; } elsif ($_ eq "dumper") { eval { require Data::Dumper }; $@ eq ""; + } elsif ($_ eq "unix") { + !{ + MacOS => 1, + MSWin32 => 1, + os2 => 1, + VMS => 1, + }->{$^O}; } elsif ($_ eq "never") { 0; } else { diff --git a/plug-ins/perl/Gimp/Fu.pm b/plug-ins/perl/Gimp/Fu.pm index 862a1857d4..4d62f0aa2c 100644 --- a/plug-ins/perl/Gimp/Fu.pm +++ b/plug-ins/perl/Gimp/Fu.pm @@ -1,26 +1,11 @@ package Gimp::Fu; -use strict 'vars'; use Carp; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS - @scripts @_params $run_mode %pf_type2string @image_params); use Gimp qw(); use Gimp::Data; -use base qw(Exporter); require Exporter; -eval { - require Data::Dumper; - import Data::Dumper 'Dumper'; -}; -if ($@) { - *Dumper = sub { - "()"; - }; -} - - =cut =head1 NAME @@ -128,14 +113,20 @@ sub Gimp::RUN_FULLINTERACTIVE (){ Gimp::RUN_INTERACTIVE+100 }; # you don't want PF_CHANNEL PF_BOOL PF_SLIDER PF_INT PF_SPINNER PF_ADJUSTMENT PF_BRUSH PF_PATTERN PF_GRADIENT PF_RADIO PF_CUSTOM PF_FILE); -@EXPORT = (qw(register main),@_params); -@EXPORT_OK = qw(interact $run_mode save_image); -%EXPORT_TAGS = (params => [@_params]); +#@EXPORT_OK = qw(interact $run_mode save_image); sub import { local $^W=0; - shift @_ if $_[0] =~ /::/; - Gimp::Fu->export_to_level(1,@_); + my $up = caller; + shift; + @_ = (qw(register main),@_params) unless @_; + for (@_) { + if ($_ eq ":params") { + push (@_, @_params); + } else { + *{"${up}::$_"} = \&$_; + } + } } # the old value of the trace flag @@ -965,7 +956,8 @@ sub register($$$$$$$$$;@) { $input_image = $_[0] if ref $_[0] eq "Gimp::Image"; $input_image = $pre[0] if ref $pre[0] eq "Gimp::Image"; - $Gimp::Data{"$function/_fu_data"}=Dumper([@_]); + eval { require Data::Dumper }; + $Gimp::Data{"$function/_fu_data"}=Data::Dumper::Dumper([@_]) unless $@; print $function,"(",join(",",(@pre,@_)),")\n" if $Gimp::verbose; diff --git a/plug-ins/perl/Gimp/Lib.xs b/plug-ins/perl/Gimp/Lib.xs index 7bc8bd4f0c..cbb65bf3c3 100644 --- a/plug-ins/perl/Gimp/Lib.xs +++ b/plug-ins/perl/Gimp/Lib.xs @@ -627,16 +627,18 @@ push_gimp_sv (GParam *arg, int array_as_ref) #if GIMP_PARASITE case PARAM_PARASITE: - if (arg->data.d_parasite.name) - { - AV *av = newAV (); - av_push (av, neuSVpv (arg->data.d_parasite.name ? arg->data.d_parasite.name : "")); - av_push (av, newSViv (arg->data.d_parasite.flags)); - av_push (av, newSVpv (arg->data.d_parasite.data, arg->data.d_parasite.size)); - sv = (SV *)av; /* no newRV_inc, since we're getting autoblessed! */ - } - else - sv = newSVsv (&PL_sv_undef); + { + AV *av = newAV (); + + if (arg->data.d_parasite.name) + { + av_push (av, neuSVpv (arg->data.d_parasite.name)); + av_push (av, newSViv (arg->data.d_parasite.flags)); + av_push (av, newSVpv (arg->data.d_parasite.data, arg->data.d_parasite.size)); + } + + sv = (SV *)av; + } break; #endif diff --git a/plug-ins/perl/Gimp/Net.pm b/plug-ins/perl/Gimp/Net.pm index b281d8f007..f3e108f8ac 100644 --- a/plug-ins/perl/Gimp/Net.pm +++ b/plug-ins/perl/Gimp/Net.pm @@ -22,7 +22,6 @@ $trace_res = *STDERR; $trace_level = 0; my $initialized = 0; -my $new_handle = "HANDLE0000"; sub initialized { $initialized } @@ -49,10 +48,12 @@ sub net2args($) { sub args2net { my($res,$v); for $v (@_) { - if(ref($v) eq "ARRAY" or ref($v) eq "Gimp::Color" or ref($v) eq "Gimp::Parasite") { - $res.="[".join(",",map { "qq[".quotemeta($_)."]" } @$v)."],"; - } elsif(ref($v)) { - $res.="b(".$$v.",".ref($v)."),"; + if(ref($v)) { + if(ref($v) eq "ARRAY" or ref($v) eq Gimp::Color or ref($v) eq Gimp::Parasite) { + $res.="[".join(",",map { "qq[".quotemeta($_)."]" } @$v)."],"; + } else { + $res.="b(".$$v.",".ref($v)."),"; + } } elsif(defined $v) { $res.="qq[".quotemeta($v)."],"; } else { @@ -138,7 +139,7 @@ sub set_trace { sub start_server { print "trying to start gimp\n" if $Gimp::verbose; - $server_fh=*{$new_handle++}; + $server_fh=local *FH; socketpair $server_fh,GIMP_FH,PF_UNIX,SOCK_STREAM,AF_UNIX or croak "unable to create socketpair for gimp communications: $!"; $gimp_pid = fork; @@ -174,7 +175,7 @@ sub try_connect { if (s{^spawn/}{}) { return start_server; } elsif (s{^unix/}{/}) { - my $server_fh=*{$new_handle++}; + my $server_fh=local *FH; return socket($server_fh,PF_UNIX,SOCK_STREAM,AF_UNIX) && connect($server_fh,sockaddr_un $_) ? $server_fh : (); @@ -182,7 +183,7 @@ sub try_connect { s{^tcp/}{}; my($host,$port)=split /:/,$_; $port=$default_tcp_port unless $port; - my $server_fh=*{$new_handle++}; + my $server_fh=local *FH; return socket($server_fh,PF_INET,SOCK_STREAM,scalar getprotobyname('tcp') || 6) && connect($server_fh,sockaddr_in $port,inet_aton $host) ? $server_fh : (); diff --git a/plug-ins/perl/MANIFEST b/plug-ins/perl/MANIFEST index fcc1639231..36a5f7de8e 100644 --- a/plug-ins/perl/MANIFEST +++ b/plug-ins/perl/MANIFEST @@ -71,4 +71,4 @@ examples/animate_cells examples/yinyang examples/image_tile examples/stamps - +examples/font_table diff --git a/plug-ins/perl/Makefile.PL b/plug-ins/perl/Makefile.PL index 5af53d2adf..aa5aeb00d6 100644 --- a/plug-ins/perl/Makefile.PL +++ b/plug-ins/perl/Makefile.PL @@ -9,7 +9,7 @@ $|=1; 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 parasite-editor scratches.pl blowinout.pl terral_text xachvision.pl gimpmagick perlcc - sethspin.pl animate_cells image_tile yinyang stamps + sethspin.pl animate_cells image_tile yinyang stamps font_map ); @shebang = (map("examples/$_",@examples), qw(Perl-Server examples/example-net.pl examples/homepage-logo.pl @@ -65,13 +65,13 @@ eval "use Parse::RecDescent;"; $PRD = $@ eq ""; $] >= 5.005 or print < 1.99 or print <fixin(\@ARGV)' + clean :: test -f Makefile || mv -f Makefile.old Makefile \$(RM_RF) inst-temp @@ -220,7 +222,7 @@ install-plugins :: \$(UMASK_NULL) ; \\ \$(CP) ".join(' ',map("'../examples/$_'",@examples))." ../Perl-Server . ; \\ \$(CHMOD) 755 * ; \\ - \$(FIXIN) * ; \\ + \$(MY_FIXIN) * ; \\ for plugin in * ; do \\ $GT --install-admin-bin \"\$\$plugin\" ; \\ done @@ -230,13 +232,15 @@ install-plugins :: WriteMakefile( 'dist' => { - 'PREOP' => 'chmod -R u=rwX,go=rX . ;', - 'COMPRESS' => 'gzip -9v', - 'SUFFIX' => '.gz', + PREOP => 'chmod -R u=rwX,go=rX . ;', + COMPRESS => 'gzip -9v', + SUFFIX => '.gz', }, 'PREREQ_PM' => { - "Gtk" => 0.3, - "Data::Dumper" => 2, + Gtk => 0.3, + PDL => 1.99, + Data::Dumper => 2, + Parse::RecDescent => 1.6, }, 'DIR' => ['Gimp'], 'NAME' => 'Gimp', diff --git a/plug-ins/perl/examples/font_table b/plug-ins/perl/examples/font_table new file mode 100755 index 0000000000..d1fc4c9508 --- /dev/null +++ b/plug-ins/perl/examples/font_table @@ -0,0 +1,303 @@ +#!/usr/bin/perl +# +# Font Table plugin for The Gimp +# +# Written because I suddenly had 4000+ TTF fonts loaded on my system +# and no idea which ones I wanted to use. +# +# Written by Aaron Sherman, (c) 1998 + +use Gimp::Feature 'unix'; +use Gimp qw(:auto); +use Gimp::Fu; + +sub font_table { + my $foundery = shift; + my $family = shift; + my $weight = shift; + my $slant = shift; + my $size = shift; + my $fg = shift; + my $bg = shift; + my $labelfont = shift; + my $test_text = shift; + my $padding = shift; + my $pageheight = shift; + my $lastimg = undef; + + $foundery = '.' if $foundery eq '*'; + $family = '.' if $family eq '*'; + $weight = '.' if $weight eq '*'; + $slant = '.' if $slant eq '*'; + + if ($size ne '*' && $size <= 0) { + die("Font Table: Size parameter ($size) is invalid"); + } + + # XXX - Here, I use xlsfonts. This is non-portable, but I could not find + # the equivilant in Gtk or PDB. Someone want to clue me in? I should + # look at the Gimp source to find how they get their font lists. + local *P; + local $_; + open(P,"xlsfonts 2>/dev/null |") || die("Font Table: Cannot fork: $!"); + while(

) { + next unless /^-/; + my @f = split /-/, $_; + if ($f[1] =~ /$foundery/i && $f[2] =~ /$family/i && $f[3] =~ /$weight/i && + $f[4] =~ /$slant/i && ($f[7] == 0 || $size eq '*' || $f[7] == $size)) { + $fonts{$_}++; + } + } + close P; + die("Font Table: Problem running xlsfonts") if $?; + + my $col1_width = 0; + my $col2_width = 0; + my $row_height = 0; + my $total_height = $padding; + my @rows; + my $firstfont = 0; + + @fonts = sort keys %fonts; + undef %fonts; + + for(my $i = 0;$i < @fonts;$i++) { + my $font = $fonts[$i]; + my @f = split /-/, $font; + if ($f[7] == 0) { + $f[7] = $size; + } + my $fslant = $f[4] eq 'r'? '' : ' italic'; + my $label = "$f[1] $f[2] ($f[3]$fslant $f[7])"; + my($cwidth,$cheight,$ascent,$descent) = + gimp_text_get_extents_fontname($label, $size, 1, $labelfont); + my($twidth,$theight,$ascent,$descent) = + gimp_text_get_extents($test_text, $f[7], 1, $f[1], $f[2], $f[3], + $f[4], '*', '*'); + + $row_height = $cheight > $theight ? $cheight : $theight; + + if ($total_height + $row_height + $padding > $pageheight) { + $lastimg = display_fonts( + $size, $fg, $bg, $labelfont, $padding, $total_height, + \@rows, $col1_width, $col2_width, $test_text, + \@fonts, $firstfont, $i-1); + $col1_width = 0; + $col2_width = 0; + $total_height = $padding; + $firstfont = $i; + @rows = (); + } + + $col1_width = $cwidth if $col1_width < $cwidth; + $col2_width = $twidth if $col2_width < $twidth; + push(@rows,$row_height); + $total_height += $row_height+$padding; + $row_height = 0; + + if ($i+1 == @fonts) { + $lastimg = display_fonts( + $size, $fg, $bg, $labelfont, $padding, $total_height, + \@rows, $col1_width, $col2_width, $test_text, + \@fonts, $firstfont, $i); + } + + } + + return undef; # This may generate a warning, but it's better than + # getting a duplicate image, which is what I get if I + # return $lastimg + # return $lastimg; +} + +sub display_fonts { + my $size = shift; + my $fg = shift; + my $bg = shift; + my $labelfont = shift; + my $padding = shift; + my $total_height = shift; + my $rows = shift; + my $col1_width = shift; + my $col2_width = shift; + my $test_text = shift; + my $fonts = shift; + my $min = shift; + my $max = shift; + + # Create new image + my $width = $col1_width + $col2_width + $padding*3; + my $height = $total_height; + my $img = gimp_image_new($width,$height,0); + my $layer = gimp_layer_new($img,$width,$height,1,"Font Table",100,0); + gimp_image_add_layer($img,$layer,0); + gimp_image_set_active_layer($img,$layer); + my $draw = gimp_image_active_drawable($img); + my $oldfg = gimp_palette_get_foreground(); + gimp_palette_set_foreground($bg); + gimp_selection_all($img); + gimp_bucket_fill($draw,0,0,100,0,0,0,0); + gimp_selection_none($img); + gimp_palette_set_foreground($fg); + + my $y = $padding; + + for(my $i = $min;$i <= $max; $i++) { + my $font = $fonts->[$i]; + my @f = split /-/, $font; + if ($f[7] == 0) { + $f[7] = $size; + } + my $fslant = $f[4] eq 'r'? '' : ' italic'; + my $label = "$f[1] $f[2] ($f[3]$fslant $f[7])"; + + my $l = gimp_text_fontname($draw,$padding, $y, $label, 0, 1, $size, 1, + $labelfont); + gimp_floating_sel_anchor($l); + $l = gimp_text($draw,$padding*2+$col1_width, $y, $test_text, 0, 1, + $f[7], 1, $f[1], $f[2], $f[3], $f[4], '*', '*'); + gimp_floating_sel_anchor($l); + + my $row = shift @$rows; + $y += $row + $padding; + } + + # Finish up + gimp_palette_set_foreground($oldfg); + gimp_selection_none($img); + gimp_display_new($img); + gimp_displays_flush(); + return $img; +} + +# Gimp::Fu registration routine for placing this function into gimp's PDB +register + "font_table", + "Create a tabular index of fonts", + "Create a tabular index of fonts", + "Aaron Sherman", "Aaron Sherman (c)", "1999-03-16", + "/Xtns/Render/Font Table", + "*", + [ + [PF_STRING, "Foundery (perl regex or \"*\")", "Foundery", "*"], + [PF_STRING, "Family (perl regex or \"*\")", "Family", "*"], + [PF_STRING, "Weight (perl regex or \"*\")", "Weight", "*"], + [PF_STRING, "Slant (perl regex or \"*\")", "Slant", "*"], + [PF_INT32, "Point Size", "Size", 18], + [PF_COLOR, "Text Color", "FG", 'black'], + [PF_COLOR, "Background Color", "BG", 'white'], + [PF_FONT, "Label Font", "Font", '-*-courier-medium-r-normal--18-*-*-*-*-*-*-*'], + [PF_STRING, "Test String", "String", 'FOUR (4) SCORE and seven (7) years @%$*&'], + [PF_INT32, "Text Padding", "Padding", 10], + [PF_INT32, "Maximum page height", "Height", 1000] + ], + \&font_table; + +exit main; + +__END__ + + +=head1 NAME + +font_table - Create images with sample renderings of the requested fonts. + +=head1 SYNOPSIS + + /Xtns/Script-Fu/Utils/Font Table + +=head1 DESCRIPTION + +This plug-in will create one or more images with sample renderings of +the fonts that you request. It is designed to be a replacement for the +Font Map plug-in which has a much more limited user interface. + +=head1 PARAMETERS + +=over 5 + +The I, I, I and I parameters are either +set to "*" to indicate that all should be matched or a perl regular +expression (e.g. "C<^ttf>" or "C<(demi)?bold>"). + +=item Foundery + +A perl regular expression or "*". + +The font foundery (e.g. "I", "I" or "I") that +you wish to select (default: "*"). + +=item Family + +A perl regular expression or "*". + +The font family (e.g. "I" or "I") that you wish to +select (default: "*"). + +=item Weight + +A perl regular expression or "*". + +The weights (e.g. "I" or "I") to be matched. Remember that since +this is a regular expression, "bold" will match "bold" and "demibold" (default: +"*"). + +=item Slant + +A perl regular expression or "*". + +The slant (e.g. "I" for itallic, "I" for oblique and "I" for +regular) (default: "*"). + +=item Point Size + +This parameter is the point size for the fonts to be matched. Note that +this is *not* pixel size. + +=item Text Color + +The color that the text should be rendered in (default: black). + +=item Background Color + +The color of the image background (default: white). + +=item Label Font + +The single font to use for labeling each font (don't use a font which might +not be able to render some of the characters in the font names). Usually +the default, "courier", is a good choice. + +=item Test String + +This is the string that will be rendered once in each font selected. + +=item Text Padding + +The amount of space between each text row. Default is 10. + +=item Page Height + +Once the rendered image has reached this height, a new image will be started. +This is in pixels, and is intended to allow ease of viewing and printing. + +=back + +=head1 AUTHOR + +Written in 1998 (c) by Aaron Sherman Eajs@ajs.comE + +=head1 BUGS + +This plug-in relies on running xlsfonts. If your platform does not have +xlsfonts, or it's not in your path, or its output looks different from +what this plug-in expects, it won't work. At the time this plug-in was +written (late 1998) gtk+ had no facility to get a list of available font +names. This may have changed, and an update to this plug-in will be +distributed if so. + +=head1 SEE ALSO + +L, L, L: the Gimp module for perl. + +=cut diff --git a/plug-ins/perl/examples/xachshadow.pl b/plug-ins/perl/examples/xachshadow.pl index 42350877ad..285c4e0afc 100755 --- a/plug-ins/perl/examples/xachshadow.pl +++ b/plug-ins/perl/examples/xachshadow.pl @@ -1,4 +1,6 @@ #!/usr/bin/perl +# by Seth Burgess + #[Xach] start off with an image, then pixelize it #[Xach] then add alpha->add layer mask [20:21] #[Xach] render a checkerboard into the layer mask @@ -15,7 +17,9 @@ # Revision 1.1: Marc Lehman added undo capability # Revision 1.2: Marc Lehman , changed function name - +# Revision 1.3: Seth Burgess , changed location and +# added my email address +# # Here's the boring start of every script... use Gimp; @@ -25,9 +29,9 @@ register "xach_shadows", "Xach's Shadows o' Fun", "Screen of 50% of your drawing into a dropshadowed layer.", "Seth Burgess", - "Seth Burgess", - "1.2", - "/Filters/Misc/Xach Shadows", + "Seth Burgess ", + "2-15-98", + "/Filters/Map/Xach Shadows", "RGB*, GRAY*", [ [PF_SLIDER, "Block size", "The size of the blocks...", 10, [0, 255, 1]], @@ -75,5 +79,6 @@ register "xach_shadows", gimp_displays_flush(); return(); }; + exit main;