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