Commit 2041fe60 authored by Manish Singh's avatar Manish Singh

PDB autogen stuff. Unfinished and undocumented

-Yosh
parent 669c2b22
Some proto-PDB code generation stuff lives here. More docs to come. For now,
don't mess with it.
-Yosh
# The GIMP -- an image manipulation program
# Copyright (C) 1998 Manish Singh <yosh@gimp.org>
# 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.
package Gimp::CodeGen::app;
$destdir = "$main::destdir/app";
*arg_types = \%Gimp::CodeGen::pdb::arg_types;
*arg_parse = \&Gimp::CodeGen::pdb::arg_parse;
*arg_ptype = \&Gimp::CodeGen::pdb::arg_ptype;
*arg_vname = \&Gimp::CodeGen::pdb::arg_vname;
*write_file = \&Gimp::CodeGen::util::write_file;
sub declare_args {
my $proc = shift;
my $out = shift;
my $result = "";
foreach (@_) {
my @args = @{$proc->{$_}} if exists $proc->{$_};
foreach (@args) {
my $arg = $arg_types{(&arg_parse($_->{type}))[0]};
if (not exists $_->{no_declare}) {
$result .= ' ' x 2;
$result .= $arg->{type} . &arg_vname($_) . ";\n";
if (exists $arg->{id_headers}) {
foreach (@{$arg->{id_headers}}) {
$out->{headers}->{$_}++;
}
}
}
}
}
$result;
}
sub make_args {
my $proc = shift;
my $result = "";
my $once;
foreach (@_) {
my @args = @{$proc->{$_}} if exists $proc->{$_};
if (scalar @args) {
$result .= "\nstatic ProcArg $proc->{name}_${_}[] =";
$result .= "\n{\n";
foreach my $arg (@{$proc->{$_}}) {
my ($type) = &arg_parse($arg->{type});
$result .= ' ' x 2 . "{\n";
$result .= ' ' x 4;
$result .= 'PDB_' . $arg_types{$type}->{name} . ",\n";
$result .= ' ' x 4;
$result .= qq/"$arg->{name}",\n/;
$result .= ' ' x 4;
$result .= qq/"$arg->{desc}"\n/;
$result .= ' ' x 2 . "},\n";
}
$result =~ s/,\n$/\n/;
$result .= "};\n";
}
}
$result;
}
sub marshal_inargs {
my $proc = shift;
my $result = "";
my %decls;
my $argc = 0;
my @inargs = @{$proc->{inargs}} if exists $proc->{inargs};
foreach (@inargs) {
my($pdbtype, @typeinfo) = &arg_parse($_->{type});
my $arg = $arg_types{$pdbtype};
my $type = &arg_ptype($arg);
my $var = &arg_vname($_);
$result .= ' ' x 2;
$result .= "if (success)\n" . ' ' x 4 if $success;
if (exists $arg->{id_func}) {
$decls{$type}++;
$result .= "{\n" . ' ' x 6 if $success;
$result .= "${type}_value = args[$argc].value.pdb_$type;\n";
$result .= ' ' x 4 if $success;
$result .= ' ' x 2;
$result .= "if (($var = ";
$result .= "$arg->{id_func} (${type}_value)) == NULL)\n";
$result .= ' ' x 4 unless $success;
$result .= "\t" if $success;
$result .= "success = FALSE;\n";
$result .= ' ' x 4 . "}\n" if $success;
$success = 1;
}
else {
if ($pdbtype eq 'enum') {
# FIXME: implement this
}
elsif ($pdbtype eq 'boolean') {
$result .= "$var = ";
$result .= "(args[$argc].value.pdb_$type) ? TRUE : FALSE;\n";
}
elsif (defined $typeinfo[0] || defined $typeinfo[2]) {
my $tests = 0;
$result .= "success = (";
if (defined $typeinfo[0]) {
$result .= "$var $typeinfo[1] $typeinfo[0]";
$tests++;
}
if (defined $typeinfo[2]) {
$result .= '|| ' if $tests;
$result .= "$var $typeinfo[2] $typeinfo[3]";
}
$result .= ");\n";
}
else {
my $cast = "";
$cast = " ($arg->{type})" if $type eq "pointer";
$cast = " ($arg->{type})" if $arg->{type} =~ /int(16|8)$/;
$result .= "$var =$cast args[$argc].value.pdb_$type;\n";
}
}
$argc++; $result .= "\n";
}
chomp $result if !$success && $argc == 1;
my $decls;
foreach (keys %decls) { $decls .= ' ' x 2 . "$_ ${_}_value;\n" }
$result = $decls . "\n" . $result if $decls;
$result and $result = "\n" . $result unless $decls;
$result;
}
sub marshal_outargs {
my $proc = shift;
my $result = <<CODE;
return_args = procedural_db_return_args (\&$proc->{name}_proc, success);
CODE
my $argc = 0;
my @outargs = @{$proc->{outargs}} if exists $proc->{outargs};
if (scalar @outargs) {
my $outargs = "";
foreach (@{$proc->{outargs}}) {
my ($pdbtype) = &arg_parse($_->{type});
my $arg = $arg_types{$pdbtype};
my $type = &arg_ptype($arg);
my $var = &arg_vname($_);
$argc++; $outargs .= ' ' x 2;
if (exists $arg->{id_ret_func}) {
$outargs .= "return_args[$argc].value.pdb_$type = ";
$outargs .= eval qq/"$arg->{id_ret_func}"/;
$outargs .= ";\n";
}
else {
$outargs .= "return_args[$argc].value.pdb_$type = $var;\n";
}
}
$outargs =~ s/^/' ' x 2/meg if $success;
$outargs =~ s/^/' ' x 2/meg if $success && $argc > 1;
$result .= "\n" if $success || $argc > 1;
$result .= ' ' x 2 . "if (success)\n" if $success;
$result .= ' ' x 4 . "{\n" if $success && $argc > 1;
$result .= $outargs;
$result .= ' ' x 4 . "}\n" if $success && $argc > 1;
$result .= "\n" . ' ' x 2 . "return return_args;\n";
}
else {
$result =~ s/_args =//;
}
$result =~ s/, success\);$/, TRUE);/m unless $success;
$result;
}
sub generate {
my @procs = @{(shift)};
my %out;
my $total = 0.0;
foreach my $name (@procs) {
my $proc = $main::pdb{$name};
my $out = \%{$out{$proc->{group}}};
my @inargs = @{$proc->{inargs}} if exists $proc->{inargs};
my @outargs = @{$proc->{outargs}} if exists $proc->{outargs};
local $success = 0;
$out->{pcount}++; $total++;
$out->{procs} .= "static ProcRecord ${name}_proc;\n";
$out->{register} .= <<CODE;
procedural_db_register (\&${name}_proc);
CODE
if (exists $proc->{invoke}->{headers}) {
foreach my $header (@{$proc->{invoke}->{headers}}) {
$out->{headers}->{$header}++;
}
}
$out->{headers}->{q/"procedural_db.h"/}++;
$out->{code} .= "\nstatic Argument *\n";
$out->{code} .= "${name}_invoker (Argument *args)\n{\n";
my $invoker = "";
$invoker .= ' ' x 2 . "Argument *return_args;\n" if scalar @outargs;
$invoker .= &declare_args($proc, $out, qw(inargs outargs));
if (exists $proc->{invoke}->{vars}) {
foreach (@{$proc->{invoke}->{vars}}) {
$invoker .= ' ' x 2 . $_ . ";\n";
}
}
$invoker.= &marshal_inargs($proc);
$invoker .= "\n" if $invoker && $invoker !~ /\n\n/s;
my $code = $proc->{invoke}->{code};
chomp $code;
$code =~ s/\t/' ' x 8/eg;
if ($code =~ /^\s*\{\s*\n.*\n\s*\}\s*$/s && !$success) {
$code =~ s/^\s*\{\s*\n//s;
$code =~ s/\n\s*}\s*$//s;
}
else {
$code =~ s/^/' ' x 2/meg;
$code =~ s/^/' ' x 2/meg if $success;
}
$code =~ s/^ {8}/\t/mg;
$code = ' ' x 2 . "if (success)\n" . $code if $success;
$success = ($code =~ /success =/) unless $success;
$out->{code} .= ' ' x 2 . "int success = TRUE;\n" if $success;
$out->{code} .= $invoker . $code . "\n";
$out->{code} .= "\n" if $code =~ /\n/s || $invoker;
$out->{code} .= &marshal_outargs($proc) . "}\n";
$out->{code} .= &make_args($proc, qw(inargs outargs));
$out->{code} .= <<CODE;
static ProcRecord ${name}_proc =
{
"gimp_$name",
"$proc->{blurb}",
"$proc->{help}",
"$proc->{author}",
"$proc->{copyright}",
"$proc->{date}",
PDB_INTERNAL,
@{[scalar @inargs or '0']},
@{[scalar @inargs ? "${name}_inargs" : 'NULL']},
@{[scalar @outargs or '0']},
@{[scalar @outargs ? "${name}_outargs" : 'NULL']},
{ { ${name}_invoker } }
};
CODE
}
my $gpl = <<'GPL';
/* 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.
*/
GPL
my $internal = "$destdir/internal_procs.h.tmp.$$";
open INTERNAL, "> $internal" or die "Can't open $cmdfile: $!\n";
print INTERNAL $gpl;
my $guard = "__INTERNAL_PROCS_H__";
print INTERNAL <<HEADER;
#ifndef $guard
#define $guard
void internal_procs_init (void);
#endif /* $guard */
HEADER
close INTERNAL;
&write_file($internal);
my $group_procs = ""; my $longest = 0;
my $once = 0; my $pcount = 0.0;
foreach $group (@main::groups) {
my $out = $out{$group};
my $cfile = "$destdir/${group}_cmds.c.tmp.$$";
open CFILE, "> $cfile" or die "Can't open $cmdfile: $!\n";
print CFILE $gpl;
foreach my $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 $out->{procs};
print CFILE "\nvoid\nregister_${group}_procs (void)\n";
print CFILE "{\n$out->{register}}\n";
print CFILE $out->{code};
close CFILE;
&write_file($cfile);
my $decl = "register_${group}_procs";
push @group_decls, $decl;
$longest = length $decl if $longest < length $decl;
$group_procs .= ' ' x 2 . "app_init_update_status (";
$group_procs .= q/"Internal Procedures"/ unless $once;
$group_procs .= 'NULL' if $once++;
$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";
$pcount += $out->{pcount};
}
$internal = "$destdir/internal_procs.c.tmp.$$";
open INTERNAL, "> $internal" or die "Can't open $cmdfile: $!\n";
print INTERNAL $gpl;
print INTERNAL qq/#include "app_procs.h"\n\n/;
print INTERNAL "/* Forward declarations for registering PDB procs */\n\n";
foreach (@group_decls) {
print INTERNAL "void $_" . ' ' x ($longest - length $_) . " (void);\n";
}
chop $group_procs;
print INTERNAL "\n/* $total total procedures registered total */\n\n";
print INTERNAL "void\ninternal_procs_init (void)\n{\n$group_procs}\n";
close INTERNAL;
&write_file($internal);
}
1;
# The GIMP -- an image manipulation program
# Copyright (C) 1998 Manish Singh <yosh@gimp.org>
# 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.
# Modify this list for the groups to parse in the pdb directory
@groups = qw(gdisplay edit floating_sel undo palette gradients convert
channel_ops);
# The GIMP -- an image manipulation program
# Copyright (C) 1998 Manish Singh <yosh@gimp.org>
# 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.
package Gimp::CodeGen::lib;
# Generates all the libgimp C wrappers (used by plugins)
$destdir = "$main::destdir/libgimp";
*arg_types = \%Gimp::CodeGen::pdb::arg_types;
*arg_parse = \&Gimp::CodeGen::pdb::arg_parse;
*write_file = \&Gimp::CodeGen::util::write_file;
sub generate {
my @procs = @{(shift)};
my %out;
foreach my $name (@procs) {
my $proc = $main::pdb{$name};
my $out = \%{$out{$proc->{group}}};
my @inargs = @{$proc->{inargs}} if exists $proc->{inargs};
my @outargs = @{$proc->{outargs}} if exists $proc->{outargs};
# The 'color' argument is special cased to accept and return the
# individual color components. This is to maintain backwards
# compatibility, but it certainly won't fly for other color models
# It also makes the code a bit messier.
# Find the return argument (defaults to the first arg if not
# explicity set
my $retarg;
foreach (@outargs) { $retarg = $_, last if exists $_->{retval} }
scalar @outargs and $retarg = $outargs[0] unless $retarg;
my $rettype; my $retcol = 0;
if ($retarg) {
my ($type) = &arg_parse($retarg->{type});
if ($type ne 'color') {
my $arg = $arg_types{$type};
$rettype = do {
if (exists $arg->{id_func}) { 'gint32 ' }
else { $arg->{type} }
};
chop $rettype unless $rettype =~ /\*$/;
}
else {
# Color returns three components in pointers passed in
$rettype = 'void'; $retcol = 1;
}
}
else {
# No return values
$rettype = 'void';
}
# The parameters to the function
my $arglist = ""; my $argpass = ""; my $color = "";
foreach (@inargs) {
my ($type) = &arg_parse($_->{type});
my $arg = $arg_types{$type};
my $id = exists $arg->{id_func};
if ($type ne 'color') {
$arglist .= do {
if ($id) { 'gint32 ' }
else { $arg->{type} }
};
$arglist .= $_->{name};
$arglist .= '_ID' if $id;
$arglist .= ', ';
}
else {
# A color needs to stick the components into a 3-element array
$color = "\n" . ' ' x 2 . "guchar $_->{name}\[3];\n\n";
$color .= ' ' x 2 . "$_->{name}\[0] = red;\n";
$color .= ' ' x 2 . "$_->{name}\[1] = green;\n";
$color .= ' ' x 2 . "$_->{name}\[2] = blue;";
$arglist .= "guchar red, guchar green, guchar blue, ";
}
# This is what's passed into gimp_run_procedure
$argpass .= "\n\t\t\t\t" . ' ' x 4;
$argpass .= "PARAM_$arg->{name}, $_->{name}";
$argpass .= '_ID' if $id;
$argpass .= ',';
}
# This marshals the return value(s)
my $return_args = "";
my $return_marshal;
$return_marshal = "gimp_destroy_params (return_vals, nreturn_vals);";
# We only need to bother with this if we have to return a value
if ($rettype ne 'void' || $retcol) {
my $argc = 1; my $once = 0;
my $firstvar;
foreach (@outargs) {
my ($type) = &arg_parse($_->{type});
my $arg = $arg_types{$type};
my $id = $arg->{id_ret_func};
my $var;
$return_marshal = "" unless $once++;
if ($type ne 'color') {
$return_args .= "\n" . ' ' x 2;
$return_args .= do {
if ($id) { 'gint32 ' }
else { $arg->{type} }
};
# The return value variable
$var = $_->{name};
$var .= '_ID' if $id;
$return_args .= $var;
# Save the first var to "return" it
$firstvar = $var unless defined $firstvar;
# Initialize all IDs to -1
$return_args .= " = -1" if $id;
$return_args .= ";";
}
$return_marshal .= <<CODE;
if (return_vals[0].data.d_status == STATUS_SUCCESS)
CODE
if ($type ne 'color') {
$return_marshal .= ' ' x 4 . "$var = ";
$return_marshal .= 'g_strdup (' if $type eq 'string';
$return_marshal .= "return_vals[$argc].data.d_$type"
$return_marshal .= ')' if $type eq 'string';
$return_marshal .= ";\n";
}
else {
# Colors are returned in parts using pointers
$arglist .= "guchar \*red, guchar \*green, guchar \*blue";
$return_marshal .= <<CODE
{
\*red = return_vals[$argc].data.d_color.red;
\*green = return_vals[$argc].data.d_color.green;
\*blue = return_vals[$argc].data.d_color.blue;
}
CODE
}
$argc++;
}
$return_marshal .= <<'CODE';
gimp_destroy_params (return_vals, nreturn_vals);
CODE
$return_marshal .= ' ' x 2 . "return $firstvar;" unless $retcol;
$return_marshal =~ s/\n\n$//s if $retcol;
}
if ($arglist) {
# We don't need the last comma in the declaration
$arglist =~ s/, $//;
}
# Our function prototype for the headers
push @{$out->{proto}}, "$rettype gimp_$name ($arglist);\n";
$out->{code} .= <<CODE;
$rettype
gimp_$name ($arglist)
{
GParam *return_vals;
int nreturn_vals;$return_args$color
return_vals = gimp_run_procedure ("gimp_$name",
\&nreturn_vals,$argpass
PARAM_END);
$return_marshal
}
CODE
}
my $lgpl = <<'LGPL';
/* LIBGIMP - The GIMP Library
* Copyright (C) 1995-1997 Peter Mattis and Spencer Kimball
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Library General Public
* License as published by the Free Software Foundation; either
* version 2 of the License, or (at your option) any later version.
*
* This library 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
* Library General Public License for more details.
*
* You should have received a copy of the GNU Library General Public
* License along with this library; if not, write to the
* Free Software Foundation, Inc., 59 Temple Place - Suite 330,
* Boston, MA 02111-1307, USA.
*/
LGPL
# We generate two files, a .h file with prototypes for all the functions
# we make, and a .c file for the actual implementation
while (my($group, $out) = each %out) {
my $hfile = "$destdir/gimp${group}.h.tmp.$$";
my $cfile = "$destdir/gimp${group}.c.tmp.$$";
my $protos;
foreach (@{$out->{proto}}) { $protos .= $_ }
chop $protos;
open HFILE, "> $hfile" or die "Can't open $cfile: $!\n";
print HFILE $lgpl;
my $guard = "__GIMP_@{[uc $group]}_H__";
print HFILE <<HEADER;
#ifndef $guard
#define $guard
#include <glib.h>
#include <libgimp/gimpprocs.h>
#ifdef __cplusplus
extern "C" {
#endif /* __cplusplus */
$protos
#ifdef __cplusplus
}
#endif /* __cplusplus */
#endif /* $guard */
HEADER
close HFILE;
&write_file($hfile);