Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
GNOME
GIMP
Commits
bad20ffc
Commit
bad20ffc
authored
Jul 29, 1999
by
Marc Lehmann
Browse files
see plug-ins/perl/Changes
parent
165c69ff
Changes
18
Hide whitespace changes
Inline
Side-by-side
plug-ins/perl/Changes
View file @
bad20ffc
...
...
@@ -6,8 +6,18 @@ Revision history for Gimp-Perl extension.
- preliminary <Load> and <Save> support (arguments are automatically
supplied).
- enabled limited pixel access functions even when PDL was not found.
- added examples/miff (a save filter for miff images).
-
implemented and
added examples/miff (a save filter for miff images).
- close DATA in Gimp unconditionally, saves one open filehandle.
- fixed the longstanding preview bug in Gimp::UI by reversing the
order of calls to draw_row. => something in gtk+ is really broken.
- fixed a longstanding (but never seen ;) bug in old_pdl: pdls that
were not sever'ed created garbage.
- allow dummy dimension in grayscale pdls, i.e. pdl(1,width,height)
instead of pdl(width,height).
- improved gimpdoc.
- removed debugging code from gouge. ouch!
- bug fixed: PDL::Core was not automatically required when not
already loaded.
1.0981 Wed Jul 28 00:09:50 CEST 1999
- improved gouge ;) In a sense, it's actually pretty code now!
...
...
plug-ins/perl/Gimp.pm
View file @
bad20ffc
...
...
@@ -328,15 +328,15 @@ unless ($no_SIG) {
die_msg
$_
[
0
];
initialized
()
?
&quiet_die
:
exit
quiet_main
();
}
else
{
die
$_
[
0
];
die
$_
[
0
];
}
};
$SIG
{
__WARN__
}
=
sub
{
unless
(
$in_quit
)
{
warn
$_
[
0
];
warn
$_
[
0
];
}
else
{
logger
(
message
=>
substr
(
$_
[
0
],
0
,
-
1
),
fatal
=>
0
,
function
=>
'
WARNING
');
logger
(
message
=>
substr
(
$_
[
0
],
0
,
-
1
),
fatal
=>
0
,
function
=>
'
WARNING
');
}
};
}
...
...
@@ -465,7 +465,7 @@ sub AUTOLOAD {
my
$ref
=
\
&
{"
Gimp::Util::
$sub
"};
*
{
$AUTOLOAD
}
=
sub
{
shift
unless
ref
$_
[
0
];
goto
&$ref
;
# does not always work, PERLBUG! #FIXME
#
goto &$ref; # does not always work, PERLBUG! #FIXME
my
@r
=
eval
{
&$ref
};
_croak
$@
if
$@
;
wantarray
?
@r
:
$r
[
0
];
...
...
@@ -475,7 +475,7 @@ sub AUTOLOAD {
my
$ref
=
\
&
{"
$interface_pkg
\
::
$sub
"};
*
{
$AUTOLOAD
}
=
sub
{
shift
unless
ref
$_
[
0
];
goto
&$ref
;
# does not always work, PERLBUG! #FIXME
#
goto &$ref; # does not always work, PERLBUG! #FIXME
my
@r
=
eval
{
&$ref
};
_croak
$@
if
$@
;
wantarray
?
@r
:
$r
[
0
];
...
...
plug-ins/perl/Gimp/Lib.xs
View file @
bad20ffc
...
...
@@ -22,12 +22,8 @@
#define PDL_clean_namespace
#include <pdlcore.h>
#undef croak
#ifdef Perl_croak_nocontext
#define croak Perl_croak_nocontext
#else
#define croak Perl_croak
#endif
#endif
/* various functions allocate static buffers, STILL. */
#define MAX_STRING 4096
...
...
@@ -77,6 +73,8 @@ static int trace = TRACE_NONE;
#if HAVE_PDL
typedef GPixelRgn GPixelRgn_PDL;
/* hack, undocumented, argh! */
static Core* PDL; /* Structure hold core C functions */
...
...
@@ -88,11 +86,12 @@ static void need_pdl (void)
if (!PDL)
{
/* the perl-server can't be bothered to do this itself! */
perl_require
_pv ("
PDL::Core");
perl_
eval_pv ("
require
PDL::Core"
, TRUE
);
/* 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");
CoreSV = perl_get_sv("PDL::SHARE", FALSE);
if (!CoreSV)
croak("gimp-perl-pixel functions require the PDL::Core module, which was not found");
PDL = (Core*) SvIV(CoreSV);
}
...
...
@@ -117,14 +116,17 @@ static pdl *new_pdl (int a, int b, int c)
static void old_pdl (pdl **p, short ndims, int dim0)
{
PDL->converttype (p, PDL_B, PDL_PERM);
PDL->make_physical (*p);
PDL->converttype (p, PDL_B, PDL_PERM);
if ((*p)->ndims < ndims + (dim0 > 1))
croak ("dimension mismatch, pdl has dimension %d but at least %d dimensions allowed", (*p)->ndims, ndims + (dim0 > 1));
if ((*p)->ndims
!=
ndims +
(dim0 >
1)
)
croak ("dimension mismatch, pdl has dimension %d but %d dimensions required", (*p)->ndims, ndims +
(dim0 > 1)
);
if ((*p)->ndims
>
ndims + 1)
croak ("dimension mismatch, pdl has dimension %d but
at most
%d dimensions required", (*p)->ndims, ndims +
1
);
if (dim
0
>
1
&& (*p)->dims[0] != dim0)
croak ("pixel size mismatch, pdl has %d
byte
pixels but %d
byte
s are required", (*p)->dims[0], dim0);
if (
(*p)->n
dim
s
>
ndims
&& (*p)->dims[0] != dim0)
croak ("pixel size mismatch, pdl has %d
channel
pixels but %d
channel
s are required", (*p)->dims[0], dim0);
}
static void pixel_rgn_pdl_delete_data (pdl *p, int param)
...
...
@@ -216,12 +218,6 @@ static SV *new_gdrawable (gint32 id)
if (!gdr)
croak ("unable to convert Gimp::Drawable into Gimp::GDrawable (id %d)", id);
#if HAVE_PDL
/* this needs to be called once before ANY pdl functions can be called. */
/* placing this here will suffice. */
need_pdl ();
#endif
if (!stash)
stash = gv_stashpv (PKG_GDRAWABLE, 1);
...
...
@@ -315,6 +311,14 @@ static GPixelRgn *old_pixelrgn (SV *sv)
return (GPixelRgn *)SvPV_nolen(SvRV(sv));
}
static GPixelRgn *old_pixelrgn_pdl (SV *sv)
{
#if HAVE_PDL
need_pdl ();
#endif
return old_pixelrgn (sv);
}
/* tracing stuff. */
static SV *trace_var = 0;
static PerlIO *trace_file = 0; /* FIXME: unportable. */
...
...
@@ -2008,6 +2012,7 @@ gimp_drawable_get_tile(gdrawable, shadow, row, col)
gint row
gint col
CODE:
need_pdl ();
RETVAL = new_tile (gimp_drawable_get_tile (old_gdrawable (gdrawable), shadow, row, col), gdrawable);
OUTPUT:
RETVAL
...
...
@@ -2019,13 +2024,14 @@ gimp_drawable_get_tile2(gdrawable, shadow, x, y)
gint x
gint y
CODE:
need_pdl ();
RETVAL = new_tile (gimp_drawable_get_tile2 (old_gdrawable (gdrawable), shadow, x, y), gdrawable);
OUTPUT:
RETVAL
pdl *
gimp_pixel_rgn_get_pixel(pr, x, y)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
int x
int y
CODE:
...
...
@@ -2036,7 +2042,7 @@ gimp_pixel_rgn_get_pixel(pr, x, y)
pdl *
gimp_pixel_rgn_get_row(pr, x, y, width)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
int x
int y
int width
...
...
@@ -2048,7 +2054,7 @@ gimp_pixel_rgn_get_row(pr, x, y, width)
pdl *
gimp_pixel_rgn_get_col(pr, x, y, height)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
int x
int y
int height
...
...
@@ -2060,7 +2066,7 @@ gimp_pixel_rgn_get_col(pr, x, y, height)
pdl *
gimp_pixel_rgn_get_rect(pr, x, y, width, height)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
int x
int y
int width
...
...
@@ -2073,7 +2079,7 @@ gimp_pixel_rgn_get_rect(pr, x, y, width, height)
void
gimp_pixel_rgn_set_pixel(pr, pdl, x, y)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
pdl * pdl
int x
int y
...
...
@@ -2083,7 +2089,7 @@ gimp_pixel_rgn_set_pixel(pr, pdl, x, y)
void
gimp_pixel_rgn_set_row(pr, pdl, x, y)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
pdl * pdl
int x
int y
...
...
@@ -2093,7 +2099,7 @@ gimp_pixel_rgn_set_row(pr, pdl, x, y)
void
gimp_pixel_rgn_set_col(pr, pdl, x, y)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
pdl * pdl
int x
int y
...
...
@@ -2103,7 +2109,7 @@ gimp_pixel_rgn_set_col(pr, pdl, x, y)
void
gimp_pixel_rgn_set_rect(pr, pdl, x, y)
GPixelRgn * pr
GPixelRgn
_PDL
* pr
pdl * pdl
int x
int y
...
...
@@ -2113,8 +2119,8 @@ gimp_pixel_rgn_set_rect(pr, pdl, x, y)
pdl *
gimp_pixel_rgn_data(pr,newdata=0)
GPixelRgn * pr
pdl *
newdata
GPixelRgn
_PDL
* pr
pdl *
newdata
CODE:
if (newdata)
{
...
...
@@ -2167,6 +2173,7 @@ SV *
gimp_tile_get_data(tile)
GTile * tile
CODE:
need_pdl;
croak ("gimp_tile_get_data is not yet implemented\n");
gimp_tile_ref (tile);
gimp_tile_unref (tile, 0);
...
...
plug-ins/perl/Gimp/OO.pod
View file @
bad20ffc
...
...
@@ -176,18 +176,6 @@ that are checked are shown as well (the null prefix "" is implicit).
gimp_brushes_
=item Edit
gimp_edit_
=item Gradients
gimp_gradients_
=item Selection
gimp_selection_
=item Patterns
gimp_patterns_
...
...
plug-ins/perl/Gimp/UI.pm
View file @
bad20ffc
...
...
@@ -185,6 +185,7 @@ sub GTK_OBJECT_INIT {
$button
=
new
Gtk::
Button
"
Cancel
";
signal_connect
$button
"
clicked
",
sub
{
hide
$w
};
$w
->
action_area
->
pack_start
(
$button
,
1
,
1
,
0
);
can_default
$button
1
;
show
$button
;
$self
->
signal_connect
("
clicked
",
sub
{
show
$w
});
...
...
@@ -223,12 +224,12 @@ sub set_preview {
hide
$cp
;
hide
$gp
;
my
$p
=
$bpp
==
1
?
$gp
:
$cp
;
show
$p
;
$p
->
size
(
$w
,
$h
);
while
(
--
$h
)
{
$p
->
draw_row
(
substr
(
$mask
,
$w*$bpp*$
h
),
0
,
$
h
,
$w
);
for
(
0
..
$h
-
1
)
{
$p
->
draw_row
(
substr
(
$mask
,
$w*$bpp
*
$
_
),
0
,
$
_
,
$w
);
}
$p
->
draw
(
undef
);
show
$p
;
$name
;
}
...
...
@@ -267,8 +268,8 @@ sub set_preview {
hide
$p
;
my
$l
=
length
(
$mask
);
$p
->
size
(
$w
,
$h
);
while
(
--
$h
)
{
$p
->
draw_row
(
substr
(
$mask
,
$w*$
h
)
^
$xor
,
0
,
$
h
,
$w
);
for
(
0
..
$h
-
1
)
{
$p
->
draw_row
(
substr
(
$mask
,
$w
*
$
_
)
^
$xor
,
0
,
$
_
,
$w
);
}
$p
->
draw
(
undef
);
show
$p
;
...
...
plug-ins/perl/MANIFEST
View file @
bad20ffc
...
...
@@ -15,12 +15,15 @@ Gimp.xs
scm2perl
scm2scm
gimpdoc
t/load.t
t/loadlib.t
t/run.t
xcftopnm
embedxpm
logo.xpm
extradefs.h
gppport.h
Perl-Server
t/load.t
t/loadlib.t
t/run.t
etc/configure
etc/configure.in
etc/aclocal.m4
...
...
@@ -100,8 +103,6 @@ examples/oneliners
examples/randomart1
examples/colourtoalpha
examples/pixelmap
embedxpm
logo.xpm
examples/frame_reshuffle
examples/frame_filter
examples/gouge
...
...
plug-ins/perl/TODO
View file @
bad20ffc
...
...
@@ -16,6 +16,9 @@ script-fu 4.9 vs. 3.3
bugs
* perl_require_pv with _59?
* scroll behaviour, use clist instead of list?
[DONE] * can_Default for oter OK-buttons
* document Gimp::PDL and rect2, ...2 functions!
[DONE] * MJH: glib-config(!!!)
[KILL] * empty desfiption -> no display in PDB?`
...
...
plug-ins/perl/examples/border.pl
View file @
bad20ffc
...
...
@@ -14,7 +14,7 @@ register "border_average",
"
calulcates the average border colour
",
"
Marc Lehmann
",
"
Marc Lehmann
",
"
0.2.
1
",
"
0.2.
2
",
"
<Image>/Filters/Misc/Border Average
",
"
RGB
",
[
...
...
@@ -58,13 +58,13 @@ register "border_average",
};
Gimp
->
progress_init
("
Border Average
",
0
);
add_new_colour
(
$drawable
->
get
->
pixel_rgn
(
$bounds
[
0
]
,
$bounds
[
1
]
,
$thickness
,
$height
,
0
,
0
)
add_new_colour
(
$drawable
->
pixel_rgn
(
$bounds
[
0
]
,
$bounds
[
1
]
,
$thickness
,
$height
,
0
,
0
)
->
get_rect
(
0
,
0
,
$thickness
,
$height
));
add_new_colour
(
$drawable
->
get
->
pixel_rgn
(
$bounds
[
2
]
-
$thickness
,
$bounds
[
1
]
,
$thickness
,
$height
,
0
,
0
)
add_new_colour
(
$drawable
->
pixel_rgn
(
$bounds
[
2
]
-
$thickness
,
$bounds
[
1
]
,
$thickness
,
$height
,
0
,
0
)
->
get_rect
(
0
,
0
,
$thickness
,
$height
));
add_new_colour
(
$drawable
->
get
->
pixel_rgn
(
$bounds
[
0
]
,
$bounds
[
1
]
,
$width
,
$thickness
,
0
,
0
)
add_new_colour
(
$drawable
->
pixel_rgn
(
$bounds
[
0
]
,
$bounds
[
1
]
,
$width
,
$thickness
,
0
,
0
)
->
get_rect
(
0
,
0
,
$width
,
$thickness
));
add_new_colour
(
$drawable
->
get
->
pixel_rgn
(
$bounds
[
0
]
,
$bounds
[
3
]
-
$thickness
,
$width
,
$thickness
,
0
,
0
)
add_new_colour
(
$drawable
->
pixel_rgn
(
$bounds
[
0
]
,
$bounds
[
3
]
-
$thickness
,
$width
,
$thickness
,
0
,
0
)
->
get_rect
(
0
,
0
,
$width
,
$thickness
));
# now find the colour
...
...
plug-ins/perl/examples/colourtoalpha
View file @
bad20ffc
...
...
@@ -12,7 +12,7 @@ register "colour_to_alpha",
.
"
amount of alpha, then readjusts the colour accordingly.
",
"
Marc Lehmann
",
"
Marc Lehmann <pcg
\@
goof.com>
",
"
19990
517
",
"
19990
729
",
"
<Image>/Filters/Colors/Colour To Alpha
",
"
RGB*
",
[
...
...
@@ -30,8 +30,8 @@ register "colour_to_alpha",
{
# $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
)
;
my
$src
=
new
PixelRgn
$drawable
,
@bounds
,
0
,
0
;
my
$dst
=
new
PixelRgn
$drawable
,
@bounds
,
1
,
1
;
$iter
=
Gimp
->
pixel_rgns_register
(
$src
,
$dst
);
...
...
plug-ins/perl/examples/gimpmagick
View file @
bad20ffc
...
...
@@ -6,7 +6,7 @@ use Gimp::Fu;
use
Gtk
;
BEGIN
{
eval
"
use Image::Magick 1.45
";
$@
and
Gimp::Feature::
missing
("
Image::Magick version 1.45 or higher
")
};
$VERSION
=
'
0.
1
';
$VERSION
=
'
0.
2
';
$preview_size
=
160
;
# max. size for image preview
...
...
@@ -115,7 +115,7 @@ sub read_pixels {
open
TEMP
,"
>
$temp
\
0
"
or
die
"
unable to open temporary file '
$temp
' for writing
\n
";
my
(
$empty
,
$x1
,
$y1
,
$x2
,
$y2
)
=
$drawable
->
mask_bounds
;
$x2
-=
$x1
;
$y2
-=
$y1
;
my
$region
=
$drawable
->
get
->
pixel_rgn
(
$x1
,
$y1
,
$x2
,
$y2
,
0
,
0
);
my
$region
=
$drawable
->
pixel_rgn
(
$x1
,
$y1
,
$x2
,
$y2
,
0
,
0
);
Gimp
->
progress_init
("
transferring image data
");
for
(
my
$y
=
0
;
$y
<
$y2
;
$y
+=
$th
)
{
...
...
plug-ins/perl/examples/gouge
View file @
bad20ffc
...
...
@@ -21,8 +21,8 @@ sub iterate {
$bounds
[
2
]
--
if
$bounds
[
0
]
+
$bounds
[
2
]
>=
(
$drawable
->
offsets
)[
0
]
+
$drawable
->
width
;
$bounds
[
3
]
--
if
$bounds
[
1
]
+
$bounds
[
3
]
>=
(
$drawable
->
offsets
)[
1
]
+
$drawable
->
height
;
{
my
$src
=
new
PixelRgn
(
$drawable
->
get
,
@bounds
[
0
,
1
],
$bounds
[
2
]
+
1
,
$bounds
[
3
]
+
1
,
0
,
0
);
my
$dst
=
new
PixelRgn
(
$drawable
->
get
,
@bounds
,
1
,
1
);
my
$src
=
new
PixelRgn
(
$drawable
,
@bounds
[
0
,
1
],
$bounds
[
2
]
+
1
,
$bounds
[
3
]
+
1
,
0
,
0
);
my
$dst
=
new
PixelRgn
(
$drawable
,
@bounds
,
1
,
1
);
my
$bpp
=
$src
->
bpp
>
1
?
"
:,
"
:
"";
...
...
@@ -30,15 +30,12 @@ sub iterate {
my
$area
=
$bounds
[
2
]
*$bounds
[
3
];
my
$progress
=
0
;
use
Time::
HiRes
'
time
';
$s
=
time
;
do
{
my
(
$x
,
$y
,
$w
,
$h
)
=
(
$dst
->
x
,
$dst
->
y,$dst->w,$dst->h);
$dst->data($kernel->($bpp,
$src
->
get_rect
(
$x
,
$y
,
$w
+
1
,
$h
+
1
)
->
convert
(
short
)));
$progress
+=
$w*$h
/
$area
;
Gimp
->
progress_update
(
$progress
);
}
while
(
Gimp
->
pixel_rgns_process
(
$iter
));
print
time
-
$s
;
}
Gimp
->
progress_update
(
1
);
...
...
plug-ins/perl/examples/logulator
View file @
bad20ffc
...
...
@@ -93,7 +93,7 @@ sub gimp_text_fontname {
my
$newlay
;
if
(
$layer
==
-
1
)
{
$newlay
=
$image
->
layer_new
(
$global_drawable
->
width
,
$global_drawable
->
height
,
$image
->
layertype
(
1
),
$text
,
100
,
NORMAL_MODE
);
$image
->
layertype
(
1
),
$text
||
"
--text--
"
,
100
,
NORMAL_MODE
);
$newlay
->
drawable_fill
(
TRANS_IMAGE_FILL
);
$newlay
->
add_layer
(
0
);
$newlay
->
edit_paste
(
0
)
->
floating_sel_anchor
;
...
...
plug-ins/perl/examples/miff
View file @
bad20ffc
...
...
@@ -26,12 +26,13 @@ register "file_miff_save",
"
Saves images in the miff (Magick Interchange File Format) format used by the ImageMagick package
",
"
Marc Lehmann
",
"
Marc Lehmann <pcg
\@
goof.com>
",
"
1999-07-2
7
",
"
1999-07-2
9
",
"
<Save>/MIFF
",
"
RGB, RGBA, GRAY, INDEXED-NOT-YET
",
# weird, but no matte for !DirectColour
[]
,
sub
{
my
(
$img
,
$drawable
,
$filename
)
=
@_
;
my
@layers
=
$img
->
get_layers
;
sysopen
FILE
,
$filename
,
O_CREAT
|
O_TRUNC
|
O_WRONLY
or
die
"
Unable to open '
$filename
' for writing: $!
\n
";
my
$hdr
=
eval
{
$img
->
find_parasite
("
gimp-comment
")
->
data
};
$hdr
=
"
COMMENT:
$hdr
\n
"
if
$hdr
;
...
...
@@ -41,14 +42,16 @@ id=ImageMagick
CREATOR: file_miff_save gimp plug-in, see http://www.gimp.org/
$hdr}
EOF
init
Progress
"
Saving '
$filename
' as MIFF...
";
my
$scene
=
0
;
for
(
$img
->
get_
layers
)
{
for
(
@
layers
)
{
print
FILE
$hdr
,
"
scene=
$scene
\n
",
"
class=
",
$_
->
color
?
"
DirectClass
"
:
"
PseudoClass
",
"
\n
";
#"gamma=", Gimp->gamma, "\n";
write_layer
(
*FILE
,
$_
);
$scene
++
;
update
Progress
$scene
/
@layers
;
}
close
FILE
;
();
...
...
plug-ins/perl/examples/pixelmap
View file @
bad20ffc
...
...
@@ -6,50 +6,54 @@ use Gimp::Fu;
use
Gimp::
Util
;
use
PDL
;
use
constant
PI
=>
4
*
atan2
1
,
1
;
register
"
pixelmap
",
"
Maps Pixel values and coordinates through general Perl expressions
",
"
=pod(DESCRIPTION)
",
"
Marc Lehmann
",
"
Marc Lehmann <pcg
\@
goof.com>
",
"
19990
528
",
"
19990
729
",
"
<Image>/Filters/Map/Pixelmap
",
"
*
",
[
[
PF_TEXT
,
"
expression
"
,
"
The perl expression to use
",
'
$p=
outer($x
,$y)
->slice("*$bpp")
'
]
[
PF_TEXT
,
"
expression
"
,
"
The perl expression to use
",
"
outer(
\
$
x
*0.1,
\$
y*0.2)
\n
->slice(
\
"
*
\
$
bpp
\
"
)
"
]
],
sub
{
# es folgt das eigentliche Skript...
my
(
$image
,
$drawable
,
$expr
)
=
@_
;
my
(
$image
,
$drawable
,
$
_
expr
)
=
@_
;
Gimp
->
progress_init
("
Mapping pixels...
");
my
$init
=
"";
$expr
=~
/\$p/
and
$init
.=
'
$p = $src->data;
';
$expr
=~
/\$x/
and
$init
.=
'
$x = sequence(byte,$src->w); $x+=$src->x;
';
$expr
=~
/\$y/
and
$init
.=
'
$y = sequence(byte,$src->h); $y+=$src->y;
';
$expr
=~
/\$bpp/
and
$init
.=
'
$bpp = $src->bpp;
';
$_expr
=~
/\$p/
and
$init
.=
'
$p = $src->data;
';
$_expr
=~
/\$x/
and
$init
.=
'
$x = sequence(long,$w); $x+=$_dst->x;
';
$_expr
=~
/\$y/
and
$init
.=
'
$y = sequence(long,$h); $y+=$_dst->y;
';
$_expr
=~
/\$bpp/
and
$init
.=
'
$bpp = $_dst->bpp;
';
my
(
$p
,
$x
,
$y
,
$bpp
,
$w
,
$h
);
$expr
=
"
sub{
$init
\n
#line 1
\n
$expr
;
\n
\$
p
}
";
$
_
expr
=
"
sub{
$init
\n
#line 1
\n
$
_
expr
\n
;
}
";
my
@bounds
=
$drawable
->
mask
;
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
);
my
(
$p
,
$x
,
$y
,
$bpp
);
my
$src
=
new
PixelRgn
$drawable
,
@_bounds
,
0
,
0
;
my
$_dst
=
new
PixelRgn
$drawable
,
@_bounds
,
1
,
1
;
$expr
=
eval
$expr
;
die
"
$@
"
if
$@
;
$
_
expr
=
eval
$
_
expr
;
die
"
$@
"
if
$@
;
$iter
=
Gimp
->
pixel_rgns_register
(
$src
,
$dst
);
$_iter
=
Gimp
->
pixel_rgns_register
(
$src
,
$_dst
);
my
$_area
=
0
;
do
{
$dst
->
data
(
&$expr
);
Gimp
->
progress_update
((
$src
->
y-$bounds[1])/$bounds[2]);
} while (Gimp->pixel_rgns_process ($iter));
(
$w
,
$h
)
=
(
$src
->
w
,
$src
->
h
);
$_area
+=
$w*$h
/
(
$_bounds
[
2
]
*$_bounds
[
3
]);
$_dst
->
data
(
&$_expr
);
Gimp
->
progress_update
(
$_area
);
}
while
(
Gimp
->
pixel_rgns_process
(
$_iter
));
}
Gimp-
>
progress_update
(
1
);
$drawable
->
merge_shadow
(
1
);
$drawable
->
update
(
$drawable
->
mask
);
...
...
plug-ins/perl/gimpdoc
View file @
bad20ffc
...
...
@@ -85,29 +85,122 @@ lw20 lw20 lw60.
TYPE NAME DESCRIPTION
EOF
sub
gen_va
(\@\@) {
my
@vals
=
@
{
+
shift
};
my
@args
=
@
{
+
shift
};
my
(
$vals
,
$args
);
if
(
@vals
==
0
)
{
$vals
=
"";
}
elsif
(
@vals
==
1
)
{
$vals
=
"
$vals
[0][1]
\\
=
\\
";
}
else
{
$vals
=
"
(
"
.
join
("
,
",
map
$_
->
[
1
],
@vals
)
.
"
)
\\
=
\\
";
}
if
(
@args
==
0
)
{
$args
=
"";
}
else
{
$args
=
"
\\
(
"
.
join
("
,
",
map
$_
->
[
1
],
@args
)
.
"
)
";
}
(
$vals
,
$args
);
}
sub
isarray
{
return
1
if
$_
[
0
]
==
&PARAM_INT8ARRAY
;
return
1
if
$_
[
0
]
==
&PARAM_INT16ARRAY
;
return
1
if
$_
[
0
]
==
&PARAM_INT32ARRAY
;
return
1
if
$_
[
0
]
==
&PARAM_FLOATARRAY
;
return
1
if
$_
[
0
]
==
&PARAM_STRINGARRAY
;
return
0
;
}
sub
killcounts
(\@) {
my
$a
=
shift
;
my
$roa
=
0
;
for
(
local
$_
=
0
;
$_
<
$#$a
;
$_
++
)
{
if
(
isarray
(
$a
->
[
$_
+
1
][
0
])
&&
$a
->
[
$_
][
0
]
==
&PARAM_INT32
)
{
splice
@$a
,
$_
,
1
;
$roa
=
1
;
}
}
$roa
;
}
sub
weight
{
my
(
$v
,
$n
,
$a
)
=
@$_
;
my
$w
=
$#$v
+
$#$a
;
$w
--
if
$n
=~
s/^\$\w+//
;
$w
+=
1
-
1
/
(
1
+
length
$n
);
if
(
$n
=~
/ ([A-Z][a-z]+)$/
)
{
$w
+=
1
unless
$
1
eq
ucfirst
$a
->
[
0
][
1
];
}
$w
;
}
sub
gen_alternatives
(\@$\@) {
my
@new
=
[
@
_
];
my
@res
;
do
{
my
@prev
=
@new
;
@new
=
();
for
my
$alt
(
@prev
)
{
my
@vals
=
@
{
$alt
->
[
0
]};
my
$name
=
$alt
->
[
1
];
my
@args
=
@
{
$alt
->
[
2
]};
# try to get rid of array counts
push
@new
,
[
\
@vals
,
$name
,
\
@args
]
if
killcounts
(
@vals
)
|
killcounts
(
@args
);