home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / DrawFile / FontTable.pm < prev    next >
Text File  |  1999-01-20  |  4KB  |  153 lines
  1. package RISCOS::DrawFile::FontTable;
  2. use Carp;
  3.  
  4. use strict;
  5. use vars qw ($VERSION @ISA);
  6.  
  7. require RISCOS::DrawFile::Object;
  8.  
  9. @ISA = 'RISCOS::DrawFile::Object';
  10. $VERSION = 0.02;
  11. # 0.02 adds Translate
  12.  
  13. ### use SelfLoader;
  14. sub RISCOS::DrawFile::FontTable::new ($$);
  15. sub RISCOS::DrawFile::FontTable::BBox ;
  16. sub RISCOS::DrawFile::FontTable::Translate ;
  17. sub RISCOS::DrawFile::FontTable::Pack ;
  18. sub RISCOS::DrawFile::FontTable::Size ;
  19. sub RISCOS::DrawFile::FontTable::Write ;
  20. sub RISCOS::DrawFile::FontTable::Type ;
  21. sub RISCOS::DrawFile::FontTable::FontByNumber ;
  22. sub RISCOS::DrawFile::FontTable::NameToNumber ;
  23. 1;
  24. ### __DATA__
  25. sub new ($$) {
  26.     my $proto = shift;
  27.     my $class = ref($proto) || $proto;
  28.  
  29.     my ($self, $type) = $class->SUPER::new;
  30.     return $self if ref ($self) eq 'ARRAY';
  31.  
  32.     carp "Cannot make a Font Table of type $type" if defined $type and $type;
  33.  
  34.     my $old = {};
  35.     my $new = {};
  36.     # my $table = [];
  37.     if (ref ($_[0]) eq 'ARRAY') {
  38.     my $index = @{$_[0]};
  39.     while ($index--) {
  40.         $old->{$index} = ${$_[0]}->[$index] if defined ${$_[0]}->[$index];
  41.     }
  42.     } elsif (ref ($_[0]) eq 'HASH') {
  43.     $new->{''} = 0;        # System font is stored as '' and font number 0
  44.     delete $_[0]->{''};
  45.     my $index = 0;
  46.     foreach (keys %{$_[0]}) {
  47.         # If more than zero are using it, assign it a table entry
  48.         $new->{$_} = ++$index if $_[0]->{$_};
  49.     #    $table[$index] = $_;
  50.     }
  51.     carp "Aaaargh - can't make a fonttable with $index entries (design limit of DrawFiles is 255)" if $index > 255;
  52.     } else {
  53.     $_ = substr $_[0], 8;
  54.     while (s/^(.)([^\0]+)\0//s)
  55.     {
  56.         $old->{ord $1} = $2;
  57.     }
  58.     carp "Spurious text '$_' at end of Font Table" unless /^\0{0,4}$/;
  59.     }
  60.     $self->{'__OLD'} = $old;
  61.     $self->{'__NEW'} = $new;
  62.     # $self->{'__TABLE'} = $table;
  63.     wantarray ? ([], 0, $self) : $self;    # We are a FontTable!
  64. }
  65.  
  66. sub BBox {
  67.     undef;
  68. }
  69.  
  70. \&BBox_Calc = \&BBox;
  71.  
  72. sub Translate {
  73. }
  74.  
  75. sub Pack {
  76. carp 'um';
  77.     my $self = shift;
  78. #    my $zeroth = shift @$self;
  79. #    my $result = $self->PackType() . $self->Size() . join ("\0", @$self, '');
  80. #    unshift @$self, $zeroth;
  81. #    $result . "\0" x ((length $result + 3) & ~3);
  82. }
  83.  
  84. sub Size {
  85.     my $self = shift;
  86.     my $new = $self->{'__NEW'};
  87.     my $size = 8;
  88.     foreach (keys %$new) {
  89.         next unless $_;
  90.         $size += 2 + length $_;
  91.     }
  92.     ($size + 3) & ~3;
  93. }
  94.  
  95. sub Write {
  96.     my $self = shift;
  97.     my $new = $self->{'__NEW'};
  98.     my $size = $self->Size;
  99.     return unless $size > 8;    # Don't do a blank fonttable
  100.     print {$_[0]} pack 'I2', 0, $size;
  101.     $size -= 8;
  102.     foreach (keys %$new) {
  103.         next unless $_;
  104.         print {$_[0]} pack 'Ca*x', $new->{$_}, $_;
  105.         $size -= 2 + length $_;
  106.     }
  107.     print {$_[0]} "\0" x $size;
  108. }
  109.  
  110. sub Type {
  111.     0;
  112. }
  113.  
  114. sub FontByNumber {
  115.     my $self = shift;
  116.     my $old = $self->{'__OLD'};
  117.     return $old->{$_[0]} unless wantarray;
  118.     map  { $old->{$_} } @_;
  119. }
  120.  
  121. sub NameToNumber {
  122.     my $self = shift;
  123.     my $what = $self->{'__NEW'}->{$_[0]};
  124.     carp "Font name lookup failed for '$_[0]'" unless $what;
  125.     # use Data::Dumper;
  126.     # print STDERR Dumper \$self unless $what;
  127.     $what;
  128. }
  129. 1;
  130. __END__
  131.  
  132. =head1 NAME
  133.  
  134. RISCOS::DrawFile::FontTable
  135.  
  136. =head1 SYNOPSIS
  137.  
  138. Class to handle font tables in DrawFiles
  139.  
  140. =head1 DESCRIPTION
  141.  
  142. C<RISCOS::DrawFile::FontTable> packs and unpacks fonttables for
  143. C<RISCOS::DrawFile>. As C<RISCOS::DrawFile::Text> objects hold their font
  144. information internally you should never need to know about Font tables.
  145.  
  146. =head1 BUGS
  147.  
  148. Not tested enough.
  149.  
  150. =head1 AUTHOR
  151.  
  152. Nicholas Clark <F<nick@unfortu.net>>
  153.