#!/usr/bin/perl | |
## | |
## Copyright (C) 2003-2007, Marcelo E. Magallon <mmagallo[]debian org> | |
## Copyright (C) 2003-2007, Milan Ikits <milan ikits[]ieee org> | |
## | |
## This program is distributed under the terms and conditions of the GNU | |
## General Public License Version 2 as published by the Free Software | |
## Foundation or, at your option, any later version. | |
use strict; | |
use warnings; | |
sub compile_regex | |
{ | |
my $regex = join('', @_); | |
return qr/$regex/ | |
} | |
my @sections = ( | |
"Name", | |
"Name Strings?", | |
"New Procedures and Functions", | |
"New Tokens", | |
); | |
my %typemap = ( | |
bitfield => "GLbitfield", | |
boolean => "GLboolean", | |
# fsck up in EXT_vertex_array | |
Boolean => "GLboolean", | |
byte => "GLbyte", | |
clampd => "GLclampd", | |
clampf => "GLclampf", | |
double => "GLdouble", | |
enum => "GLenum", | |
# Intel fsck up | |
Glenum => "GLenum", | |
float => "GLfloat", | |
half => "GLhalf", | |
int => "GLint", | |
short => "GLshort", | |
sizei => "GLsizei", | |
ubyte => "GLubyte", | |
uint => "GLuint", | |
ushort => "GLushort", | |
DMbuffer => "void *", | |
# ARB VBO introduces these. | |
sizeiptrARB => "GLsizeiptrARB", | |
intptrARB => "GLintptrARB", | |
# ARB shader objects introduces these, charARB is at least 8 bits, | |
# handleARB is at least 32 bits | |
charARB => "GLcharARB", | |
handleARB => "GLhandleARB", | |
# GLX 1.3 defines new types which might not be available at compile time | |
#GLXFBConfig => "void*", | |
#GLXFBConfigID => "XID", | |
#GLXContextID => "XID", | |
#GLXWindow => "XID", | |
#GLXPbuffer => "XID", | |
# Weird stuff to some SGIX extension | |
#GLXFBConfigSGIX => "void*", | |
#GLXFBConfigIDSGIX => "XID", | |
); | |
my %voidtypemap = ( | |
void => "GLvoid", | |
); | |
my %taboo_tokens = ( | |
GL_ZERO => 1, | |
); | |
# list of function definitions to be ignored, unless they are being defined in | |
# the given spec. This is an ugly hack arround the fact that people writing | |
# spec files seem to shut down all brain activity while they are at this task. | |
# | |
# This will be moved to its own file eventually. | |
# | |
# (mem, 2003-03-19) | |
my %fnc_ignore_list = ( | |
"BindProgramARB" => "ARB_vertex_program", | |
"ColorSubTableEXT" => "EXT_color_subtable", | |
"DeleteProgramsARB" => "ARB_vertex_program", | |
"GenProgramsARB" => "ARB_vertex_program", | |
"GetProgramEnvParameterdvARB" => "ARB_vertex_program", | |
"GetProgramEnvParameterfvARB" => "ARB_vertex_program", | |
"GetProgramLocalParameterdvARB" => "ARB_vertex_program", | |
"GetProgramLocalParameterfvARB" => "ARB_vertex_program", | |
"GetProgramStringARB" => "ARB_vertex_program", | |
"GetProgramivARB" => "ARB_vertex_program", | |
"IsProgramARB" => "ARB_vertex_program", | |
"ProgramEnvParameter4dARB" => "ARB_vertex_program", | |
"ProgramEnvParameter4dvARB" => "ARB_vertex_program", | |
"ProgramEnvParameter4fARB" => "ARB_vertex_program", | |
"ProgramEnvParameter4fvARB" => "ARB_vertex_program", | |
"ProgramLocalParameter4dARB" => "ARB_vertex_program", | |
"ProgramLocalParameter4dvARB" => "ARB_vertex_program", | |
"ProgramLocalParameter4fARB" => "ARB_vertex_program", | |
"ProgramLocalParameter4fvARB" => "ARB_vertex_program", | |
"ProgramStringARB" => "ARB_vertex_program", | |
); | |
my %regex = ( | |
eofnc => qr/(?:\);?$|^$)/, # )$ | );$ | ^$ | |
extname => qr/^[A-Z][A-Za-z0-9_]+$/, | |
function => qr/^(.+) ([a-z][a-z0-9_]*) \((.+)\)$/i, | |
prefix => qr/^(?:[aw]?gl|glX)/, # gl | agl | wgl | glX | |
tprefix => qr/^(?:[AW]?GL|GLX)_/, # GL_ | AGL_ | WGL_ | GLX_ | |
section => compile_regex('^(', join('|', @sections), ')$'), # sections in spec | |
token => qr/^([A-Z0-9][A-Z0-9_]*):?\s+((?:0x)?[0-9A-F]+)(.*)$/, # define tokens | |
types => compile_regex('\b(', join('|', keys %typemap), ')\b'), # var types | |
voidtype => compile_regex('\b(', keys %voidtypemap, ')\b '), # void type | |
); | |
# reshapes the the function declaration from multiline to single line form | |
sub normalize_prototype | |
{ | |
local $_ = join(" ", @_); | |
s/\s+/ /g; # multiple whitespace -> single space | |
s/\s*\(\s*/ \(/; # exactly one space before ( and none after | |
s/\s*\)\s*/\)/; # no after before or after ) | |
s/\s*\*([a-zA-Z])/\* $1/; # "* identifier" | |
s/\*wgl/\* wgl/; # "* wgl" | |
s/\*glX/\* glX/; # "* glX" | |
s/\.\.\./void/; # ... -> void | |
s/;$//; # remove ; at the end of the line | |
return $_; | |
} | |
# Ugly hack to work arround the fact that functions are declared in more | |
# than one spec file. | |
sub ignore_function($$) | |
{ | |
return exists($fnc_ignore_list{$_[0]}) && $fnc_ignore_list{$_[0]} ne $_[1] | |
} | |
sub parse_spec($) | |
{ | |
my $filename = shift; | |
my $extname = ""; | |
my $vendortag = ""; | |
my @extnames = (); | |
my %functions = (); | |
my %tokens = (); | |
my $section = ""; | |
my @fnc = (); | |
my %proc = ( | |
"Name" => sub { | |
if (/^([a-z0-9]+)_([a-z0-9_]+)/i) | |
{ | |
$extname = "$1_$2"; | |
$vendortag = $1; | |
} | |
}, | |
"Name Strings" => sub { | |
# Add extension name to extension list | |
# Does this look even plausible? | |
if (/$regex{extname}/) | |
{ | |
# prefix with "GL_" if prefix not present | |
s/^/GL_/ unless /$regex{tprefix}/o; | |
# Add extension name to extension list | |
push @extnames, $_; | |
} | |
}, | |
"New Procedures and Functions" => sub { | |
# if line matches end of function | |
if (/$regex{eofnc}/) | |
{ | |
# add line to function declaration | |
push @fnc, $_; | |
# if normalized version of function looks like a function | |
if (normalize_prototype(@fnc) =~ /$regex{function}/) | |
{ | |
# get return type, name, and arguments from regex | |
my ($return, $name, $parms) = ($1, $2, $3); | |
if (!ignore_function($name, $extname)) | |
{ | |
# prefix with "gl" if prefix not present | |
$name =~ s/^/gl/ unless $name =~ /$regex{prefix}/; | |
# is this a pure GL function? | |
if ($name =~ /^gl/ && $name !~ /^glX/) | |
{ | |
# apply typemaps | |
$return =~ s/$regex{types}/$typemap{$1}/og; | |
$return =~ s/void\*/GLvoid */og; | |
$parms =~ s/$regex{types}/$typemap{$1}/og; | |
$parms =~ s/$regex{voidtype}/$voidtypemap{$1}/og; | |
} | |
# add to functions hash | |
$functions{$name} = { | |
rtype => $return, | |
parms => $parms, | |
}; | |
} | |
} | |
# reset function declaration | |
@fnc = (); | |
} elsif ($_ ne "" and $_ ne "None") { | |
# if not eof, add line to function declaration | |
push @fnc, $_ | |
} | |
}, | |
"New Tokens" => sub { | |
if (/$regex{token}/) | |
{ | |
my ($name, $value) = ($1, $2); | |
# prefix with "GL_" if prefix not present | |
$name =~ s/^/GL_/ unless $name =~ /$regex{tprefix}/; | |
# Add (name, value) pair to tokens hash, unless it's taboo | |
$tokens{$name} = $value unless exists $taboo_tokens{$name}; | |
} | |
}, | |
); | |
# Some people can't read, the template clearly says "Name String_s_" | |
$proc{"Name String"} = $proc{"Name Strings"}; | |
# Open spec file | |
open SPEC, "<$filename" or return; | |
# For each line of SPEC | |
while(<SPEC>) | |
{ | |
# Delete trailing newline character | |
chomp; | |
# Remove trailing white spaces | |
s/\s+$//; | |
# If starts with a capital letter, it must be a new section | |
if (/^[A-Z]/) | |
{ | |
# Match section name with one of the predefined names | |
$section = /$regex{section}/o ? $1 : "default"; | |
} else { | |
# Line is internal to a section | |
# Remove leading whitespace | |
s/^\s+//; | |
# Call appropriate section processing function if it exists | |
&{$proc{$section}} if exists $proc{$section}; | |
} | |
} | |
close SPEC; | |
return ($extname, \@extnames, \%tokens, \%functions); | |
} | |
#---------------------------------------------------------------------------------------- | |
my @speclist = (); | |
my %extensions = (); | |
my $ext_dir = shift; | |
my $reg_http = "http://oss.sgi.com/projects/ogl-sample/"; | |
# Take command line arguments or read list from file | |
if (@ARGV) | |
{ | |
@speclist = @ARGV; | |
} else { | |
local $/; #??? | |
@speclist = split "\n", (<>); | |
} | |
foreach my $spec (sort @speclist) | |
{ | |
my ($extname, $extnames, $tokens, $functions) = parse_spec($spec); | |
foreach my $ext (@{$extnames}) | |
{ | |
my $info = "$ext_dir/" . $ext; | |
open EXT, ">$info"; | |
print EXT $ext . "\n"; | |
print EXT $reg_http . $spec . "\n"; | |
my $prefix = $ext; | |
$prefix =~ s/^(.+?)(_.+)$/$1/; | |
foreach my $token (sort { hex ${$tokens}{$a} <=> hex ${$tokens}{$b} } keys %{$tokens}) | |
{ | |
if ($token =~ /^$prefix\_.*/i) | |
{ | |
print EXT "\t" . $token . " " . ${%{$tokens}}{$token} . "\n"; | |
} | |
} | |
foreach my $function (sort keys %{$functions}) | |
{ | |
if ($function =~ /^$prefix.*/i) | |
{ | |
print EXT "\t" . ${$functions}{$function}{rtype} . " " . $function . " (" . ${$functions}{$function}{parms} . ")" . "\n"; | |
} | |
} | |
close EXT; | |
} | |
} |