Adding upstream version 2.10.36.upstream/2.10.36

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 240 insertions, 0 deletions

diff --git a/pdb/pdbgen.pl b/pdb/pdbgen.pl
new file mode 100755
index 0000000..30288d4
--- /dev/null
+++ b/pdb/pdbgen.pl
@@ -0,0 +1,240 @@
+#!/usr/bin/perl -w
+
+# GIMP - The GNU Image Manipulation Program
+# Copyright (C) 1998-2003 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 3 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, see <https://www.gnu.org/licenses/>.
+
+require 5.004;
+
+BEGIN {
+    $srcdir   = $ENV{srcdir}   || '.';
+    $destdir  = $ENV{destdir}  || '.';
+    $builddir = $ENV{builddir} || '.';
+}
+
+use lib $srcdir;
+
+BEGIN {
+    # Some important stuff
+    require 'pdb.pl';
+    require 'enums.pl';
+    require 'util.pl';
+
+    # What to do?
+    require 'groups.pl';
+
+    if ($ENV{PDBGEN_GROUPS}) {
+	@groups = split(/:/, $ENV{PDBGEN_GROUPS});
+    }
+}
+
+# Stifle "used only once" warnings
+$destdir = $destdir;
+$builddir = $builddir;
+%pdb = ();
+
+# The actual parser (in a string so we can eval it in another namespace)
+$evalcode = <<'CODE';
+{
+    my $file = $main::file;
+    my $srcdir = $main::srcdir;
+
+    my $copyvars = sub {
+	my $dest = shift;
+
+	foreach (@_) {
+	    if (eval "defined scalar $_") {
+		(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 $since
+		      $deprecated @inargs @outargs %invoke $canonical_name);
+
+    # These are attached to the group structure
+    my @groupvars = qw($desc $doc_title $doc_short_desc $doc_long_desc
+                       @headers %extra);
+
+    # Hook some variables into the top-level namespace
+    *pdb = \%main::pdb;
+    *gen = \%main::gen;
+    *grp = \%main::grp;
+
+    # Hide our globals
+    my $safeeval = sub { local(%pdb, %gen, %grp); eval $_[0]; die $@ if $@ };
+
+    # Some standard shortcuts used by all def files
+    &$safeeval("do '$main::srcdir/stddefs.pdb'");
+
+    # Group properties
+    foreach (@groupvars) { eval "undef $_" }
+
+    # Load the file in and get the group info
+    &$safeeval("require '$main::srcdir/groups/$file.pdb'");
+
+    # Save these for later
+    &$copyvars(\$grp{$file}, @groupvars);
+
+    foreach $proc (@procs) {
+	# Reset all our PDB vars so previous defs don't interfere
+	foreach (@procvars) { eval "undef $_" }
+
+	# Get the info
+	&$safeeval("&$proc");
+
+	# Some derived fields
+	$name = $proc;
+	$group = $file;
+
+	($canonical_name = $name) =~ s/_/-/g;
+
+	# Load the info into %pdb, making copies of the data instead of refs
+	my $entry = {};
+	&$copyvars(\$entry, @procvars);
+	$pdb{$proc} = $entry;
+    }
+
+    # Find out what to do with these entries 
+    while (my ($dest, $procs) = each %exports) { push @{$gen{$dest}}, @$procs }
+}
+CODE
+
+# Slurp in the PDB defs
+foreach $file (@groups) {
+    print "Processing $srcdir/groups/$file.pdb...\n";
+    eval "package Gimp::CodeGen::Safe::$file; $evalcode;";
+    die $@ if $@;
+}
+
+# Squash whitespace into just single spaces between words.
+# Single new lines are considered as normal spaces, but n > 1 newlines are considered (n - 1) newlines.
+# The slightly complicated suite of regexp is so that \n\s+\n is still considered a double newline.
+sub trimspace { for (${$_[0]}) { s/(\S)[\ \t\r\f]*\n[\ \t\r\f]*(\S)/$1 $2/g; s/[\ \t\r\f]+/ /gs;
+    s/\n(([\ \t\r\f]*\n)+)/$1/g; s/[\ \t\r\f]*\n[\ \t\r\f]/\n/g ; s/^\s+//; s/\s+$//; } }
+
+# Trim spaces and escape quotes C-style
+sub nicetext {
+    my $val = shift;
+    if (defined $$val) {
+	&trimspace($val);
+	$$val =~ s/"/\\"/g;
+    }
+}
+
+# Do the same for all the strings in the args, plus expand constraint text
+sub niceargs {
+    my $args = shift;
+    foreach $arg (@$args) {
+	foreach (keys %$arg) {
+	    &nicetext(\$arg->{$_});
+	}
+    }
+}
+
+# Trim spaces from all the elements in a list
+sub nicelist {
+    my $list = shift;
+    foreach (@$list) { &trimspace(\$_) }
+}
+
+# Add args for array lengths
+
+sub arrayexpand {
+    my $args = shift;
+    my $newargs;
+
+    foreach (@$$args) {
+	if (exists $_->{array}) {
+	    my $arg = $_->{array};
+
+	    $arg->{name} = 'num_' . $_->{name} unless exists $arg->{name};
+
+	    # We can't have negative lengths, but let them set a min number
+	    unless (exists $arg->{type}) {
+		$arg->{type} = '0 <= int32';
+	    }
+	    elsif ($arg->{type} !~ /^\s*\d+\s*</) {
+		$arg->{type} = '0 <= ' . $arg->{type};
+	    }
+
+	    $arg->{void_ret} = 1 if exists $_->{void_ret};
+
+	    $arg->{num} = 1;
+
+	    push @$newargs, $arg;
+ 	}
+
+	push @$newargs, $_;
+    }
+
+    $$args = $newargs;
+}
+
+sub canonicalargs {
+    my $args = shift;
+    foreach $arg (@$args) {
+        ($arg->{canonical_name} = $arg->{name}) =~ s/_/-/g;
+    }
+}
+
+# Post-process each pdb entry
+while ((undef, $entry) = each %pdb) {
+    &nicetext(\$entry->{blurb});
+    &nicetext(\$entry->{help});
+    &nicetext(\$entry->{author});
+    &nicetext(\$entry->{copyright});
+    &nicetext(\$entry->{date});
+
+    foreach (qw(in out)) {
+	my $args = $_ . 'args';
+	if (exists $entry->{$args}) {
+	    &arrayexpand(\$entry->{$args});
+    	    &niceargs($entry->{$args});
+	    &canonicalargs($entry->{$args});
+	}
+    }
+
+    &nicelist($entry->{invoke}{headers}) if exists $entry->{invoke}{headers};
+    &nicelist($entry->{globals}) if exists $entry->{globals};
+
+    $entry->{invoke}{success} = 'TRUE' unless exists $entry->{invoke}{success};
+}
+
+# Generate code from the modules
+my $didstuff;
+while (@ARGV) {
+    my $type = shift @ARGV;
+
+    print "\nProcessing $type...\n";
+
+    if (exists $gen{$type}) {
+	require "$type.pl";
+	&{"Gimp::CodeGen::${type}::generate"}($gen{$type});
+	print "done.\n";
+	$didstuff = 1;
+    }
+    else {
+	print "nothing to do.\n";
+    }
+}
+
+print "\nNothing done at all.\n" unless $didstuff;