lib/SDL/Surface.pm

   1 package SDL::Surface;
   2 use strict;
   3 use warnings;
   4 require Exporter;
   5 require DynaLoader;
   6 our @ISA = qw(Exporter DynaLoader);
   7 bootstrap SDL::Surface;
   8
   9 1;
  10
  11 __END__
  12
  13 #!/usr/bin/env perl
  14 #
  15 # Surface.pm
  16 #
  17 # Copyright (C) 2005 David J. Goehrig <dgoehrig@cpan.org>
  18 #
  19 # ------------------------------------------------------------------------------
  20 #
  21 # This library is free software; you can redistribute it and/or
  22 # modify it under the terms of the GNU Lesser General Public
  23 # License as published by the Free Software Foundation; either
  24 # version 2.1 of the License, or (at your option) any later version.
  25 #
  26 # This library is distributed in the hope that it will be useful,
  27 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  28 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  29 # Lesser General Public License for more details.
  30 #
  31 # You should have received a copy of the GNU Lesser General Public
  32 # License along with this library; if not, write to the Free Software
  33 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  34 #
  35 # ------------------------------------------------------------------------------
  36 #
  37 # Please feel free to send questions, suggestions or improvements to:
  38 #
  39 #       David J. Goehrig
  40 #       dgoehrig@cpan.org
  41 #
  42
  43 package SDL::Surface;
  44
  45 use strict;
  46 use warnings;
  47 use Carp;
  48 use SDL;
  49 use SDL::SFont;
  50 use SDL::Color;
  51 use SDL::Rect;
  52 use Data::Dumper;
  53 sub new {
  54         my $proto = shift;
  55         my $class = ref($proto) || $proto;
  56         my %options = @_;
  57         my $self;
  58
  59         verify (%options, qw/ -name -n -flags -fl -width -w -height -h -depth -d
  60                                 -pitch -p -Rmask -r -Gmask -g -Bmask -b -Amask -a
  61                                 -from -f /) if $SDL::DEBUG;
  62
  63         if ( defined($options{-name}) && $options{-name} ne "" && exists $SDL::{IMGLoad} ) {
  64            $self = \SDL::IMGLoad($options{-name});
  65         } else {
  66                 my $f = $options{-flags}        || $options{-fl}        || SDL::SDL_ANYFORMAT();
  67                 my $w = $options{-width}        || $options{-w}         || 1;
  68                 my $h = $options{-height}       || $options{-h}         || 1;
  69                 my $d = $options{-depth}        || $options{-d}         || 8;
  70                 my $p = $options{-pitch}        || $options{-p}         || $w*$d;
  71                 my $r = $options{-Rmask}        || $options{-r}
  72                         ||  ( SDL::BigEndian() ? 0xff000000 : 0x000000ff );
  73                 my $g = $options{-Gmask}        || $options{-g}
  74                         ||  ( SDL::BigEndian() ? 0x00ff0000 : 0x0000ff00 );
  75                 my $b = $options{-Bmask}        || $options{-b}
  76                         ||  ( SDL::BigEndian() ? 0x0000ff00 : 0x00ff0000 );
  77                 my $a = $options{-Amask}        || $options{-a}
  78                         ||  ( SDL::BigEndian() ? 0x000000ff : 0xff000000 );
  79
  80                 if ( $options{-from}|| $options{-f} ) {
  81                         my $src = $options{-from}|| $options{-f};
  82                         $self = \SDL::CreateRGBSurfaceFrom($src,$w,$h,$d,$p,$r,$g,$b,$a);
  83                 } else {
  84                         $self = \SDL::CreateRGBSurface($f,$w,$h,$d,$r,$g,$b,$a);
  85                 }
  86         }
  87         croak "SDL::Surface::new failed. ", SDL::GetError()
  88                 unless ( $$self);
  89         bless $self,$class;
  90         return $self;
  91 }
  92
  93 sub DESTROY {
  94         SDL::FreeSurface(${$_[0]});
  95 }
  96
  97 sub flags {
  98         SDL::SurfaceFlags(${$_[0]});
  99 }
 100
 101 sub palette {
 102         SDL::SurfacePalette(${$_[0]});
 103 }
 104
 105 sub bpp {
 106         SDL::SurfaceBitsPerPixel(${$_[0]});
 107 }
 108
 109 sub bytes_per_pixel {
 110         SDL::SurfaceBytesPerPixel(${$_[0]});
 111 }
 112
 113 sub Rshift {
 114         SDL::SurfaceRshift(${$_[0]});
 115 }
 116
 117 sub Gshift {
 118         SDL::SurfaceGshift(${$_[0]});
 119 }
 120
 121 sub Bshift {
 122         SDL::SurfaceBshift(${$_[0]});
 123 }
 124
 125 sub Ashift {
 126         SDL::SurfaceAshift(${$_[0]});
 127 }
 128
 129 sub Rmask {
 130         SDL::SurfaceRmask(${$_[0]});
 131 }
 132
 133 sub Gmask {
 134         SDL::SurfaceGmask(${$_[0]});
 135 }
 136
 137 sub Bmask {
 138         SDL::SurfaceBmask(${$_[0]});
 139 }
 140
 141 sub Amask {
 142         SDL::SurfaceAmask(${$_[0]});
 143 }
 144
 145 sub color_key {
 146         SDL::SurfaceColorKey(${$_[0]});
 147 }
 148
 149 sub alpha {
 150         SDL::SurfaceAlpha(${$_[0]});
 151 }
 152
 153 sub width {
 154         SDL::SurfaceW(${$_[0]});
 155 }
 156
 157 sub height {
 158         SDL::SurfaceH(${$_[0]});
 159 }
 160
 161 sub pitch {
 162         SDL::SurfacePitch(${$_[0]});
 163 }
 164
 165 sub pixels {
 166         SDL::SurfacePixels(${$_[0]});
 167 }
 168
 169 sub pixel {
 170         croak "SDL::Surface::pixel requires a SDL::Color"
 171                 if $_[3] && $SDL::DEBUG && !$_[3]->isa("SDL::Color");
 172         $_[3] ?
 173                 new SDL::Color -color => SDL::SurfacePixel(${$_[0]},$_[1],$_[2],${$_[3]}) :
 174                 new SDL::Color -color => SDL::SurfacePixel(${$_[0]},$_[1],$_[2]);
 175 }
 176
 177 sub fill {
 178         if ($_[1] == 0 ) {
 179                 SDL::FillRect(${$_[0]},0,${$_[2]});
 180         } else {
 181                 SDL::FillRect(${$_[0]},$_[1],$_[2]);
 182         }
 183 }
 184
 185 sub lockp {
 186         SDL::MUSTLOCK(${$_[0]});
 187 }
 188
 189 sub lock {
 190         SDL::SurfaceLock(${$_[0]});
 191 }
 192
 193 sub unlock {
 194         SDL::SurfaceUnlock(${$_[0]});
 195 }
 196
 197 sub update {
 198         my $self = shift;;
 199         if ($SDL::DEBUG) {
 200                 for (@_) {
 201                         croak "SDL::Surface::update requires SDL::Rect objects"
 202                                 unless $_->isa('SDL::Rect');
 203                 }
 204         }
 205         SDL::UpdateRects($$self, map { ${$_} } @_ );
 206 }
 207
 208 sub flip {
 209         SDL::Flip(${$_[0]});
 210 }
 211
 212 sub blit {
 213                 $_[1] = 0 unless defined $_[1];
 214                 $_[3] = 0 unless defined $_[3];
 215
 216         if ($SDL::DEBUG) {
 217                 croak "SDL::Surface::blit requires SDL::Rect objects"
 218                         unless ($_[1] == 0 || $_[1]->isa('SDL::Rect'))
 219                         && ($_[3] == 0 || $_[3]->isa('SDL::Rect'));
 220                 croak "SDL::Surface::blit requires SDL::Surface objects"
 221                         unless $_[2]->isa('SDL::Surface');
 222         }
 223         #BlitSurface ( src, src_rect, dest, dest_rect )
 224
 225                 SDL::BlitSurface( ${$_[0]}, $_[1], ${$_[2]}, $_[3]);
 226 }
 227
 228 sub set_colors {
 229         my $self = shift;
 230         my $start = shift;
 231         for (@_) {
 232                 croak "SDL::Surface::set_colors requires SDL::Color objects"
 233                         unless !$SDL::DEBUG || $_->isa('SDL::Color');
 234         }
 235         return SDL::SetColors($$self, $start, map { ${$_} } @_);
 236 }
 237
 238 sub set_color_key {
 239         croak "SDL::Surface::set_color_key requires a SDL::Color object"
 240                 unless !$SDL::DEBUG || (ref($_[2]) && $_[2]->isa('SDL::Color'));
 241         SDL::SetColorKey(${$_[0]},$_[1],${$_[2]});
 242 }
 243
 244 sub set_alpha {
 245         SDL::SetAlpha(${$_[0]},$_[1],$_[2]);
 246 }
 247
 248 sub display_format {
 249         my $self = shift;
 250         my $tmp = SDL::DisplayFormat($$self);
 251         SDL::FreeSurface ($$self);
 252         $$self = $tmp;
 253         $self;
 254 }
 255
 256 sub display_format_alpha {
 257         my $self = shift;
 258         my $tmp = SDL::DisplayFormatAlpha($$self);
 259         SDL::FreeSurface ($$self);
 260         $$self = $tmp;
 261         $self;
 262 }
 263
 264 sub rgb {
 265         my $self = shift;
 266         my $tmp = SDL::ConvertRGB($$self);
 267         SDL::FreeSurface($$self);
 268         $$self = $tmp;
 269         $self;
 270 }
 271
 272 sub rgba {
 273         my $self = shift;
 274         my $tmp = SDL::ConvertRGBA($$self);
 275         SDL::FreeSurface($$self);
 276         $$self = $tmp;
 277         $self;
 278 }
 279
 280 sub rect {
 281         my $self = shift;
 282         new SDL::Rect -width => $self->width(), -height => $self->height(),
 283                         -x => $_[0] || 0, -y => $_[1] || 0;
 284 }
 285
 286 sub print {
 287         my ($self,$x,$y,@text) = @_;
 288         SDL::SFont::PutString( $$self, $x, $y, join('',@text));
 289 }
 290
 291 sub save_bmp {
 292         SDL::SaveBMP( ${$_[0]},$_[1]);
 293 }
 294
 295 sub video_info {
 296         shift;
 297         SDL::VideoInfo();
 298 }
 299
 300 1;
 301
 302 __END__;
 303
 304 =pod
 305
 306 =head1 NAME
 307
 308 SDL::Surface - a SDL perl extension
 309
 310 =head1 SYNOPSIS
 311
 312   use SDL::Surface;
 313   $image = new SDL::Surface(-name=>"yomama.jpg");
 314
 315 =head1 DESCRIPTION
 316
 317 The C<SDL::Surface> module encapsulates the SDL_Surface* structure, and
 318 many of its ancillatory functions.  Not only is it a workhorse of the
 319 OO Layer, it is the base class for the C<SDL::App> class.
 320
 321 =head1 EXPORTS
 322
 323         SDL_SWSURFACE           SDL_HWSURFACE
 324         SDL_ASYNCBLIT           SDL_ANYFORMAT
 325         SDL_HWPALETTE           SDL_DOUBLEBUF
 326         SDL_FULLSCREEN          SDL_OPENGL
 327         SDL_OPENGLBLIT          SDL_RESIZEABLE
 328         SDL_NOFRAME             SDL_SRCCOLORKEY
 329         SDL_RLEACCEL            SDL_SRCALPHA
 330         SDL_PREALLOC
 331
 332 =head1 METHODS
 333
 334 =head2 new (-name => 'foo.png')
 335
 336 The C<SDL::Surface> class can be instantiated in a number of different ways.
 337 If support for the SDL_image library was included when SDL_perl was compiled,
 338 the easiest way to create a new surface is to use the C<SDL::Surface::new>
 339 method with the C<-name> option.  This will load the image from the file
 340 and return an object encapsulating the SDL_Surface*.
 341
 342 =head2 new (-from => $buffer, ... )
 343
 344 If the contents of the new Surface is already in memory, C<SDL::Surface::new>
 345 may be called with the C<-from> option to create an image from that section
 346 of memory.  This method takes the following additional parameters:
 347
 348 =over 4
 349
 350 =item *
 351
 352 -width          the width of the image in pixels
 353
 354 =item *
 355
 356 -height         the height of the image in pixels
 357
 358 =item *
 359
 360 -depth          the number of bits per pixel
 361
 362 =item *
 363
 364 -pitch          the number of bytes per line
 365
 366 =item *
 367
 368 -Rmask          an optional bitmask for red
 369
 370 =item *
 371
 372 -Gmask          an optional bitmask for green
 373
 374 =item *
 375
 376 -Bmask          an optional bitmask for green
 377
 378 =item *
 379
 380 -Amask          an optional bitmask for alpha
 381
 382 =back
 383
 384 =head2 new ( -flags => SDL_SWSURFACE, ... )
 385
 386 Finally, C<SDL::Suface::new> may be invoked with the C<-flags> option, in a
 387 similar fashion to the C<-from> directive.  This invocation takes the same
 388 additional options as C<-from> with the exception of C<-pitch> which is ignored.
 389 This method returns a new, blank, SDL::Surface option with any of the following
 390 flags turned on:
 391
 392 =over 4
 393
 394 =item *
 395
 396 SWSURFACE()     a non-accelerated surface
 397
 398 =item *
 399
 400 HWSURFACE()     a hardware accelerated surface
 401
 402 =item *
 403
 404 SRCCOLORKEY()   a surface with a transperant color
 405
 406 =item *
 407
 408 SRCALPHA()      an alpha blended, translucent surface
 409
 410 =back
 411
 412 =head2 flags ()
 413
 414 C<SDL::Surface::flags> returns the flags with which the surface was initialized.
 415
 416 =head2 palette ()
 417
 418 C<SDL::Surface::palette> currently returns a SDL_Palette*, this may change in
 419 future revisions.
 420
 421 =head2 bpp ()
 422
 423 C<SDL::Surface::bpp> returns the bits per pixel of the surface
 424
 425 =head2 bytes_per_pixel ()
 426
 427 C<SDL::Surface::bytes_per_pixel> returns the bytes per pixel of the surface
 428
 429 =head2 Rshift ()
 430
 431 C<SDL::Surface::Rshift> returns the bit index of the red field for the surface's pixel format
 432
 433 =head2 Gshift ()
 434
 435 C<SDL::Surface::Gshift> returns the bit index of the green field for the surface's pixel format
 436
 437 =head2 Bshift ()
 438
 439 C<SDL::Surface::Bshift> returns the bit index of the blue field for the surface's pixel format
 440
 441 =head2 Ashift ()
 442
 443 C<SDL::Surface::Ashift> returns the bit index of the alpha field for the surface's pixel format
 444
 445 =head2 Rmask ()
 446
 447 C<SDL::Surface::Rmask> returns the bit mask for the red field for teh surface's pixel format
 448
 449 =head2 Gmask ()
 450
 451 C<SDL::Surface::Gmask> returns the bit mask for the green field for teh surface's pixel format
 452
 453 =head2 Bmask ()
 454
 455 C<SDL::Surface::Bmask> returns the bit mask for the blue field for teh surface's pixel format
 456
 457 =head2 Amask ()
 458
 459 C<SDL::Surface::Amask> returns the bit mask for the alpha field for teh surface's pixel format
 460
 461 =head2 color_key ()
 462
 463 C<SDL::Surface::color_key> returns the current color key for the image, which can be set with
 464 the C<SDL::Surface::set_color_key> method.  Before calling C<SDL::Surface::color_key> on
 465 a image, you should fist call C<SDL::Surface::display_format> to convert it to the same
 466 format as the display.  Failure to do so will result in failure to apply the correct color_key.
 467
 468 =head2 alpha ()
 469
 470 C<SDL::Surface::alpha> returns the current alpha value for the image, which can be set with
 471 the C<SDL::Surface::set_alpha> method.
 472
 473 =head2 width ()
 474
 475 C<SDL::Surface::width> returns the width in pixels of the surface
 476
 477 =head2 height ()
 478
 479 C<SDL::Surface::height> returns the height in pixels of the surface
 480
 481 =head2 pitch ()
 482
 483 C<SDL::Surface::pitch> returns the width of a surface's scanline in bytes
 484
 485 =head2 pixels ()
 486
 487 C<SDL::Surface::pixels> returns a Uint8* to the image's pixel data.  This is not
 488 inherently useful within perl, though may be used to pass image data to user provided
 489 C functions.
 490
 491 =head2 pixel (x,y,[color])
 492
 493 C<SDL::Surface::pixel> will set the color value of the pixel at (x,y) to the given
 494 color if provided.  C<SDL::Surface::pixel> returns a SDL::Color object for the
 495 color value of the pixel at (x,y) after any possible modifications.
 496
 497 =head2 fill (rect,color)
 498
 499 C<SDL::Surface::fill> will fill the given SDL::Rect rectangle with the specified SDL::Color
 500 This function optionally takes a SDL_Rect* and a SDL_Color*
 501
 502 =head2 lockp ()
 503
 504 C<SDL::Surface::lockp> returns true if the surface must be locked
 505
 506 =head2 lock ()
 507
 508 C<SDL::Surface::lock> places a hardware lock if necessary, preventing access to
 509 the surface's memory
 510
 511 =head2 unlock ()
 512
 513 C<SDL::Surface::unlock> removes any hardware locks, enabling blits
 514
 515 =head2 update ( rects...)
 516
 517 C<SDL::Surface::update> takes one or more SDL::Rect's which determine which sections
 518 of the image are to be updated.  This option is only useful on the appliaction surface.
 519
 520 =head2 flip ()
 521
 522 C<SDL::Surface::flip> updates the full surface, using a double buffer if available
 523
 524 =head2 blit (srect,dest,drect)
 525
 526 C<SDL::Surface::blit> blits the current surface onto the destination surface,
 527 according to the provided rectangles.  If a rectangle is 0, then the full surface is used.
 528
 529 =head2 set_colors (start,colors...)
 530
 531 C<SDL::Surface::set_colors> updates the palette starting at index C<start> with the
 532 supplied colors.  The colors may either be SDL::Color objects or SDL_Color* from the
 533 low level C-style API.
 534
 535 =head2 set_color_key (flag,pixel) or (flag,x,y)
 536
 537 C<SDL::Surface::set_color_key> sets the blit flag, usually SDL_SRCCOLORKEY,
 538 to the specified L<SDL::Color> object.  Optional a SDL_Color* may be passed.
 539
 540 =head2 set_alpha (flag,alpha)
 541
 542 C<SDL::Surface::set_alpha> sets the opacity of the image for alpha blits.
 543 C<alpha> takes a value from 0x00 to 0xff.
 544
 545 =head2 display_format ()
 546
 547 C<SDL::Surface::display_format> converts the surface to the same format as the
 548 current screen.
 549
 550 =head2 display_format_alpha ()
 551
 552 C<SDL::Surface::display_format_alpha> converts the surface to the same format as the
 553 current screen, plus an alpha channel.
 554
 555 =head2 rgb ()
 556
 557 C<SDL::Surface::rgb> converts the surface to a 24 bit rgb format regardless of the initial format.
 558
 559 =head2 rgba ()
 560
 561 C<SDL::Surface::rgba> converts the surface to a 32 bit rgba format regarless of the initial format.
 562
 563 =head2 print (x,y,text...)
 564
 565 C<SDL::Surface::print> renders the text using the current font onto the image.
 566 This option is only supported for with SDL_image and SFont.
 567
 568 =head2 save_bmp (filename)
 569
 570 C<SDL::Surface::save_bmp> saves the surface to filename in Windows BMP format.
 571
 572 =head2 video_info ()
 573
 574 C<SDL::Surface::video_info> returns a hash describing the current state of the
 575 video hardware.
 576
 577 =head1 AUTHOR
 578
 579 David J. Goehrig
 580
 581 =head1 SEE ALSO
 582
 583 L<perl> L<SDL::App> L<SDL::Color> L<SDL::Palette> L<SDL::Rect>
 584
 585 =cut