From: Kartik Thakore Date: Mon, 26 Oct 2009 23:00:53 +0000 (-0400) Subject: Moved old SDL::Palette to SDL::Game::Palette. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=60891a9e021e167c097eeb9747b1a509a8eb2cb8;p=sdlgit%2FSDL_perl.git Moved old SDL::Palette to SDL::Game::Palette. Made palette() a method of SDL::PixelFormat. Added tests for SDL::Palette. --- diff --git a/lib/SDL/Game/Palette.pm b/lib/SDL/Game/Palette.pm new file mode 100644 index 0000000..b8fb578 --- /dev/null +++ b/lib/SDL/Game/Palette.pm @@ -0,0 +1,164 @@ +#!/usr/bin/env perl +# +# Palette.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 +# + +# NB: there is no palette destructor because most of the time the +# palette will be owned by a surface, so any palettes you create +# with new, won't be destroyed until the program ends! + +package SDL::Game::Palette; +use strict; +use warnings; +use Carp; + +# NB: there is no palette destructor because most of the time the +# palette will be owned by a surface, so any palettes you create +# with new, won't be destroyed until the program ends! + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $image; + my $self; + if (@_) { + $image = shift; + $self = \$image->palette(); + } else { + $self = \SDL::NewPalette(256); + } + croak SDL::GetError() unless $$self; + bless $self, $class; + return $self; +} + +sub size { + my $self = shift; + return SDL::PaletteNColors($$self); +} + +sub color { + my $self = shift; + my $index = shift; + my ($r,$g,$b); + if (@_) { + $r = shift; $g = shift; $b = shift; + return SDL::PaletteColors($$self,$index,$r,$g,$b); + } else { + return SDL::PaletteColors($$self,$index); + } +} + +sub red { + my $self = shift; + my $index = shift; + my $c; + if (@_) { + $c = shift; + return SDL::ColorR( + SDL::PaletteColors($$self,$index),$c); + } else { + return SDL::ColorR( + SDL::PaletteColors($$self,$index)); + } +} + +sub green { + my $self = shift; + my $index = shift; + my $c; + if (@_) { + $c = shift; + return SDL::ColorG( + SDL::PaletteColors($$self,$index),$c); + } else { + return SDL::ColorG( + SDL::PaletteColors($$self,$index)); + } +} + +sub blue { + my $self = shift; + my $index = shift; + my $c; + if (@_) { + $c = shift; + return SDL::ColorB( + SDL::PaletteColors($$self,$index),$c); + } else { + return SDL::ColorB( + SDL::PaletteColors($$self,$index)); + } +} + +1; + +__END__; + +=pod + +=head1 NAME + +SDL::Palette - a perl extension + +=head1 DESCRIPTION + +L provides an interface to the SDL_Palette structures, +and can be used to set the color values of an existing palette's indexes. + +=head1 METHODS + +=head2 blue ( index, [value] ) + +Fetches and sets the blue component of the color at index. + +=head2 green ( index, [value] ) + +Fetches and sets the green component of the color at index. + +=head2 red ( index, [value] ) + +Fetches and sets the red component of the color at index. + +=head2 color ( index, [ r, g, b ] ) + +Fetches and sets the RGB, returns an SDL_Color *. + +=head2 size + +Returns the size of the palette. + +=head1 AUTHOR + +David J. Goehrig + +=head1 SEE ALSO + +L L L + +=cut diff --git a/lib/SDL/Palette.pm b/lib/SDL/Palette.pm index df99f3f..9d3040a 100644 --- a/lib/SDL/Palette.pm +++ b/lib/SDL/Palette.pm @@ -1,124 +1,15 @@ -#!/usr/bin/env perl -# -# Palette.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 -# - -# NB: there is no palette destructor because most of the time the -# palette will be owned by a surface, so any palettes you create -# with new, won't be destroyed until the program ends! - +#!perl package SDL::Palette; use strict; use warnings; -use Carp; - -# NB: there is no palette destructor because most of the time the -# palette will be owned by a surface, so any palettes you create -# with new, won't be destroyed until the program ends! - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - my $image; - my $self; - if (@_) { - $image = shift; - $self = \$image->palette(); - } else { - $self = \SDL::NewPalette(256); - } - croak SDL::GetError() unless $$self; - bless $self, $class; - return $self; -} - -sub size { - my $self = shift; - return SDL::PaletteNColors($$self); -} - -sub color { - my $self = shift; - my $index = shift; - my ($r,$g,$b); - if (@_) { - $r = shift; $g = shift; $b = shift; - return SDL::PaletteColors($$self,$index,$r,$g,$b); - } else { - return SDL::PaletteColors($$self,$index); - } -} - -sub red { - my $self = shift; - my $index = shift; - my $c; - if (@_) { - $c = shift; - return SDL::ColorR( - SDL::PaletteColors($$self,$index),$c); - } else { - return SDL::ColorR( - SDL::PaletteColors($$self,$index)); - } -} - -sub green { - my $self = shift; - my $index = shift; - my $c; - if (@_) { - $c = shift; - return SDL::ColorG( - SDL::PaletteColors($$self,$index),$c); - } else { - return SDL::ColorG( - SDL::PaletteColors($$self,$index)); - } -} - -sub blue { - my $self = shift; - my $index = shift; - my $c; - if (@_) { - $c = shift; - return SDL::ColorB( - SDL::PaletteColors($$self,$index),$c); - } else { - return SDL::ColorB( - SDL::PaletteColors($$self,$index)); - } -} +require Exporter; +require DynaLoader; +our @ISA = qw(Exporter DynaLoader); +bootstrap SDL::Palette; 1; -__END__; +__END__ =pod @@ -128,37 +19,30 @@ SDL::Palette - a perl extension =head1 DESCRIPTION -L provides an interface to the SDL_Palette structures, +L provides an interface to the C structures, and can be used to set the color values of an existing palette's indexes. =head1 METHODS -=head2 blue ( index, [value] ) - -Fetches and sets the blue component of the color at index. +=head2 ncolors ( ) -=head2 green ( index, [value] ) +Fetches the number of colors in palette -Fetches and sets the green component of the color at index. +=head2 colors ( index ) -=head2 red ( index, [value] ) +Fetches an array of colors in palette -Fetches and sets the red component of the color at index. +=head2 color_index ( index ) -=head2 color ( index, [ r, g, b ] ) - -Fetches and sets the RGB, returns an SDL_Color *. +Fetches the SDL_Color at the provide index in palette =head2 size Returns the size of the palette. -=head1 AUTHOR - -David J. Goehrig =head1 SEE ALSO -L L L +L L =cut diff --git a/lib/SDL/PixelFormat.pm b/lib/SDL/PixelFormat.pm index 4795c43..a69f3d2 100644 --- a/lib/SDL/PixelFormat.pm +++ b/lib/SDL/PixelFormat.pm @@ -30,6 +30,11 @@ An C stores surface format information =head1 METHODS +=head2 palette + + $surface->format->palette; + +Returns the C and L of the format of the surface. =head2 BitsPerPixel diff --git a/src/Core/objects/Palette.xs b/src/Core/objects/Palette.xs index 3177b02..ce69ba2 100644 --- a/src/Core/objects/Palette.xs +++ b/src/Core/objects/Palette.xs @@ -46,7 +46,7 @@ palette_colors ( palette ) SDL_Color * -palette_colors_index ( palette, index ) +palette_color_index ( palette, index ) SDL_Palette *palette int index PREINIT: diff --git a/src/Core/objects/PixelFormat.xs b/src/Core/objects/PixelFormat.xs index 76ab6d1..a463c3d 100644 --- a/src/Core/objects/PixelFormat.xs +++ b/src/Core/objects/PixelFormat.xs @@ -27,6 +27,17 @@ SDL_PixelFormat -- Stores surface format information =cut +SDL_Palette* +pixelformat_palette( pixelformat ) + SDL_PixelFormat *pixelformat + PREINIT: + char* CLASS = "SDL::Palette"; + CODE: + RETVAL = pixelformat->palette; + OUTPUT: + RETVAL + + Uint8 pixelformat_BitsPerPixel( pixelformat ) SDL_PixelFormat *pixelformat diff --git a/t/core_palette.t b/t/core_palette.t new file mode 100644 index 0000000..a3a16ff --- /dev/null +++ b/t/core_palette.t @@ -0,0 +1,31 @@ +#!perl +use strict; +use warnings; +use Test::More tests => 999999999; +use_ok('SDL::Palette'); + +can_ok('SDL::Palette', qw/ ncolors colors color_index /); + +use SDL; +use SDL::Surface; +use SDL::PixelFormat; + +SDL::Init(SDL_INIT_VIDEO); + +my $display = SDL::SetVideoMode(640,480,32, SDL_SWSURFACE ); + +isa_ok($display->format, 'SDL::PixelFormat', 'Are we a SDL::PixelFormat?'); + +is( !defined $display->format->palette , 1, 'Palette is not defined as BitPerPixels is greater then 8'); + +$display = SDL::SetVideoMode(640,480,8, SDL_SWSURFACE ); +isa_ok($display->format, 'SDL::PixelFormat', 'Are we a SDL::PixelFormat?'); + +isa_ok( $display->format->palette , 'SDL::Palette', 'Palette is SDL::Palette when BitPerPixels is 8 '); + +is( $display->format->palette->ncolors, 256, '256 colors in palette'); + +isa_ok( $display->format->palette->colors(), 'ARRAY', 'Palette->colors[x] is a color'); + +isa_ok( $display->format->palette->color_index(23), 'SDL::Color', 'Palette->color_index() is a SDL::Color'); + diff --git a/t/palettepm.t b/t/palettepm.t index 3cc9cfc..e4ab803 100644 --- a/t/palettepm.t +++ b/t/palettepm.t @@ -41,9 +41,9 @@ use Test::More; plan ( tests => 2 ); -use_ok( 'SDL::Palette' ); +use_ok( 'SDL::Game::Palette' ); -can_ok ('SDL::Palette', qw/ +can_ok ('SDL::Game::Palette', qw/ new size red