1# $Id: Text.pm,v 1.37 2003/06/19 00:13:10 mgjv Exp $ 2 3package GD::Text; 4 5($GD::Text::prog_version) = '$Revision: 1.37 $' =~ /\s([\d.]+)/; 6$GD::Text::VERSION = '0.86'; 7 8=head1 NAME 9 10GD::Text - Text utilities for use with GD 11 12=head1 SYNOPSIS 13 14 use GD; 15 use GD::Text; 16 17 my $gd_text = GD::Text->new() or die GD::Text::error(); 18 $gd_text->set_font('funny.ttf', 12) or die $gd_text->error; 19 $gd_text->set_font(gdTinyFont); 20 $gd_text->set_font(GD::Font::Tiny); 21 ... 22 $gd_text->set_text($string); 23 my ($w, $h) = $gd_text->get('width', 'height'); 24 25 if ($gd_text->is_ttf) 26 { 27 ... 28 } 29 30Or alternatively 31 32 my $gd_text = GD::Text->new( 33 text => 'Some text', 34 font => 'funny.ttf', 35 ptsize => 14, 36 ); 37 38=head1 DESCRIPTION 39 40This module provides a font-independent way of dealing with text in 41GD, for use with the GD::Text::* modules and GD::Graph. 42 43=head1 NOTES 44 45As with all Modules for Perl: Please stick to using the interface. If 46you try to fiddle too much with knowledge of the internals of this 47module, you could get burned. I may change them at any time. 48 49You can only use TrueType fonts with version of GD > 1.20, and then 50only if compiled with support for this. If you attempt to do it 51anyway, you will get errors. 52 53If you want to refer to builtin GD fonts by their short name 54(C<gdTinyFont>, C<gdGiantFont>), you will need to C<use> the GD module 55as well as one the GD::Text modules, because it is GD that exports 56those names into your name space. If you don't like that, use the 57longer alternatives (C<GD::Font->Giant>) instead. 58 59=head1 METHODS 60 61=cut 62 63use strict; 64 65use GD; 66use Carp; 67use Cwd; 68 69use vars qw($FONT_PATH @FONT_PATH $OS); 70BEGIN 71{ 72 $FONT_PATH = $ENV{FONT_PATH} || 73 $ENV{TTF_FONT_PATH} || 74 $ENV{TT_FONT_PATH} || ''; 75 unless ($OS = $^O) 76 { 77 require Config; 78 $OS = $Config::Config{'os_name'}; 79 } 80} 81 82my $ERROR; 83 84=head2 GD::Text->new( attrib => value, ... ) 85 86Create a new object. See the C<set()> method for attributes. 87 88=cut 89 90sub new 91{ 92 my $proto = shift; 93 my $class = ref($proto) || $proto; 94 my $self = { 95 type => 'builtin', 96 font => gdSmallFont, 97 ptsize => 10, 98 }; 99 bless $self => $class; 100 $self->set(@_) or return; 101 return $self 102} 103 104=head2 GD::Text::error() or $gd_text->error(); 105 106Return the last error that occured in the class. This may be 107imperfect. 108 109=cut 110 111# XXX This sucks! fix it 112sub error { $ERROR }; 113 114sub _set_error { $ERROR = shift }; 115 116=head2 $gd_text->set_font( font, size ) 117 118Set the font to use for this string. The arguments are either a GD 119builtin font (like gdSmallFont or GD::Font->Small) or the name of a 120TrueType font file and the size of the font to use. See also 121L<"font_path">. 122 123If you are not using an absolute path to the font file, you can leave of 124the .ttf file extension, but you have to append it for absolute paths: 125 126 $gd_text->set_font('arial', 12); 127 # but 128 $gd_text->set_font('/usr/fonts/arial.ttf', 12); 129 130The first argument can be a reference to an array of fonts. The first 131font from the array that can be found will be used. This allows you to 132do something like 133 134 $gd_text->font_path( '/usr/share/fonts:/usr/fonts'); 135 $gd_text->set_font( 136 ['verdana', 'arial', gdMediumBoldFont], 14); 137 138if you'd prefer verdana to be used, would be satisfied with arial, but 139if none of that is available just want to make sure you can fall 140back on something that will be available. 141 142Returns true on success, false on error. 143 144=cut 145 146sub set_font 147{ 148 my $self = shift; 149 my $fonts = shift; 150 my $size = shift; 151 152 # Make sure we have a reference to an array 153 $fonts = [$fonts] unless ref($fonts) eq 'ARRAY'; 154 155 foreach my $font (@{$fonts}) 156 { 157 my $rc = ref($font) && $font->isa('GD::Font') ? 158 $self->_set_builtin_font($font) : 159 $self->_set_TTF_font($font, $size || $self->{ptsize}) ; 160 return $rc if $rc; 161 } 162 163 return; 164} 165 166sub _set_builtin_font 167{ 168 my $self = shift; 169 my $font = shift; 170 171 $self->{type} = 'builtin'; 172 $self->{font} = $font; 173 $self->{ptsize} = 0; 174 $self->_recalc(); 175 return 1; 176} 177 178sub _find_TTF 179{ 180 my $font = shift || return; 181 local $FONT_PATH = $FONT_PATH; 182 183 # XXX MOVE A LOT OF THIS INTO THE font_path SUB, filling the 184 # @FONT_PATH array 185 my ($psep, $dsep); 186 187 if ($OS =~ /^MS(DOS|Win)/i) 188 { 189 # Fix backslashes 190 $font =~ s#\\#/#g; 191 # Check for absolute path 192 $font =~ m#^([A-Za-z]:|/)# and return $font; 193 $FONT_PATH =~ s#\\#/#g; # XXX move to set_font_path? 194 $psep = '/'; 195 $dsep = ';'; 196 } 197=pod 198 elsif ($OS =~ /^MacOS/i) 199 { 200 # Check for absolute path 201 $font =~ /:/ and $font !~ /^:/ and return $font; 202 $psep = ':'; 203 $dsep = ','; 204 } 205 elsif ($OS =~ /^AmigaOS/i) 206 { 207 # What's an absolute path here? 208 $psep = '/'; 209 $dsep = ':'; # XXX ? 210 } 211 elsif ($OS =~ /^VMS/i) 212 { 213 # What's an absolute path here? 214 $psep = '/'; 215 $dsep = ':'; 216 } 217=cut 218 else 219 { 220 # Default to Unix 221 # Check for absolute path 222 substr($font, 0, 1) eq '/' and return $font; 223 $psep = '/'; 224 $dsep = ':'; 225 } 226 227 # If we don't have a font path set, we look in the current directory 228 # only. 229 if ($FONT_PATH) 230 { 231 # We have a font path, and a relative path to the font file. 232 # Let's see if the current directory is in the font path. If 233 # not, put it at the front. 234 $FONT_PATH = ".$dsep$FONT_PATH" 235 unless $FONT_PATH eq '.' || $FONT_PATH =~ /^\.$dsep/ || 236 $FONT_PATH =~ /$dsep\.$/ || $FONT_PATH =~ /$dsep\.$dsep/; 237 } 238 else 239 { 240 # XXX what about MacOS? It doesn't work like this on MacOS. 241 $FONT_PATH = '.'; 242 } 243 244 # Let's search for it 245 # TODO Maybe truncate base name at 8 characters for dos-like 246 # installations? 247 for my $path (split /$dsep/, $FONT_PATH) 248 { 249 # XXX Can I use File::Basename for this? 250 my $file = "$path$psep$font"; 251 -f $file and return $file; 252 # See if we can find one with an extension at the end 253 for my $ext (qw/ ttf TTF /) 254 { 255 -f "$file.$ext" and return "$file.$ext"; 256 } 257 } 258 259 return; 260} 261 262sub _set_TTF_font 263{ 264 my $self = shift; 265 my $font = shift; 266 my $size = shift; 267 268 $ERROR = "TrueType fonts require a point size", return 269 unless (defined $size && $size > 0); 270 271 return unless $self->can_do_ttf; 272 273 my $font_file = _find_TTF($font) or 274 $ERROR = "Cannot find TTF font: $font", return; 275 276 # XXX Fix for Freetype 2.0x bug, where relative paths to a font file 277 # no longer work. 278 if (substr($font_file, 0, 1) eq '.') 279 { 280 # This is a relative path. Replace ./path/file with 281 # $cwd/path/file 282 my $oldpath = $ENV{PATH}; 283 $ENV{PATH} = "/bin:/usr/bin"; # Keep -T happy 284 require Cwd; 285 substr($font_file, 0, 1) = Cwd::cwd; 286 $ENV{PATH} = $oldpath; 287 } 288 289 # Check that the font exists and is a real TTF font 290 my @bb = GD::Image->stringTTF(0, $font_file, $size, 0, 0, 0, "foo"); 291 $ERROR = "$@", return unless @bb; 292 293 $self->{type} = 'ttf'; 294 $self->{font} = $font_file; 295 $self->{ptsize} = $size; 296 $self->_recalc(); 297 return 1; 298} 299 300=head2 $gd_text->set_text('some text') 301 302Set the text to operate on. 303Returns true on success and false on error. 304 305=cut 306 307sub set_text 308{ 309 my $self = shift; 310 my $text = shift; 311 312 $ERROR = "No text set", return unless defined $text; 313 314 $self->{text} = $text; 315 $self->_recalc_width(); 316} 317 318=head2 $gd_text->set( attrib => value, ... ) 319 320The set method provides a convenience replacement for the various other 321C<set_xxx()> methods. Valid attributes are: 322 323=over 4 324 325=item text 326 327The text to operate on, see also C<set_text()>. 328 329=item font, ptsize 330 331The font to use and the point size. The point size is only used for 332TrueType fonts. Also see C<set_font()>. 333 334=back 335 336Returns true on success, false on any error, even if it was partially 337successful. When an error is returned, no guarantees are given about 338the correctness of the attributes. 339 340=cut 341 342# We use this to save a few CPU cycles 343my $recalc = 1; 344 345sub set 346{ 347 my $self = shift; 348 $ERROR = "Incorrect attribute list", return if @_%2; 349 my %args = @_; 350 351 $ERROR = ''; 352 353 $recalc = 0; 354 foreach (keys %args) 355 { 356 /^text$/i and do { 357 $self->set_text($args{$_}); 358 next; 359 }; 360 /^font$/i and do { 361 $self->set_font($args{$_}, $self->{ptsize}) or return; 362 next; 363 }; 364 /^ptsize$/i and do { 365 $self->{ptsize} = $args{$_}; 366 next; 367 }; 368 $ERROR .= " '$_'"; 369 } 370 $recalc = 1; 371 $self->_recalc(); 372 373 if ($ERROR ne '') 374 { 375 $ERROR = "Illegal attribute(s):$ERROR"; 376 return; 377 } 378 379 return 1; 380} 381 382=head2 $gd_text->get( attrib, ... ) 383 384Get the value of an attribute. 385Return a list of the attribute values in list context, and the value of 386the first attribute in scalar context. 387 388The attributes that can be retrieved are all the ones that can be set, 389and: 390 391=over 4 392 393=item width, height 394 395The width (height) of the string in pixels 396 397=item space 398 399The width of a space in pixels 400 401=item char_up, char_down 402 403The number of pixels that a character can stick out above and below the 404baseline. Note that this is only useful for TrueType fonts. For builtins 405char_up is equal to height, and char_down is always 0. 406 407=back 408 409Note that some of these parameters (char_up, char_down and space) are 410generic font properties, and not necessarily a property of the text 411that is set. 412 413=cut 414 415sub get 416{ 417 my $self = shift; 418 my @wanted = map $self->{$_}, @_; 419 wantarray ? @wanted : $wanted[0]; 420} 421 422=head2 $gd_text->width('string') 423 424Return the length of a string in pixels, without changing the current 425value of the text. Returns the width of 'string' rendered in the 426current font and size. On failure, returns undef. 427 428The use of this method is vaguely deprecated. 429 430=cut 431 432sub width 433{ 434 my $self = shift; 435 my $string = shift; 436 my $save = $self->get('text'); 437 438 my $len = $self->set_text($string); 439 return unless defined $len; 440 my $w = $self->get('width'); 441 $self->set_text($save); 442 443 return $w; 444} 445 446# Here we do the real work. See the documentation for the get method to 447# find out which attributes need to be set and/or reset 448 449sub _recalc_width 450{ 451 my $self = shift; 452 453 return unless $recalc; 454 return unless (defined $self->{text} && $self->{font}); 455 456 if ($self->is_builtin) 457 { 458 $self->{'width'} = $self->{font}->width() * length($self->{text}); 459 } 460 elsif ($self->is_ttf) 461 { 462 my @bb1 = GD::Image->stringTTF(0, 463 $self->{font}, $self->{ptsize}, 0, 0, 0, $self->{text}); 464 $self->{'width'} = $bb1[2] - $bb1[0]; 465 } 466 else 467 { 468 confess "Impossible error in GD::Text::_recalc."; 469 } 470} 471 472my ($test_string, $space_string, $n_spaces); 473 474BEGIN 475{ 476 # Build a string of all characters that are printable, and that are 477 # not whitespace. 478 479 my @test_chars = map chr, 0x01 .. 0xff; 480 481 my $isprintable_sub; 482 if ($] >= 5.008) 483 { 484 # We have to do this at run time, otherwise 5.005_03 will 485 # whinge about [[::]] syntax being reserved, and this cannot 486 # be shut up with $^W 487 #$^W = 0; 488 eval '$isprintable_sub = sub { $_[0] =~ /^[[:graph:]]$/ }' 489 } 490 else 491 { 492 eval { local $SIG{'__WARN__'}; require POSIX }; 493 if ($@) 494 { 495 @test_chars = map chr, 0x21..0x7e, 0xa1..0xff; 496 $isprintable_sub = sub { 1 } 497 } 498 else 499 { 500 $isprintable_sub = sub { POSIX::isgraph($_[0]) } 501 } 502 } 503 504 $test_string = join '', grep $isprintable_sub->($_), @test_chars; 505 506 # Put a space every 5 characters, and count how many there are 507 $space_string = $test_string; 508 $n_spaces = $space_string =~ s/(.{5})(.{5})/$1 $2/g; 509} 510 511sub _recalc 512{ 513 my $self = shift; 514 515 return unless $recalc; 516 return unless $self->{font}; 517 518 if ($self->is_builtin) 519 { 520 $self->{height} = 521 $self->{char_up} = $self->{font}->height(); 522 $self->{char_down} = 0; 523 $self->{space} = $self->{font}->width(); 524 } 525 elsif ($self->is_ttf) 526 { 527 my @bb1 = GD::Image->stringTTF(0, 528 $self->{font}, $self->{ptsize}, 0, 0, 0, $test_string) 529 or return; 530 my @bb2 = GD::Image->stringTTF(0, 531 $self->{font}, $self->{ptsize}, 0, 0, 0, $space_string); 532 $self->{char_up} = -$bb1[7]; 533 $self->{char_down} = $bb1[1]; 534 $self->{height} = $self->{char_up} + $self->{char_down}; 535 # XXX Should we really round this? 536 $self->{space} = sprintf "%.0f", 537 (($bb2[2]-$bb2[0]) - ($bb1[2]-$bb1[0]))/$n_spaces; 538 } 539 else 540 { 541 confess "Impossible error in GD::Text::_recalc."; 542 } 543 544 $self->_recalc_width() if defined $self->{text}; 545 546 return 1; 547} 548 549=head2 $gd_text->is_builtin 550 551Returns true if the current object is based on a builtin GD font. 552 553=cut 554 555sub is_builtin 556{ 557 my $self = shift; 558 return $self->{type} eq 'builtin'; 559} 560 561=head2 $gd_text->is_ttf 562 563Returns true if the current object is based on a TrueType font. 564 565=cut 566 567sub is_ttf 568{ 569 my $self = shift; 570 return $self->{type} eq 'ttf'; 571} 572 573=head2 $gd_text->can_do_ttf() or GD::Text->can_do_ttf() 574 575Return true if this object can handle TTF fonts. 576 577This depends on whether your version of GD is newer than 1.19 and 578has TTF support compiled into it. 579 580=cut 581 582sub can_do_ttf 583{ 584 my $proto = shift; 585 586 # Just see whether there is a stringTTF method at all 587 GD::Image->can('stringTTF') or return; 588 589 # Let's check whether TTF support has been compiled in. We don't 590 # need to worry about providing a real font. The following will 591 # always fail, but we'll check the message to see why it failed 592 GD::Image->stringTTF(0, 'foo', 10, 0, 0, 0, 'foo'); 593 594 # Error message: libgd was not built with TrueType font support 595 $@ =~ /not built with.*font support/i and return; 596 597 # Well.. It all seems to be fine 598 return 1; 599} 600 601=head2 $gd_text->font_path(path_spec), GD::Text->font_path(path_spec) 602 603This sets the font path for the I<class> (i.e. not just for the object). 604The C<set_font> method will search this path to find the font specified 605if it is a TrueType font. It should contain a list of 606paths. The current directory is always searched first, unless '.' is 607present in FONT_PATH. Examples: 608 609 GD::Text->font_path('/usr/ttfonts'); # Unix 610 GD::Text->font_path('c:/fonts'); # MS-OS 611 612Any font name that is not an absolute path will first be looked for in 613the current directory, and then in /usr/ttfonts (c:\fonts). 614 615 GD::Text->font_path('/usr/ttfonts:.:lib/fonts'); # Unix 616 GD::Text->font_path('c:/fonts;.;f:/fonts'); # MS-OS 617 618Any font name that is not an absolute path will first be looked for in 619/usr/ttfonts (c:\fonts), then in the current directory. and then in 620lib/fonts (f:\fonts), 621relative to the current directory. 622 623 GD::Text->font_path(undef); 624 625Font files are only looked for in the current directory. 626 627FONT_PATH is initialised at module load time from the environment 628variables FONT_PATH or, if that's not present, TTF_FONT_PATH, or 629TT_FONT_PATH. 630 631Returns the value the font path is set to. If called without arguments 632C<font_path> returns the current font path. 633 634Note: This currently only works for unices, and (hopefully) for 635Microsoft based OS's. If anyone feels the urge to have a look at the 636code, and send me patches for their OS, I'd be most grateful) 637 638=cut 639 640sub font_path 641{ 642 my $proto = shift; 643 if (@_) 644 { 645 $FONT_PATH = shift; 646 if ($FONT_PATH) 647 { 648 # clean up a bit 649 $FONT_PATH =~ s/^:+//; 650 $FONT_PATH =~ s/:+$//; 651 } 652 } 653 $FONT_PATH; 654} 655 656=head1 BUGS 657 658This module has only been tested with anglo-centric 'normal' fonts and 659encodings. Fonts that have other characteristics may not work well. 660If that happens, please let me know how to make this work better. 661 662The font height gets estimated by building a string with all printable 663characters (with an ordinal value between 0 and 255) that pass the 664POSIX::isprint() test (and not the isspace() test). If your system 665doesn't have POSIX, I make an approximation that may be false. Under 666Perl 5.8.0 the [[:print:]] character class is used, since the POSIX 667is*() functions don't seem to work correctly. 668 669The whole font path thing works well on Unix, but probably not very well 670on other OS's. This is only a problem if you try to use a font path. If 671you don't use a font path, there should never be a problem. I will try 672to expand this in the future, but only if there's a demand for it. 673Suggestions welcome. 674 675=head1 COPYRIGHT 676 677copyright 1999 678Martien Verbruggen (mgjv@comdyn.com.au) 679 680=head1 SEE ALSO 681 682GD(3), GD::Text::Wrap(3), GD::Text::Align(3) 683 684=cut 685 6861; 687