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