Commit 5aa63839 authored by Marc Lehmann's avatar Marc Lehmann

see plug-ins/perl/Changes

parent 0a4686ed
Revision history for Gimp-Perl extension.
1.09
- corrected PDL version check to work with version 2.001.
- new file Net.xs, containing protocol serializer
- new, faster and leaner protocol (bumped protocol version number).
- added SvPV_nolen to ppport.h and made use of it everywhere.
- renamed nolib => Module.
1.089 Tue May 18 19:55:25 CEST 1999
- added colourtoalpha.
- made all internal C functions static -> less namespace bloat.
......@@ -14,8 +21,6 @@ Revision history for Gimp-Perl extension.
- made my first attempt at implementing XS-PDL support.
- transform obnjects ids of -1 into undef and vice versa.
- Gimp::Fu did not properly supply a default value for PF_COLOUR.
- :auto is NO LONGER the default for the import method(!).
(NOT YET).
1.083 Wed May 12 03:36:10 CEST 1999
- took a modified enums.pl to autogenerate constants. Some constants
......
......@@ -13,7 +13,7 @@ use subs qw(init end lock unlock canonicalize_color);
require DynaLoader;
@ISA=qw(DynaLoader);
$VERSION = 1.089;
$VERSION = 1.09;
@_param = qw(
PARAM_BOUNDARY PARAM_CHANNEL PARAM_COLOR PARAM_DISPLAY PARAM_DRAWABLE
......@@ -93,7 +93,7 @@ sub BLACK (){ 2 }
sub _PS_FLAG_QUIET { 0000000001 }; # do not output messages
sub _PS_FLAG_BATCH { 0000000002 }; # started via Gimp::Net, extra = filehandle
$_PROT_VERSION = "2"; # protocol version
$_PROT_VERSION = "3"; # protocol version
# we really abuse the import facility..
sub import($;@) {
......
......@@ -28,8 +28,10 @@
# define GIMP_PARASITE 1
#endif
#ifndef HAVE_EXIT
/* expect iso-c here. */
#include <signal.h>
# include <signal.h>
#endif
MODULE = Gimp PACKAGE = Gimp
......
......@@ -55,6 +55,8 @@
#define PKG_REGION GIMP_PKG "Region"
#if GIMP_PARASITE
# define PKG_PARASITE GIMP_PKG "Parasite"
#else
# define PKG_PARASITE ((char *)0)
#endif
#define PKG_GDRAWABLE GIMP_PKG "GDrawable"
......@@ -87,7 +89,8 @@ static void need_pdl (void)
/* Get pointer to structure of core shared C routines */
if (!(CoreSV = perl_get_sv("PDL::SHARE",FALSE)))
Perl_croak("gimp-perl-pixel functions require the PDL::Core module");
Perl_croak("gimp-perl-pixel functions require the PDL::Core module");
PDL = (Core*) SvIV(CoreSV);
}
}
......@@ -254,8 +257,7 @@ static GTile *old_tile (SV *sv)
/* magic stuff. literally. */
static int gpixelrgn_free (SV *obj, MAGIC *mg)
{
STRLEN dc;
GPixelRgn *pr = (GPixelRgn *)SvPV(obj,dc);
GPixelRgn *pr = (GPixelRgn *)SvPV_nolen(obj);
/* automatically done on detach */
/* if (pr->dirty)
......@@ -269,10 +271,9 @@ MGVTBL vtbl_gpixelrgn = {0, 0, 0, 0, gpixelrgn_free};
static SV *new_gpixelrgn (SV *gdrawable, int x, int y, int width, int height, int dirty, int shadow)
{
static HV *stash;
STRLEN dc;
MAGIC *mg;
SV *sv = newSVn (sizeof (GPixelRgn));
GPixelRgn *pr = (GPixelRgn *)SvPV(sv,dc);
GPixelRgn *pr = (GPixelRgn *)SvPV_nolen(sv);
if (!(sv_derived_from (gdrawable, PKG_GDRAWABLE)))
{
......@@ -297,12 +298,10 @@ static SV *new_gpixelrgn (SV *gdrawable, int x, int y, int width, int height, in
static GPixelRgn *old_pixelrgn (SV *sv)
{
STRLEN dc;
if (!sv_derived_from (sv, PKG_PIXELRGN))
croak ("argument is not of type " PKG_PIXELRGN);
return (GPixelRgn *)SvPV(SvRV(sv),dc);
return (GPixelRgn *)SvPV_nolen(SvRV(sv));
}
/* tracing stuff. */
......@@ -540,7 +539,6 @@ dump_params (int nparams, GParam *args, GParamDef *params)
static int
convert_array2paramdef (AV *av, GParamDef **res)
{
STRLEN dc;
int count = 0;
GParamDef *def = 0;
......@@ -581,8 +579,8 @@ convert_array2paramdef (AV *av, GParamDef **res)
}
def->type = SvIV (type);
def->name = name ? SvPV (name, dc) : 0;
def->description = help ? SvPV (help, dc) : 0;
def->name = name ? SvPV_nolen (name) : 0;
def->description = help ? SvPV_nolen (help) : 0;
def++;
}
else
......@@ -612,10 +610,7 @@ param_stash (GParamType type)
0 , 0 , 0 , 0 , 0 ,
PKG_COLOR , PKG_REGION , PKG_DISPLAY , PKG_IMAGE , PKG_LAYER ,
PKG_CHANNEL , PKG_DRAWABLE , PKG_SELECTION , 0 , 0 ,
#if GIMP_PARASITE
PKG_PARASITE,
#endif
0
PKG_PARASITE, 0
};
if (bless [type] && !bless_hv [type])
......@@ -633,6 +628,9 @@ autobless (SV *sv, int type)
if (stash)
sv = sv_bless (newRV_noinc (sv), stash);
if (stash && !SvOBJECT(SvRV(sv)))
croak ("jupp\n");
return sv;
}
......@@ -744,8 +742,7 @@ static int check_int (char *croak_str, SV *sv)
{
if (SvTYPE (sv) == SVt_PV && !SvIOKp(sv))
{
STRLEN dc;
char *p = SvPV (sv, dc);
char *p = SvPV_nolen (sv);
if (*p
&& *p != '0' && *p != '1' && *p != '2' && *p != '3' && *p != '4'
......@@ -875,7 +872,7 @@ push_gimp_sv (GParam *arg, int array_as_ref)
PUTBACK;
}
#define SvPv(sv) SvPV((sv), dc)
#define SvPv(sv) SvPV_nolen(sv)
#define Sv32(sv) unbless ((sv), PKG_ANY, croak_str)
#define av2gimp(arg,sv,datatype,type,svxv) { \
......@@ -907,8 +904,6 @@ push_gimp_sv (GParam *arg, int array_as_ref)
static int
convert_sv2gimp (char *croak_str, GParam *arg, SV *sv)
{
STRLEN dc;
switch (arg->type)
{
case PARAM_INT32: check_int (croak_str, sv);
......@@ -1104,7 +1099,6 @@ static void pii_run(char *name, int nparams, GParam *param, int *xnreturn_vals,
static int nreturn_vals;
dSP;
STRLEN dc;
int i, count;
char *err_msg = 0;
......@@ -1174,7 +1168,7 @@ static void pii_run(char *name, int nparams, GParam *param, int *xnreturn_vals,
if (SvTRUE (ERRSV))
{
if (strEQ ("IGNORE THIS MESSAGE\n", SvPV (ERRSV, dc)))
if (strEQ ("IGNORE THIS MESSAGE\n", SvPV_nolen (ERRSV)))
{
nreturn_vals = 0;
return_vals = g_new (GParam, 1);
......@@ -1184,7 +1178,7 @@ static void pii_run(char *name, int nparams, GParam *param, int *xnreturn_vals,
*xreturn_vals = return_vals;
}
else
err_msg = g_strdup (SvPV (ERRSV, dc));
err_msg = g_strdup (SvPV_nolen (ERRSV));
}
else
{
......@@ -1314,7 +1308,6 @@ int
gimp_main(...)
PREINIT:
CODE:
STRLEN dc;
SV *sv;
if ((sv = perl_get_sv ("Gimp::help", FALSE)) && SvTRUE (sv))
......@@ -1328,11 +1321,11 @@ gimp_main(...)
{
AV *av = perl_get_av ("ARGV", FALSE);
argv [argc++] = SvPV (perl_get_sv ("0", FALSE), dc);
argv [argc++] = SvPV_nolen (perl_get_sv ("0", FALSE));
if (av && av_len (av) < 10-1)
{
while (argc-1 <= av_len (av))
argv [argc] = SvPV (*av_fetch (av, argc-1, 0), dc),
argv [argc] = SvPV_nolen (*av_fetch (av, argc-1, 0)),
argc++;
}
else
......@@ -1629,12 +1622,11 @@ gimp_set_data(id, data)
CODE:
{
STRLEN dlen;
STRLEN dc;
void *dta;
dta = SvPV (data, dlen);
gimp_set_data (SvPV (id, dc), dta, dlen);
gimp_set_data (SvPV_nolen (id), dta, dlen);
}
void
......@@ -1644,14 +1636,13 @@ gimp_get_data(id)
{
SV *data;
STRLEN dlen;
STRLEN dc;
dlen = get_data_size (SvPV (id, dc));
dlen = get_data_size (SvPV_nolen (id));
/* I count on dlen being zero if "id" doesn't exist. */
data = newSVpv ("", 0);
gimp_get_data (SvPV (id, dc), SvGROW (data, dlen+1));
gimp_get_data (SvPV_nolen (id), SvGROW (data, dlen+1));
SvCUR_set (data, dlen);
*((char *)SvPV (data, dc) + dlen) = 0;
*((char *)SvPV_nolen (data) + dlen) = 0;
XPUSHs (sv_2mortal (data));
}
......@@ -1695,12 +1686,6 @@ gimp_tile_width()
guint
gimp_tile_height()
#if HAVE_PDL
void
gimp_tile_flush(tile)
GTile * tile
void
gimp_tile_cache_size(kilobytes)
gulong kilobytes
......@@ -1709,6 +1694,8 @@ void
gimp_tile_cache_ntiles(ntiles)
gulong ntiles
#if HAVE_PDL
SV *
gimp_drawable_get(drawable_ID)
DRAWABLE drawable_ID
......@@ -1743,19 +1730,6 @@ gimp_drawable_get_tile2(gdrawable, shadow, x, y)
OUTPUT:
RETVAL
void
gimp_tile_ref(tile)
GTile * tile
void
gimp_tile_ref_zero(tile)
GTile * tile
void
gimp_tile_unref(tile, dirty)
GTile * tile
int dirty
SV *
gimp_pixel_rgn_init(gdrawable, x, y, width, height, dirty, shadow)
SV * gdrawable
......@@ -2100,7 +2074,7 @@ gimp_tile_dirty(tile)
OUTPUT:
RETVAL
gint32
DRAWABLE
gimp_tile_drawable(tile)
GTile *tile
CODE:
......@@ -2155,13 +2129,12 @@ gimp_patterns_get_pattern_data(name)
SV * name
PPCODE:
{
STRLEN dc;
GParam *return_vals;
int nreturn_vals;
return_vals = gimp_run_procedure ("gimp_patterns_get_pattern_data",
&nreturn_vals,
PARAM_STRING, SvPV (name, dc),
PARAM_STRING, SvPV_nolen (name),
PARAM_END);
if (nreturn_vals == 7
......
......@@ -12,7 +12,15 @@ use vars qw(
$server_fh $trace_level $trace_res $auth $gimp_pid
);
use subs qw(gimp_call_procedure);
use Socket; # IO::Socket is _really_ slow
use base qw(DynaLoader);
use Socket; # IO::Socket is _really_ slow, so don't use it!
require DynaLoader;
$VERSION = $Gimp::VERSION;
bootstrap Gimp::Net $VERSION;
$default_tcp_port = 10009;
$default_unix_dir = "/tmp/gimp-perl-serv-uid-$>/";
......@@ -38,31 +46,6 @@ sub import {
};
}
# network to array
sub net2args($) {
no strict 'subs';
sub b($$) { bless \(my $x=$_[0]),$_[1] }
eval "($_[0])";
}
sub args2net {
my($res,$v);
for $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 {
$res.="undef,";
}
}
substr($res,0,-1); # may not be worth the effort
}
sub _gimp_procedure_available {
my $req="TEST".$_[0];
print $server_fh pack("N",length($req)).$req;
......
......@@ -96,3 +96,4 @@ examples/mirrorsplit
examples/oneliners
examples/randomart1
examples/colourtoalpha
......@@ -253,7 +253,7 @@ close C;
print "ok\n";
$GIMP_INC_NOUI = "-I../../ $GIMP_INC_NOUI" if $IN_GIMP;
@DIRS= 'Gimp';
@DIRS= qw/Gimp Net/;
$build_module = $IN_GIMP || $ENV{GIMP_PERL_MODULE_INC};
# temporarily disabled because of politics
......@@ -263,7 +263,7 @@ print "building embedded perl module... ";
if ($build_module) {
print "yes\n";
$dont_embed = "false";
push(@DIRS,'nolib');
push(@DIRS,'Module');
print "configuring in embed/Makefile...\n";
system("cd embed && perl Makefile.PL");
} else {
......
use ExtUtils::MakeMaker;
do '../config.pl';
sub MY::postamble {
<<"EOF";
clean ::
test -f Makefile || mv -f Makefile.old Makefile
EOF
}
$GIMP_INC_NOUI = "-I../../.. $GIMP_INC_NOUI" if $IN_GIMP;
WriteMakefile(
'NAME' => 'Gimp::Net',
'VERSION_FROM' => '../Gimp.pm',
'INC' => "$INC1 $CPPFLAGS $pdl_inc $CFLAGS",
'DEFINE' => "$DEFINE1 $DEFS",
'TYPEMAPS' => ["$topdir/typemap",@pdl_typemaps],
);
#include "config.h"
/* dunno where this comes from */
#undef VOIDUSED
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_newCONSTSUB
#include "ppport.h"
#if HAVE_PDL
# include <pdlcore.h>
# undef croak
# define croak Perl_croak
/* hack, undocumented, argh! */
static Core* PDL; /* Structure hold core C functions */
/* get pointer to PDL structure. */
static void need_pdl (void)
{
SV *CoreSV;
if (!PDL)
{
/* Get pointer to structure of core shared C routines */
if (!(CoreSV = perl_get_sv("PDL::SHARE",FALSE)))
Perl_croak("gimp-perl-pixel functions require the PDL::Core module");
PDL = (Core*) SvIV(CoreSV);
}
}
#endif
/* allocate this much as initial length */
#define INITIAL_PV 256
/* and increment in these steps */
#define PV_INC 512
/* types
*
* u undef
* a num sv* array
* p len cont pv
* i int iv
* b stash sv blessed reference
* r simple reference
* h len (key sv)* hash (not yet supported!)
* p piddle (not yet supported!)
*
*/
static void sv2net (SV *s, SV *sv)
{
if (SvLEN(sv)-SvCUR(sv) < 96)
SvGROW (sv, SvLEN(sv) + PV_INC);
if (SvROK(sv))
{
SV *rv = SvRV(sv);
if (SvOBJECT (rv))
{
char *name = HvNAME (SvSTASH (rv));
sv_catpvf (s, "b%x:%s", strlen (name), name);
}
else
sv_catpvn (s, "r", 1);
if (SvTYPE(rv) == SVt_PVAV)
{
AV *av = (AV*)rv;
int i;
sv_catpvf (s, "a%x:", (int)av_len(av));
for (i = 0; i <= av_len(av); i++)
sv2net (s, *av_fetch(av,i,0));
}
else if (SvTYPE(rv) == SVt_PVMG)
sv2net (s, rv);
else
croak ("Internal error: unable to convert reference in sv2net, please report!");
}
else if (SvOK(sv))
{
if (SvTYPE(sv) == SVt_IV)
sv_catpvf (s,"i%ld:", (long)SvIV(sv));
else
{
char *str;
STRLEN len;
/* slower than necessary, just make it an pv */
str = SvPV(sv,len);
sv_catpvf (s, "p%x:", (int)len);
sv_catpvn (s, str, len);
}
}
else
sv_catpvn (s, "u", 1);
}
static SV *net2sv (char **_s)
{
char *s = *_s;
SV *sv;
AV *av;
unsigned int ui, n;
long l;
char str[64];
switch (*s++)
{
case 'u':
sv = newSVsv (&PL_sv_undef);
break;
case 'i':
sscanf (s, "%ld:%n", &l, &n); s += n;
sv = newSViv ((IV)l);
break;
case 'p':
sscanf (s, "%x:%n", &ui, &n); s += n;
sv = newSVpvn (s, (STRLEN)ui);
s += ui;
break;
case 'r':
sv = newRV_noinc (net2sv (&s));
break;
case 'b':
sscanf (s, "%x:%n", &ui, &n); s += n;
if (ui >= sizeof str)
croak ("Internal error: stashname too long, please report!");
memcpy (str, s, ui); s += ui;
str[ui] = 0;
sv = sv_bless (newRV_noinc (net2sv (&s)), gv_stashpv (str, 1));
break;
case 'a':
sscanf (s, "%x:%n", &ui, &n); s += n;
av = newAV ();
av_extend (av, ui);
for (n = 0; n <= ui; n++)
av_store (av, n, net2sv (&s));
sv = (SV*)av;
break;
default:
croak ("Internal error: unable to handle argtype '%c' in net2sv, please report!", s[-1]);
}
*_s = s;
return sv;
}
MODULE = Gimp::Net PACKAGE = Gimp::Net
PROTOTYPES: ENABLE
SV *
args2net(...)
CODE:
int index;
RETVAL = newSVpv ("", 0);
(void) SvUPGRADE (RETVAL, SVt_PV);
SvGROW (RETVAL, INITIAL_PV);
for (index = 0; index < items; index++)
sv2net (RETVAL, ST(index));
OUTPUT:
RETVAL
void
net2args(s)
char * s
PPCODE:
/* this depends on a trailing zero! */
while (*s)
XPUSHs (sv_2mortal (net2sv (&s)));
......@@ -10,6 +10,10 @@ make test TEST_VERBOSE=1
bugs
* KILL :auto from default(!)
* gimp-piddle must be written back automatically on destroy, if changed
* possibly rename "Brush Selection" to "Paint Settings"
* gimp-tile set dirty automatically(!)
* fatal errors in config.pl (!)
* disable module build (EMBEDMYALLOC)
[DONE] * turn -1 into undef and vice versa.
......
......@@ -27,6 +27,7 @@ sub MY::const_loadlibs {
sub MY::install {
<<EOF;
install :: all \$(INST_DYNAMIC)
\$(RM_F) \$(gimpplugindir)/modules/\$(DLBASE).\$(DLEXT)
\$(CP) \$(INST_DYNAMIC) \$(gimpplugindir)/modules/\$(DLBASE).\$(DLEXT)
\$(CHMOD) 755 \$(gimpplugindir)/modules/\$(DLBASE).\$(DLEXT)
......
......@@ -82,8 +82,9 @@ $cfg{_DEFS} = $DEFS;
$INC1 = "-I$topdir";
$DEFINE1 = $IN_GIMP ? "-DIN_GIMP" : "";
eval "use PDL;";
eval "use PDL";
if (!$@) {
require PDL::Version;
if ($PDL::Version::VERSION > 1.99) {
require PDL::Core::Dev;
if (!$@) {
......
#!/usr/bin/perl -w
use Gimp::Feature 'pdl';
use Gimp 1.084;
use Gimp::Fu;
use Gimp::Util;
use PDL::LiteF;
register "colour_to_alpha",
"Converts the specified colour to alpha",
"This replaces as much as possible of the specified colour in each pixel by a corresponding "
."amount of alpha, then readjusts the colour accordingly.",
"Marc Lehmann",
"Marc Lehmann <pcg\@goof.com>",
"19990517",
"<Image>/Filters/Colors/Colour To Alpha",
"RGB*",
[
[PF_COLOR, "colour", , "The colour to replace"],
],
sub { # es folgt das eigentliche Skript...
my($image,$drawable,$colour)=@_;
$drawable->layer or die "colour_to_alpha only works with layers\n";
$drawable->add_alpha unless $drawable->has_alpha;
Gimp->progress_init ("Replacing colour...");
my @bounds = $drawable->mask;
{
# $src and $dst must either be scoped or explicitly undef'ed
# before merge_shadow.
my $src = new PixelRgn ($drawable->get,@bounds,0,0);
my $dst = new PixelRgn ($drawable->get,@bounds,1,1);
$iter = Gimp->pixel_rgns_register ($src, $dst);
do {
# get the pixels ($pixels will be modified in-place!)
$pixels = $src->data;
# extract the rgb portion only
$rgb = $pixels->slice("0:2");
# calculate difference to destination colour
$diff = 255 + minimum $rgb - pdl $colour;
# adjust alpha part
my $alpha = $pixels->slice("(3)");
$alpha .= 255-$diff;
# adjust the colour
my $a = ($diff/(255**2))->slice("*3") * pdl $colour;
$rgb .= 255-(255-$rgb) / (1-$a);
# write the pixels into dst
$dst->data($pixels);
Gimp->progress_update (($src->y-$bounds[1])/$bounds[2]);
} while (Gimp->pixel_rgns_process ($iter));
}
Gimp->progress_update (1);
$drawable->merge_shadow (1);
$drawable->update ($drawable->mask);
(); # wir haben kein neues Bild erzeugt
};
exit main;
Makefile
pm_to_blib
Module.c
Module.bs
......@@ -2,7 +2,7 @@
#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_
/* Perl/Pollution/Portability Version 1.0007 */
/* Perl/Pollution/Portability Version 1.0007-gimp-1 */
/* Copyright (C) 1999, Kenneth Albanowski. This code may be used and
distributed under the same license as any version of Perl. */
......@@ -283,5 +283,9 @@ SV *sv;
#endif /* newCONSTSUB */
/*GIMP*/
#ifndef SvPV_nolen
# define SvPV_nolen(b) SvPV((b),PL_na)
#endif
#endif /* _P_P_PORTABILITY_H_ */
......@@ -52,5 +52,8 @@ OUTPUT
T_PREF
$arg = autobless (newSViv($var), PARAM_$ntype);
T_PREF_ANY
$arg = autobless (newSViv($var), PARAM_$ntype);
T_GDRAWABLE
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment