Commit 0db24d2a authored by Marc Lehmann's avatar Marc Lehmann
Browse files

see plug-ins/perl/Changes

parent 7cad9389
......@@ -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.
......
......@@ -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] }
......
......@@ -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 {
......
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;
......
......@@ -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
......
......@@ -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 : ();
......
......@@ -71,4 +71,4 @@ examples/animate_cells
examples/yinyang
examples/image_tile
examples/stamps
examples/font_table
......@@ -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 <<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 (or to gimp-1.1). Therefore, some
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...
NOTICE: 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 (or to gimp-1.1). Also, some features of
Gimp DO NOT WORK WITH 5.004 or gimp-1.0 and are disabled. Since
5.005 is much better and has many many bugs fixed, an upgrade
would come in handy...
EOF
......@@ -99,7 +99,7 @@ EOF
!$PDL or $PDL::Version::VERSION > 1.99 or print <<EOF;
WARNING: PDL version $PDL::Version::VERSION is installed. Gimp::PDL was only
tested with 1.99 and higher. In case of problems its advisable to
tested with 2.0 and higher. In case of problems its advisable to
upgrade PDL to at least version 2.
EOF
......@@ -209,6 +209,8 @@ maintainer-clean :: realclean
distclean :: realclean
check :: test
MY_FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker -e 'MY->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',
......
#!/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(<P>) {
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",
"<Toolbox>/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
<Toolbox>/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<Foundary>, I<Family>, I<Weight> and I<Slant> 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<adobe>", "I<bitstream>" or "I<ttf>") that
you wish to select (default: "*").
=item Family
A perl regular expression or "*".
The font family (e.g. "I<courier>" or "I<helvetica>") that you wish to
select (default: "*").
=item Weight
A perl regular expression or "*".
The weights (e.g. "I<bold>" or "I<medium>") 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<i>" for itallic, "I<o>" for oblique and "I<r>" 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 E<lt>ajs@ajs.comE<gt>
=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<gimp>, L<perl>, L<Gimp>: the Gimp module for perl.
=cut
#!/usr/bin/perl
# by Seth Burgess <sjburges@gimp.org>