mirror of https://github.com/GNOME/gimp.git
see plug-ins/perl/Changes
This commit is contained in:
Marc Lehmann
parent
441d271d22
commit
c5db9098cc
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
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) {
|
||||
$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
|
||||
|
|
|
|||
|
|
@ -1,9 +1,5 @@
|
|||
#include "config.h"
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#include <libgimp/gimp.h>
|
||||
|
||||
/* 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 <signal.h>
|
||||
|
||||
/* 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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ t/load.t
|
|||
t/loadlib.t
|
||||
t/run.t
|
||||
extradefs.h
|
||||
ppport.h
|
||||
Perl-Server
|
||||
etc/configure
|
||||
etc/configure.in
|
||||
|
|
|
|||
|
|
@ -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 <<EOF;
|
||||
|
||||
WARNING: I've detected an old version of Gimp-Perl installed
|
||||
already. Since I cannot detect the prefix used to install
|
||||
it I will just overwrite it. If you happen to use two
|
||||
different and incompatible versions of the Gimp with differing
|
||||
prefixes you should call configure with the --disable-perl
|
||||
switch to disable the perl extension, or consider installing
|
||||
the perl module elsewhere, using the environment variables
|
||||
PERL5LIB=/my/module/dir and PERL_MM_OPTS="PREFIX=\$PERL5LIB" to
|
||||
overwrite the installation directory (PERL_MM_OPTS) and run the
|
||||
Gimp (PERL5LIB). See "perldoc ExtUtils::MakeMaker" for a full
|
||||
discussion of your options.
|
||||
|
||||
EOF
|
||||
} else {
|
||||
if ($GIMP_PREFIX ne $old_prefix) {
|
||||
print <<EOF;
|
||||
|
||||
WARNING: I've detected another installaion of the Gimp-Perl extension.
|
||||
|
||||
This version uses the prefix '$GIMP_PREFIX'.
|
||||
The already installed version uses the prefix '$old_prefix'.
|
||||
|
||||
They don't match, which indicates that installing Gimp-Perl might
|
||||
overwrite an old but still used installation. Gimp-Perl will
|
||||
therefore be disabled, and not be installed.
|
||||
|
||||
EOF
|
||||
not_halt("prefix mismatch");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
eval "use Gtk;"; $GTK = $@ eq "";
|
||||
eval "use PDL;"; $PDL = $@ eq "";
|
||||
eval "use Parse::RecDescent;"; $PRD = $@ eq "";
|
||||
|
|
@ -167,6 +129,44 @@ WARNING: version 0.3 of Gtk is _required_ for this module to
|
|||
EOF
|
||||
}
|
||||
|
||||
eval { $Gimp::no_SIG=1; require Gimp };
|
||||
unless($@) {
|
||||
$old_prefix = eval { Gimp::_gimp_prefix() };
|
||||
if ($@) {
|
||||
print <<EOF;
|
||||
|
||||
WARNING: I've detected an old version of Gimp-Perl installed
|
||||
already. Since I cannot detect the prefix used to install
|
||||
it I will just overwrite it. If you happen to use two
|
||||
different and incompatible versions of the Gimp with differing
|
||||
prefixes you should call configure with the --disable-perl
|
||||
switch to disable the perl extension, or consider installing
|
||||
the perl module elsewhere, using the environment variables
|
||||
PERL5LIB=/my/module/dir and PERL_MM_OPTS="PREFIX=\$PERL5LIB" to
|
||||
overwrite the installation directory (PERL_MM_OPTS) and run the
|
||||
Gimp (PERL5LIB). See "perldoc ExtUtils::MakeMaker" for a full
|
||||
discussion of your options.
|
||||
|
||||
EOF
|
||||
} else {
|
||||
if ($GIMP_PREFIX ne $old_prefix) {
|
||||
print <<EOF;
|
||||
|
||||
WARNING: I've detected another installaion of the Gimp-Perl extension.
|
||||
|
||||
This version uses the prefix '$GIMP_PREFIX'.
|
||||
The already installed version uses the prefix '$old_prefix'.
|
||||
|
||||
They don't match, which indicates that installing Gimp-Perl might
|
||||
overwrite an old but still used installation. Gimp-Perl will
|
||||
therefore be disabled, and not be installed.
|
||||
|
||||
EOF
|
||||
not_halt("prefix mismatch");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# wo do no longer do these dirty things
|
||||
#for(@shebang) {
|
||||
# system ($Config{perlpath},"-pi","-e","\$. == 1 and \$_ = '#!$Config{perlpath}\n'",$_);
|
||||
|
|
@ -195,7 +195,7 @@ install ::
|
|||
exit ; \
|
||||
fi \
|
||||
done ; \
|
||||
$(MAKE) really-install install-plugins
|
||||
$(MAKE) UNINST=1 really-install install-plugins
|
||||
|
||||
'.$install;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -103,7 +103,6 @@ register
|
|||
[PF_RADIO, "series", "Kind of series", 1, [["Arithmetic",1],["Geometric",0]]]
|
||||
],
|
||||
[],
|
||||
['gtk-1.2'],
|
||||
\&blowinout;
|
||||
|
||||
exit main;
|
||||
|
|
|
|||
|
|
@ -73,9 +73,10 @@ sub gtkview_log {
|
|||
$font = load Gtk::Gdk::Font "9x15bold";
|
||||
$font = fontset_load Gtk::Gdk::Font "-*-courier-medium-r-normal--*-120-*-*-*-*-*" unless $font;
|
||||
$font = $b->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);
|
||||
|
|
|
|||
|
|
@ -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();
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<kjahds@kjahds.com>, 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 (<DATA>) {
|
||||
$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 (<IN>) { $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 (<DIFF>) { 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_ */
|
||||
Loading…
Reference in New Issue