# This program looks at the OpenGL installation as defined in perldl.conf
# when the Makefile is built.
# and builds the perl pdl interface based on the information found therein
# It preprocesses the include files with the cpp to try to get the prototypes
# as they are defined for the machine architecture. Bits of this code can be
# traced back to OpenGL-0.4, Tk, and many others who came before.
#
# Jim Edwards 7/18/2000
#
#
# Notes assembled 19-Aug-2004, CED:
# What a crock! Krufty and klever but oh-so-open-loop.
# The general flow: (remember, .pd files like this one get executed to create
# appropriate .xs files):
# - Find "gl.h", "glu.h", and "glx.h" in the appropriate /usr/include
# type directory
# - Preprocess them to remove extraneous "API" phrase at the beginning
# of each function declaration
# - Run them through cpp to get honest-to-Bog function declarations
# - Parse the function declarations to determine how to declare each
# function in the XS file.
#
# This broke under Mandrake 10, because the Mandrake glu.h file includes
# function declarations of the form "<type> <name> (<arg1>,<arg2>...)"
# rather than "extern <type> <name> (<arg1>,<arg2>...)". Similar
# strangenesses may hassle you -- if you're looking here because of
# undefined function calls in "demo 3d", you've probably come to the right
# place.
#
##############################
# Notes 6-March-2006 CED - preparing for 2.4.3
#
# Fuck. This is even worse than I thought. The latest is that it stopped compiling
# under recent (2005) Fedora releases. The problem is that gl.h (and other headers)
# now contain #ifdefs that make it practically impossible to parse them before
# compile time. So now we spend a great deal of time assembling all the precursor
# .h's for each .h, so that they are preprocessed in context. That means we need
# a fence in the source files we feed to the preprocessor, so that we don't detect and
# declare definitions that are already included from other .h files, or that are irrelevant
# to GL (e.g. printf()). The previous solution was to simply ignore all #includes but there
# is now enough compile-time switching that we have to preprocess the whole batch.
#
# TO DO: ensure that at least a particular subset of functions are found,
# or else barf the compile.
#
use Getopt::Long;
use strict;
use Config;
my (@incs,@defines);
GetOptions("I=s@" => \@incs,
"D=s@" => \@defines );
#
my @funcs = qw|gl.h glx.h glu.h|;
my @types = qw|X.h gl.h glx.h glu.h glxtokens.h|;
my $verbose = 1;
my $pmdocs;
#
# These are prototypes which for one reason or another (hopefully documented
# further below) we dont want to generate.
#
my @dontfuncs;
my @oosubs; # holds subroutine prototypes for oo interface
my %dontfuncs;
for(@dontfuncs) {$dontfuncs{$_} = 1}
my(@path);
foreach(@incs){
if(-d "$_"){
push(@path,$_);
}else{
die "ERROR: directory $_ not found, fix perldl.conf and rerun perl Makefile.PL";
}
}
foreach(@defines){
$_ = "-D$_";
}
# This next seems to be important to keep some extraneous mesa debugging definitions
# from being caught. Blech.
push(@defines,"-DGL_MESA_program_debug");
push(@defines,"-DGL_MESA_shader_debug");
push(@defines,"-DGL_ATI_blend_equation_separate");
push(@defines,"-DGLX_MESA_swap_frame_usage");
push(@defines,"-DGLX_MESA_swap_control");
push(@defines,"-DGLX_ARB_render_texture");
# The '/usr/X11R6/include' path is where GL/glx.h etc are found
# on my OS-X 10.3 machine. It seems to me that the Makefile.PL's should
# have set the paths up by now, rather than having the logic in the *pd
# file; I think the whole build of the TriD stuff needs reworking...
#
# Doug
#
push @path, "/usr/include";
push @path, "/usr/X11R6/include"
if $^O eq "darwin";
my %consts; # filled by sub getconsts
my @subnames; # filled by sub getfuncs
my %t=(
'unsigned long' => 'T_U_LONG',
'signed long' => 'T_LONG',
'long' => 'T_LONG',
'unsigned int' => 'T_U_INT',
'signed int' => 'T_INT',
'int' => 'T_INT',
'unsigned short'=> 'T_U_SHORT',
'signed short' => 'T_SHORT',
'short' => 'T_SHORT',
'unsigned char'=> 'T_U_CHAR',
'signed char' => 'T_CHAR',
'char' => 'T_CHAR',
'void' => 'T_VOID',
'float' => 'T_FLOAT',
'double' => 'T_DOUBLE',
'XID' => 'T_U_LONG',
'void *' => 'T_PTR',
'GLXFBConfig' => 'T_PTR',
'Display *' => 'T_PTR',
'Bool' => 'T_U_CHAR',
);
my @prefile;
my @pre_includes = ();
my @gl_includes;
my @post_includes = ("stdio.h");
open(TYPEMAP,">typemap") or die "Can not write typemap\n";;
print STDERR "\nPDL::Graphics::TriD::OpenGL : Detecting GL API from system headers...\n";
foreach my $file (@types){
my @file;
print STDERR "\nPDL::Graphics::TriD::OpenGL: PROCESSING FILE $file.....";
my $found;
glpath: foreach my $path (@path){
foreach my $subdir("GL/","X11/","") {
if(-e "$path/$subdir$file"){
&getconsts("$path/$subdir$file");
push(@gl_includes,"$subdir$file");
@prefile = ();
@file = &cpp("$path/$subdir$file",[@pre_includes,@gl_includes]);
# print STDERR "Got back from cpp - file has ".(0+@file)." lines...\n";
# Hack to identify XID-equivalent types and add them to the TYPEMAP.
# This generates typemap lines of the form "Window\tXID", because some perl
# versions (e.g. 5.8.6) don't ship with typemap entries for the X types.
# -CED 7-Mar-2006
hack:for( @prefile,@file ) {
next hack unless(m/^\s*typedef\s+XID\s+(\w+)\;/);
my $k = $1;
$t{$k} = $t{'XID'};
# print STDERR "TYPEMAP ENTRY FOR $file: $k->XID\n";
}
# Hack to identify simple GL types and add them to the TYPEMAP.
hack2: for( @prefile,@file ) {
# print STDERR "\t-$_";
next hack2 unless( m/^\s*typedef\s(.*)\s(GL\w+)\s*\;\s*$/);
# print STDERR "\t-$_";
my($ctype,$gltype) = ($1,$2);
map { s/^\s*//; s/\s*$//; s/\s+/ /g; } ($ctype,$gltype);
# print "\nTypedef sorting: $gltype is a $ctype\n";
unless($t{$ctype}) {
print STDERR "(Probably harmless): Sorting typedefs, but my little mind is blown! (ctype was '$ctype')\n";
next hack2;
}
$t{$gltype} = $t{$ctype};
}
hack3: for( @prefile,@file ) {
# print STDERR "\t-$_";
next hack3 unless( m/^\s*typedef\s.*\*\s*(_*GL\w+).*\;\s*$/);
# print STDERR "\t:$_";
my($gltype) = ($1);
map { s/^\s*//; s/\s*$//; s/\s+/ /g; } ($gltype);
# print "\nTypedef sorting: $gltype is a ptr\n";
$t{$gltype} = "T_PTR";
}
$found=1;
last glpath;
}
}
}
unless($found){
print STDERR "WARNING: could not find file $file in path '".join(":",@path)."'. (may be okay)\n";
}
# print STDERR ":::::::::::::::::::::::::::::::::\n";
# print STDERR "PDL::Graphics::TriD::OpenGL: Calling gettypes for $file (",$#file,")\n" ;
# gettypes(@file);
}
print (STDERR "\n\n\n\n\n\n\n\n\n\n\n\n\n\n************************************\n***********************************\n*****************************\nPre-processed files. gl_includes is now ",join(",",@gl_includes),"...\n\n\n\n\n\n\n\n");
while ( my ($key, $val) = each %t ) {
print TYPEMAP "$key $val\n" ;
};
close TYPEMAP;
select STDOUT;
my @typemap_lines = map { "$_\t$t{$_}\n" } keys %t;
pp_addhdr(
join("\n",map {"#include <$_>"} (@pre_includes,@gl_includes,@post_includes)) .
'
#define NUM_ARG 6
static int debug=0;
static int default_attributes[] = { GLX_RGBA, /*GLX_DOUBLEBUFFER,*/ None };
static Bool WaitForNotify(Display *d, XEvent *e, char *arg) {
return (e->type == MapNotify) && (e->xmap.window == (Window)arg);
}
'
);
#
# generate the xs code
#
#
my $ppcode = "pp_addxs('','\n";
$ppcode .= glpcopenwindow();
$ppcode .= "\n');\n\n";
foreach my $file (@funcs){
print STDERR "XXXXXXXXXX Processing $file\n";
my @file;
if($file=~/^gl/){
my $found;
foreach my $path (@path){
if(-e "$path/GL/$file"){
@file = cpp("$path/GL/$file");
$found=1;
last;
}
}
unless($found){
print STDERR "WARNING: could not find file $file in $0 (may be okay)\n";
}
}
$ppcode .= getfuncs(@file);
}
$ppcode .= pmstuff(@oosubs);
$ppcode .= exports(\%consts);
#
# print the code out so that we can refer to this
# file in the case of any errors
#
$ppcode .= "pp_addpm(<<'EODOCS');\n";
$ppcode .= "\n=head2 OpenGL Interface Functions\n\n";
$ppcode .= "=over 4\n\nThe following is a list of OpenGL functions for which an interface was created. Please refer to the OpenGL documentation for descriptions.\n\n";
$ppcode .= $pmdocs;
$ppcode .= "=back\n\n=cut\n\nEODOCS\n";
$ppcode .= "pp_done();";
open(F,">ppcode.out");
print F $ppcode;
close(F);
eval $ppcode;
sub cpp {
my ($file) = shift;
my ($include_list) = shift || [];
my @includes = map { "\n#include <$_>\n" } @$include_list;
my $open_fencestr = "11HdyTbIVg6s"; # some gibberish output by DES
my $close_fencestr = "23Cnba1nbf31"; # some gibberish I type
print STDERR "Running cpp on $file\n"if($verbose);
open(FILE,"$file") || die "Could not open file $file";
my @rawfile = (@includes, "Start of $file ($close_fencestr)....\n", <FILE>);
close(FILE);
my $nfile = $file;
$nfile =~ s/.*\//tmp_/;
open(TFILE,">$nfile") || die "Could not write $nfile";
##############################
# Walk through the file and mark the last instance of #include with a fence
my @file;
while(@rawfile) {
my $line = shift @rawfile;
if($line =~ m/\A\#\s*include\s/) {
$line =~ s/\n(.)/\\n$1/g;
chomp $line;
push(@file,"\nFENCE ($open_fencestr): Ignore stuff till the next fence ($line)\n\n");
push(@file,$line."\n");
push(@file,"\nFENCE ($close_fencestr): Stop ignoring stuff\n\n");
} else {
push(@file,$line);
}
}
##############################
# Now dump the processed array to a temp file for cpp to crunch on
foreach(@file){
# print STDERR "from $file: ",$_ ;
print TFILE $_;
}
close(TFILE);
#
# Put together a preprocessor command
#
my $com="$Config{cpprun} -P @defines";
foreach(split ' ', $Config{cppflags}.' '.$Config{cflags} . ' ' . $Config{ccflags}){
$com .= " $_" if(1 || /-D/);
}
$com .= " -D_LANGUAGE_C -DAPIENTRY=''"; # forces prototypes of SGI GL
print STDERR "*** CPP command: $com $nfile |\n";
##############################
# Execute cpp and snarf up its output
open(CPP_PIPE,"$com $nfile |") || die "cant open $com $nfile|\n";
@rawfile = <CPP_PIPE>;
close CPP_PIPE;
# print STDERR "CPP call returned ".(0+@rawfile)." lines...\n";
if ($verbose) {
use File::Basename;
my $out = basename($file).".cpp";
open FI, ">$out" ||
die "can't open temp output file $out";
# print STDERR "outputting to $out...\n";
print FI "/* command: $com */\n";
print FI join('',@rawfile);
close FI;
}
##############################
# Edit out the sections to be ignored...
my @file;
my $ignoring=0;
print STDERR "open_fencestr = '$open_fencestr'; close_fencestr = '$close_fencestr'\n";
print STDERR "rawfile has ".(0+@rawfile)." lines...\n";
my $lineno = 0;
for my $line(@rawfile) {
$lineno++;
if($line =~ m/$open_fencestr/o) {
# print "Starting to ignore - trigger line was '$line' (line $lineno)\n";
$ignoring = 1;
next;
}
if($line =~ m/$close_fencestr/o) {
# print "Ending ignorance - trigger line was '$line (line $lineno);'\n";
$ignoring = 0;
next;
}
chomp $line;
unless($ignoring) {
push (@file,"$line\n");
# print STDERR "Keeping: $line\n";
}
# if($ignoring) {
# print STDERR "*******: $line\n";
# }
}
my $str = join("\n",@file);
@file = split /\n/,$str;
open(FILE,">${nfile}-out");
print FILE join "\n",@file,"";
close FILE;
print STDERR "SUB CPP: Returning ".(0+@file)." lines...\n";
return @file;
}
sub gettypes {
my(@file) = @_;
my @tkeys = keys(%t);
foreach my $line (@file) {
if($line =~ /typedef/) {
my $cnt=0;
foreach my $k (@tkeys) {
if($line =~ /typedef\s+$k\s+(\w+)\s*\;/){
print "$1\t\tT_$t{$k}\n" ;
}elsif($line =~ /typedef\s+signed\s+$k\s+(\w+)\s*\;/){
print "$1\t\tT_$t{$k}\n" ;
}elsif($line =~ /typedef\s+unsigned\s+$k\s+(\w+)\s*\;/){
print "$1\t\tT_U_$t{$k}\n" ;
}elsif($line =~ /typedef\s+\w+\s+\(\s*\*\s*(\w+)\s*\)\s*\(.*\)\;/){
print "$1\t\tT_PTR\n" ;
}else{
$cnt++;
}
}
if($cnt > $#tkeys){
$line =~ /typedef\s+(.*)\s+(\w+)\s*\;/;
print STDERR "typedef Not Found >$line<$1<$2\n" if($verbose);
}
}
}
}
sub getfuncs {
my(@file) = @_;
my $outstr;
my $str = join ' ',@file;
# while($str =~ /extern\s+(\S[^\;]*)\s+(\w+)\s*\(([^\(\)]*)\)\s*\;/gs){
# my @vfuncs;
while($str =~ /(extern\s)?\s*(\w+)\s+(\w+)\s*\(([^\(\)]*)\)\s*\;/gs){
my $rt=$2;
my $name=$3;
my $args=$4;
# $rt =~ s/^\s*const\s+//;
if($dontfuncs{$name}) { next }
if($args =~ /GLvoid\s*\*\s*\*/) { next }
push @subnames,$name;
# print "Gen: $rt $name $args\n" if $verbose;
# push @vfuncs,"$rt,$name,V_$name,($args)";
#
# Ignore Display * when looking for pointers
#
if($args =~ /Display/ ||
$args =~ /GLXDrawable/ ||
$args =~ /GLXContext/){
push @oosubs,[$rt,$name,$args];
}
my $targs = $args;
$targs =~ s/Display\s*\*/long/g;
my $exists_pointer = ($targs =~ /\*/);
my @args = split(/\,/,$args);
@args=() if (($args =~ /^\s*void\s*$/) || ($args =~ /^\s*$/));
$pmdocs .= "=item * \n\n$name\n\n";
$outstr .= "pp_addxs('','\n";
$outstr .= "$rt\n";
$outstr .= "$name(";
my $i=0;
foreach my $a (@args) {
$outstr .= "," if($i);
$a =~ s/^\s*(.*\S)\s*$/$1/g;
$a =~ s/const\s+(\w+)\s+(\w+)\s*\[[^\]]*\]/$1_star $2/;
unless($a =~ s/^\s*Display\s*\*(\w+)/Display * $1/){
$a =~ s/(\w+)\s+(\w+)\s*\[[^\]]*\]/$1_star $2/;
$a =~ s/const\s+(.*\S)\s*\*\s*(.*)/$1_star $2/;
$a =~ s/(.*\S)\s*\*\s*(.*)/$1_star $2/;
}
$a =~ s/const\s+//;
$a =~ s/^\s*(\w+)\s*$/$1 arg$i/;
$a =~ /(.*)\s+(\w+)$/;
$outstr .= "$2";
$i++;
}
$outstr .= ")\n";
foreach my $a (@args) {
$a =~ /(.*)\s+(\w+)\s*$/;
my $t=$1;
my $n=$2;
$t =~ s/.*_star/char \*/;
$outstr .= "\t$t\t$n\n";
}
if($exists_pointer){
$outstr .= "\tCODE:\n";
$outstr .= "\t{\n";
$outstr .= "\t\tunsigned int err;\n";
$outstr .= "\t\t$name(";
my $i=0;
foreach my $a (@args) {
$outstr .= "," if($i);
$a =~ /(.*)\s+(\w+)\s*$/;
my $t=$1;
my $n=$2;
# print "HERE $t<>$n<\n";
if($t =~ /^(.*)_star/) {
$outstr .= "($1 *)";
}
$outstr .= $n;
$i++;
}
$outstr .= ");\n";
$outstr .= "\t\tif(debug) while((err = glGetError()) != GL_NO_ERROR){\n";
$outstr .= "\t\t\tprintf(\"ERROR issued in GL $name %s\\n\", gluErrorString(err));}\n";
$outstr .= "\t}\n";
}
$outstr .= "\n');\n\n";
}
return $outstr;
}
sub glpcopenwindow{
# just print this out verbatim to the xs
return sprintf <<'EOXS';
HV *
glpcOpenWindow(x,y,w,h,pw,event_mask, ...)
int x
int y
int w
int h
int pw
long event_mask
CODE:
{
Display *dpy;
Window win;
GLXContext ctx;
XVisualInfo *vi;
XSetWindowAttributes swa;
XEvent event;
Colormap cmap;
Window pwin=(Window)pw;
int *attributes = default_attributes;
unsigned int err;
RETVAL = newHV();
if(items>NUM_ARG){
int i;
attributes = (int *)malloc((items-NUM_ARG+1)* sizeof(int));
if(attributes==NULL){
return;
}
for(i=NUM_ARG;i<items;i++) {
attributes[i-NUM_ARG]=SvIV(ST(i));
}
attributes[items-NUM_ARG]=None;
}
if(debug){
int i;
for(i=0;attributes[i] != None; i++){
printf("att=%%d %%d\n",i,attributes[i]);
}
}
/* get a connection */
dpy = XOpenDisplay(NULL);
if (dpy==NULL){
printf("ERROR: failed to get an X connection\n");
return;
}else if(debug){
printf("Display open %%x\n",dpy);
}
/* get an appropriate visual */
vi = glXChooseVisual(dpy, DefaultScreen(dpy),attributes);
if(!vi) {
printf("ERROR: failed to get an X visual\n");
return;
}else if(debug){
printf("Visual open %%x\n",vi);
}
/* create a GLX context */
ctx = glXCreateContext(dpy, vi, NULL, GL_TRUE);
if(!ctx) {
printf("ERROR: failed to get an X Context\n");
return;
}else if(debug){
printf("Context Created %%x\n",ctx);
}
/* create a color map */
cmap = XCreateColormap(dpy, RootWindow(dpy, vi->screen),
vi->visual, AllocNone);
/* create a window */
swa.colormap = cmap;
swa.border_pixel = 0;
swa.event_mask = event_mask;
if(!pwin){
pwin=RootWindow(dpy, vi->screen);
if(debug) printf("Using root as parent window 0x%%x\n",pwin);
}
if(x>=0) {
win = XCreateWindow(dpy, pwin, x, y, w, h, 0, vi->depth, InputOutput, vi->visual, CWBackPixel | CWBorderPixel|CWColormap|CWEventMask, &swa);
if(debug) printf("win = 0x%%x\n",win);
if(!win) {
return;
}
XMapWindow(dpy, win);
if(event_mask & StructureNotifyMask) {
XIfEvent(dpy, &event, WaitForNotify, (char*)win);
}
}
/* connect the context to the window */
if(!glXMakeCurrent(dpy, win, ctx)) {
return;
}
if(debug)
printf("Display=0x%%x Window=0x%%x Context=0x%%x\n",dpy,win,ctx);
hv_store(RETVAL, "Display", strlen("Display"), newSViv((IV) dpy),0);
hv_store(RETVAL, "Window", strlen("Window"), newSViv((IV) win),0);
hv_store(RETVAL, "Context", strlen("Context"), newSViv((IV) ctx),0);
hv_store(RETVAL, "GL_Version",strlen("GL_Version"),
newSVpv((char *) glGetString(GL_VERSION),0),0);
hv_store(RETVAL, "GL_Vendor",strlen("GL_Vendor"),
newSVpv((char *) glGetString(GL_VENDOR),0),0);
hv_store(RETVAL, "GL_Renderer",strlen("GL_Renderer"),
newSVpv((char *) glGetString(GL_RENDERER),0),0);
/* clear the buffer */
glClearColor(0,0,0,1);
while((err = glGetError()) != GL_NO_ERROR){
printf("ERROR issued in GL %%s\n", gluErrorString(err));
}
}
OUTPUT:
RETVAL
int
glpRasterFont(name,base,number,d)
char *name
int base
int number
Display *d
CODE:
{
XFontStruct *fi;
int lb;
fi = XLoadQueryFont(d,name);
if(fi == NULL) {
die("No font %s found",name);
}
lb = glGenLists(number);
if(lb == 0) {
die("No display lists left for font %s (need %d)",name,number);
}
glXUseXFont(fi->fid, base, number, lb);
RETVAL=lb;
}
OUTPUT:
RETVAL
void
glpSetDebug(flag)
int flag
CODE:
{
debug=flag;
}
void
glpPrintString(base,str)
int base
char *str
CODE:
{
glPushAttrib(GL_LIST_BIT);
glListBase(base);
glCallLists(strlen(str),GL_UNSIGNED_BYTE,(GLubyte*)str);
glPopAttrib();
}
int
XPending(d)
Display * d
int
XResizeWindow(d, w, x, y)
Display * d
Window w
int x
int y
void
glpXNextEvent(d)
void * d
PPCODE:
{
XEvent event;
char buf[10];
KeySym ks;
XNextEvent(d,&event);
switch(event.type) {
case ConfigureNotify:
EXTEND(sp,3);
PUSHs(sv_2mortal(newSViv(event.type)));
PUSHs(sv_2mortal(newSViv(event.xconfigure.width)));
PUSHs(sv_2mortal(newSViv(event.xconfigure.height)));
break;
case KeyPress:
case KeyRelease:
EXTEND(sp,2);
PUSHs(sv_2mortal(newSViv(event.type)));
XLookupString(&event.xkey,buf,sizeof(buf),&ks,0);
buf[0]=(char)ks;buf[1]=\'\0\';
PUSHs(sv_2mortal(newSVpv(buf,1)));
break;
case ButtonPress:
case ButtonRelease:
EXTEND(sp,7);
PUSHs(sv_2mortal(newSViv(event.type)));
PUSHs(sv_2mortal(newSViv(event.xbutton.button)));
PUSHs(sv_2mortal(newSViv(event.xbutton.x)));
PUSHs(sv_2mortal(newSViv(event.xbutton.y)));
PUSHs(sv_2mortal(newSViv(event.xbutton.x_root)));
PUSHs(sv_2mortal(newSViv(event.xbutton.y_root)));
PUSHs(sv_2mortal(newSViv(event.xbutton.state)));
break;
case MotionNotify:
EXTEND(sp,4);
PUSHs(sv_2mortal(newSViv(event.type)));
PUSHs(sv_2mortal(newSViv(event.xmotion.state)));
PUSHs(sv_2mortal(newSViv(event.xmotion.x)));
PUSHs(sv_2mortal(newSViv(event.xmotion.y)));
break;
case Expose:
default:
EXTEND(sp,1);
PUSHs(sv_2mortal(newSViv(event.type)));
break;
}
}
EOXS
}
sub pmstuff {
my(@oosubs) = @_;
my $outstr;
$outstr .= "pp_addpm(<<'CONSTANTS');\n";
foreach(sort keys %consts){
my $val = $consts{$_};
$val =~ s/\(int\)//;
$val =~ s/^(\D+)$/\'$1\'/;
$val = $consts{$val} if(defined $consts{$val});
$val =~ s/(\d)L/$1/;
$outstr .= "sub $_ () {$val}\n";
}
$outstr .= "CONSTANTS\n";
$outstr .= sprintf <<'END';
pp_addpm(<<'EOD');
=head1 NAME
PDL::Graphics::OpenGL -- a PDL interface to the OpenGL graphics library.
PDL::Graphics::OpenGLOO - an Object Oriented interface to the interface.
=head1 DESCRIPTION
This package implements an interface to various OpenGL or OpenGL
emulator libraries. Most of the interface is generated at PDL compile
time by the script opengl.pd which runs the c preprocessor on various
OpenGL include files to determine the correct C prototypes for each
configuration. The object oriented interface defines an Object which
contains the Display, Window and Context properties of the defined
OpenGL device. Any OpenGL function called from the OO interface will
recieve these fields from the object, they should not be passed explicitly.
This package is primarily intended for internal use by the
PDL::Graphics::TriD package, but should also be usable in its own right.
=head1 FUNCTIONS
=cut
package PDL::Graphics::OpenGL::OO;
use PDL::Options;
use strict;
my $debug;
#
# This is a list of all the fields of the opengl object and one could create a
# psuedo hash style object but I want to use multiple inheritence with Tk...
#
#use fields qw/Display Window Context Options GL_Vendor GL_Version GL_Renderer/;
=head2 new($class,$options)
Returns a new OpenGL object with attributes specified in the options
field. These attributes are:
=for ref
x,y - the position of the upper left corner of the window (0,0)
width,height - the width and height of the window in pixels (500,500)
parent - the parent under which the new window should be opened (root)
mask - the user interface mask (StructureNotifyMask)
attributes - attributes to pass to glXChooseVisual
=cut
sub new {
my($class_or_hash,$options) = @_;
my $isref = ref($class_or_hash);
my $p;
# PDL::Graphics::OpenGL::glpSetDebug(1);
if($isref and defined $class_or_hash->{Options}){
$p = $class_or_hash->{Options};
}else{
my $opt = new PDL::Options(default_options());
$opt->incremental(1);
$opt->options($options) if(defined $options);
$p = $opt->options;
}
my $self = PDL::Graphics::OpenGL::glpcOpenWindow(
$p->{x},$p->{y},$p->{width},$p->{height},
$p->{parent},$p->{mask},
@{$p->{attributes}});
if(ref($self) ne 'HASH'){
die "Could not create OpenGL window";
}
$self->{window_type} = 'pdl-legacy-x11';
# psuedo-hash style see note above
# no strict 'refs';
# my $self = bless [ \%%{"$class\::FIELDS"}], $class;
#
$self->{Options} = $p;
if($isref){
if(defined($class_or_hash->{Options})){
return bless $self,ref($class_or_hash);
}else{
foreach(keys %%$self){
$class_or_hash->{$_} = $self->{$_};
}
return $class_or_hash;
}
}
bless $self,$class_or_hash;
}
=head2 default_options
default options for object oriented methods
=cut
#'
sub default_options{
{'x' => 0,
'y' => 0,
'width' => 500,
'height'=> 500,
'parent'=> 0,
'mask' => &PDL::Graphics::OpenGL::StructureNotifyMask,
'attributes'=> [&PDL::Graphics::OpenGL::GLX_RGBA,
&PDL::Graphics::OpenGL::GLX_RED_SIZE,1,
&PDL::Graphics::OpenGL::GLX_GREEN_SIZE,1,
&PDL::Graphics::OpenGL::GLX_BLUE_SIZE,1,
&PDL::Graphics::OpenGL::GLX_DOUBLEBUFFER
]
}
}
=head2 XPending()
OO interface to XPending
=cut
sub XPending {
my($self) = @_;
PDL::Graphics::OpenGL::XPending($self->{Display});
}
=head2 XResizeWindow(x,y)
OO interface to XResizeWindow
=cut
sub XResizeWindow {
my($self,$x,$y) = @_;
PDL::Graphics::OpenGL::XResizeWindow($self->{Display},$self->{Window},$x,$y);
}
=head2 glpXNextEvent()
OO interface to glpXNextEvent
=cut
sub glpXNextEvent {
my($self) = @_;
PDL::Graphics::OpenGL::glpXNextEvent($self->{Display});
}
=head2 glpRasterFont()
OO interface to the glpRasterFont function
=cut
sub glpRasterFont{
my($this,@args) = @_;
PDL::Graphics::OpenGL::glpRasterFont($args[0],$args[1],$args[2],$this->{Display});
}
=head2 AUTOLOAD
If the function is not prototyped in OO we assume there is
no explicit mention of the three identifying parameters (Display, Window, Context)
and try to load the OpenGL function.
=cut
sub AUTOLOAD {
my($self,@args) = @_;
use vars qw($AUTOLOAD);
my $sub = $AUTOLOAD;
return if($sub =~ /DESTROY/);
$sub =~ s/.*:://;
$sub = "PDL::Graphics::OpenGL::$sub";
if(defined $debug){
print "In AUTOLOAD: $sub at ",__FILE__," line ",__LINE__,".\n";
}
no strict 'refs';
return(&{$sub}(@args));
}
END
foreach(@oosubs){
my($rt,$name,$args) = @$_;
$outstr .= "\n=head2 $name\n\n";
$outstr .= "OO interface to the $name function\n\n=cut\n\n";
$outstr .= "sub $name {\n";
$outstr .= "\tmy(\$this,\@args) = \@_;\n";
$outstr .= "\t&PDL::Graphics::OpenGL::$name(";
my @args = split(/\,/,$args);
my $argcnt=0;
my $i=0;
foreach(@args){
$outstr .= "," if($i++);
if(/^\s*Display\s+\*/){
$outstr .= "\$this->{Display}";
}elsif(/^\s*GLXDrawable\s/){
$outstr .= "\$this->{Window}";
}elsif(/^\s*GLXContext\s/){
$outstr .= "\$this->{Context}";
}else{
$outstr .= "\$args[$argcnt]";
$argcnt++;
}
}
$outstr .= ");\n}\n";
}
$outstr .= "\nEOD\n";
return $outstr;
}
sub getconsts {
my ($file) = @_;
print STDERR "Getting constants from file $file\n" if($verbose);
open(FILE,$file) || die "cant open $file\n";
my @file = <FILE>;
close(FILE);
foreach my $line (@file) {
if($line =~ /^\#define\s+(\w+)\s+(\S+)\s*/) {
$consts{$1} = $2;
} elsif($line =~ /^\s*(\w+)\s*=\s*(\S+)\s*,\s*/) {
# Assume it's inside an enum.
$consts{$1} = $2;
}
}
}
sub exports{
my($consts) = @_;
my $outstr="pp_add_exported('','\n";
foreach (sort keys %$consts){
$outstr .= "\t\t$_\n";
}
foreach (sort @subnames){
$outstr .= "\t\t$_\n";
}
$outstr .= "');\n";
return $outstr;
}