diff --git a/plug-ins/perl/Changes b/plug-ins/perl/Changes index 99b97b5d6a..dc78637073 100644 --- a/plug-ins/perl/Changes +++ b/plug-ins/perl/Changes @@ -12,6 +12,8 @@ Revision history for Gimp-Perl extension. - the case when "not enough arguments" were supplied for a function was not reliably detected. - gimp_progress_init now accepts either one or two arguments. + - switched to using Devel::PPPort, which hopefulyl solves all my + problems. 1.061 Fri Mar 12 21:27:26 CET 1999 - closed big, BIG security hole on password authenticitation diff --git a/plug-ins/perl/Gimp.pm b/plug-ins/perl/Gimp.pm index ba3a4a0216..109269d2d6 100644 --- a/plug-ins/perl/Gimp.pm +++ b/plug-ins/perl/Gimp.pm @@ -5,7 +5,8 @@ use Carp; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD %EXPORT_TAGS @EXPORT_FAIL @_consts @_procs $interface_pkg $interface_type @_param @_al_consts @PREFIXES $_PROT_VERSION - @gimp_gui_functions $function + @gimp_gui_functions $function $basename + $in_quit $in_run $in_net $in_init $in_query $no_SIG $help $verbose $host); require DynaLoader; @@ -269,8 +270,6 @@ EOF my @log; my $caller; -my $ignore_die; -my $in_quit; sub format_msg { $_=shift; @@ -292,14 +291,12 @@ sub _initialized_callback { # fatal sub logger { my %args = @_; - my $file=$0; - $file=~s/^.*[\\\/]//; $args{message} = "unknown message" unless defined $args{message}; $args{function} = $function unless defined $args{function}; $args{function} = "" unless defined $args{function}; $args{fatal} = 1 unless defined $args{fatal}; - push(@log,[$file,@args{'function','message','fatal'}]); - print STDERR format_msg($log[-1]),"\n"; + push(@log,[$basename,@args{'function','message','fatal'}]); + print STDERR format_msg($log[-1]),"\n" if ($in_run || $in_net || $verbose); _initialized_callback if initialized(); } @@ -324,15 +321,17 @@ sub callback { return () if $caller eq "Gimp"; if ($type eq "-run") { local $function = shift; + local $in_run = 1; call_callback 1,$function,@_; } elsif ($type eq "-net") { + local $in_net = 1; call_callback 1,"net"; } elsif ($type eq "-query") { + local $in_query = 1; call_callback 1,"query"; } elsif ($type eq "-quit") { - $ignore_die = 1; + local $in_quit = 1; call_callback 0,"quit"; - undef $ignore_die; } } @@ -348,22 +347,24 @@ sub quiet_main { main; } -$SIG{__DIE__} = sub { - if (!$^S && $ignore_die) { - die_msg $_[0]; - initialized() ? die "BE QUIET ABOUT THIS DIE\n" : xs_exit(main()); - } else { - die $_[0]; - } -}; +unless ($no_SIG) { + $SIG{__DIE__} = sub { + unless ($^S || !defined $^S || $in_quit) { + die_msg $_[0]; + initialized() ? die "BE QUIET ABOUT THIS DIE\n" : xs_exit(main()); + } else { + die $_[0]; + } + }; -$SIG{__WARN__} = sub { - if ($ignore_die) { - warn $_[0]; - } else { - logger(message => substr($_[0],0,-1), fatal => 0, function => 'WARNING'); - } -}; + $SIG{__WARN__} = sub { + unless ($in_quit) { + warn $_[0]; + } else { + logger(message => substr($_[0],0,-1), fatal => 0, function => 'WARNING'); + } + }; +} ############################################################################## @@ -388,10 +389,15 @@ for(qw(_gimp_procedure_available gimp_call_procedure set_trace initialized)) { *lock = \&{"${interface_pkg}::lock" }; *unlock= \&{"${interface_pkg}::unlock" }; -@PREFIXES=("gimp_", ""); +($basename = $0) =~ s/^.*[\\\/]//; + +$verbose= +$in_quit=$in_run=$in_net=$in_init=$in_query=0; # perl -w is braindamaged my %ignore_function = (); +@PREFIXES=("gimp_", ""); + @gimp_gui_functions = qw( gimp_progress_init gimp_progress_update diff --git a/plug-ins/perl/Gimp.xs b/plug-ins/perl/Gimp.xs index 77834f526e..2d3022b992 100644 --- a/plug-ins/perl/Gimp.xs +++ b/plug-ins/perl/Gimp.xs @@ -1,9 +1,5 @@ #include "config.h" -#ifdef __cplusplus -extern "C" { -#endif - #include /* FIXME */ @@ -17,9 +13,8 @@ extern "C" { #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#ifdef __cplusplus -} -#endif +#define NEED_newCONSTSUB +#include "ppport.h" /* FIXME */ /* dirty is used in gimp.h. */ @@ -36,43 +31,6 @@ extern "C" { /* expect iso-c here. */ #include -/* Shamelesssly stolen from IO.xs. See perlguts, this is only for - * 5.004 compatibility. - */ -#ifndef newCONSTSUB -static void -newCONSTSUB(stash,name,sv) - HV *stash; - char *name; - SV *sv; -{ -#ifdef dTHR - dTHR; -#endif - U32 oldhints = hints; - HV *old_cop_stash = curcop->cop_stash; - HV *old_curstash = curstash; - line_t oldline = curcop->cop_line; - curcop->cop_line = copline; - - hints &= ~HINT_BLOCK_SCOPE; - if(stash) - curstash = curcop->cop_stash = stash; - - newSUB( - start_subparse (FALSE, 0), - newSVOP(OP_CONST, 0, newSVpv(name,0)), - newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */ - newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) - ); - - hints = oldhints; - curcop->cop_stash = old_cop_stash; - curstash = old_curstash; - curcop->cop_line = oldline; -} -#endif - MODULE = Gimp PACKAGE = Gimp PROTOTYPES: ENABLE diff --git a/plug-ins/perl/Gimp/Fu.pm b/plug-ins/perl/Gimp/Fu.pm index f4e981d471..00f53dffcc 100644 --- a/plug-ins/perl/Gimp/Fu.pm +++ b/plug-ins/perl/Gimp/Fu.pm @@ -13,7 +13,7 @@ require Exporter; eval { require Data::Dumper; - import Data::Dumper; + import Data::Dumper 'Dumper'; }; if ($@) { *Dumper = sub { @@ -21,6 +21,7 @@ if ($@) { }; } + =cut =head1 NAME @@ -157,6 +158,19 @@ sub _find_digits { $digits>0 ? int $digits+0.9 : 0; } +sub help_window { + my($blurb,$help)=@_; + my $helpwin = new Gtk::Dialog; + set_title $helpwin $0; + $helpwin->vbox->add(new Gtk::Label "Blurb:\n".Gimp::wrap_text($blurb,60) + ."\n\nHelp:\n".Gimp::wrap_text($help,60)); + my $button = new Gtk::Button "Close"; + signal_connect $button "clicked",sub { hide $helpwin }; + $helpwin->action_area->add($button); + + show_all $helpwin; +} + sub interact($$$@) { local $^W=0; my($function)=shift; @@ -418,17 +432,7 @@ sub interact($$$@) { $button = new Gtk::Button "Help"; $g->attach($button,0,1,$res,$res+1,{},{},4,2); - signal_connect $button "clicked", sub { - my $helpwin = new Gtk::Dialog; - set_title $helpwin $0; - $helpwin->vbox->add(new Gtk::Label "Blurb:\n".Gimp::wrap_text($blurb,40) - ."\n\nHelp:\n".Gimp::wrap_text($help,40)); - my $button = new Gtk::Button "Close"; - signal_connect $button "clicked",sub { hide $helpwin }; - $helpwin->action_area->add($button); - - show_all $helpwin; - }; + signal_connect $button "clicked", sub { help_window($blurb,$help) }; my $v=new Gtk::HBox 0,5; $g->attach($v,1,2,$res,$res+1,{},{},4,2); diff --git a/plug-ins/perl/Gimp/Lib.xs b/plug-ins/perl/Gimp/Lib.xs index c6063e9db2..eb213bfcc4 100644 --- a/plug-ins/perl/Gimp/Lib.xs +++ b/plug-ins/perl/Gimp/Lib.xs @@ -27,7 +27,7 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include "patchlevel.h" +#include "ppport.h" /* I actually do care a bit about older perls... */ #ifndef ERRSV @@ -37,10 +37,6 @@ #ifndef dTHR # define dTHR (void)0 #endif -#if (PATCHLEVEL < 5) -# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) -# define PL_sv_undef sv_undef -#endif /* dirty is used in gimp.h AND in perl < 5.005 or with PERL_POLLUTE. */ #ifdef dirty @@ -620,7 +616,7 @@ push_gimp_sv (GParam *arg, int array_as_ref) av_push (av, newSViv (arg->data.d_color.red)); av_push (av, newSViv (arg->data.d_color.green)); av_push (av, newSViv (arg->data.d_color.blue)); - sv = (SV *)av; /* no newRV, since we're getting autoblessed! */ + sv = (SV *)av; /* no newRV_inc, since we're getting autoblessed! */ } break; @@ -631,7 +627,7 @@ push_gimp_sv (GParam *arg, int array_as_ref) 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; /* no newRV, since we're getting autoblessed! */ + sv = (SV *)av; /* no newRV_inc, since we're getting autoblessed! */ } break; #endif diff --git a/plug-ins/perl/MANIFEST b/plug-ins/perl/MANIFEST index 535347667b..f9fb91c901 100644 --- a/plug-ins/perl/MANIFEST +++ b/plug-ins/perl/MANIFEST @@ -17,6 +17,7 @@ t/load.t t/loadlib.t t/run.t extradefs.h +ppport.h Perl-Server etc/configure etc/configure.in diff --git a/plug-ins/perl/Makefile.PL b/plug-ins/perl/Makefile.PL index 1e1357b27c..64d85f312c 100644 --- a/plug-ins/perl/Makefile.PL +++ b/plug-ins/perl/Makefile.PL @@ -59,44 +59,6 @@ Do you want me to make these tests [y]? "; require ExtUtils::MakeMaker; import ExtUtils::MakeMaker; -eval { require Gimp }; -unless($@) { - $old_prefix = eval { Gimp::_gimp_prefix() }; - if ($@) { - print <style->font unless $font; + $w->vbox->add($b); + $b->realize; # for gtk-1.0 $b->insert($font,$b->style->fg(-normal),undef,$log); $b->set_usize($font->string_width('M')*80,($font->ascent+$font->descent)*($lines+1)); - $w->vbox->add($b); $b = new Gtk::Button "OK"; $b->can_default(1); diff --git a/plug-ins/perl/examples/terral_text b/plug-ins/perl/examples/terral_text index 7605857203..a87b7e31a1 100644 --- a/plug-ins/perl/examples/terral_text +++ b/plug-ins/perl/examples/terral_text @@ -49,7 +49,6 @@ register [ PF_SLIDER, "Blur Amount", "Blur Amount", 10, [0,26,1]], ], [], - ['gtk-1.2'], sub { ($img, $pattern, $solidnoise, $font, $text, $blur) = @_; $oldbg = gimp_palette_get_background(); diff --git a/plug-ins/perl/ppport.h b/plug-ins/perl/ppport.h new file mode 100644 index 0000000000..af1f6e094d --- /dev/null +++ b/plug-ins/perl/ppport.h @@ -0,0 +1,279 @@ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +/* Perl/Pollution/Portability Version 1.0005 */ + +/* Copyright (C) 1999, Kenneth Albanowski. This code may be used and + distributed under the same license as any version of Perl. */ + +/* For the latest version of this code, please contact the author at + , or check with the Perl maintainers. */ + +/* If you needed to customize this file for your project, please mention + your changes. */ + + +/* + In order for a Perl extension module to be as portable as possible + across differing versions of Perl itself, certain steps need to be taken. + Including this header is the first major one, then using dTHR is all the + appropriate places and using a PL_ prefix to refer to global Perl + variables is the second. +*/ + + +/* If you use one of a few functions that were not present in earlier + versions of Perl, please add a define before the inclusion of ppport.h + for a static include, or use the GLOBAL request in a single module to + produce a global definition that can be referenced from the other + modules. + + Function: Static define: Extern define: + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + +*/ + + +/* To verify whether ppport.h is needed for your module, and whether any + special defines should be used, ppport.h can be run through Perl to check + your source code. Simply say: + + perl -x ppport.h *.c *.h *.xs foo/*.c [etc] + + The result will be a list of patches suggesting changes that should at + least be acceptable, if not necessarily the most efficient solution, or a + fix for all possible problems. It won't catch where dTHR is needed, and + doesn't attempt to account for global macro or function definitions, + nested includes, typemaps, etc. + + In order to test for the need of dTHR, please try your module under a + recent version of Perl that has threading compiled-in. + +*/ + + +/* +#!/usr/bin/perl +@ARGV = ("*.xs") if !@ARGV; +%badmacros = %funcs = %macros = (); $replace = 0; +foreach () { + $funcs{$1} = 1 if /Provide:\s+(\S+)/; + $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/; + $replace = $1 if /Replace:\s+(\d+)/; + $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/; +} +foreach $filename (map(glob($_),@ARGV)) { + unless (open(IN, "<$filename")) { + warn "Unable to read from $file: $!\n"; + next; + } + print "Scanning $filename...\n"; + $c = ""; while () { $c .= $_; } close(IN); + $need_include = 0; %add_func = (); $changes = 0; + $has_include = ($c =~ /#.*include.*ppport/m); + + foreach $func (keys %funcs) { + if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) { + if ($c !~ /\b$func\b/m) { + print "If $func isn't needed, you don't need to request it.\n" if + $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m); + } else { + print "Uses $func\n"; + $need_include = 1; + } + } else { + if ($c =~ /\b$func\b/m) { + $add_func{$func} =1 ; + print "Uses $func\n"; + $need_include = 1; + } + } + } + + if (not $need_include) { + foreach $macro (keys %macros) { + if ($c =~ /\b$macro\b/m) { + print "Uses $macro\n"; + $need_include = 1; + } + } + } + + foreach $badmacro (keys %badmacros) { + if ($c =~ /\b$badmacro\b/m) { + $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm); + print "Uses $badmacros{$badmacro} (instead of $badmacro)\n"; + $need_include = 1; + } + } + + if (scalar(keys %add_func) or $need_include != $has_include) { + if (!$has_include) { + $inc = join('',map("#define NEED_$_\n", sort keys %add_func)). + "#include \"ppport.h\"\n"; + $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m; + } elsif (keys %add_func) { + $inc = join('',map("#define NEED_$_\n", sort keys %add_func)); + $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m; + } + if (!$need_include) { + print "Doesn't seem to need ppport.h.\n"; + $c =~ s/^.*#.*include.*ppport.*\n//m; + } + $changes++; + } + + if ($changes) { + open(OUT,">/tmp/ppport.h.$$"); + print OUT $c; + close(OUT); + open(DIFF, "diff -u $filename /tmp/ppport.h.$$|"); + while () { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; } + close(DIFF); + unlink("/tmp/ppport.h.$$"); + } else { + print "Looks OK\n"; + } +} +__DATA__ +*/ + + +#include "patchlevel.h" +#ifndef PERL_PATCHLEVEL +/* Replace: 1 */ +# define PERL_PATCHLEVEL PATCHLEVEL +/* Replace: 0 */ +#endif +#ifndef PERL_SUBVERSION +# define PERL_SUBVERSION SUBVERSION +#endif + +#ifndef ERRSV +# define ERRSV perl_get_sv("@",FALSE) +#endif + +#if (PERL_PATCHLEVEL < 4) || ((PERL_PATCHLEVEL == 4) && (PERL_SUBVERSION <= 4)) +/* Replace: 1 */ +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_sv_no sv_no +# define PL_na na +# define PL_stdingv stdingv +# define PL_hints hints +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_copline copline +# define PL_Sv Sv +/* Replace: 0 */ +#endif + +#if (PERL_PATCHLEVEL < 5) +# ifdef WIN32 +# define dTHR extern int Perl___notused +# else +# define dTHR extern int errno +# endif +#endif + +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) +#endif + +#ifndef newSVpvn +# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) +#endif + +#ifndef newRV_inc +/* Replace: 1 */ +# define newRV_inc(sv) newRV(sv) +/* Replace: 0 */ +#endif + +#ifndef newRV_noinc +# ifdef __GNUC__ +# define newRV_noinc(sv) \ + ({ \ + SV *nsv = (SV*)newRV(sv); \ + SvREFCNT_dec(sv); \ + nsv; \ + }) +# else +# if defined(CRIPPLED_CC) || defined(USE_THREADS) +static SV * newRV_noinc (SV * sv) +{ + SV *nsv = (SV*)newRV(sv); + SvREFCNT_dec(sv); + return nsv; +} +# else +# define newRV_noinc(sv) \ + ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv) +# endif +# endif +#endif + +/* Provide: newCONSTSUB */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_PATCHLEVEL < 4) || ((PERL_PATCHLEVEL == 4) && (PERL_SUBVERSION < 63)) + +#if defined(NEED_newCONSTSUB) +static +#else +extern void newCONSTSUB _((HV * stash, char * name, SV *sv)); +#endif + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) +void +newCONSTSUB(stash,name,sv) +HV *stash; +char *name; +SV *sv; +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_PATCHLEVEL < 3) || ((PERL_PATCHLEVEL == 3) && (PERL_SUBVERSION < 22)) + /* before 5.003_22 */ + start_subparse(), +#else +# if (PERL_PATCHLEVEL == 3) && (PERL_SUBVERSION == 22) + /* 5.003_22 */ + start_subparse(0), +# else + /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +# endif +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif + +#endif /* newCONSTSUB */ + + +#endif /* _P_P_PORTABILITY_H_ */