view release on metacpan or  search on metacpan

test.pl  view on Meta::CPAN

#!/usr/bin/perl -w
use strict;

our $PERL_VERSION = $^V;
$PERL_VERSION =~ s|^v||;

use OpenGL::Modern qw(glpSetAutoCheckErrors);
use OpenGL qw/
  :glconstants
  glGetString glGetError glpErrorString
  glGenTextures_p glBindTexture glTexParameteri glTexImage2D_c glTexEnvf
    glDeleteTextures_p
  glGenerateMipmapEXT
  glGenFramebuffersEXT_p glBindFramebufferEXT glFramebufferTexture2DEXT
    glCheckFramebufferStatusEXT glDeleteFramebuffersEXT_p
  glGenRenderbuffersEXT_p glBindRenderbufferEXT glRenderbufferStorageEXT
    glDeleteRenderbuffersEXT_p
  glFramebufferRenderbufferEXT
  glGenBuffersARB_p glBindBufferARB
    glMapBufferARB_c glUnmapBufferARB glDeleteBuffersARB_p
  glEnableClientState glDisableClientState
  glEnable glDisable glBlendFunc glDepthFunc glShadeModel
    glMatrixMode glLoadIdentity glLightfv_p glColorMaterial
    glTranslatef glRotatef
    glColor3f glColor4f
    glPushMatrix glPopMatrix glPushAttrib glPopAttrib
    glOrtho glFrustum
  glRasterPos2i glRasterPos2f
  glPixelZoom glReadPixels_c glDrawPixels_c
  glGetDoublev_c glGetIntegerv_c
  glClearColor glClearDepth glClear glViewport glDrawElements_c
/;
use OpenGL qw/
  glpHasGLUT glpCheckExtension glpFullScreen glpRestoreScreen
  glBufferDataARB_o glBufferSubDataARB_o
  glVertexPointer_o glNormalPointer_o glColorPointer_o glTexCoordPointer_o
/;
use OpenGL::GLUT qw/
  :constants :functions
/;
use OpenGL::Config;     # for build information

eval 'use OpenGL::Image 1.03';  # Need to use OpenGL::Image 1.03 or higher!
my $hasImage = !$@;
my $hasIM_635 = $hasImage && OpenGL::Image::HasEngine('Magick','6.3.5');

eval 'use OpenGL::Shader';
my $hasShader = !$@;

eval 'use Image::Magick';
my $hasIM = !$@;

eval 'use Time::HiRes qw( gettimeofday )';
my $hasHires = !$@;
$|++;


# ----------------------
# Based on a cube demo by
# Chris Halsall (chalsall@chalsall.com) for the
# O'Reilly Network on Linux.com (oreilly.linux.com).
# May 2000.
#
# Translated from C to Perl by J-L Morel <jl_morel@bribes.org>
# ( http://www.bribes.org/perl/wopengl.html )
#
# Updated for FBO, VBO, Vertex/Fragment Program extensions
# and ImageMagick support
# by Bob "grafman" Free <grafman@graphcomp.com>
# ( http://graphcomp.com/opengl )
#


# Requires GLUT/FreeGLUT
if (!glpHasGLUT())
{
  print <<'EOF';
    This test requires GLUT:
    If you have X installed, you can try the scripts in ./examples/
    Most of them do not use GLUT.

    It is recommended that you install FreeGLUT for improved Makefile.PL
    configuration, installation and debugging.
EOF
  exit 0;
}


use constant PROGRAM_TITLE => "OpenGL Test App";
use constant DO_TESTS => 0;


# Run in Game Mode
my $gameMode;
if (scalar(@ARGV) and lc($ARGV[0]) eq 'gamemode')
{
  $gameMode = $ARGV[1] || '';
}

# Keyboard modifiers
my $key_mods =
{
  eval(GLUT_ACTIVE_SHIFT) => "SHIFT",
  eval(GLUT_ACTIVE_CTRL) => "CTRL",
  eval(GLUT_ACTIVE_ALT) => "ALT"
};

# Some global variables.
my $hasFBO = 0;
my $hasVBO = 0;

