Commit | Line | Data |
7b6a53a1 |
1 | #!/usr/bin/env perl |
8fde61e3 |
2 | # |
7b6a53a1 |
3 | # Color.pm |
4 | # |
5 | # Copyright (C) 2005 David J. Goehrig <dgoehrig@cpan.org> |
6 | # |
7 | # ------------------------------------------------------------------------------ |
8 | # |
9 | # This library is free software; you can redistribute it and/or |
10 | # modify it under the terms of the GNU Lesser General Public |
11 | # License as published by the Free Software Foundation; either |
12 | # version 2.1 of the License, or (at your option) any later version. |
13 | # |
14 | # This library is distributed in the hope that it will be useful, |
15 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
16 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
17 | # Lesser General Public License for more details. |
18 | # |
19 | # You should have received a copy of the GNU Lesser General Public |
20 | # License along with this library; if not, write to the Free Software |
21 | # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
22 | # |
23 | # ------------------------------------------------------------------------------ |
24 | # |
25 | # Please feel free to send questions, suggestions or improvements to: |
26 | # |
27 | # David J. Goehrig |
28 | # dgoehrig@cpan.org |
8fde61e3 |
29 | # |
8fde61e3 |
30 | |
31 | package SDL::Color; |
32 | |
33 | use strict; |
084b921f |
34 | use warnings; |
35 | use Carp; |
8fde61e3 |
36 | use SDL; |
37 | |
38 | sub new { |
39 | my $proto = shift; |
40 | my $class = ref($proto) || $proto; |
45f73689 |
41 | return bless \SDL::NewColor(@_), $class if (@_ == 3); |
7b6a53a1 |
42 | |
45f73689 |
43 | my $self; |
44 | |
8fde61e3 |
45 | my (%options) = @_; |
46 | |
47 | verify (%options, qw/ -color -surface -pixel -r -g -b /) if $SDL::DEBUG; |
48 | |
49 | if ($options{-color}) { |
50 | $self = \$options{-color}; |
51 | } elsif ($options{-pixel} && $options{-surface}) { |
084b921f |
52 | croak "SDL::Color::new requires an SDL::Surface" |
8fde61e3 |
53 | unless !$SDL::DEBUG || $options{-surface}->isa("SDL::Surface"); |
54 | $self = \SDL::NewColor(SDL::GetRGB(${$options{-surface}}, $options{-pixel})); |
55 | } else { |
56 | my @color; |
57 | push @color, $options{-red} || $options{-r} || 0; |
58 | push @color, $options{-green} || $options{-g} || 0; |
59 | push @color, $options{-blue} || $options{-b} || 0; |
60 | $self = \SDL::NewColor(@color); |
61 | } |
084b921f |
62 | croak "Could not create color, ", SDL::GetError(), "\n" |
8fde61e3 |
63 | unless ($$self); |
7b6a53a1 |
64 | bless $self,$class; |
65 | return $self; |
8fde61e3 |
66 | } |
67 | |
68 | sub DESTROY { |
69 | SDL::FreeColor(${$_[0]}); |
70 | } |
71 | |
72 | sub r { |
73 | my $self = shift; |
74 | SDL::ColorR($$self,@_); |
75 | } |
76 | |
77 | sub g { |
78 | my $self = shift; |
79 | SDL::ColorG($$self,@_); |
80 | } |
81 | |
82 | sub b { |
83 | my $self = shift; |
84 | SDL::ColorB($$self,@_); |
85 | } |
86 | |
45f73689 |
87 | sub rgb { |
88 | my $self = shift; |
89 | SDL::ColorRGB($$self,@_); |
90 | } |
91 | |
8fde61e3 |
92 | sub pixel { |
084b921f |
93 | croak "SDL::Color::pixel requires an SDL::Surface" |
8fde61e3 |
94 | unless !$SDL::DEBUG || $_[1]->isa("SDL::Surface"); |
95 | SDL::MapRGB(${$_[1]},$_[0]->r(),$_[0]->g(),$_[0]->b()); |
96 | } |
97 | |
7b6a53a1 |
98 | $SDL::Color::black = new SDL::Color -r => 0, -g => 0, -b => 0; |
99 | $SDL::Color::white = new SDL::Color -r => 255, -g => 255, -b => 255; |
100 | $SDL::Color::red = new SDL::Color -r => 255, -g => 0, -b => 0; |
101 | $SDL::Color::blue = new SDL::Color -r => 0, -g => 0, -b => 255; |
102 | $SDL::Color::green = new SDL::Color -r => 0, -g => 255, -b => 0; |
103 | $SDL::Color::purple = new SDL::Color -r => 255, -g => 0, -b => 255; |
104 | $SDL::Color::yellow = new SDL::Color -r => 255, -g => 255, -b => 0; |
8fde61e3 |
105 | |
106 | 1; |
107 | |
108 | __END__; |
109 | |
110 | =pod |
111 | |
112 | =head1 NAME |
113 | |
114 | SDL::Color - a SDL perl extension |
115 | |
116 | =head1 SYNOPSIS |
117 | |
118 | $color = new SDL::Color ( -r => 0xde, -g => 0xad, -b =>c0 ); |
119 | $color = new SDL::Color -surface => $app, -pixel => $app->pixel($x,$y); |
120 | $color = new SDL::Color -color => SDL::NewColor(0xff,0xaa,0xdd); |
121 | |
122 | =head1 DESCRIPTION |
123 | |
124 | C<SDL::Color> is a wrapper for display format independent color |
7b6a53a1 |
125 | representations, with the same interface as L<SDL::Color>. |
8fde61e3 |
126 | |
127 | =head2 new ( -color => ) |
128 | |
129 | C<SDL::Color::new> with a C<-color> option will construct a new object |
130 | referencing the passed SDL_Color*. |
131 | |
132 | =head2 new (-r => , -g => , -b => ) |
133 | |
134 | C<SDL::Color::new> with C<-r,-g,-b> options will construct both a SDL_Color |
135 | structure, and the associated object with the specified vales. |
136 | |
137 | =head2 new (-pixel =>, -surface =>) |
138 | |
139 | C<SDL::Color::new> with C<-pixel,-surface> options will generate a SDL_Color* |
140 | with the r,g,b values associated with the integer value passed by C<-pixel> |
141 | for the given C<-surface>'s format. |
142 | |
143 | =head2 r ( [ red ] ), g( [ green ] ), b( [ blue ] ) |
144 | |
145 | C<SDL::Color::r, SDL::Color::g, SDL::Color::b> are accessor methods for |
146 | the red, green, and blue components respectively. The color value can be set |
147 | by passing a byte value (0-255) to each function. |
148 | |
149 | =head2 pixel ( surface ) |
150 | |
151 | C<SDL::Color::pixel> takes a C<SDL::Surface> object and r,g,b values, and |
152 | returns the integer representation of the closest color for the given surface. |
153 | |
154 | =head1 AUTHOR |
155 | |
156 | David J. Goehrig |
157 | |
158 | =head1 SEE ALSO |
159 | |
7b6a53a1 |
160 | L<perl> L<SDL::Surface> |
8fde61e3 |
161 | |
162 | =cut |