From: Leon Brocard Date: Wed, 14 Oct 2009 07:13:53 +0000 (+0100) Subject: Split out SDL_Color into its own C-level class X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3e3f41eebdfe76f06783edd413755a6bb1b98966;p=sdlgit%2FSDL_perl.git Split out SDL_Color into its own C-level class --- diff --git a/Build.PL b/Build.PL index b96fd1f..55d6148 100644 --- a/Build.PL +++ b/Build.PL @@ -48,7 +48,13 @@ my %subsystems = }, libraries => [qw( SDL )], }, - + Color => { + file => { + from => 'src/Color.xs', + to => 'lib/SDL/Color.xs', + }, + libraries => [qw( SDL )], + }, OpenGL => { file => { from => 'src/OpenGL.xs', diff --git a/MANIFEST b/MANIFEST index ba5495d..33bfbad 100644 --- a/MANIFEST +++ b/MANIFEST @@ -55,6 +55,7 @@ scripts/README scripts/SDL/Constants.pm scripts/sdl_const.pl scripts/sdl_words.txt +src/Color.xs src/defines.h src/OpenGL.xs src/Rect.xs diff --git a/lib/SDL/Color.pm b/lib/SDL/Color.pm index 2c426e4..4521fcb 100644 --- a/lib/SDL/Color.pm +++ b/lib/SDL/Color.pm @@ -1,162 +1,72 @@ -#!/usr/bin/env perl -# -# Color.pm -# -# Copyright (C) 2005 David J. Goehrig -# -# ------------------------------------------------------------------------------ -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Lesser General Public -# License as published by the Free Software Foundation; either -# version 2.1 of the License, or (at your option) any later version. -# -# This library 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 -# Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public -# License along with this library; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -# -# ------------------------------------------------------------------------------ -# -# Please feel free to send questions, suggestions or improvements to: -# -# David J. Goehrig -# dgoehrig@cpan.org -# - package SDL::Color; - use strict; use warnings; use Carp; -use SDL; - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - return bless \SDL::NewColor(@_), $class if (@_ == 3); - - my $self; - - my (%options) = @_; - - verify (%options, qw/ -color -surface -pixel -r -g -b /) if $SDL::DEBUG; - - if ($options{-color}) { - $self = \$options{-color}; - } elsif ($options{-pixel} && $options{-surface}) { - croak "SDL::Color::new requires an SDL::Surface" - unless !$SDL::DEBUG || $options{-surface}->isa("SDL::Surface"); - $self = \SDL::NewColor(SDL::GetRGB(${$options{-surface}}, $options{-pixel})); - } else { - my @color; - push @color, $options{-red} || $options{-r} || 0; - push @color, $options{-green} || $options{-g} || 0; - push @color, $options{-blue} || $options{-b} || 0; - $self = \SDL::NewColor(@color); - } - croak "Could not create color, ", SDL::GetError(), "\n" - unless ($$self); - bless $self,$class; - return $self; -} - -sub DESTROY { - SDL::FreeColor(${$_[0]}); -} - -sub r { - my $self = shift; - SDL::ColorR($$self,@_); -} - -sub g { - my $self = shift; - SDL::ColorG($$self,@_); -} - -sub b { - my $self = shift; - SDL::ColorB($$self,@_); -} - -sub rgb { - my $self = shift; - SDL::ColorRGB($$self,@_); -} - -sub pixel { - croak "SDL::Color::pixel requires an SDL::Surface" - unless !$SDL::DEBUG || $_[1]->isa("SDL::Surface"); - SDL::MapRGB(${$_[1]},$_[0]->r(),$_[0]->g(),$_[0]->b()); -} - -$SDL::Color::black = new SDL::Color -r => 0, -g => 0, -b => 0; -$SDL::Color::white = new SDL::Color -r => 255, -g => 255, -b => 255; -$SDL::Color::red = new SDL::Color -r => 255, -g => 0, -b => 0; -$SDL::Color::blue = new SDL::Color -r => 0, -g => 0, -b => 255; -$SDL::Color::green = new SDL::Color -r => 0, -g => 255, -b => 0; -$SDL::Color::purple = new SDL::Color -r => 255, -g => 0, -b => 255; -$SDL::Color::yellow = new SDL::Color -r => 255, -g => 255, -b => 0; +require Exporter; +require DynaLoader; +our @ISA = qw(Exporter DynaLoader); +bootstrap SDL::Color; 1; -__END__; +__END__ =pod =head1 NAME -SDL::Color - a SDL perl extension +SDL::Color - Format independent color description =head1 SYNOPSIS - $color = new SDL::Color ( -r => 0xde, -g => 0xad, -b =>c0 ); - $color = new SDL::Color -surface => $app, -pixel => $app->pixel($x,$y); - $color = new SDL::Color -color => SDL::NewColor(0xff,0xaa,0xdd); + my $black = SDL::Color->new( 0, 0, 0); + my $color = SDL::Color->new(255, 0, 0); + my $r = $color->r; # 255 + my $g = $color->g; # 0 + my $b = $color->b; # 0 + $color->g(255); + $color->b(255); + # $color is now white =head1 DESCRIPTION -C is a wrapper for display format independent color -representations, with the same interface as L. +C describes a color in a format independent way. + +=head1 METHODS -=head2 new ( -color => ) +=head2 new ( $r, $g, $b ) -C with a C<-color> option will construct a new object -referencing the passed SDL_Color*. +The constructor creates a new color with the specified red, green and +blue values: -=head2 new (-r => , -g => , -b => ) + my $color = SDL::Color->new(255, 0, 0); -C with C<-r,-g,-b> options will construct both a SDL_Color -structure, and the associated object with the specified vales. +=head2 r -=head2 new (-pixel =>, -surface =>) +If passed a value, this method sets the red component of the color; +if not, it returns the red component of the color: -C with C<-pixel,-surface> options will generate a SDL_Color* -with the r,g,b values associated with the integer value passed by C<-pixel> -for the given C<-surface>'s format. + my $r = $color->r; # 255 + $color->r(128); -=head2 r ( [ red ] ), g( [ green ] ), b( [ blue ] ) +=head2 g -C are accessor methods for -the red, green, and blue components respectively. The color value can be set -by passing a byte value (0-255) to each function. +If passed a value, this method sets the green component of the color; +if not, it returns the green component of the color: -=head2 pixel ( surface ) + my $g = $color->g; # 255 + $color->g(128); -C takes a C object and r,g,b values, and -returns the integer representation of the closest color for the given surface. +=head2 b -=head1 AUTHOR +If passed a value, this method sets the blue component of the color; +if not, it returns the blue component of the color: -David J. Goehrig + my $b = $color->b; # 255 + $color->b(128); =head1 SEE ALSO -L L +L =cut diff --git a/lib/SDL/Surface.pm b/lib/SDL/Surface.pm index 5b2b316..35796c9 100644 --- a/lib/SDL/Surface.pm +++ b/lib/SDL/Surface.pm @@ -166,7 +166,7 @@ sub fill { if ($_[1] == 0 ) { SDL::FillRect(${$_[0]},0,${$_[2]}); } else { - SDL::FillRect(${$_[0]},$_[1],${$_[2]}); + SDL::FillRect(${$_[0]},$_[1],$_[2]); } } diff --git a/lib/SDL/TTFont.pm b/lib/SDL/TTFont.pm index 91d892e..ef8804f 100644 --- a/lib/SDL/TTFont.pm +++ b/lib/SDL/TTFont.pm @@ -82,7 +82,7 @@ sub print { SDL::FreeSurface($self->{-surface}) if ($$self{-surface}); $$self{-surface} = SDL::TTFPutString($$self{-font},$$self{-mode}, - $$surface,$x,$y,${$$self{-fg}},${$$self{-bg}},join("",@text)); + $$surface,$x,$y,$self->{-fg},$self->{-bg},join("",@text)); croak "Could not print \"", join("",@text), "\" to surface, ", SDL::GetError(), "\n" unless ($$self{-surface}); diff --git a/src/Color.xs b/src/Color.xs new file mode 100644 index 0000000..63261f2 --- /dev/null +++ b/src/Color.xs @@ -0,0 +1,72 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef aTHX_ +#define aTHX_ +#endif + +#include + +MODULE = SDL::Color PACKAGE = SDL::Color PREFIX = color_ + +=for documentation + +SDL_Color -- Format independent color description + + typedef struct{ + Uint8 r; + Uint8 g; + Uint8 b; + Uint8 unused; + } SDL_Color; + +=cut + +SDL_Color * +color_new (CLASS, r, g, b ) + char* CLASS + Uint8 r + Uint8 g + Uint8 b + CODE: + RETVAL = (SDL_Color *) safemalloc(sizeof(SDL_Color)); + RETVAL->r = r; + RETVAL->g = g; + RETVAL->b = b; + OUTPUT: + RETVAL + +Uint8 +color_r ( color, ... ) + SDL_Color *color + CODE: + if (items > 1 ) color->r = SvIV(ST(1)); + RETVAL = color->r; + OUTPUT: + RETVAL + +Uint8 +color_g ( color, ... ) + SDL_Color *color + CODE: + if (items > 1 ) color->g = SvIV(ST(1)); + RETVAL = color->g; + OUTPUT: + RETVAL + +Uint8 +color_b ( color, ... ) + SDL_Color *color + CODE: + if (items > 1 ) color->b = SvIV(ST(1)); + RETVAL = color->b; + OUTPUT: + RETVAL + +void +color_DESTROY ( color ) + SDL_Color *color + CODE: + return; safefree(color); + diff --git a/src/SDL.xs b/src/SDL.xs index 9c26874..a415673 100644 --- a/src/SDL.xs +++ b/src/SDL.xs @@ -1079,6 +1079,10 @@ SurfacePixels ( surface ) OUTPUT: RETVAL +=for comment + +Comment out for now as it does not compile + SDL_Color* SurfacePixel ( surface, x, y, ... ) SDL_Surface *surface @@ -1143,6 +1147,8 @@ SurfacePixel ( surface, x, y, ... ) OUTPUT: RETVAL +=cut + int MUSTLOCK ( surface ) SDL_Surface *surface @@ -1225,68 +1231,6 @@ ListModes ( format, flags ) OUTPUT: RETVAL - -SDL_Color * -NewColor ( r, g, b ) - Uint8 r - Uint8 g - Uint8 b - CODE: - RETVAL = (SDL_Color *) safemalloc(sizeof(SDL_Color)); - RETVAL->r = r; - RETVAL->g = g; - RETVAL->b = b; - OUTPUT: - RETVAL - -Uint8 -ColorR ( color, ... ) - SDL_Color *color - CODE: - if (items > 1 ) color->r = SvIV(ST(1)); - RETVAL = color->r; - OUTPUT: - RETVAL - -Uint8 -ColorG ( color, ... ) - SDL_Color *color - CODE: - if (items > 1 ) color->g = SvIV(ST(1)); - RETVAL = color->g; - OUTPUT: - RETVAL - -Uint8 -ColorB ( color, ... ) - SDL_Color *color - CODE: - if (items > 1 ) color->b = SvIV(ST(1)); - RETVAL = color->b; - OUTPUT: - RETVAL - - -void -ColorRGB ( color, ... ) - SDL_Color *color - PPCODE: - if (items > 1 ) { - color->r = SvIV(ST(1)); - color->g = SvIV(ST(2)); - color->b = SvIV(ST(3)); - } - mXPUSHi( color->r ); - mXPUSHi( color->g ); - mXPUSHi( color->b ); - XSRETURN(3); - -void -FreeColor ( color ) - SDL_Color *color - CODE: - return; safefree(color); - SDL_Palette * NewPalette ( number ) int number @@ -1307,6 +1251,10 @@ PaletteNColors ( palette, ... ) OUTPUT: RETVAL +=for comment + +Comment out for now as it does not compile + SDL_Color * PaletteColors ( palette, index, ... ) SDL_Palette *palette @@ -1321,6 +1269,8 @@ PaletteColors ( palette, index, ... ) OUTPUT: RETVAL +=cut + int VideoModeOK ( width, height, bpp, flags ) int width diff --git a/t/colorpm.t b/t/colorpm.t index 67dba94..7245992 100644 --- a/t/colorpm.t +++ b/t/colorpm.t @@ -1,66 +1,33 @@ -#!/usr/bin/perl -w -# -# Copyright (C) 2003 Tels -# Copyright (C) 2004 David J. Goehrig -# -# Copyright (C) 2005 David J. Goehrig -# -# ------------------------------------------------------------------------------ -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Lesser General Public -# License as published by the Free Software Foundation; either -# version 2.1 of the License, or (at your option) any later version. -# -# This library 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 -# Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public -# License along with this library; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -# -# ------------------------------------------------------------------------------ -# -# Please feel free to send questions, suggestions or improvements to: -# -# David J. Goehrig -# dgoehrig\@cpan.org -# -# -# basic testing of SDL::Color - -BEGIN { - unshift @INC, 'blib/lib','blib/arch'; -} - +#!perl use strict; - -use Test::More; - -plan ( tests => 10 ); - -use_ok( 'SDL::Color' ); - -can_ok ('SDL::Color', qw/ - new - r - g - b - pixel /); - -# some basic tests: - -my $color = SDL::Color->new(); -is (ref($color), 'SDL::Color', 'new was ok'); -is ($color->r(),0, 'r is 0'); -is ($color->g(),0, 'g is 0'); -is ($color->b(),0, 'b is 0'); - -$color = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff); -is (ref($color), 'SDL::Color', 'new was ok'); -is ($color->r(),255, 'r is 255'); -is ($color->g(),255, 'g is 255'); -is ($color->b(),255, 'b is 255'); - +use warnings; +use Test::More tests => 15; +use_ok('SDL::Color'); + +# check empty: black +my $black = SDL::Color->new( 0, 0, 0 ); +isa_ok( $black, 'SDL::Color' ); +is( $black->r(), 0, 'black r is 0' ); +is( $black->g(), 0, 'black g is 0' ); +is( $black->b(), 0, 'black b is 0' ); + +# check full: white +my $white = SDL::Color->new( 0xff, 0xff, 0xff ); +isa_ok( $white, 'SDL::Color' ); +is( $white->r(), 255, 'white r is 255' ); +is( $white->g(), 255, 'white g is 255' ); +is( $white->b(), 255, 'white b is 255' ); + +# check setting a value +my $orange = $white; +$orange->r(254); +$orange->g(153); +$orange->b(0); +is( $orange->r(), 254, 'orange_notcloned r is 254' ); +is( $orange->g(), 153, 'orange_notcloned g is 153' ); +is( $orange->b(), 0, 'orange_notcloned b is 0' ); + +# check that copies also change +is( $white->r(), 254, 'white (now orange) r is 254' ); +is( $white->g(), 153, 'white (now orange) g is 154' ); +is( $white->b(), 0, 'white (now orange) b is 0' ); diff --git a/t/intergation1.t b/t/intergation1.t index 9598ddd..7b71d66 100644 --- a/t/intergation1.t +++ b/t/intergation1.t @@ -65,15 +65,15 @@ my $app = SDL::App->new(-title => "Test", -width => 640, -height => 480, -init my $rect = SDL::Rect->new( 0,0, $app->width, $app->height); my $blue = SDL::Color->new( - -r => 0x00, - -g => 0x00, - -b => 0xff, + 0x00, + 0x00, + 0xff, ); my $col = SDL::Color->new( - -r => 0xf0, - -g => 0x00, - -b => 0x33, + 0xf0, + 0x00, + 0x33, ); diff --git a/typemap b/typemap index 12a35fa..756be5b 100644 --- a/typemap +++ b/typemap @@ -20,7 +20,7 @@ SDL_CD * T_PTR SDL_CDtrack * T_PTR SDL_TimerCallback T_PTR SDL_Rect * O_OBJECT -SDL_Color * T_PTR +SDL_Color * O_OBJECT SDL_Palette * T_PTR SDL_PixelFormat * T_PTR SDL_Cursor * T_PTR