dnrops
/
gimp
mirror of https://github.com/GNOME/gimp.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Lossa stuff 

-Yosh
This commit is contained in:
Manish Singh 1999-04-04 05:59:08 +00:00
parent 323fa245f0
commit 9435e618aa
16 changed files with 1478 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
tools/pdbgen/Makefile.am
View File

@ -3,7 +3,9 @@ enum_headers = \
../../app/channel_ops.h \
../../app/text_tool.h \
../../app/gimpdrawable.h \
../../app/gimpimage.h
../../app/gimpimage.h \
../../app/procedural_db.h \
../../app/paint_funcs.h
enums.pl: enumgen.pl $(enum_headers)
cd $(srcdir) \

272
tools/pdbgen/app.pl
View File

@ -60,6 +60,37 @@ sub format_code_frag {
$code;
}
sub make_arg_test {
my ($arg, $reverse, $test) = @_;
my $result = "";
my $yes = exists $arg->{on_success};
my $no = !exists $arg->{no_success} || exists $arg->{on_fail};
if ($yes || $no) {
&$reverse(\$test) if $yes;
$result = ' ' x 2 . "if ($test)\n";
$result .= &format_code_frag($arg->{on_success}, 1) if $yes;
if ($no) {
$result .= ' ' x 2 . "else\n" if $yes;
if (!exists $arg->{no_success}) {
$success = 1;
$result .= ' ' x 4 . "success = FALSE;\n";
}
if (exists $arg->{on_fail}) {
$result .= &format_code_frag($_->{on_fail}, 1);
}
}
}
$result;
}
sub declare_args {
my $proc = shift;
my $out = shift;
@ -116,10 +147,18 @@ sub make_arg_recs {
/array/ && do { last };
/boolean/ && do { $info = 'TRUE or FALSE'; last };
/int|float/ && do { $info =~ s/$type/$arg->{name}/e; last };
/enum/ && do { $info = $enums{$name}->{info};
/enum/ && do { my $enum = $enums{$name};
$info = $enum->{info};
foreach (@remove) {
$info =~ s/$_ \(.*?\)(, )?//
} last };
if (exists $enum->{nicks}->{$_}) {
$nick = $enum->{nicks}->{$_};
}
else {
$nick = $_;
}
$info =~ s/$nick \(.*?\)(, )?//
}
$info =~ s/, $//; last };
}
$desc =~ s/%%desc%%/$info/eg;
@ -159,123 +198,113 @@ sub marshal_inargs {
$result .= <<CODE;
$var = $arg->{id_func} (args[$argc].value.pdb_$type);
CODE
if (!exists $_->{no_success}) {
$result .= ' ' x 2 . "if ($var ";
$result .= exists $_->{on_success} ? '!=' : '==';
$result .= " NULL)\n";
if (exists $_->{on_success}) {
$result .= &format_code_frag($_->{on_success}, 1);
$result .= ' ' x 2 . "else\n";
}
$result .= ' ' x 4 . "success = FALSE;\n";
if (exists $_->{on_fail}) {
$result .= &format_code_frag($_->{on_fail}, 1);
}
$success = 1;
}
$result .= &make_arg_test($_, sub { ${$_[0]} =~ s/==/!=/ },
"$var == NULL");
}
else {
my $code = ' ' x 2 . "$var =";
$result .= ' ' x 2 . "$var =";
my $cast = "";
if ($type eq 'pointer' || $arg->{type} =~ /int(16|8)$/) {
$cast = " ($arg->{type})";
}
$code .= "$cast args[$argc].value.pdb_$type";
$code .= ' ? TRUE : FALSE' if $pdbtype eq 'boolean';
$code .= ";\n";
$result .= "$cast args[$argc].value.pdb_$type";
$result .= ' ? TRUE : FALSE' if $pdbtype eq 'boolean';
$result .= ";\n";
if (!exists $_->{no_success}) {
if ($pdbtype eq 'string') {
$code .= ' ' x 2 . "success = $var != NULL;\n";
}
elsif ($pdbtype eq 'enum' && !$enums{$typeinfo[0]}->{contig}) {
if ($pdbtype eq 'string') {
$result .= &make_arg_test($_, sub { ${$_[0]} =~ s/==/!=/ },
"$var == NULL");
}
elsif ($pdbtype eq 'unit') {
$result .= &make_arg_test($_, sub { ${$_[0]} = "!(${$_[0]})" },
'unit < UNIT_PIXEL || unit >= ' .
'gimp_unit_get_number_of_units ()');
}
elsif ($pdbtype eq 'enum' && !$enums{$typeinfo[0]}->{contig}) {
if (!exists $_->{no_success} || exists $_->{on_success} ||
exists $_->{on_fail}) {
my %vals; my $symbols = $enums{pop @typeinfo}->{symbols};
@vals{@$symbols}++; delete @vals{@typeinfo};
$code .= <<CODE;
switch ($var)
{
CODE
my $okvals = ""; my $failvals = "";
my $once = 0;
foreach (@$symbols) {
$code .= ' ' x 4 . "case $_:\n" if exists $vals{$_};
if (exists $vals{$_}) {
$okvals .= ' ' x 4 if $once++;
$okvals .= "case $_:\n";
}
}
$code .= <<CODE;
sub format_switch_frag {
my ($arg, $key) = @_;
my $frag = "";
if (exists $arg->{$key}) {
$frag = &format_code_frag($arg->{$key}, 1);
$frag =~ s/\t/' ' x 8/eg;
$frag =~ s/^/' ' x 2/meg;
$frag =~ s/^ {8}/\t/mg;
}
$frag;
}
$okvals .= &format_switch_frag($_, 'on_success');
$failvals .= "default:\n";
if (!exists $_->{no_success}) {
$success = 1;
$failvals .= ' ' x 6 . "success = FALSE\n"
}
$failvals .= &format_switch_frag($_, 'on_fail');
$result .= <<CODE;
switch ($var)
{
$okvals
break;
default:
success = FALSE;
$failvals
break;
}
CODE
}
elsif (defined $typeinfo[0] || defined $typeinfo[2]) {
my $tests = 0; my $extra = "";
if ($pdbtype eq 'enum') {
my $symbols = $enums{pop @typeinfo}->{symbols};
foreach (@typeinfo) { $extra .= " && $var != $_" }
$typeinfo[0] = $symbols->[0];
$typeinfo[1] = '>=';
$typeinfo[2] = $symbols->[$#$symbols];
$typeinfo[3] = '<=';
}
$code .= ' ' x 2 . "success = ";
if (defined $typeinfo[0]) {
$code .= "$var $typeinfo[1] $typeinfo[0]";
$tests++;
}
if (defined $typeinfo[2]) {
$code .= ' && ' if $tests;
$code .= "$var $typeinfo[3] $typeinfo[2]";
}
$code .= "$extra;\n";
}
if ($code =~ /success/) {
my $tests = 0;
if (exists $_->{on_success}) {
$code .= ' ' x 2 . "if (success)\n";
$code .= &format_code_frag($_->{on_success}, 1);
$tests++;
}
if (exists $_->{on_fail}) {
$code .= ' ' x 2;
$code .= $tests ? "else\n" : "if (success)\n";
$code .= &format_code_frag($_->{on_fail}, 1);
}
if ($success) {
$code =~ s/^/' ' x 4/meg;
$code =~ s/^ {8}/\t/mg;
$code .= ' ' x 4 . "}\n";
$result .= ' ' x 2 . "if (success)\n" . ' ' x 4 . "{\n";
}
else {
$success_init = 0;
}
$success = 1;
}
}
elsif (defined $typeinfo[0] || defined $typeinfo[2]) {
my $code = ""; my $tests = 0; my $extra = "";
$result .= $code;
if ($pdbtype eq 'enum') {
my $symbols = $enums{shift @typeinfo}->{symbols};
foreach (@typeinfo) { $extra .= " || $var == $_" }
$typeinfo[0] = $symbols->[0];
$typeinfo[1] = '<';
$typeinfo[2] = $symbols->[$#$symbols];
$typeinfo[3] = '>';
}
elsif ($pdbtype eq 'float') {
foreach (@typeinfo[0, 2]) {
$_ .= '.0' if defined $_ && !/\./
}
}
if (defined $typeinfo[0]) {
$code .= "$var $typeinfo[1] $typeinfo[0]";
$code .= '.0' if $pdbtype eq 'float' && $typeinfo[0] !~ /\./;
$tests++;
}
if (defined $typeinfo[2]) {
$code .= ' || ' if $tests;
$code .= "$var $typeinfo[3] $typeinfo[2]";
}
$code .= $extra;
$result .= &make_arg_test($_, sub { ${$_[0]} = "!(${$_[0]})" },
$code);
}
}
$argc++; $result .= "\n";
@ -344,7 +373,6 @@ sub generate {
my @outargs = @{$proc->{outargs}} if exists $proc->{outargs};
local $success = 0;
local $success_init = 1;
$out->{pcount}++; $total++;
@ -476,13 +504,11 @@ CODE
}
if ($success) {
$success_init = 0 if $proc->{invoke}->{success} eq 'NONE';
my $header = ' ' x 2 . "gboolean success";
$header .= " = $proc->{invoke}->{success}" if $success_init;
$header .= ";\n";
$out->{code} .= $header;
$out->{code} .= ' ' x 2 . "gboolean success";
unless ($proc->{invoke}->{success} eq 'NONE') {
$out->{code} .= " = $proc->{invoke}->{success}";
}
$out->{code} .= ";\n";
}
$out->{code} .= $code;
@ -500,15 +526,13 @@ static ProcRecord ${name}_proc =
"$proc->{copyright}",
"$proc->{date}",
PDB_INTERNAL,
@{[scalar @inargs or '0']},
@{[scalar @inargs]},
@{[scalar @inargs ? "${name}_inargs" : 'NULL']},
@{[scalar @outargs or '0']},
@{[scalar @outargs]},
@{[scalar @outargs ? "${name}_outargs" : 'NULL']},
{ { ${name}_invoker } }
};
CODE
delete $out->{headers}->{q/"procedural_db.h"/};
}
my $gpl = <<'GPL';
@ -554,20 +578,27 @@ HEADER
foreach $group (@main::groups) {
my $out = $out{$group};
foreach (@{$main::grp{$group}->{headers}}) { $out->{headers}->{$_}++ }
delete $out->{headers}->{q/"procedural_db.h"/};
my $headers = "";
foreach (sort keys %{$out->{headers}}) { $headers .= "#include $_\n" }
my $extra = {};
if (exists $main::grp{$group}->{extra}->{app}) {
$extra = $main::grp{$group}->{extra}->{app}
}
my $cfile = "$destdir/${group}_cmds.c$FILE_EXT";
open CFILE, "> $cfile" or die "Can't open $cmdfile: $!\n";
print CFILE $gpl;
print CFILE qq/#include "procedural_db.h"\n\n/;
foreach $header (sort keys %{$out->{headers}}) {
print CFILE "#include $header\n";
}
print CFILE "\n";
if (exists $main::grp{$group}->{code}) {
print CFILE "$main::grp{$group}->{code}\n";
}
print CFILE $headers, "\n";
print CFILE $extra->{decls}, "\n" if exists $extra->{decls};
print CFILE $out->{procs};
print CFILE "\nvoid\nregister_${group}_procs (void)\n";
print CFILE "{\n$out->{register}}\n";
print CFILE "\n", $extra->{code} if exists $extra->{code};
print CFILE $out->{code};
close CFILE;
&write_file($cfile);
@ -577,9 +608,9 @@ HEADER
$longest = length $decl if $longest < length $decl;
$group_procs .= ' ' x 2 . "app_init_update_status (";
$group_procs .= q/"Internal Procedures"/ unless $once;
$group_procs .= q/_("Internal Procedures")/ unless $once;
$group_procs .= 'NULL' if $once++;
$group_procs .= qq/, "$main::grp{$group}->{desc}", /;
$group_procs .= qq/, _("$main::grp{$group}->{desc}"), /;
($group_procs .= sprintf "%.3f", $pcount / $total) =~ s/\.?0*$//s;
$group_procs .= ($group_procs !~ /\.\d+$/s ? ".0" : "") . ");\n";
$group_procs .= ' ' x 2 . "register_${group}_procs ();\n\n";
@ -589,7 +620,8 @@ HEADER
$internal = "$destdir/internal_procs.c$FILE_EXT";
open INTERNAL, "> $internal" or die "Can't open $cmdfile: $!\n";
print INTERNAL $gpl;
print INTERNAL qq/#include "app_procs.h"\n\n/;
print INTERNAL qq@#include "app_procs.h"\n\n@;
print INTERNAL qq@#include "libgimp/gimpintl.h"\n\n@;
print INTERNAL "/* Forward declarations for registering PDB procs */\n\n";
foreach (@group_decls) {
print INTERNAL "void $_" . ' ' x ($longest - length $_) . " (void);\n";

68
tools/pdbgen/enumgen.pl
View File

@ -25,16 +25,12 @@ BEGIN {
use lib $srcdir;
use Text::Wrap qw(wrap $columns);
$columns = 79;
$columns = 77;
require 'util.pl';
BEGIN { require 'util.pl' }
eval <<'CODE';
*write_file = \&Gimp::CodeGen::util::write_file;
*FILE_EXT = \$Gimp::CodeGen::util::FILE_EXT;
CODE
$FILE_EXT = $FILE_EXT;
my $header = <<'HEADER';
:# The GIMP -- an image manipulation program
@ -66,7 +62,10 @@ my $footer = <<'FOOTER';
:
:foreach $e (values %enums) {
: $e->{info} = "";
: foreach (@{$e->{symbols}}) { $e->{info} .= "$_ ($e->{mapping}->{$_}), " }
: foreach (@{$e->{symbols}}) {
: my $nick = exists $e->{nicks}->{$_} ? $e->{nicks}->{$_} : $_;
: $e->{info} .= "$nick ($e->{mapping}->{$_}), "
: }
: $e->{info} =~ s/, $//;
:}
:
@ -76,9 +75,21 @@ FOOTER
$header =~ s/^://mg;
$footer =~ s/^://mg;
my ($enumname, $contig, $symbols, @mapping, $before);
my ($enumname, $contig, $symbols, @nicks, @mapping, $before, $chop);
# Most of this enum parsing stuff was swiped from makeenums.pl in GTK+
sub parse_options {
my $opts = shift;
my @opts;
for $opt (split /\s*,\s*/, $opts) {
my ($key,$val) = $opt =~ /\s*(\w+)(?:=(\S+))?/;
defined $val or $val = 1;
push @opts, $key, $val;
}
@opts;
}
sub parse_entries {
my $file = shift;
@ -127,7 +138,20 @@ sub parse_entries {
>\*/)?
\s*$
@x) {
my ($name, $value) = ($1, $2);
my ($name, $value, $options) = ($1, $2, $3);
if (defined $options) {
my %options = parse_options($options);
next if defined $options{skip};
if (defined $options{nick}) {
push @nicks, $name, $options{nick};
}
}
elsif (defined $chop) {
my $nick = $name;
$nick =~ s/$chop//;
push @nicks, $name, $nick;
}
$symbols .= $name . ' ';
@ -163,7 +187,18 @@ while (<>) {
close (ARGV); # reset line numbering
}
if (/^\s*typedef\s+enum\s*({)?/) {
if (m@^\s*typedef\s+enum\s*
({)?\s*
(?:/\*<
(([^*]|\*(?!/))*)
>\*/)?
@x) {
if (defined $2) {
my %options = parse_options($2);
$chop = $options{"chop"};
} else {
$chop = undef;
}
# Didn't have trailing '{' look on next lines
if (!defined $1) {
while (<>) {
@ -173,7 +208,7 @@ while (<>) {
}
}
$symbols = ""; $contig = 1; $before = -1; @mapping = ();
$symbols = ""; $contig = 1; $before = -1; @mapping = (); @nicks = ();
# Now parse the entries
&parse_entries (\*ARGV);
@ -188,11 +223,20 @@ while (<>) {
}
$mapping =~ s/,\n\s*$//s;
my $nicks = ""; $pos = 1;
foreach (@nicks) {
$nicks .= $pos++ % 2 ? "$_ => " : "'$_',\n\t\t ";
}
if ($nicks) {
$nicks =~ s/,\n\s*$//s;
$nicks = ",\n\t nicks => { " . $nicks . " }";
}
$code .= <<ENTRY;
$enumname =>
{ contig => $contig,
symbols => [ qw($symbols) ],
mapping => { $mapping }
mapping => { $mapping }$nicks
},
ENTRY
}

113
tools/pdbgen/enums.pl
View File

@ -22,8 +22,8 @@ package Gimp::CodeGen::enums;
%enums = (
ConvertPaletteType =>
{ contig => 1,
symbols => [ qw(MAKE_PALETTE REUSE_PALETTE WEB_PALETTE MONO_PALETTE
CUSTOM_PALETTE) ],
symbols => [ qw(MAKE_PALETTE REUSE_PALETTE WEB_PALETTE
MONO_PALETTE CUSTOM_PALETTE) ],
mapping => { MAKE_PALETTE => '0',
REUSE_PALETTE => '1',
WEB_PALETTE => '2',
@ -61,7 +61,13 @@ package Gimp::CodeGen::enums;
GRAY_GIMAGE => '2',
GRAYA_GIMAGE => '3',
INDEXED_GIMAGE => '4',
INDEXEDA_GIMAGE => '5' }
INDEXEDA_GIMAGE => '5' },
nicks => { RGB_GIMAGE => 'RGB',
RGBA_GIMAGE => 'RGBA',
GRAY_GIMAGE => 'GRAY',
GRAYA_GIMAGE => 'GRAYA',
INDEXED_GIMAGE => 'INDEXED',
INDEXEDA_GIMAGE => 'INDEXEDA' }
},
GimpImageBaseType =>
{ contig => 1,
@ -88,12 +94,111 @@ package Gimp::CodeGen::enums;
ClipToImage => '1',
ClipToBottomLayer => '2',
FlattenImage => '3' }
},
PDBArgType =>
{ contig => 1,
symbols => [ qw(PDB_INT32 PDB_INT16 PDB_INT8 PDB_FLOAT PDB_STRING
PDB_INT32ARRAY PDB_INT16ARRAY PDB_INT8ARRAY
PDB_FLOATARRAY PDB_STRINGARRAY PDB_COLOR
PDB_REGION PDB_DISPLAY PDB_IMAGE PDB_LAYER
PDB_CHANNEL PDB_DRAWABLE PDB_SELECTION
PDB_BOUNDARY PDB_PATH PDB_PARASITE PDB_STATUS
PDB_END) ],
mapping => { PDB_INT32 => '0',
PDB_INT16 => '1',
PDB_INT8 => '2',
PDB_FLOAT => '3',
PDB_STRING => '4',
PDB_INT32ARRAY => '5',
PDB_INT16ARRAY => '6',
PDB_INT8ARRAY => '7',
PDB_FLOATARRAY => '8',
PDB_STRINGARRAY => '9',
PDB_COLOR => '10',
PDB_REGION => '11',
PDB_DISPLAY => '12',
PDB_IMAGE => '13',
PDB_LAYER => '14',
PDB_CHANNEL => '15',
PDB_DRAWABLE => '16',
PDB_SELECTION => '17',
PDB_BOUNDARY => '18',
PDB_PATH => '19',
PDB_PARASITE => '20',
PDB_STATUS => '21',
PDB_END => '22' }
},
PDBStatusType =>
{ contig => 1,
symbols => [ qw(PDB_EXECUTION_ERROR PDB_CALLING_ERROR
PDB_PASS_THROUGH PDB_SUCCESS) ],
mapping => { PDB_EXECUTION_ERROR => '0',
PDB_CALLING_ERROR => '1',
PDB_PASS_THROUGH => '2',
PDB_SUCCESS => '3' }
},
PDBProcType =>
{ contig => 1,
symbols => [ qw(PDB_INTERNAL PDB_PLUGIN PDB_EXTENSION
PDB_TEMPORARY) ],
mapping => { PDB_INTERNAL => '0',
PDB_PLUGIN => '1',
PDB_EXTENSION => '2',
PDB_TEMPORARY => '3' }
},
LayerModeEffects =>
{ contig => 1,
symbols => [ qw(NORMAL_MODE DISSOLVE_MODE BEHIND_MODE
MULTIPLY_MODE SCREEN_MODE OVERLAY_MODE
DIFFERENCE_MODE ADDITION_MODE SUBTRACT_MODE
DARKEN_ONLY_MODE LIGHTEN_ONLY_MODE HUE_MODE
SATURATION_MODE COLOR_MODE VALUE_MODE DIVIDE_MODE
ERASE_MODE REPLACE_MODE) ],
mapping => { NORMAL_MODE => '0',
DISSOLVE_MODE => '1',
BEHIND_MODE => '2',
MULTIPLY_MODE => '3',
SCREEN_MODE => '4',
OVERLAY_MODE => '5',
DIFFERENCE_MODE => '6',
ADDITION_MODE => '7',
SUBTRACT_MODE => '8',
DARKEN_ONLY_MODE => '9',
LIGHTEN_ONLY_MODE => '10',
HUE_MODE => '11',
SATURATION_MODE => '12',
COLOR_MODE => '13',
VALUE_MODE => '14',
DIVIDE_MODE => '15',
ERASE_MODE => '16',
REPLACE_MODE => '17' },
nicks => { NORMAL_MODE => 'NORMAL',
DISSOLVE_MODE => 'DISSOLVE',
BEHIND_MODE => 'BEHIND',
MULTIPLY_MODE => 'MULTIPLY/BURN',
SCREEN_MODE => 'SCREEN',
OVERLAY_MODE => 'OVERLAY',
DIFFERENCE_MODE => 'DIFFERENCE',
ADDITION_MODE => 'ADDITION',
SUBTRACT_MODE => 'SUBTRACT',
DARKEN_ONLY_MODE => 'DARKEN-ONLY',
LIGHTEN_ONLY_MODE => 'LIGHTEN-ONLY',
HUE_MODE => 'HUE',
SATURATION_MODE => 'SATURATION',
COLOR_MODE => 'COLOR',
VALUE_MODE => 'VALUE',
DIVIDE_MODE => 'DIVIDE/DODGE',
ERASE_MODE => 'ERASE',
REPLACE_MODE => 'REPLACE' }
}
);
foreach $e (values %enums) {
$e->{info} = "";
foreach (@{$e->{symbols}}) { $e->{info} .= "$_ ($e->{mapping}->{$_}), " }
foreach (@{$e->{symbols}}) {
my $nick = exists $e->{nicks}->{$_} ? $e->{nicks}->{$_} : $_;
$e->{info} .= "$nick ($e->{mapping}->{$_}), "
}
$e->{info} =~ s/, $//;
}

3
tools/pdbgen/groups.pl
View File

@ -17,4 +17,5 @@
# Modify this list for the groups to parse in the pdb directory
@groups = qw(gdisplay edit floating_sel undo palette gradient convert
channel_ops text gimprc drawable parasite paths);
channel_ops gimprc drawable parasite paths gradient_select
unit procedural_db brushes);

16
tools/pdbgen/lib.pl
View File

@ -308,9 +308,16 @@ LGPL
my $hfile = "$destdir/gimp${group}.h$FILE_EXT";
my $cfile = "$destdir/gimp${group}.c$FILE_EXT";
my $protos;
foreach (@{$out->{proto}}) { $protos .= $_ }
chop $protos;
my $extra = {};
if (exists $main::grp{$group}->{extra}->{lib}) {
$extra = $main::grp{$group}->{extra}->{lib}
}
my $body;
$body = $extra->{decls} if exists $extra->{decls};
foreach (@{$out->{proto}}) { $body .= $_ }
$body .= $extra->{protos} if exists $extra->{protos};
chomp $body;
open HFILE, "> $hfile" or die "Can't open $cfile: $!\n";
print HFILE $lgpl;
@ -329,7 +336,7 @@ extern "C" {
#endif /* __cplusplus */
$protos
$body
#ifdef __cplusplus
@ -345,6 +352,7 @@ HEADER
open CFILE, "> $cfile" or die "Can't open $cfile: $!\n";
print CFILE $lgpl;
print CFILE qq/#include "gimp${group}.h"\n/;
print CFILE "\n", $extra->{code} if exists $extra->{code};
print CFILE $out->{code};
close CFILE;
&write_file($cfile);

27
tools/pdbgen/pdb.pl
View File

@ -74,17 +74,25 @@ package Gimp::CodeGen::pdb;
# Special cases
enum => { name => 'INT32', type => 'gint32 ' },
boolean => { name => 'INT32', type => 'gboolean ' },
unit => { name => 'INT32', type => 'GUnit ' },
region => { name => 'REGION', type => 'gpointer ' } # not supported
);
# Split out the parts of an arg constraint
sub arg_parse {
my %testmap = (
'<' => '>',
'>' => '<',
'<=' => '>=',
'>=' => '<='
my %premap = (
'<' => '<=',
'>' => '>=',
'<=' => '<',
'>=' => '>'
);
my %postmap = (
'<' => '>=',
'>' => '<=',
'<=' => '>',
'>=' => '<'
);
my $arg = shift;
@ -100,11 +108,11 @@ sub arg_parse {
return @retvals;
}
elsif ($arg =~ /^(?:([+-.\d].*?) \s* (<=|<))?
elsif ($arg =~ /^(?:([+-.\d][^\s]*) \s* (<=|<))?
\s* (\w+) \s*
(?:(<=|<) \s* ([+-.\d].*?))?
(?:(<=|<) \s* ([+-.\d][^\s]*))?
/x) {
return ($3, $1, $2 ? $testmap{$2} : $2, $5, $4 ? $testmap{$4} : $4);
return ($3, $1, $2 ? $premap{$2} : $2, $5, $4 ? $postmap{$4} : $4);
}
}
@ -115,6 +123,7 @@ sub arg_ptype {
if (exists $arg->{id_func}) { 'int' }
elsif ($arg->{type} =~ /\*/) { 'pointer' }
elsif ($arg->{type} =~ /boolean/) { 'int' }
elsif ($arg->{type} =~ /GUnit/) { 'int' }
elsif ($arg->{type} =~ /int/) { 'int' }
elsif ($arg->{type} =~ /double/) { 'float' }
else { 'pointer' }
@ -125,3 +134,5 @@ sub arg_ptype {
sub arg_vname { exists $_[0]->{alias} ? $_[0]->{alias} : $_[0]->{name} }
sub arg_numtype () { 'gint32 ' }
1;

241
tools/pdbgen/pdb/brushes.pdb Normal file
View File

@ -0,0 +1,241 @@
# The GIMP -- an image manipulation program
# Copyright (C) 1995 Spencer Kimball and Peter Mattis
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# "Perlized" from C source by Manish Singh <yosh@gimp.org>
sub opacity_arg () {{
name => 'opacity',
type => '0 <= float <= 100',
desc => 'The brush opacity: %%desc%%'
}}
sub spacing_arg () {{
name => 'spacing',
type => '0 <= int32 <= 1000',
desc => 'The brush spacing: %%desc%%'
}}
sub paint_mode_arg () {{
name => 'paint_mode',
type => 'enum LayerModeEffects (no ERASE_MODE, REPLACE_MODE)',
desc => 'The paint mode: { %%desc%% }'
}}
# The defs
sub brushes_refresh {
$blurb = 'Refresh current brushes.';
$help = <<'HELP';
This procedure retrieves all brushes currently in the user's brush path
and updates the brush dialog accordingly.
HELP
$author = $copyright = 'Seth Burgess';
$date = '1997';
%invoke = (
code => <<'CODE'
{
/* FIXME: I've hardcoded success to be 1, because brushes_init() is a
* void function right now. It'd be nice if it returned a value at
* some future date, so we could tell if things blew up when reparsing
* the list (for whatever reason).
* - Seth "Yes, this is a kludge" Burgess
* <sjburges@ou.edu>
*/
brushes_init (FALSE);
}
CODE
);
}
sub brushes_get_brush {
$blurb = 'Retrieve information about the currently active brush mask.';
$help = <<'HELP';
This procedure retrieves information about the currently active brush mask.
This includes the brush name, the width and height, and the brush spacing
paramter. All paint operations and stroke operations use this mask to control
the application of paint to the image.
HELP
&std_pdb_misc;
@outargs = (
{ name => 'name', type => 'string',
desc => 'The brush name',
alias => 'g_strdup (brushp->name)', no_declare => 1 },
{ name => 'width', type => 'int32',
desc => 'The brush width',
alias => 'brushp->mask->width', no_declare => 1 },
{ name => 'height', type => 'int32',
desc => 'The brush height',
alias => 'brushp->mask->height', no_declare => 1 },
{ name => 'spacing', type => 'int32',
desc => 'The brush spacing: (% of MAX [width, height])',
alias => 'brushp->spacing', no_declare => 1 }
);
%invoke = (
vars => ['GimpBrush *brushp'],
code => 'success = (brushp = get_active_brush ()) != NULL;'
);
}
sub brushes_set_brush {
$blurb = 'Set the specified brush as the active brush.';
$help = <<'HELP';
This procedure allows the active brush mask to be set by specifying its name.
The name is simply a string which corresponds to one of the names of the
installed brushes. If there is no matching brush found, this procedure will
return an error. Otherwise, the specified brush becomes active and will be
used in all subsequent paint operations.
HELP
&std_pdb_misc;
@inargs = (
{ name => 'name', type => 'string',
desc => 'The brush name' }
);
%invoke = (
vars => ['GimpBrush *brushp'],
code => <<'CODE'
{
brushp = gimp_brush_list_get_brush (brush_list, name);
if (brushp)
select_brush (brushp);
else
success = FALSE;
}
CODE
);
}
sub brushes_get_opacity {
$blurb = 'Get the brush opacity.';
$help = <<'HELP';
This procedure returns the opacity setting for brushes. This value is set
globally and will remain the same even if the brush mask is changed. The return
value is a floating point number between 0 and 100.
HELP
&std_pdb_misc;
@outargs = ( &opacity_arg );
$outargs[0]->{alias} = 'gimp_brush_get_opacity () * 100.0';
$outargs[0]->{no_declare} = 1;
}
sub brushes_set_opacity {
$blurb = 'Set the brush opacity.';
$help = <<'HELP';
This procedure modifies the opacity setting for brushes. This value is set
globally and will remain the same even if the brush mask is changed. The value
should be a floating point number between 0 and 100.
HELP
&std_pdb_misc;
@inargs = ( &opacity_arg );
%invoke = ( code => 'gimp_brush_set_opacity (opacity / 100.0);' );
}
sub brushes_get_spacing {
$blurb = 'Get the brush spacing.';
$help = <<'HELP';
This procedure returns the spacing setting for brushes. This value is set per
brush and will change if a different brush is selected. The return value is an
integer between 0 and 1000 which represents percentage of the maximum of the
width and height of the mask.
HELP
&std_pdb_misc;
@outargs = ( &spacing_arg );
$outargs[0]->{alias} = 'gimp_brush_get_spacing ()';
$outargs[0]->{no_declare} = 1;
}
sub brushes_set_spacing {
$blurb = 'Set the brush spacing.';
$help = <<'HELP';
This procedure modifies the spacing setting for the current brush. This value
is set on a per-brush basis and will change if a different brush mask is
selected. The value should be a integer between 0 and 1000.
HELP
&std_pdb_misc;
@inargs = ( &spacing_arg );
%invoke = ( code => 'gimp_brush_set_spacing (spacing);' );
}
sub brushes_get_paint_mode {
$blurb = 'Get the brush paint mode.';
$help = <<'HELP';
This procedure returns the paint-mode setting for brushes. This value is set
globally and will not change if a different brush is selected. The return value
is an integer which corresponds to the values listed in the argument
description.
HELP
&std_pdb_misc;
@outargs = ( &paint_mode_arg );
$outargs[0]->{alias} = 'gimp_brush_get_paint_mode ()';
$outargs[0]->{no_declare} = 1;
}
sub brushes_set_paint_mode {
$blurb = 'Set the brush paint_mode.';
$help = <<'HELP';
This procedure modifies the paint_mode setting for the current brush. This
value is set globally and will not change if a different brush mask is
selected.
HELP
&std_pdb_misc;
@inargs = ( &paint_mode_arg );
%invoke = ( code => 'gimp_brush_set_paint_mode (paint_mode);' );
}
@headers = qw("gimpbrushlist.h");
@procs = qw(brushes_refresh brushes_get_brush brushes_set_brush
brushes_get_opacity brushes_set_opacity brushes_get_spacing
brushes_set_spacing brushes_get_paint_mode brushes_set_paint_mode);
%exports = (app => [@procs]);
$desc = 'Brushes';
&brushes_get_paint_mode;
1;

139
tools/pdbgen/pdb/drawable.pdb
View File

@ -24,6 +24,25 @@ sub drawable_arg {{
no_success => 1
}}
sub drawable_coord_args {
@inargs = ( &drawable_arg );
delete $inargs[0]->{no_success};
foreach (qw(x y)) {
push @inargs, { name => "${_}_coord", type => '0 <= int32',
desc => "The $_ coordinate", alias => $_ }
}
}
sub pixel_arg {{
name => 'pixel',
type => 'int8array',
desc => 'The pixel value',
array => { name => 'num_channels', type => 'int32',
desc => 'The number of channels for the pixel',
no_success => 1 }
}}
sub drawable_prop_proc {
my ($return, $name, $type, $func, $desc) = @_;
@ -48,7 +67,24 @@ This procedure returns non-zero if the specified drawable is of type
HELP
&drawable_prop_proc("whether the drawable is $desc type", $func, 'boolean',
$func, "non-zero if the drawable is $desc type")
$func, "non-zero if the drawable is $desc type");
}
sub drawable_is_proc {
my $desc = shift;
my $type = $desc;
$type =~ s/ /_/g;
$help = <<HELP;
This procedure returns non-zero if the specified drawable is a $desc.
HELP
&drawable_prop_proc("whether the drawable is a $desc",
$type, 'boolean', $type,
"Non-zero if the drawable is a $desc");
$outargs[0]->{alias} .= ' ? TRUE : FALSE';
}
sub drawable_merge_shadow {
@ -273,13 +309,112 @@ HELP
%invoke = ( code => 'drawable_offsets (drawable, &offset_x, &offset_y);' );
}
sub drawable_layer {
&drawable_is_proc('layer');
}
sub drawable_layer_mask {
&drawable_is_proc('layer mask');
}
sub drawable_channel {
&drawable_is_proc('channel');
}
sub drawable_set_pixel {
$blurb = 'Sets the value of the pixel at the specified coordinates.';
$help = <<'HELP';
This procedure sets the pixel value at the specified coordinates. The
'num_channels' argument must always be equal to the bytes-per-pixel value for
the spec ified drawable.
HELP
&std_pdb_misc;
$date = '1997';
&drawable_coord_args();
push @inargs, &pixel_arg();
%invoke = (
vars => [ 'gint8 *p', 'gint b', 'Tile *tile' ],
code => <<'CODE'
{
if (x < drawable_width (drawable) && y < drawable_height (drawable) &&
num_channels == drawable_bytes (drawable))
{
tile = tile_manager_get_tile (drawable_data (drawable), x, y,
TRUE, TRUE);
x %= TILE_WIDTH;
y %= TILE_WIDTH;
p = tile_data_pointer (tile, y, x);
for (b = 0; b < num_channels; b++)
*p++ = *pixel++;
tile_release (tile, TRUE);
}
else
success = FALSE;
}
CODE
);
}
sub drawable_get_pixel {
$blurb = 'Gets the value of the pixel at the specified coordinates.';
$help = <<'HELP';
This procedure gets the pixel value at the specified coordinates. The
'num_channels' argument must always be equal to the bytes-per-pixel value for
the specified drawable.
HELP
&std_pdb_misc;
$date = '1997';
&drawable_coord_args();
@outargs = ( &pixel_arg );
%invoke = (
vars => [ 'gint8 *p', 'gint b', 'Tile *tile' ],
code => <<'CODE'
{
if (x < drawable_width (drawable) && y < drawable_height (drawable)
{
num_channels = drawable_bytes (drawable);
pixel = g_new (gint8, num_channels);
tile = tile_manager_get_tile (drawable_data (drawable), x, y,
TRUE, TRUE);
x %= TILE_WIDTH;
y %= TILE_WIDTH;
p = tile_data_pointer (tile, y, x);
for (b = 0; b < num_channels; b++)
pixel[b] = p[b];
tile_release (tile, FALSE);
}
else
success = FALSE;
}
CODE
);
}
@headers = qw("drawable.h");
@procs = qw(drawable_merge_shadow drawable_fill drawable_update
drawable_mask_bounds drawable_gimage drawable_type
drawable_has_alpha drawable_type_with_alpha drawable_color
drawable_gray drawable_indexed drawable_bytes drawable_width
drawable_height drawable_offsets);
drawable_height drawable_offsets drawable_layer
drawable_layer_mask drawable_channel drawable_set_pixel
drawable_get_pixel);
%exports = (app => [@procs]);
$desc = 'Drawable procedures';

6
tools/pdbgen/pdb/edit.pdb
View File

@ -155,12 +155,12 @@ HELP
push @{$invoke{headers}}, qw("gimage_mask.h");
}
# For edit_paste
$extra{app}->{decls} = "extern TileManager *global_buf;\n";
@procs = qw(edit_cut edit_copy edit_paste edit_clear edit_fill edit_stroke);
%exports = (app => [@procs]);
$desc = 'Edit procedures';
# For edit_paste
$code = "extern TileManager *global_buf;\n";
1;

215
tools/pdbgen/pdb/gradient_select.pdb
View File

@ -22,7 +22,151 @@ sub pdb_misc {
$date = '1998';
}
sub get_gradient_data {
sub sample_size_arg {{
name => 'sample_size',
type => '0 < int32 <= 10000',
desc => 'Size of the sample to return when the gradient is changed
(%%desc%%)',
on_fail => 'sample_size = G_SAMPLE;',
no_success => 1
}}
sub gradients_popup {
$blurb = 'Invokes the Gimp gradients selection.';
$help = 'This procedure popups the gradients selection dialog.';
&pdb_misc;
@inargs = (
{ name => 'gradients_callback', type => 'string', alias => 'name',
desc => 'The callback PDB proc to call when gradient selection is
made' },
{ name => 'popup_title', type => 'string', alias => 'title',
desc => 'Title to give the gradient popup window' },
{ name => 'initial_gradient', type => 'string',
desc => 'The name of the pattern to set as the first selected',
no_success => 1 },
&sample_size_arg
);
%invoke = (
vars => [ 'ProcRecord *prec', 'GradSelectP newdialog' ],
code => <<'CODE'
{
if ((prec = procedural_db_lookup (name)))
{
if (initial_gradient && strlen (initial_gradient))
newdialog = gsel_new_selection (title, initial_gradient);
else
newdialog = gsel_new_selection (title, NULL);
newdialog->callback_name = g_strdup (name);
newdialog->sample_size = sample_size;
/* Add to active gradient dialogs list */
active_dialogs = g_slist_append (active_dialogs, newdialog);
}
else
success = FALSE;
}
CODE
);
}
sub gradients_close_popup {
$blurb = 'Popdown the Gimp gradient selection.';
$help = 'This procedure closes an opened gradient selection dialog.';
&pdb_misc;
@inargs = (
{ name => 'gradients_callback', type => 'string', alias => 'name',
desc => 'The name of the callback registered for this popup' }
);
%invoke = (
vars => [ 'ProcRecord *prec', 'GradSelectP gsp' ],
code => <<'CODE'
{
if ((prec = procedural_db_lookup (name)) &&
(gsp = gradients_get_gradientselect (name))
{
active_dialogs = g_slist_remove (active_dialogs, gsp);
if (GTK_WIDGET_VISIBLE (gsp->shell))
gtk_widget_hide (gsp->shell);
/* Free memory if poping down dialog which is not the main one */
if (gsp != gradient_select_dialog)
{
/* Send data back */
gtk_widget_destroy (gsp->shell);
grad_select_free (gsp);
}
}
else
success = FALSE;
}
CODE
);
}
sub gradients_set_popup {
$blurb = 'Sets the current gradient selection in a popup.';
$help = $blurb;
&pdb_misc;
@inargs = (
{ name => 'gradients_callback', type => 'string', alias => 'pdbname',
desc => 'The name of the callback registered for this popup' },
{ name => 'gradient_name', type => 'string',
desc => 'The name of the gradient to set as selected' }
);
%invoke = (
vars => [ 'ProcRecord *prec', 'GradSelectP gsp' ],
code => <<'CODE'
{
if ((prec = procedural_db_lookup (name)) &&
(gsp = gradients_get_gradientselect (name))
{
GSList *tmp;
gradient_t *active = NULL;
int pos = 0;
tmp = gradients_list;
while (tmp)
{
active = tmp->data;
if (!strcmp (gradient_name, active->name)
break; /* We found the one we want */
pos++;
tmp = tmp->next;
}
if (active)
{
gtk_clist_select_row (GTK_CLIST (gsp->clist), pos, -1);
gtk_clist_moveto (GTK_CLIST (gsp->clist), pos, 0, 0.0, 0.0);
}
else
success = FALSE;
}
else
success = FALSE;
}
CODE
);
}
sub gradients_get_gradient_data {
$blurb = <<'BLURB';
Retrieve information about the specified gradient (including data).
BLURB
@ -37,17 +181,14 @@ HELP
@inargs = (
{ name => 'name', type => 'string',
desc => 'The gradient name ("" means current active gradient)' },
{ name => 'sample_size', type => '0 < int32 < 10000',
desc => 'The size of the sample to return when the gradient is
changed $desc',
on_fail => 'sample_size = G_SAMPLE;' }
&sample_size_arg
);
@outargs = (
{ name => 'name', type => 'string',
desc => 'The gradient name',
alias => 'g_strdup (grad->name)', no_declare => 1 },
{ name => 'grad_data', type => 'floatarray',
{ name => 'grad_data', type => 'floatarray', alias => 'values',
desc => 'The gradient sample data',
array => { name => 'width',
desc => 'The gradient sample width (r,g,b,a)',
@ -59,16 +200,12 @@ HELP
vars => ['gradient_t *grad'],
code => <<'CODE'
{
if (name[0] == '\0')
success = (grad = curr_gradient) != NULL;
else
if (strlen (name))
{
GSList *list;
GSList *list = gradients_list;
success = FALSE;
list = gradients_list;
while (list)
{
grad = list->data;
@ -82,17 +219,67 @@ HELP
list = list->next;
}
}
else
success = (grad = curr_gradient) != NULL;
if (success)
{
gdouble *,
gdouble *values, *pv;
gdouble pos, delta;
gdouble r, g, b, a;
int i = sample_size;
pos = 0.0;
delta = 1.0 / (i - 1);
pv = values = g_new (gdouble, i * 4);
curr_gradient = grad;
while (i--)
{
grad_get_color_at (pos, &r, &g, &b, &a);
*pv++ = r;
*pv++ = g;
*pv++ = b;
*pv++ = a;
pos += delta;
}
curr_gradient = oldgrad;
}
}
CODE
);
}
@procs = qw(gradients_get_gradient_data);
@headers = qw("gradient_select.h");
$extra{app}->{code} = <<'CODE';
static GradSelectP
gradients_get_gradientselect(gchar *name)
{
GSList *list = active_dialogs;
GradSelectP gsp;
while (list)
{
gsp = (GradSelectP) list->data;
if (!strcmp (name, gsp->callback_name))
return gsp;
list = list->next;
}
return NULL;
}
CODE
@procs = qw(gradients_popup gradients_close_popup gradients_set_popup
gradients_get_gradient_data);
%exports = (app => [@procs]);
$desc = 'Gradient UI';

64
tools/pdbgen/pdb/parasite.pdb
View File

@ -47,7 +47,7 @@ sub parasite_new {
@inargs = (
&name_arg('create'),
{ name => 'flags', type => 'int32',
desc => 'The flags (persistance == 1)' },
desc => 'The flags (1 == persistance)' },
{ name => 'size', type => '0 <= int32',
desc => 'The size of the data in bytes' },
{ name => 'data', type => 'string',
@ -82,9 +82,8 @@ HELP
@outargs = ( &parasite_outarg('found') );
%invoke = (
headers => [ qw("gimpparasite.h") ],
code => <<'CODE'
success = (parasite = parasite_copy (gimp_find_parasite (name))) != NULL;
success = (parasite = parasite_copy (gimp_parasite_find (name))) != NULL;
CODE
);
}
@ -102,12 +101,65 @@ HELP
{ name => 'parasite', type => 'parasite',
desc => 'The parasite to attach to the gimp' }
);
%invoke = ( code => 'gimp_parasite_attach (parasite);' );
}
@headers = qw("libgimp/parasite.h");
sub parasite_detach {
$blurb = 'Removes a parasite from the gimp.';
@procs = qw(parasite_new parasite_find parasite_attach);
%exports = (app => [@procs]);
$help = <<'HELP';
This procedure detaches a parasite from the gimp. It has no return values.
HELP
&pdb_misc;
@inargs = (
{ name => 'name', type => 'string',
desc => 'The name of the parasite to detach from the gimp.' }
);
%invoke = ( code => 'gimp_parasite_detach (name);' );
}
sub parasite_list {
$blurb = 'List all parasites.';
$help = 'Returns a list of all currently attached parasites.';
$author = $copyright = 'Marc Lehmann';
$date = '1999';
@outargs = (
{ name => 'parasites', type => 'stringarray',
desc => 'The names of currently attached parasites',
array => { desc => 'The number of attached parasites' } }
);
%invoke = ( code => 'parasites = gimp_parasite_list (&num_parasites);' );
}
@headers = qw("libgimp/parasite.h" "gimpparasite.h");
$extra{lib}->{protos} = <<'CODE';
void gimp_parasite_attach_new (const char *name, int flags, int size
const void *data);
CODE
$extra{lib}->{code} = <<'CODE';
void
gimp_parasite_attach_new (const char *name, int flags, int size,
const void *data)
{
Parasite *p = parasite_new (name, flags, size, data);
gimp_parasite_attach (p);
parasite_free (p);
}
CODE
@procs = qw(parasite_new parasite_find parasite_attach parasite_detach
parasite_list);
%exports = (app => [@procs], lib => [@procs[1..3]]);
$desc = 'Parasite procedures';

294
tools/pdbgen/pdb/procedural_db.pdb
View File

@ -17,31 +17,37 @@
# "Perlized" from C source by Manish Singh <yosh@gimp.org>
sub proc_name_arg {
{ name => 'procedure', type => 'string',
desc => 'The procedure name', alias => 'proc_name' },
}
sub proc_name_arg {{
name => 'procedure',
type => 'string',
desc => 'The procedure name',
alias => 'proc_name'
}}
sub regex_arg {
my $type = shift;
{ name => $type, type => 'string',
desc => "The regex for procedure $type" }
}
sub data_ident_arg {
{ name => 'identifier', type => 'string',
desc => 'The identifier associated with data' }
}
sub data_ident_arg {{
name => 'identifier',
type => 'string',
desc => 'The identifier associated with data'
}}
sub data_bytes_arg {
{ name => 'bytes', type => 'int32',
desc => 'The number of bytes in the data' }
}
sub data_bytes_arg {{
name => 'bytes',
type => '0 < int32',
desc => 'The number of bytes in the data',
alias => 'data->bytes',
no_declare => 1
}}
sub data_arg {
{ name => 'data', type => 'int8array',
desc => 'A byte array containing data' }
}
sub data_arg {{
name => 'data',
type => 'int8array',
desc => 'A byte array containing data',
array => &data_bytes_arg
}}
sub arg_info_proc {
my $type = shift; my $long_type = shift; my $real_type = shift;
@ -61,30 +67,29 @@ HELP
@inargs = (
&proc_name_arg,
{ name => "$type_num", type => 'int32',
{ name => "${type}_num", type => 'int32',
desc => "The $long_type number" }
);
@outargs = (
{ name => "${type}_type", type => 'enum PDBArgType',
desc => "The type of $long_type %%desc%%",
alias => "${type}->arg_type" },
alias => "${type}->arg_type", no_declare => 1 },
{ name => "${type}_name", type => 'string',
desc => "The name of the $long_type",
alias => "${type}->name" },
alias => "g_strdup (${type}->name)", no_declare => 1 },
{ name => "${type}_desc", type => 'string',
desc => "A description of the $long_type",
alias => "${type}->description" }
alias => "g_strdup (${type}->description)", no_declare => 1 }
);
%invoke = (
headers => [ qw("procedural_db.h") ],
vars => [ 'ProcRecord *proc;' ],
code => <<CODE
{
proc = procedural_db_lookup (proc_name);
if (proc && (${type}_num >= 0 && ${type}_num < proc->num_$real_type))
$type = \&proc->${real_type}[${type}_num];
$type = \&proc->${real_type}\[${type}_num];
else
success = FALSE;
}
@ -94,9 +99,39 @@ CODE
# The defs
sub procedural_db_query {
$alias{lib} = 'query_database';
sub procedural_db_dump {
$blurb = 'Dumps the current contents of the procedural database';
$help = <<'HELP';
This procedure dumps the contents of the procedural database to the specified
file. The file will contain all of the information provided for each registered
procedure. This file is in a format appropriate for use with the supplied
"pdb_self_doc.el" Elisp script, which generates a texinfo document.
HELP
&std_pdb_misc;
$author = 'Spencer Kimball & Josh MacDonald';
$copyright = $author . ' & Peter Mattis';
@inargs = (
{ name => 'filename', type => 'string',
desc => 'The dump filename' }
);
%invoke = (
code => <<'CODE'
{
if ((procedural_db_out = fopen (filename, "w")))
{
g_hash_table_foreach (procedural_ht, procedural_db_print_entry, NULL);
fclose (procedural_db_out);
}
}
CODE
);
}
sub procedural_db_query {
$blurb = <<'BLURB';
Queries the procedural database for its contents using regular expression
matching.
@ -117,46 +152,36 @@ HELP
&std_pdb_misc;
@inargs = (
&regex_arg('name'),
&regex_arg('blurb'),
&regex_arg('help'),
&regex_arg('author'),
&regex_arg('copyright'),
&regex_arg('date'),
&regex_arg('proc_type')
);
$inargs[$#inargs]->{desc} =~
s <proc_type$>
<type: { 'Internal GIMP procedure', 'GIMP Plug-in',
'GIMP Extension' }>;
my $regcomp = ""; my $free = ""; $once = 0;
foreach (qw(name blurb help author copyright date proc_type)) {
push @inargs, { name => $_, type => 'string',
desc => "The regex for procedure $_" };
@outargs = (
{
name => 'num_matches',
type => 'int32',
desc => 'The number of matching procedures',
alias => 'pdb_query.num_procs'
},
{
name => 'procedure_names',
type => 'stringarray',
desc => 'The list of procedure names',
alias => 'pdb_query.list_or_procs'
}
);
my($regcomp, $free, $once);
foreach (@inargs) {
$regcomp .= ' ' x 2 if $once;
$regcomp .= "regcomp (&pdb_query.${_}_regex, $_, 0);\n";
$free .= ' ' x 2 if $once++;
$free .= "free (pdb_query.${_}_regex.buffer);\n";
}
chop $free;
$inargs[$#inargs]->{desc} =~
s <proc_type$>
<type: { 'Internal GIMP procedure', 'GIMP Plug-in',
'GIMP Extension' }>;
@outargs = (
{ name => 'procedure_names', type => 'stringarray',
desc => 'The list of procedure names',
alias => 'pdb_query.list_of_procs', no_declare => 1,
array => { name => 'num_matches',
desc => 'The number of matching procedures',
alias => 'pdb_query.num_procs', no_declare => 1 }
}
);
%invoke = (
headers => [ qw("procedural_db.h" "regex.h") ],
headers => [ qw("regex.h") ],
vars => [ 'PDBQuery pdb_query' ],
code => <<CODE
{
@ -173,8 +198,6 @@ CODE
}
sub procedural_db_proc_info {
$alias{lib} = 'query_procedure';
$blurb = <<'BLURB';
Queries the procedural database for information on the specified procedure.
BLURB
@ -212,12 +235,15 @@ HELP
desc => 'The number of return values' }
);
foreach (@outargs) { $_->{alias} = "proc->$_->{name}" }
foreach (@outargs) {
$_->{alias} = "proc->$_->{name}";
$_->{alias} = "g_strdup ($_->{alias})" if $_->{type} eq 'string';
$_->{no_declare} = 1;
}
%invoke = (
headers => [ qw("procedural_db.h") ],
code => <<'CODE'
success = ((proc = procedural_db_lookup (proc_name)) != NULL);
success = (proc = procedural_db_lookup (proc_name)) != NULL;
CODE
);
}
@ -246,14 +272,10 @@ HELP
@inargs = ( &data_ident_arg );
@outargs = ( &data_bytes_arg, &data_arg );
$outargs[0]->{alias} = 'data->bytes';
$outargs[1]->{alias} = 'data_copy';
@globals = ('static GList *data_list = NULL');
@outargs = ( &data_arg );
$outargs[0]->{alias} = 'data_copy';
%invoke = (
headers => [ qw("procedural.db.h") ],
vars => ['PDBData *data', 'char *data_copy', 'GList *list'],
code => <<'CODE'
{
@ -265,7 +287,7 @@ HELP
data = (PDBData *) list->data;
list = list->next;
if (strcmp (data->identifier, identifier) == 0)
if (!strcmp (data->identifier, identifier))
{
data_copy = g_new (char, data->bytes);
memcpy (data_copy, data->data, data->bytes);
@ -280,8 +302,6 @@ CODE
}
sub procedural_db_get_data_size {
$alias{lib} = 'get_data_size';
$blurb = 'Returns size of data associated with the specified identifier.';
$help = <<'HELP';
@ -290,17 +310,14 @@ the specified identifier. If no data has been associated with the identifier,
an error is returned.
HELP
$author = 'Nick Lamb';
$copyright = $author;
$author = $copyright = 'Nick Lamb';
$date = '1998';
@inargs = ( &data_ident_arg );
@outargs = ( &data_bytes_arg );
$outargs[0]->{alias} = 'data->bytes';
%invoke = (
headers => [ qw("procedural.db.h") ],
vars => ['PDBData *data', 'GList *list'],
code => <<'CODE'
{
@ -312,7 +329,7 @@ HELP
data = (PDBData *) list->data;
list = list->next;
if (strcmp (data->identifier, identifier) == 0)
if (!strcmp (data->identifier, identifier))
{
success = TRUE;
break;
@ -336,18 +353,17 @@ HELP
&std_pdb_misc;
$date = '1997';
@inargs = ( &data_ident_arg, &data_bytes_arg, &data_arg );
$inargs[2]->{alias} = 'data_src';
@inargs = ( &data_ident_arg, &data_arg );
$inargs[1]->{alias} = 'data_src';
%invoke = (
headers => [ qw("procedural.db.h") ],
vars => ['PDBData *data = NULL', 'GList *list'],
code => <<'CODE'
{
list = data_list;
while (list)
{
if (strcmp (((PDBData *) list->data)->identifier, identifier) == 0)
if (!strcmp (((PDBData *) list->data)->identifier, identifier))
data = (PDBData *) list->data;
list = list->next;
@ -371,7 +387,7 @@ CODE
);
}
$support{types} = <<'SUPPORT';
$extra{app}->{decls} = <<'CODE';
/* Query structure */
typedef struct _PDBQuery PDBQuery;
@ -385,7 +401,7 @@ struct _PDBQuery
regex_t date_regex;
regex_t proc_type_regex;
char ** list_of_procs;
gchar **list_of_procs;
int num_procs;
};
@ -393,16 +409,18 @@ typedef struct _PDBData PDBData;
struct _PDBData
{
char *identifier;
int bytes;
char *data;
gchar *identifier;
gint bytes;
gchar *data;
};
SUPPORT
$support{code} = <<'SUPPORT';
static inline int
static GList *data_list = NULL;
CODE
$extra{app}->{code} = <<'CODE';
static int
match_strings (regex_t *preg,
char *a)
gchar *a)
{
return regexec (preg, a, 0, NULL, 0);
}
@ -427,28 +445,112 @@ procedural_db_query_entry (gpointer key,
!match_strings (&pdb_query->author_regex, proc->author) &&
!match_strings (&pdb_query->copyright_regex, proc->copyright) &&
!match_strings (&pdb_query->date_regex, proc->date) &&
!match_strings (&pdb_query->proc_type_regex, proc_type_str[(int) proc->pro
c_type]))
!match_strings (&pdb_query->proc_type_regex,
proc_type_str[(int) proc->proc_type]))
{
new_length = (proc->name) ? (strlen (proc->name) + 1) : 0;
new_length = proc->name ? (strlen (proc->name) + 1) : 0;
if (new_length)
{
pdb_query->num_procs++;
pdb_query->list_of_procs = g_realloc (pdb_query->list_of_procs,
(sizeof (char **) * pdb_query->nu
m_procs));
(sizeof (gchar **) * pdb_query->num_procs));
pdb_query->list_of_procs[pdb_query->num_procs - 1] = g_strdup (proc->n
ame);
}
}
}
SUPPORT
static void
output_string (gchar *string)
{
fprintf (procedural_db_out, "\"");
while (*string)
{
switch (*string)
{
case '\\' : fprintf (procedural_db_out, "\\\\"); break;
case '\"' : fprintf (procedural_db_out, "\\\""); break;
case '{' : fprintf (procedural_db_out, "@{"); break;
case '@' : fprintf (procedural_db_out, "@@"); break;
case '}' : fprintf (procedural_db_out, "@}"); break;
default:
fprintf (procedural_db_out, "%c", *string);
}
string++;
}
fprintf (procedural_db_out, "\"\n");
}
static void
procedural_db_print_entry (gpointer key,
gpointer value,
gpointer user_data)
{
int i;
ProcRecord *procedure;
GList *list = (GList *) value;
int num = 0;
GString *buf = g_string_new ("");
while (list)
{
num++;
procedure = (ProcRecord*) list->data;
list = list->next;
fprintf (procedural_db_out, "\n(register-procedure ");
if (list || num != 1)
{
g_string_sprintf (buf, "%s <%d>", procedure->name, num);
output_string (buf->str);
}
else
output_string (procedure->name);
output_string (procedure->blurb);
output_string (procedure->help);
output_string (procedure->author);
output_string (procedure->copyright);
output_string (procedure->date);
output_string (proc_type_str[(int) procedure->proc_type]);
fprintf (procedural_db_out, "( ");
for (i = 0; i < procedure->num_args; i++)
{
fprintf (procedural_db_out, "( ");
output_string (procedure->args[i].name );
output_string (type_str[procedure->args[i].arg_type]);
output_string (procedure->args[i].description);
fprintf (procedural_db_out, " ) ");
}
fprintf (procedural_db_out, " ) ");
fprintf (procedural_db_out, "( ");
for (i = 0; i < procedure->num_values; i++)
{
fprintf (procedural_db_out, "( ");
output_string (procedure->values[i].name );
output_string (type_str[procedure->values[i].arg_type]);
output_string (procedure->values[i].description);
fprintf (procedural_db_out, " ) ");
}
fprintf (procedural_db_out, " ) ");
fprintf (procedural_db_out, " ) ");
}
g_string_free (buf, TRUE);
}
CODE
@procs = qw(procedural_db_dump procedural_db_query procedural_db_proc_info
procedural_db_proc_arg procedural_db_proc_val
procedural_db_get_data procedural_db_get_data_size
procedural_db_set_data)
procedural_db_set_data);
%exports = (app => [@procs], lib => [@procs[5..7], @procs[1..2]]);
$desc = 'Procedural database';

71
tools/pdbgen/pdb/text.pdb → tools/pdbgen/pdb/text_tool.pdb
View File

@ -175,17 +175,9 @@ HELP
&extents_outargs;
%invoke = (
code => <<'CODE'
{
success = text_get_xlfd (size, size_type, foundry, family, weight,
slant, set_width, spacing, registry, encoding,
fontname);
if (success)
success = text_get_extents (fontname, text, &width, &height, &ascent,
&descent);
}
CODE
pass_through => 'text_get_extents_fontname',
pass_args => [ 0..2 ],
make_args => [ &fontname_makeargs ]
);
}
@ -248,13 +240,62 @@ HELP
&extents_outargs;
%invoke = (
pass_through => 'text_get_extents',
pass_args => [ 0..2 ],
make_args => [ &fontname_makeargs ]
code => <<'CODE'
success = text_get_extents (fontname, text,
&width, &height,
&ascent, &descent);
CODE
);
}
@headers = qw("text_tool.h");
@headers = qw("text_tool.h" <string.h>);
$extra{app}->{code} = <<'CODE';
static int
text_get_xlfd (double size,
int size_type,
char *foundry,
char *family,
char *weight,
char *slant,
char *set_width,
char *spacing,
char *registry,
char *encoding,
char *fontname)
{
char pixel_size[12], point_size[12];
if (size > 0)
{
switch (size_type)
{
case PIXELS:
sprintf (pixel_size, "%d", (int) size);
sprintf (point_size, "*");
break;
case POINTS:
sprintf (pixel_size, "*");
sprintf (point_size, "%d", (int) (size * 10));
break;
}
/* create the fontname */
g_snprintf (fontname, "-%s-%s-%s-%s-%s-*-%s-%s-75-75-%s-*-%s-%s",
foundry,
family,
weight,
slant,
set_width,
pixel_size, point_size,
spacing,
registry, encoding);
return TRUE;
}
else
return FALSE;
}
CODE
@procs = qw(text text_get_extents text_fontname text_get_extents_fontname);
%exports = (app => [@procs]);

208
tools/pdbgen/pdb/unit.pdb Normal file
View File

@ -0,0 +1,208 @@
# The GIMP -- an image manipulation program
# Copyright (C) 1995 Spencer Kimball and Peter Mattis
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# "Perlized" from C source by Manish Singh <yosh@gimp.org>
sub pdb_misc {
$author = $copyright = 'Michael Natterer';
$date = '1999';
}
sub unit_arg () {{
name => 'unit_id',
type => 'unit',
desc => "The unit's integer ID",
alias => 'unit'
}}
sub unit_prop_proc {
my ($prop, $type, $desc) = @_;
$desc = $prop unless $desc;
$blurb = "Returns the $desc of the unit.";
&pdb_misc;
@inargs = ( &unit_arg );
@outargs = (
{ name => $prop, type => $type,
desc => "The unit's $desc",
alias => "gimp_unit_get_$prop (unit)",
no_declare => 1 }
);
if ($type eq 'string') {
$outargs[0]->{alias} = "g_strdup ($outargs[0]->{alias})";
}
}
sub unit_get_number_of_units {
$blurb = 'Returns the number of units.';
$help = 'This procedure returns the number of defined units.';
&pdb_misc;
@outargs = (
{ name => 'num_units', type => 'int32',
desc => 'The number of units',
alias => 'gimp_unit_get_number_of_units ()', no_declare => 1 }
);
}
sub unit_new {
$blurb = "Creates a new unit and returns it's integer ID.";
$help = <<'HELP';
This procedure creates a new unit and returns it's integer ID. Note that the
new unit will have it's deletion flag set to TRUE, so you will have to set it
to FALSE with gimp_unit_set_deletion_flag to make it persistent.
HELP
&pdb_misc;
@inargs = (
{ name => 'identifier', type => 'string',
desc => "The new unit's identifier" },
{ name => 'factor', type => 'float',
desc => "The new unit's factor" },
{ name => 'digits', type => 'int32',
desc => "The new unit's digits" },
{ name => 'symbol', type => 'string',
desc => "The new unit's symbol" },
{ name => 'abbreviation', type => 'string',
desc => "The new unit's abbreviation" },
{ name => 'singular', type => 'string',
desc => "The new unit's singular form" },
{ name => 'plural', type => 'string',
desc => "The new unit's plural form" }
);
@outargs = ( &unit_arg );
$outargs[0]->{desc} = "The new unit's ID";
$outargs[0]->{init} = 1;
%invoke = (
code => <<'CODE'
unit = gimp_unit_new (identifier, factor, digits, symbol, abbreviation,
singular, plural);
CODE
);
}
sub unit_get_deletion_flag {
$help = <<'HELP';
This procedure returns the deletion flag of the unit. If this value is TRUE the
unit's definition will not be saved in the user's unitrc file on gimp exit.
HELP
&unit_prop_proc('deletion_flag', 'boolean', 'deletion flag');
}
sub unit_set_deletion_flag {
$blurb = 'Sets the deletion flag of a unit.';
$help = <<'HELP';
This procedure sets the unit's deletion flag. If the deletion flag of a unit is
TRUE on gimp exit, this unit's definition will not be saved in the user's
unitrc.
HELP
&pdb_misc;
@inargs = (
&unit_arg,
{ name => 'deletion_flag', type => 'boolean',
desc => 'The new deletion flag of the unit' }
);
%invoke = ( code => 'gimp_unit_set_deletion_flag (unit, deletion_flag);' );
}
sub unit_get_identifier {
$help = <<'HELP';
This procedure returns the textual identifier of the unit. For built-in units
it will be the english singular form of the unit's name. For user-defined units
this should equal to the singular form.
HELP
&unit_prop_proc('identifier', 'string', 'textual identifier');
}
sub unit_get_factor {
$help = <<'HELP';
This procedure returns the unit's factor which indicates how many units make up
an inch. Note that asking for the factor of "pixels" will produce an error.
HELP
&unit_prop_proc('factor', 'float');
}
sub unit_get_digits {
$help = <<'HELP';
This procedure returns the number of digits you should provide in input or
output functions to get approximately the same accuracy as with two digits and
inches. Note that asking for the digits of "pixels" will produce an error.
HELP
&unit_prop_proc('digits', 'int32', 'number of digits');
}
sub unit_get_symbol {
$help = <<'HELP';
This procedure returns the symbol of the unit ("''" for inches).
HELP
&unit_prop_proc('symbol', 'string');
}
sub unit_get_abbreviation {
$help = <<'HELP';
This procedure returns the abbreviation of the unit ("in" for inches).
HELP
&unit_prop_proc('abbreviation', 'string');
}
sub unit_get_singular {
$help = <<'HELP';
This procedure returns the singular form of the unit.
HELP
&unit_prop_proc('singular', 'string', 'singular form');
}
sub unit_get_plural {
$help = <<'HELP';
This procedure returns the singular form of the unit.
HELP
&unit_prop_proc('plural', 'string', 'plural form');
}
@headers = qw("libgimp/gimpunit.h");
@procs = qw(unit_get_number_of_units unit_new unit_get_deletion_flag
unit_set_deletion_flag unit_get_identifier unit_get_factor
unit_get_digits unit_get_symbol unit_get_abbreviation
unit_get_singular unit_get_plural);
%exports = (app => [@procs]);
$desc = 'Units';
1;

43
tools/pdbgen/pdbgen.pl
View File

@ -17,7 +17,7 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
require 5.002;
require 5.004;
BEGIN {
$srcdir = '.';
@ -36,14 +36,29 @@ $evalcode = <<'CODE';
{
my $file = $main::file;
my $srcdir = $main::srcdir;
my $proc;
my($var, $type);
my($dest, $procs);
my $copyvars = sub {
my $dest = shift;
foreach (@_) {
if (eval "defined $_") {
(my $var = $_) =~ s/^(\W)//;
for ($1) {
/\$/ && do { $$dest->{$var} = $$var ; last; };
/\@/ && do { $$dest->{$var} = [ @$var ]; last; };
/\%/ && do { $$dest->{$var} = { %$var }; last; };
}
}
}
};
# Variables to evaluate and insert into the PDB structure
my @procvars = qw($name $group $blurb $help $author $copyright $date
@inargs @outargs %invoke);
# These are attached to the group structure
my @groupvars = qw($desc @headers %extra);
# Hook some variables into the top-level namespace
*pdb = \%main::pdb;
*gen = \%main::gen;
@ -56,14 +71,13 @@ $evalcode = <<'CODE';
&$safeeval("do '$main::srcdir/stddefs.pdb'");
# Group properties
undef $desc; undef $code; undef @headers;
foreach (@groupvars) { eval "undef $_" }
# Load the file in and get the group info
&$safeeval("require '$main::srcdir/pdb/$file.pdb'");
# Save these for later
$grp{$file}->{desc} = $desc if defined $desc;
$grp{$file}->{code} = $code if defined $code;
&$copyvars(\$grp{$file}, @groupvars);
foreach $proc (@procs) {
# Reset all our PDB vars so previous defs don't interfere
@ -78,23 +92,12 @@ $evalcode = <<'CODE';
# Load the info into %pdb, making copies of the data instead of refs
my $entry = {};
foreach (@procvars) {
if (eval "defined $_") {
($var = $_) =~ s/^(\W)//, $type = $1;
for ($type) {
/\$/ && do { $entry->{$var} = $$var ; last; };
/\@/ && do { $entry->{$var} = [ @$var ]; last; };
/\%/ && do { $entry->{$var} = { %$var }; last; };
}
}
}
&$copyvars(\$entry, @procvars);
$pdb{$proc} = $entry;
push @{$entry->{invoke}->{headers}}, @headers if scalar @headers;
}
# Find out what to do with these entries
while (($dest, $procs) = each %exports) { push @{$gen{$dest}}, @$procs }
while (my ($dest, $procs) = each %exports) { push @{$gen{$dest}}, @$procs }
}
CODE