lib/SDL/TTFont.pm

   1 #!/usr/bin/env perl
   2 #
   3 # TTFont.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
  29 #
  30
  31 package SDL::TTFont;
  32
  33 use strict;
  34 use warnings;
  35 use Carp;
  36 use SDL;
  37 use SDL::Surface;
  38
  39 use vars qw/ @ISA /;
  40
  41 @ISA = qw(SDL::Surface);
  42
  43 sub new {
  44         my $proto = shift;
  45         my $class = ref($proto) || $proto;
  46         my $self = {};
  47         my %options;
  48         (%options) = @_;
  49         $self->{-mode} = $options{-mode}        || $options{-m}  || SDL::TEXT_SHADED();
  50         $self->{-name} = $options{-name}        || $options{-n};
  51         $self->{-size} = $options{-size}        || $options{-s};
  52         $self->{-fg} = $options{-foreground}    || $options{-fg} || $SDL::Color::black;
  53         $self->{-bg} = $options{-background}    || $options{-bg} || $SDL::Color::white;
  54
  55         croak "SDL::TTFont::new requires a -name\n"
  56                 unless ($$self{-name});
  57
  58         croak "SDL::TTFont::new requires a -size\n"
  59                 unless ($$self{-size});
  60
  61         $self->{-font} = SDL::TTFOpenFont($self->{-name},$self->{-size});
  62
  63         croak "Could not open font $$self{-name}, ", SDL::GetError(), "\n"
  64                 unless ($self->{-font});
  65
  66         bless $self,$class;
  67         return $self;
  68 }
  69
  70 sub DESTROY {
  71         my $self = shift;
  72         SDL::FreeSurface($self->{-surface}) if (defined ($self->{-surface}));
  73         SDL::TTFCloseFont($self->{-font}) if (defined ($self->{-font}));
  74 }
  75
  76 sub print {
  77         my ($self,$surface,$x,$y,@text) = @_;
  78
  79         croak "Print requies an SDL::Surface"
  80                 unless( ref($surface) && $surface->isa("SDL::Surface") );
  81
  82         SDL::FreeSurface($self->{-surface}) if ($$self{-surface});
  83
  84         $$self{-surface} = SDL::TTFPutString($$self{-font},$$self{-mode},
  85                 $$surface,$x,$y,${$$self{-fg}},${$$self{-bg}},join("",@text));
  86
  87         croak "Could not print \"", join("",@text), "\" to surface, ",
  88                 SDL::GetError(), "\n" unless ($$self{-surface});
  89 }
  90
  91 sub width {
  92         my ($self,@text) = @_;
  93         my $aref = SDL::TTFSizeText($$self{-font},join(" ",@text));
  94         $$aref[0];
  95 }
  96
  97 sub height {
  98         my ($self) = @_;
  99         SDL::TTFFontHeight($$self{-font});
 100 }
 101
 102 sub ascent {
 103         my ($self) = @_;
 104         SDL::TTFFontAscent($$self{-font});
 105 }
 106
 107 sub descent {
 108         my ($self) = @_;
 109         SDL::TTFFontDescent($$self{-font});
 110 }
 111
 112 sub normal {
 113         my ($self) = @_;
 114         SDL::TTFSetFontStyle($$self{-font},SDL::TTF_STYLE_NORMAL());
 115 }
 116
 117 sub bold {
 118         my ($self) = @_;
 119         SDL::TTFSetFontStyle($$self{-font},SDL::TTF_STYLE_BOLD());
 120 }
 121
 122 sub italic {
 123         my ($self) = @_;
 124         SDL::TTFSetFontStyle($$self{-font},SDL::TTF_STYLE_ITALIC());
 125
 126 }
 127
 128 sub underline {
 129         my ($self) = @_;
 130         SDL::TTFSetFontStyle($$self{-font},SDL::TTF_STYLE_UNDERLINE());
 131 }
 132
 133 sub text_shaded {
 134         my ($self) = @_;
 135         $$self{-mode} = SDL::TEXT_SHADED();
 136 }
 137
 138 sub text_solid {
 139         my ($self) = @_;
 140         $$self{-mode} = SDL::TEXT_SOLID();
 141 }
 142
 143 sub text_blended {
 144         my ($self) = @_;
 145         $$self{-mode} = SDL::TEXT_BLENDED();
 146 }
 147
 148 sub utf8_shaded {
 149         my ($self) = @_;
 150         $$self{-mode} = SDL::UTF8_SHADED();
 151 }
 152
 153 sub utf8_solid {
 154         my ($self) = @_;
 155         $$self{-mode} = SDL::UTF8_SOLID();
 156 }
 157
 158 sub utf8_blended {
 159         my ($self) = @_;
 160         $$self{-mode} = SDL::UTF8_BLENDED();
 161 }
 162
 163 sub unicode_shaded {
 164         my ($self) = @_;
 165         $$self{-mode} = SDL::UNICODE_SHADED();
 166 }
 167
 168 sub unicode_solid {
 169         my ($self) = @_;
 170         $$self{-mode} = SDL::UNICODE_SOLID();
 171 }
 172
 173 sub unicode_blended {
 174         my ($self) = @_;
 175         $$self{-mode} = SDL::UNICODE_BLENDED();
 176 }
 177
 178 croak "Could not initialize True Type Fonts\n"
 179         if ( SDL::TTFInit() < 0);
 180
 181 1;
 182
 183 __END__;
 184
 185 =pod
 186
 187 =head1 NAME
 188
 189 SDL::TTFont - a SDL perl extension
 190
 191 =head1 SYNOPSIS
 192
 193   $font = new TTFont -name => "Utopia.ttf", -size => 18;
 194
 195 =head1 DESCRIPTION
 196
 197 L<SDL::TTFont> is a module for applying true type fonts to L<SDL::Surface>.
 198
 199 =head1 AUTHOR
 200
 201 David J. Goehrig
 202
 203 =head1 SEE ALSO
 204
 205 L<perl> L<SDL::Surface>
 206
 207 =cut