243 lines
6.1 KiB
Perl
243 lines
6.1 KiB
Perl
#!/usr/bin/perl -w
|
|
|
|
# PIKA - Photo and Image Kooker Application
|
|
# 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
|
|
$lib_private $skip_gi);
|
|
|
|
# These are attached to the group structure
|
|
my @groupvars = qw($desc $doc_title $doc_short_desc $doc_long_desc
|
|
$lib_private $skip_gi
|
|
@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 Pika::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";
|
|
&{"Pika::CodeGen::${type}::generate"}($gen{$type});
|
|
print "done.\n";
|
|
$didstuff = 1;
|
|
}
|
|
else {
|
|
print "nothing to do.\n";
|
|
}
|
|
}
|
|
|
|
print "\nNothing done at all.\n" unless $didstuff;
|
