1#!/usr/bin/perl -w
2
3# GIMP - The GNU Image Manipulation Program
4# Copyright (C) 1998-2003 Manish Singh <yosh@gimp.org>
5
6# This program is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation; either version 3 of the License, or
9# (at your option) any later version.
10
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14# GNU General Public License for more details.
15
16# You should have received a copy of the GNU General Public License
17# along with this program.  If not, see <https://www.gnu.org/licenses/>.
18
19require 5.004;
20
21BEGIN {
22    $srcdir   = $ENV{srcdir}   || '.';
23    $destdir  = $ENV{destdir}  || '.';
24    $builddir = $ENV{builddir} || '.';
25}
26
27use lib $srcdir;
28
29BEGIN {
30    # Some important stuff
31    require 'pdb.pl';
32    require 'enums.pl';
33    require 'util.pl';
34
35    # What to do?
36    require 'groups.pl';
37
38    if ($ENV{PDBGEN_GROUPS}) {
39	@groups = split(/:/, $ENV{PDBGEN_GROUPS});
40    }
41}
42
43# Stifle "used only once" warnings
44$destdir = $destdir;
45$builddir = $builddir;
46%pdb = ();
47
48# The actual parser (in a string so we can eval it in another namespace)
49$evalcode = <<'CODE';
50{
51    my $file = $main::file;
52    my $srcdir = $main::srcdir;
53
54    my $copyvars = sub {
55	my $dest = shift;
56
57	foreach (@_) {
58	    if (eval "defined scalar $_") {
59		(my $var = $_) =~ s/^(\W)//;
60		 for ($1) {
61		    /\$/ && do { $$dest->{$var} =   $$var  ; last; };
62		    /\@/ && do { $$dest->{$var} = [ @$var ]; last; };
63		    /\%/ && do { $$dest->{$var} = { %$var }; last; };
64		}
65	    }
66	}
67    };
68
69    # Variables to evaluate and insert into the PDB structure
70    my @procvars = qw($name $group $blurb $help $author $copyright $date $since
71		      $deprecated @inargs @outargs %invoke $canonical_name);
72
73    # These are attached to the group structure
74    my @groupvars = qw($desc $doc_title $doc_short_desc $doc_long_desc
75                       @headers %extra);
76
77    # Hook some variables into the top-level namespace
78    *pdb = \%main::pdb;
79    *gen = \%main::gen;
80    *grp = \%main::grp;
81
82    # Hide our globals
83    my $safeeval = sub { local(%pdb, %gen, %grp); eval $_[0]; die $@ if $@ };
84
85    # Some standard shortcuts used by all def files
86    &$safeeval("do '$main::srcdir/stddefs.pdb'");
87
88    # Group properties
89    foreach (@groupvars) { eval "undef $_" }
90
91    # Load the file in and get the group info
92    &$safeeval("require '$main::srcdir/groups/$file.pdb'");
93
94    # Save these for later
95    &$copyvars(\$grp{$file}, @groupvars);
96
97    foreach $proc (@procs) {
98	# Reset all our PDB vars so previous defs don't interfere
99	foreach (@procvars) { eval "undef $_" }
100
101	# Get the info
102	&$safeeval("&$proc");
103
104	# Some derived fields
105	$name = $proc;
106	$group = $file;
107
108	($canonical_name = $name) =~ s/_/-/g;
109
110	# Load the info into %pdb, making copies of the data instead of refs
111	my $entry = {};
112	&$copyvars(\$entry, @procvars);
113	$pdb{$proc} = $entry;
114    }
115
116    # Find out what to do with these entries
117    while (my ($dest, $procs) = each %exports) { push @{$gen{$dest}}, @$procs }
118}
119CODE
120
121# Slurp in the PDB defs
122foreach $file (@groups) {
123    print "Processing $srcdir/groups/$file.pdb...\n";
124    eval "package Gimp::CodeGen::Safe::$file; $evalcode;";
125    die $@ if $@;
126}
127
128# Squash whitespace into just single spaces between words.
129# Single new lines are considered as normal spaces, but n > 1 newlines are considered (n - 1) newlines.
130# The slightly complicated suite of regexp is so that \n\s+\n is still considered a double newline.
131sub trimspace { for (${$_[0]}) { s/(\S)[\ \t\r\f]*\n[\ \t\r\f]*(\S)/$1 $2/g; s/[\ \t\r\f]+/ /gs;
132    s/\n(([\ \t\r\f]*\n)+)/$1/g; s/[\ \t\r\f]*\n[\ \t\r\f]/\n/g ; s/^\s+//; s/\s+$//; } }
133
134# Trim spaces and escape quotes C-style
135sub nicetext {
136    my $val = shift;
137    if (defined $$val) {
138	&trimspace($val);
139	$$val =~ s/"/\\"/g;
140    }
141}
142
143# Do the same for all the strings in the args, plus expand constraint text
144sub niceargs {
145    my $args = shift;
146    foreach $arg (@$args) {
147	foreach (keys %$arg) {
148	    &nicetext(\$arg->{$_});
149	}
150    }
151}
152
153# Trim spaces from all the elements in a list
154sub nicelist {
155    my $list = shift;
156    foreach (@$list) { &trimspace(\$_) }
157}
158
159# Add args for array lengths
160
161sub arrayexpand {
162    my $args = shift;
163    my $newargs;
164
165    foreach (@$$args) {
166	if (exists $_->{array}) {
167	    my $arg = $_->{array};
168
169	    $arg->{name} = 'num_' . $_->{name} unless exists $arg->{name};
170
171	    # We can't have negative lengths, but let them set a min number
172	    unless (exists $arg->{type}) {
173		$arg->{type} = '0 <= int32';
174	    }
175	    elsif ($arg->{type} !~ /^\s*\d+\s*</) {
176		$arg->{type} = '0 <= ' . $arg->{type};
177	    }
178
179	    $arg->{void_ret} = 1 if exists $_->{void_ret};
180
181	    $arg->{num} = 1;
182
183	    push @$newargs, $arg;
184 	}
185
186	push @$newargs, $_;
187    }
188
189    $$args = $newargs;
190}
191
192sub canonicalargs {
193    my $args = shift;
194    foreach $arg (@$args) {
195        ($arg->{canonical_name} = $arg->{name}) =~ s/_/-/g;
196    }
197}
198
199# Post-process each pdb entry
200while ((undef, $entry) = each %pdb) {
201    &nicetext(\$entry->{blurb});
202    &nicetext(\$entry->{help});
203    &nicetext(\$entry->{author});
204    &nicetext(\$entry->{copyright});
205    &nicetext(\$entry->{date});
206
207    foreach (qw(in out)) {
208	my $args = $_ . 'args';
209	if (exists $entry->{$args}) {
210	    &arrayexpand(\$entry->{$args});
211    	    &niceargs($entry->{$args});
212	    &canonicalargs($entry->{$args});
213	}
214    }
215
216    &nicelist($entry->{invoke}{headers}) if exists $entry->{invoke}{headers};
217    &nicelist($entry->{globals}) if exists $entry->{globals};
218
219    $entry->{invoke}{success} = 'TRUE' unless exists $entry->{invoke}{success};
220}
221
222# Generate code from the modules
223my $didstuff;
224while (@ARGV) {
225    my $type = shift @ARGV;
226
227    print "\nProcessing $type...\n";
228
229    if (exists $gen{$type}) {
230	require "$type.pl";
231	&{"Gimp::CodeGen::${type}::generate"}($gen{$type});
232	print "done.\n";
233	$didstuff = 1;
234    }
235    else {
236	print "nothing to do.\n";
237    }
238}
239
240print "\nNothing done at all.\n" unless $didstuff;
241