crude sketch of auto error checking - please help improve (#50)

* crude sketch of auto error checking

* Cleanup and add new glp functions to export tags list

* Add string output for glGetError returns

* Make glpSetAutoCheckErrors() return the current setting

And take no arguments to just return the current flag value.

Modern.xs

@@ -11,9 +11,11 @@
 #include <src/glew.c>
 #include <src/glew-context.c>
 
+#include "gl_errors.h"
 #include "const-c.inc"
 
 static int _done_glewInit = 0;
+static int _auto_check_errors = 0;
 
 /*
   Maybe one day we'll allow Perl callbacks for GLDEBUGPROCARB
@@ -102,6 +104,33 @@ CODE:
 OUTPUT:
     RETVAL
 
+int
+glpSetAutoCheckErrors(...)
+CODE:
+    int state;
+    if (items == 1) {
+        state = (int)SvIV(ST(0));
+        if (state != 0 && state != 1 )
+            croak( "Usage: glpSetAutoCheckErrors(1|0)\n" );
+        _auto_check_errors = state;
+    }
+    RETVAL = _auto_check_errors;
+OUTPUT:
+    RETVAL
+
+void
+glpCheckErrors()
+CODE:
+    int err = GL_NO_ERROR;
+    int error_count = 0;
+    while ( ( err = glGetError() ) != GL_NO_ERROR ) {
+        /* warn( "OpenGL error: %d", err ); */
+        warn( "glpCheckErrors: OpenGL error: %d %s", err, gl_error_string(err) );
+	error_count++;
+    }
+    if( error_count )
+      croak( "glpCheckErrors: %d OpenGL errors encountered.", error_count );
+
 # This isn't a bad idea, but I postpone this API and the corresponding
 # typemap hackery until later
 #GLboolean

gl_errors.h

@@ -0,0 +1,33 @@
+/*
+#define GL_NO_ERROR                      0
+#define GL_INVALID_ENUM                  0x0500
+#define GL_INVALID_VALUE                 0x0501
+#define GL_INVALID_OPERATION             0x0502
+#define GL_STACK_OVERFLOW                0x0503
+#define GL_STACK_UNDERFLOW               0x0504
+#define GL_OUT_OF_MEMORY                 0x0505
+#define GL_INVALID_FRAMEBUFFER_OPERATION 0x0506
+#define GL_CONTEXT_LOST                  0x0507
+*/
+
+const char* const gl_error_symbol_strings[] = {
+    "GL_NO_ERROR",
+    "GL_INVALID_ENUM",
+    "GL_INVALID_VALUE",
+    "GL_INVALID_OPERATION",
+    "GL_STACK_OVERFLOW",
+    "GL_STACK_UNDERFLOW",
+    "GL_OUT_OF_MEMORY",
+    "GL_INVALID_FRAMEBUFFER_OPERATION",
+    "GL_CONTEXT_LOST",
+};
+
+int is_gl_error(int rval) {
+    int err;
+    err = rval & 0x0507 > 0 ? (rval & 0x07) + 1 : 0;
+    return err;
+}
+
+const char* gl_error_string(int err) {
+    return gl_error_symbol_strings[is_gl_error(err)];
+}

lib/OpenGL/Modern.pm

