lib/SDL/TTFont.pm

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