test.pl  view on Meta::CPAN

      {
        # A simple repeating squares pattern.
        # Dark blue on white.
        if ( ( ($x+$w_32)%$w_4 < $w_16 ) && ( ($y+$w_32)%$w_4 < $w_16))
        {
          $tex .= pack "C3", 0,0,120;       # Dark blue
        }
        else
        {
          $tex .= pack "C3", 240, 240, 240; # White
        }

        # Make a round dot in the texture's alpha-channel.
        # Calculate distance to center (squared).
        my $t = ($x-$w_2)*($x-$w_2) + ($y-$w_2)*($y-$w_2);

        if ( $t < $hole_size)
        {
          $tex .= pack "C", 255;  # The dot itself is opaque.
        }
        elsif ($t < $hole_size + $hole_border)
        {
          $tex .= pack "C", 128;  # Give our dot an anti-aliased edge.
        }
        else
        {
          $tex .= pack "C", 0;    # Outside of the dot, it's transparent.
        }
      }
    }

    $Tex_Pixels = OpenGL::Array->new_scalar(GL_UNSIGNED_BYTE,$tex,length($tex));

    $Tex_Type = GL_RGBA8;
    $Tex_Format = GL_RGBA;
    $Tex_Size =  GL_UNSIGNED_BYTE;
  }
  glBindTexture(GL_TEXTURE_2D, $TextureID_image);

  if ($hasFBO) {
    # Use MipMap
    print "Using Mipmap\n";
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER,
      GL_NEAREST);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER,
      GL_NEAREST_MIPMAP_LINEAR);
  } else {
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
  }
  glTexImage2D_c(GL_TEXTURE_2D, 0, $Tex_Type,
    $Tex_Width, $Tex_Height,
    0, $Tex_Format, $Tex_Size, $Tex_Pixels->ptr);
  glGenerateMipmapEXT(GL_TEXTURE_2D) if $hasFBO;

  # Benchmarks for Image Loading
  if (DO_TESTS && $hasIM)
  {
    my $loops = 1000;

    my $im = Image::Magick->new();
    $im->Read($Tex_File);
    $im->Set(magick=>'RGBA',depth=>8);
    $im->Negate(channel=>'alpha');


    # Bench ImageToBlob
    my $start = gettimeofday();
    for (my $i=0;$i<$loops;$i++)
    {
      my($blob) = $im->ImageToBlob();

      glTexImage2D_s(GL_TEXTURE_2D, 0, GL_RGBA8, $Tex_Width, $Tex_Height,
        0, GL_RGBA, GL_UNSIGNED_BYTE, $blob);
    }
    my $now = gettimeofday();
    my $fps = $loops / ($now - $start);
    print "ImageToBlob + glTexImage2D_s: $fps\n";


    # Bench GetPixels
    $start = gettimeofday();
    for (my $i=0;$i<$loops;$i++)
    {
      my @pixels = $im->GetPixels(map=>'BGRA',
        width=>$Tex_Width, height=>$Tex_Height, normalize=>'false');

      glTexImage2D_p(GL_TEXTURE_2D, 0, $Tex_Type, $Tex_Width, $Tex_Height,
        0, $Tex_Format, $Tex_Size, @pixels);
    }
    $now = gettimeofday();
    $fps = $loops / ($now - $start);
    print "GetPixels + glTexImage2D_p: $fps\n";


    # Bench OpenGL::Image
    if ($hasIM_635)
    {
      my $start = gettimeofday();
      for (my $i=0;$i<$loops;$i++)
      {
        glTexImage2D_c(GL_TEXTURE_2D, 0, $Tex_Type, $Tex_Width, $Tex_Height,
          0, $Tex_Format, $Tex_Size, $Tex_Pixels->ptr());
      }
      my $now = gettimeofday();
      my $fps = $loops / ($now - $start);
      print "OpenGL::Image + glTexImage2D_c: $fps\n";
    }
  }

  # Build FBO texture
  if ($hasFBO)
  {
    printf("Using FBOs\n");

    ($FrameBufferID) = glGenFramebuffersEXT_p(1);
    ($RenderBufferID) = glGenRenderbuffersEXT_p(1);

    # Initiate texture
    glBindTexture(GL_TEXTURE_2D, $TextureID_FBO);
    glTexImage2D_c(GL_TEXTURE_2D, 0, $Tex_Type, $Tex_Width, $Tex_Height,