@@ -43,6 +43,8 @@ our %EXPORT_TAGS = (
           glGetString
           glewInit
           done_glewInit
+          glpSetAutoCheckErrors
+          glpCheckErrors
 
           glClear
           glClearColor

lib/OpenGL/Modern/NameLists/Modern.pm

@@ -7,6 +7,8 @@ sub gl_functions {
     qw(
       glGetString
       glShaderSource_p
+      glpCheckErrors
+      glpSetAutoCheckErrors
       glAccum
       glActiveProgramEXT
       glActiveShaderProgram

t/02_auto_error_check.t

@@ -0,0 +1,48 @@
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use OpenGL::Modern ':all';
+use OpenGL::Modern::Helpers 'glGetVersion_p';
+use Capture::Tiny 'capture';
+
+SKIP: {
+    plan skip_all => "glewContext did not succeed, skipping live tests"
+      if glewCreateContext() != GLEW_OK;    # returns GL_TRUE or GL_FALSE
+
+    my $gI_status = ( done_glewInit() ) ? GLEW_OK() : glewInit();    # returns GLEW_OK or ???
+    plan skip_all => "glewInit did not succeed, skipping live tests"
+      if $gI_status != GLEW_OK;
+
+    glClear GL_COLOR;
+    pass "didn't crash yet";
+
+    my ( $out, $err ) = capture {
+        eval { $@ = undef; glpCheckErrors };
+    };
+    like $err, qr/OpenGL error: 1281/,          "got expected errors";
+    like $@,   qr/1 OpenGL errors encountered/, "can check for errors manually";
+
+    eval { $@ = undef; glpSetAutoCheckErrors 3 };
+    is $@, "Usage: glpSetAutoCheckErrors(1|0)\n", "glpSetAutoCheckErrors only accepts 2 values";
+
+    glpSetAutoCheckErrors 1;
+    ( $out, $err ) = capture {
+        eval { $@ = undef; glClear GL_COLOR };
+    };
+    like $err, qr/OpenGL error: 1281/,          "got expected errors";
+    like $@,   qr/1 OpenGL errors encountered/, "errors cause crashes now";
+
+    glpSetAutoCheckErrors 0;
+    glClear GL_COLOR;
+    pass "crashes are gone again";
+
+    ( $out, $err ) = capture {
+        eval { $@ = undef; glpCheckErrors };
+    };
+    like $err, qr/OpenGL error: 1281/,          "got expected errors";
+    like $@,   qr/1 OpenGL errors encountered/, "but we can still check for errors manually";
+
+    done_testing;
+}

utils/generate-XS.pl

@@ -31,6 +31,8 @@ =head1 PURPOSE
 my @manual_list = qw(
   glGetString
   glShaderSource_p
+  glpCheckErrors
+  glpSetAutoCheckErrors
 );
 
 my %manual;
@@ -303,13 +305,30 @@ sub generate_glew_xs {
             $decl .= "     $xs_args;\n";
         }
 
+        my $error_check = $name eq "glGetError" ? "" : <<"XS";
+    if ( _auto_check_errors ) {
+        int err = GL_NO_ERROR;
+        int error_count = 0;
+        while ( ( err = glGetError() ) != GL_NO_ERROR ) {
+            /* warn( "OpenGL error: %d", err ); */
+            warn( "$name: OpenGL error: %d %s", err, gl_error_string(err) );
+            error_count++;
+        }
+        if( error_count )
+          croak( "$name: %d OpenGL errors encountered.", error_count );
+    }
+XS
+        chomp $error_check;    # trailing newline needs to be done conditionally
+
         my $res = $decl . <<XS;
 CODE:
     if ( ! _done_glewInit ) {
         glewExperimental = GL_TRUE;
         glewInit() || _done_glewInit++;
     }
+$error_check
 XS
+
         if ( $item->{glewtype} eq 'fun' and $glewImpl ) {
             $res .= <<XS;
     if ( ! $glewImpl ) {
@@ -318,23 +337,23 @@ sub generate_glew_xs {
 XS
         }
 
+        $error_check = "\n$error_check" if $error_check;    # otherwise glGetError gets a stray newline
+
         if ( $no_return_value ) {
             $res .= <<XS;
-    $name($args);
-
+    $name($args);$error_check
 XS
-
         }
         else {
-            $res .= "    RETVAL = $name" . ( ( $item->{glewtype} eq 'var' ) ? ";\n" : "($args);\n" );
+            my $arg_list = $item->{glewtype} eq 'var' ? "" : "($args)";
             $res .= <<XS;
+    RETVAL = $name$arg_list;$error_check
 OUTPUT:
     RETVAL
-
 XS
         }
 
-        $content .= $res;
+        $content .= "$res\n";
     }
     return $content;
 }