line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package SDLx::Surface; |
2
|
10
|
|
|
10
|
|
1570
|
use strict; |
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
306
|
|
3
|
10
|
|
|
10
|
|
55
|
use warnings; |
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
324
|
|
4
|
10
|
|
|
10
|
|
147
|
use vars qw(@ISA @EXPORT @EXPORT_OK); |
|
10
|
|
|
|
|
24
|
|
|
10
|
|
|
|
|
710
|
|
5
|
|
|
|
|
|
|
require Exporter; |
6
|
|
|
|
|
|
|
require DynaLoader; |
7
|
10
|
|
|
10
|
|
69
|
use Carp (); |
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
216
|
|
8
|
10
|
|
|
10
|
|
138
|
use SDL; |
|
10
|
|
|
|
|
29
|
|
|
10
|
|
|
|
|
788
|
|
9
|
10
|
|
|
10
|
|
512
|
use SDL::Rect; |
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
1719
|
|
10
|
10
|
|
|
10
|
|
871
|
use SDL::Video; |
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
4227
|
|
11
|
10
|
|
|
10
|
|
3031
|
use SDL::Image; |
|
10
|
|
|
|
|
28
|
|
|
10
|
|
|
|
|
547
|
|
12
|
10
|
|
|
10
|
|
2067
|
use SDL::Color; |
|
10
|
|
|
|
|
22
|
|
|
10
|
|
|
|
|
2653
|
|
13
|
10
|
|
|
10
|
|
1705
|
use SDL::Config; |
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
264
|
|
14
|
10
|
|
|
10
|
|
70
|
use SDL::Surface; |
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
1960
|
|
15
|
10
|
|
|
10
|
|
65
|
use SDL::PixelFormat; |
|
10
|
|
|
|
|
22
|
|
|
10
|
|
|
|
|
2569
|
|
16
|
|
|
|
|
|
|
|
17
|
10
|
|
|
10
|
|
3470
|
use SDL::GFX::Primitives; |
|
10
|
|
|
|
|
36
|
|
|
10
|
|
|
|
|
564
|
|
18
|
|
|
|
|
|
|
|
19
|
10
|
|
|
10
|
|
4542
|
use Tie::Simple; |
|
10
|
|
|
|
|
100415
|
|
|
10
|
|
|
|
|
279
|
|
20
|
10
|
|
|
10
|
|
3761
|
use SDLx::Validate; |
|
10
|
|
|
|
|
24
|
|
|
10
|
|
|
|
|
376
|
|
21
|
10
|
|
|
10
|
|
3832
|
use SDLx::Surface::TiedMatrix; |
|
10
|
|
|
|
|
28
|
|
|
10
|
|
|
|
|
410
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our $VERSION = 2.548; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
use overload ( |
26
|
10
|
|
|
|
|
71
|
'@{}' => '_array', |
27
|
|
|
|
|
|
|
fallback => 1, |
28
|
10
|
|
|
10
|
|
61
|
); |
|
10
|
|
|
|
|
20
|
|
29
|
10
|
|
|
10
|
|
777
|
use SDL::Constants ':SDL::Video'; |
|
10
|
|
|
|
|
18
|
|
|
10
|
|
|
|
|
3854
|
|
30
|
|
|
|
|
|
|
our @ISA = qw(Exporter DynaLoader SDL::Surface); |
31
|
|
|
|
|
|
|
|
32
|
10
|
|
|
10
|
|
68
|
use SDL::Internal::Loader; |
|
10
|
|
|
|
|
27
|
|
|
10
|
|
|
|
|
25185
|
|
33
|
|
|
|
|
|
|
internal_load_dlls(__PACKAGE__); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
bootstrap SDLx::Surface; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# I won't use a module here for efficiency and simplification of the |
38
|
|
|
|
|
|
|
# hierarchy. |
39
|
|
|
|
|
|
|
# Inside out object |
40
|
|
|
|
|
|
|
my %_tied_array; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub new { |
43
|
40
|
|
|
40
|
0
|
3527
|
my ( $class, %options ) = @_; |
44
|
40
|
|
|
|
|
68
|
my $self; |
45
|
|
|
|
|
|
|
|
46
|
40
|
100
|
|
|
|
104
|
if ( $options{surface} ) { |
47
|
32
|
|
|
|
|
62
|
$self = bless $options{surface}, $class; |
48
|
|
|
|
|
|
|
} else { |
49
|
8
|
|
66
|
|
|
34
|
my $width = $options{width} || $options{w}; |
50
|
8
|
|
66
|
|
|
29
|
my $height = $options{height} || $options{h}; |
51
|
8
|
50
|
33
|
|
|
51
|
if ( $width and $height ) #atleast give a dimension |
52
|
|
|
|
|
|
|
{ |
53
|
8
|
|
100
|
|
|
58
|
$options{flags} ||= SDL_ANYFORMAT; |
54
|
8
|
|
100
|
|
|
34
|
$options{depth} ||= 32; |
55
|
|
|
|
|
|
|
|
56
|
8
|
|
50
|
|
|
41
|
$options{redmask} ||= 0xFF000000; |
57
|
8
|
|
100
|
|
|
37
|
$options{greenmask} ||= 0x00FF0000; |
58
|
8
|
|
50
|
|
|
37
|
$options{bluemask} ||= 0x0000FF00; |
59
|
8
|
|
50
|
|
|
48
|
$options{alphamask} ||= 0x000000FF; |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
$self = bless SDL::Surface->new( |
62
|
|
|
|
|
|
|
$options{flags}, $width, $height, |
63
|
|
|
|
|
|
|
$options{depth}, $options{redmask}, $options{greenmask}, |
64
|
|
|
|
|
|
|
$options{bluemask}, $options{alphamask} |
65
|
8
|
|
|
|
|
1517
|
), $class; |
66
|
|
|
|
|
|
|
} else { |
67
|
0
|
|
|
|
|
0
|
Carp::confess 'Provide surface, or atleast width and height'; |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
} |
70
|
40
|
100
|
|
|
|
107
|
if ( exists $options{color} ) { |
71
|
1
|
|
|
|
|
8
|
$self->draw_rect( undef, $options{color} ); |
72
|
|
|
|
|
|
|
} |
73
|
40
|
|
|
|
|
197
|
return $self; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub display { |
77
|
1
|
|
|
1
|
0
|
2833
|
my $disp = SDL::Video::get_video_surface; |
78
|
1
|
50
|
|
|
|
15
|
return SDLx::Surface->new( surface => $disp ) if $disp; |
79
|
0
|
|
|
|
|
0
|
my %options = @_; |
80
|
|
|
|
|
|
|
|
81
|
0
|
|
0
|
|
|
0
|
my $width = $options{width} || $options{w}; |
82
|
0
|
|
0
|
|
|
0
|
my $height = $options{height} || $options{h}; |
83
|
0
|
0
|
0
|
|
|
0
|
if ( $width and $height ) #atleast give a dimension |
84
|
|
|
|
|
|
|
{ |
85
|
0
|
|
0
|
|
|
0
|
$options{depth} ||= 32; |
86
|
0
|
|
0
|
|
|
0
|
$options{flags} ||= SDL_ANYFORMAT; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my $surface = SDL::Video::set_video_mode( |
89
|
|
|
|
|
|
|
$width, $height, $options{depth}, |
90
|
|
|
|
|
|
|
$options{flags}, |
91
|
0
|
|
|
|
|
0
|
); |
92
|
0
|
|
|
|
|
0
|
return SDLx::Surface->new( surface => $surface ); |
93
|
|
|
|
|
|
|
} else { |
94
|
0
|
|
|
|
|
0
|
Carp::confess 'set_video_mode externally or atleast provide width and height'; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
sub duplicate { |
100
|
1
|
|
|
1
|
0
|
525
|
my $surface = shift; |
101
|
1
|
|
|
|
|
7
|
SDLx::Validate::surface($surface); |
102
|
1
|
|
|
|
|
41
|
return SDLx::Surface->new( |
103
|
|
|
|
|
|
|
width => $surface->w, |
104
|
|
|
|
|
|
|
height => $surface->h, |
105
|
|
|
|
|
|
|
depth => $surface->format->BitsPerPixel, |
106
|
|
|
|
|
|
|
flags => $surface->flags |
107
|
|
|
|
|
|
|
); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
### Overloads |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub _tied_array { |
114
|
79
|
|
|
79
|
|
170
|
my ( $self, $array ) = @_; |
115
|
79
|
100
|
|
|
|
216
|
if ($array) { |
116
|
5
|
50
|
|
|
|
16
|
$_tied_array{$$self} = $array if $array; |
117
|
|
|
|
|
|
|
} |
118
|
79
|
|
|
|
|
211
|
return $_tied_array{$$self}; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub get_pixel { |
122
|
60
|
|
|
60
|
0
|
102
|
my ( $self, $y, $x ) = @_; |
123
|
60
|
|
|
|
|
299
|
return SDLx::Surface::get_pixel_xs( $self, $x, $y ); |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub set_pixel { |
127
|
6
|
|
|
6
|
0
|
12
|
my ( $self, $y, $x, $new_value ) = @_; |
128
|
|
|
|
|
|
|
|
129
|
6
|
|
|
|
|
22
|
$new_value = SDLx::Validate::num_rgba($new_value); |
130
|
|
|
|
|
|
|
|
131
|
6
|
|
|
|
|
29
|
SDLx::Surface::set_pixel_xs( $self, $x, $y, $new_value ); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
sub _array { |
135
|
74
|
|
|
74
|
|
3973
|
my $self = shift; |
136
|
|
|
|
|
|
|
|
137
|
74
|
|
|
|
|
163
|
my $array = $self->_tied_array; |
138
|
|
|
|
|
|
|
|
139
|
74
|
100
|
|
|
|
171
|
unless ($array) { |
140
|
5
|
|
|
|
|
31
|
tie my @array, 'SDLx::Surface::TiedMatrix', $self; |
141
|
5
|
|
|
|
|
10
|
$array = \@array; |
142
|
5
|
|
|
|
|
14
|
$self->_tied_array($array); |
143
|
|
|
|
|
|
|
} |
144
|
74
|
|
|
|
|
376
|
return $array; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
#ATTRIBUTE |
148
|
|
|
|
|
|
|
|
149
|
47
|
|
|
47
|
0
|
82174
|
sub surface { $_[0] } |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
0
|
0
|
0
|
sub width { $_[0]->w } |
152
|
0
|
|
|
0
|
0
|
0
|
sub height { $_[0]->h } |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
#WRAPPING |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub clip_rect { |
157
|
|
|
|
|
|
|
|
158
|
0
|
0
|
0
|
0
|
0
|
0
|
SDL::Video::set_clip_rect( $_[1] ) if $_[1] && $_[1]->isa('SDL::Rect'); |
159
|
0
|
|
|
|
|
0
|
SDL::Video::get_clip_rect( $_[0] ); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
sub load { |
164
|
11
|
|
|
11
|
0
|
27
|
my ( $self, $filename, $type ) = @_; |
165
|
11
|
|
|
|
|
16
|
my $surface; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# short-circuit if it's a bitmap |
168
|
11
|
50
|
33
|
|
|
73
|
if ( ( $type and lc $type eq 'bmp' ) |
|
|
|
33
|
|
|
|
|
169
|
|
|
|
|
|
|
or lc substr( $filename, -4, 4 ) eq '.bmp' ) |
170
|
|
|
|
|
|
|
{ |
171
|
11
|
50
|
|
|
|
1318
|
$surface = SDL::Video::load_BMP($filename) |
172
|
|
|
|
|
|
|
or Carp::confess "error loading image $filename: " . SDL::get_error; |
173
|
|
|
|
|
|
|
} else { |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# otherwise, make sure we can load first |
176
|
|
|
|
|
|
|
#eval { require SDL::Image; 1 }; This doesn't work. As you can still load SDL::Image but can't call any functions. |
177
|
|
|
|
|
|
|
# |
178
|
0
|
0
|
|
|
|
0
|
Carp::confess 'no SDL_image support found. Can only load bitmaps' |
179
|
|
|
|
|
|
|
unless SDL::Config->has('SDL_image'); #this checks if we actually have that library. C Library != SDL::Image |
180
|
|
|
|
|
|
|
|
181
|
0
|
|
|
|
|
0
|
require SDL::Image; |
182
|
|
|
|
|
|
|
|
183
|
0
|
0
|
|
|
|
0
|
if ($type) { #I don't understand what you are doing here |
184
|
0
|
|
|
|
|
0
|
require SDL::RWOps; |
185
|
0
|
0
|
|
|
|
0
|
my $file = SDL::RWOps->new_file( $filename, "rb" ) |
186
|
|
|
|
|
|
|
or Carp::confess "error loading file $filename: " . SDL::get_error; |
187
|
0
|
0
|
|
|
|
0
|
$surface = SDL::Image::load_typed_rw( $file, 1, $type ) |
188
|
|
|
|
|
|
|
or Carp::confess "error loading image $file: " . SDL::get_error; |
189
|
|
|
|
|
|
|
} else { |
190
|
0
|
0
|
|
|
|
0
|
$surface = SDL::Image::load($filename) |
191
|
|
|
|
|
|
|
or Carp::confess "error loading image $filename: " . SDL::get_error; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
11
|
|
|
|
|
31
|
my $formated_surface = $surface; |
196
|
11
|
50
|
|
|
|
37
|
if( SDL::Video::get_video_surface ) |
197
|
|
|
|
|
|
|
{ |
198
|
|
|
|
|
|
|
#Reduces memory usage for loaded images |
199
|
11
|
|
|
|
|
1888
|
$formated_surface = SDL::Video::display_format_alpha($surface); |
200
|
|
|
|
|
|
|
} |
201
|
11
|
|
|
|
|
77
|
return SDLx::Surface->new( surface => $formated_surface ); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
#EXTENSTIONS |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub blit_by { |
207
|
1
|
|
|
1
|
0
|
3
|
my ( $dest, $src, $src_rect, $dest_rect ) = @_; |
208
|
1
|
|
|
|
|
1217
|
SDLx::Surface::blit( $src, $dest, $src_rect, $dest_rect ); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub flip { |
212
|
1
|
50
|
|
1
|
0
|
2758
|
Carp::confess "surface is not defined" unless $_[0]; |
213
|
1
|
50
|
|
|
|
7
|
Carp::confess "Error flipping surface: " . SDL::get_error() |
214
|
|
|
|
|
|
|
if ( SDL::Video::flip( $_[0] ) == -1 ); |
215
|
1
|
|
|
|
|
3
|
return $_[0]; |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub update { |
220
|
3
|
|
|
3
|
0
|
1023
|
my ( $surface, $rects ) = @_; |
221
|
|
|
|
|
|
|
|
222
|
3
|
100
|
66
|
|
|
21
|
if ( !defined($rects) || ( ref($rects) eq 'ARRAY' && !ref( $rects->[0] ) ) ) { |
|
|
|
100
|
|
|
|
|
223
|
2
|
|
|
|
|
2
|
my @rect; |
224
|
2
|
100
|
|
|
|
6
|
@rect = @{$rects} if $rects; |
|
1
|
|
|
|
|
2
|
|
225
|
2
|
|
50
|
|
|
8
|
$rect[0] ||= 0; |
226
|
2
|
|
100
|
|
|
7
|
$rect[1] ||= 0; |
227
|
2
|
|
66
|
|
|
9
|
$rect[2] ||= $surface->w; |
228
|
2
|
|
66
|
|
|
6
|
$rect[3] ||= $surface->h; |
229
|
|
|
|
|
|
|
|
230
|
2
|
|
|
|
|
7
|
SDL::Video::update_rect( $surface, @rect ); |
231
|
|
|
|
|
|
|
} else { |
232
|
1
|
|
|
|
|
2
|
SDL::Video::update_rects( $surface, map { SDLx::Validate::rect($_) } @{$rects} ); |
|
2
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
3
|
|
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
3
|
|
|
|
|
5
|
return $surface; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub draw_line { |
239
|
6
|
|
|
6
|
0
|
28
|
my ( $self, $start, $end, $color, $antialias ) = @_; |
240
|
|
|
|
|
|
|
|
241
|
6
|
50
|
|
|
|
21
|
Carp::confess "Error start needs an array ref [x,y]" |
242
|
|
|
|
|
|
|
unless ref($start) eq 'ARRAY'; |
243
|
6
|
50
|
|
|
|
18
|
Carp::confess "Error end needs an array ref [x,y]" |
244
|
|
|
|
|
|
|
unless ref($end) eq 'ARRAY'; |
245
|
|
|
|
|
|
|
|
246
|
6
|
50
|
|
|
|
21
|
unless ( SDL::Config->has('SDL_gfx_primitives') ) { |
247
|
0
|
|
|
|
|
0
|
Carp::cluck("SDL_gfx_primitives support has not been compiled"); |
248
|
0
|
|
|
|
|
0
|
return; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
6
|
|
|
|
|
32
|
$color = SDLx::Validate::num_rgba($color); |
252
|
|
|
|
|
|
|
|
253
|
6
|
|
|
|
|
15
|
my $result; |
254
|
6
|
100
|
|
|
|
14
|
if ($antialias) { |
255
|
2
|
|
|
|
|
14
|
$result = SDL::GFX::Primitives::aaline_color( $self, @$start, @$end, $color ); |
256
|
|
|
|
|
|
|
} else { |
257
|
4
|
|
|
|
|
24
|
$result = SDL::GFX::Primitives::line_color( $self, @$start, @$end, $color ); |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
6
|
50
|
|
|
|
31
|
Carp::confess "Error drawing line: " . SDL::get_error() if ( $result == -1 ); |
261
|
|
|
|
|
|
|
|
262
|
6
|
|
|
|
|
21
|
return $self; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub draw_circle { |
266
|
9
|
|
|
9
|
0
|
1711
|
my ( $self, $center, $radius, $color, $antialias ) = @_; |
267
|
|
|
|
|
|
|
|
268
|
9
|
50
|
|
|
|
36
|
unless ( SDL::Config->has('SDL_gfx_primitives') ) { |
269
|
0
|
|
|
|
|
0
|
Carp::cluck("SDL_gfx_primitives support has not been compiled"); |
270
|
0
|
|
|
|
|
0
|
return; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
9
|
50
|
33
|
|
|
62
|
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 ); |
274
|
9
|
|
|
|
|
51
|
$color = SDLx::Validate::num_rgba($color); |
275
|
|
|
|
|
|
|
|
276
|
9
|
100
|
|
|
|
33
|
unless( $antialias ) |
277
|
|
|
|
|
|
|
{ |
278
|
5
|
|
|
|
|
11
|
SDL::GFX::Primitives::circle_color( $self, @{$center}, $radius, $color ); |
|
5
|
|
|
|
|
67
|
|
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
else |
281
|
|
|
|
|
|
|
{ |
282
|
4
|
|
|
|
|
9
|
SDL::GFX::Primitives::aacircle_color( $self, @{$center}, $radius, $color ); |
|
4
|
|
|
|
|
142
|
|
283
|
|
|
|
|
|
|
} |
284
|
9
|
|
|
|
|
52
|
return $self; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub draw_circle_filled { |
288
|
4
|
|
|
4
|
0
|
13
|
my ( $self, $center, $radius, $color) = @_; |
289
|
|
|
|
|
|
|
|
290
|
4
|
50
|
|
|
|
16
|
unless ( SDL::Config->has('SDL_gfx_primitives') ) { |
291
|
0
|
|
|
|
|
0
|
Carp::cluck("SDL_gfx_primitives support has not been compiled"); |
292
|
0
|
|
|
|
|
0
|
return; |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
4
|
50
|
33
|
|
|
31
|
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 ); |
296
|
4
|
|
|
|
|
24
|
$color = SDLx::Validate::num_rgba($color); |
297
|
|
|
|
|
|
|
|
298
|
4
|
|
|
|
|
13
|
SDL::GFX::Primitives::filled_circle_color( $self, @{$center}, $radius, $color ); |
|
4
|
|
|
|
|
55
|
|
299
|
|
|
|
|
|
|
|
300
|
4
|
|
|
|
|
13
|
return $self; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
sub draw_trigon { |
304
|
9
|
|
|
9
|
0
|
2238
|
my ( $self, $vertices, $color, $antialias ) = @_; |
305
|
|
|
|
|
|
|
|
306
|
9
|
|
|
|
|
49
|
$color = SDLx::Validate::num_rgba($color); |
307
|
|
|
|
|
|
|
|
308
|
9
|
100
|
|
|
|
33
|
if ($antialias) { |
309
|
4
|
|
|
|
|
36
|
SDL::GFX::Primitives::aatrigon_color( $self, $vertices->[0][0], $vertices->[0][1], $vertices->[1][0], $vertices->[1][1], $vertices->[2][0], $vertices->[2][1], $color ); |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
else |
312
|
|
|
|
|
|
|
{ |
313
|
5
|
|
|
|
|
39
|
SDL::GFX::Primitives::trigon_color( $self, $vertices->[0][0], $vertices->[0][1], $vertices->[1][0], $vertices->[1][1], $vertices->[2][0], $vertices->[2][1], $color ); |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
9
|
|
|
|
|
33
|
return $self; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub draw_trigon_filled { |
320
|
5
|
|
|
5
|
0
|
14
|
my ( $self, $vertices, $color ) = @_; |
321
|
|
|
|
|
|
|
|
322
|
5
|
|
|
|
|
24
|
$color = SDLx::Validate::num_rgba($color); |
323
|
|
|
|
|
|
|
|
324
|
5
|
|
|
|
|
52
|
SDL::GFX::Primitives::filled_trigon_color( $self, $vertices->[0][0], $vertices->[0][1], $vertices->[1][0], $vertices->[1][1], $vertices->[2][0], $vertices->[2][1], $color ); |
325
|
|
|
|
|
|
|
|
326
|
5
|
|
|
|
|
17
|
return $self; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
sub draw_polygon_filled { |
330
|
5
|
|
|
5
|
0
|
1450
|
my ( $self, $vertices, $color ) = @_; |
331
|
|
|
|
|
|
|
|
332
|
5
|
|
|
|
|
30
|
$color = SDLx::Validate::num_rgba($color); |
333
|
|
|
|
|
|
|
|
334
|
5
|
|
|
|
|
19
|
my @vx = map { $_->[0] } @$vertices; |
|
3
|
|
|
|
|
11
|
|
335
|
5
|
|
|
|
|
11
|
my @vy = map { $_->[1] } @$vertices; |
|
3
|
|
|
|
|
8
|
|
336
|
5
|
|
|
|
|
32
|
SDL::GFX::Primitives::filled_polygon_color( $self, \@vx, \@vy, scalar @$vertices, $color ); |
337
|
|
|
|
|
|
|
|
338
|
5
|
|
|
|
|
23
|
return $self; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub draw_arc { |
342
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $center, $radius, $start, $end, $color ) = @_; |
343
|
|
|
|
|
|
|
|
344
|
0
|
0
|
0
|
|
|
0
|
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 ); |
345
|
0
|
|
|
|
|
0
|
$color = SDLx::Validate::num_rgba($color); |
346
|
|
|
|
|
|
|
|
347
|
0
|
|
|
|
|
0
|
SDL::GFX::Primitives::arc_color( $self, @$center, $radius, $start, $end, $color ); |
348
|
|
|
|
|
|
|
|
349
|
0
|
|
|
|
|
0
|
return $self; |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
sub draw_ellipse { |
353
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $center, $rx, $ry, $color, $antialias ) = @_; |
354
|
|
|
|
|
|
|
|
355
|
0
|
0
|
0
|
|
|
0
|
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 ); |
356
|
0
|
|
|
|
|
0
|
$color = SDLx::Validate::num_rgba($color); |
357
|
|
|
|
|
|
|
|
358
|
0
|
0
|
|
|
|
0
|
if ($antialias) |
359
|
|
|
|
|
|
|
{ |
360
|
0
|
|
|
|
|
0
|
SDL::GFX::Primitives::aaellipse_color( $self, @$center, $rx, $ry, $color ); |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
else |
363
|
|
|
|
|
|
|
{ |
364
|
0
|
|
|
|
|
0
|
SDL::GFX::Primitives::ellipse_color( $self, @$center, $rx, $ry, $color ); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
0
|
|
|
|
|
0
|
return $self; |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
sub draw_ellipse_filled { |
371
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $center, $rx, $ry, $color ) = @_; |
372
|
|
|
|
|
|
|
|
373
|
0
|
0
|
0
|
|
|
0
|
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 ); |
374
|
0
|
|
|
|
|
0
|
$color = SDLx::Validate::num_rgba($color); |
375
|
|
|
|
|
|
|
|
376
|
0
|
|
|
|
|
0
|
SDL::GFX::Primitives::filled_ellipse_color( $self, @$center, $rx, $ry, $color ); |
377
|
|
|
|
|
|
|
|
378
|
0
|
|
|
|
|
0
|
return $self; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
sub draw_bezier { |
382
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $vector, $smooth, $color ) = @_; |
383
|
|
|
|
|
|
|
|
384
|
0
|
|
|
|
|
0
|
$color = SDLx::Validate::num_rgba($color); |
385
|
|
|
|
|
|
|
|
386
|
0
|
|
|
|
|
0
|
my @vx = map { $_->[0] } @$vector; |
|
0
|
|
|
|
|
0
|
|
387
|
0
|
|
|
|
|
0
|
my @vy = map { $_->[1] } @$vector; |
|
0
|
|
|
|
|
0
|
|
388
|
0
|
|
|
|
|
0
|
SDL::GFX::Primitives::bezier_color( $self, \@vx, \@vy, scalar @$vector, $smooth, $color ); |
389
|
|
|
|
|
|
|
|
390
|
0
|
|
|
|
|
0
|
return $self; |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
sub draw_gfx_text { |
394
|
3
|
|
|
3
|
0
|
11
|
my ( $self, $vector, $color, $text, $font ) = @_; |
395
|
|
|
|
|
|
|
|
396
|
3
|
50
|
|
|
|
17
|
unless ( SDL::Config->has('SDL_gfx_primitives') ) { |
397
|
0
|
|
|
|
|
0
|
Carp::cluck("SDL_gfx_primitives support has not been compiled"); |
398
|
0
|
|
|
|
|
0
|
return; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
3
|
100
|
|
|
|
12
|
if ($font) { |
402
|
1
|
50
|
33
|
|
|
21
|
if ( ref($font) eq 'HASH' && exists $font->{data} && exists $font->{cw} && exists $font->{ch} ) { |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
403
|
1
|
|
|
|
|
10
|
SDL::GFX::Primitives::set_font( $font->{data}, $font->{cw}, $font->{ch} ); |
404
|
|
|
|
|
|
|
} else { |
405
|
0
|
|
|
|
|
0
|
Carp::cluck |
406
|
|
|
|
|
|
|
"Set font data as a hash of type \n \$font = {data => \$data, cw => \$cw, ch => \$ch}. \n Refer to perldoc SDL::GFX::Primitives set_font for initializing this variables."; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
} |
409
|
3
|
50
|
33
|
|
|
24
|
Carp::confess "vector needs to be an array ref of size 2. [x,y] " |
410
|
|
|
|
|
|
|
unless ( ref($vector) eq 'ARRAY' && scalar(@$vector) == 2 ); |
411
|
|
|
|
|
|
|
|
412
|
3
|
|
|
|
|
16
|
$color = SDLx::Validate::num_rgba($color); |
413
|
|
|
|
|
|
|
|
414
|
3
|
|
|
|
|
95
|
my $result = SDL::GFX::Primitives::string_color( $self, $vector->[0], $vector->[1], $text, $color ); |
415
|
|
|
|
|
|
|
|
416
|
3
|
50
|
|
|
|
13
|
Carp::confess "Error drawing text: " . SDL::get_error() if ( $result == -1 ); |
417
|
|
|
|
|
|
|
|
418
|
3
|
|
|
|
|
10
|
return $self; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
sub DESTROY { |
422
|
23
|
|
|
23
|
|
4204
|
my $self = shift; |
423
|
23
|
|
|
|
|
101
|
delete $_tied_array{$$self}; |
424
|
23
|
|
|
|
|
762
|
SDL::Surface::DESTROY($self); |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
1; |