home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / DrawFile / Text.pm < prev    next >
Text File  |  1999-01-20  |  8KB  |  318 lines
  1. package RISCOS::DrawFile::Text;
  2. use Carp;
  3.  
  4. use strict;
  5. use vars qw ($VERSION @ISA);
  6. use RISCOS::Units qw(pack_transform_block unpack_transform_block
  7.              millipoint2draw point2draw);
  8. require RISCOS::DrawFile::Object;
  9. require RISCOS::Font;
  10. use RISCOS::Colour qw(pack_colour unpack_colour);
  11.  
  12. $VERSION = 0.05;
  13. # 0.02 Change pack template to I5i2 as x,y are *signed*
  14. # 0.03 PrePack calls BBox, not BBoxCalc
  15. # 0.04 if font passed to new is a font object then read its details, ignore
  16. # xsize, ysize
  17. # flags to strip spaces and return empty objects
  18. # 0.05 adds Translate
  19.  
  20. @ISA = 'RISCOS::DrawFile::Object';
  21.  
  22. ### use SelfLoader;
  23. sub RISCOS::DrawFile::Text::new ($$);
  24. sub RISCOS::DrawFile::Text::Type ;
  25. sub RISCOS::DrawFile::Text::BBox_Calc ;
  26. sub RISCOS::DrawFile::Text::Translate ($$$$);
  27. sub RISCOS::DrawFile::Text::PrePack ;
  28. sub RISCOS::DrawFile::Text::Size ;
  29. sub RISCOS::DrawFile::Text::Pack ($$);
  30. sub RISCOS::DrawFile::Text::ForeColour ;
  31. sub RISCOS::DrawFile::Text::BackColour ;
  32. sub RISCOS::DrawFile::Text::Font ;
  33. sub RISCOS::DrawFile::Text::Text ;
  34. sub RISCOS::DrawFile::Text::X ;
  35. sub RISCOS::DrawFile::Text::Y ;
  36. sub RISCOS::DrawFile::Text::W ;
  37. sub RISCOS::DrawFile::Text::H ;
  38. sub RISCOS::DrawFile::Text::Kern ;
  39. 1;
  40. ### __DATA__
  41. sub new ($$) {
  42.     my $proto = shift;
  43.     my $class = ref($proto) || $proto;
  44.  
  45.     my ($self, $type) = $class->SUPER::new (@_);
  46.     return $self if ref ($self) eq 'ARRAY';
  47.  
  48.     my ($flag, $strip, $bbox, $length, $fore, $back, $font, $xsize, $ysize,
  49.     $xbase, $ybase, $text, $kern, $r2l, $trans) = (0);
  50.     return wantarray ? () : undef unless defined $_[0];
  51.     $strip = $_[1] || 0;
  52.     if (ref ($_[0]) eq 'ARRAY') {
  53.     ($fore, $back, $font, $xsize, $ysize, $xbase, $ybase, $text, $kern,
  54.       $r2l, $trans) = @{$_[0]};
  55.     $flag |= 1 if $kern;
  56.     $flag |= 2 if $r2l;
  57.     if (ref ($font) eq 'RISCOS::Font') {
  58.         if ($strip & 2 and $text =~ s/^( +)//) {
  59.         $xbase += millipoint2draw $font->StringBBox($1)->[2];
  60.         }
  61.         ($font, $xsize, $ysize) = $font->Name();
  62.     } else {
  63.         $ysize = $xsize unless defined $ysize;
  64.     }
  65.     ($fore, $back) = pack_colour ($fore, $back);
  66.     $trans = [@$trans] if defined $trans;    # Copy it.
  67.     } else {
  68.     # Time to unpack data
  69.     my $data = 0;
  70.     if (ref ($_[0]) eq 'SCALAR' or ref ($_[0]) eq 'LVALUE') {
  71.         # Has bounding box stripped
  72.         $data = ${$_[0]};
  73.     } else {
  74.         ($length, @$bbox) = unpack 'x4Ii4', $_[0];
  75.         return undef unless length ($_[0]) == $length or $length & 3;
  76.         $data = substr $_[0], 24;
  77.     }
  78.     if ($type == 12) {
  79.         $data =~ s/^(.{24})(....)//s;
  80.         $trans = unpack_transform_block $1;
  81.         $flag = unpack 'I', $2;
  82.         # $kern = $flag & 0;
  83.         # $r2l = $flag & 1;
  84.         carp sprintf 'DrawFile object 12 (transformed text) flag is %X '
  85.              . '(reserved bits not zero)', $flag if $flag & ~3;
  86.         # Note that the low byte of this flag word is passed unmasked << 9
  87.         # to Font_ScanString in R2
  88.     }
  89.     my $style;
  90.     ($fore, $back, $style, $xsize, $ysize, $xbase, $ybase, $text)
  91.      = unpack 'a4a4I3i2a*', $data;
  92.     $xsize /= 640;
  93.     $ysize /= 640;
  94.     $text =~ s/\0.*//s;
  95.     if ($style) {
  96.         croak 'No FontTable' unless defined ${$_[2]};
  97.         unless (defined ($font = ${$_[2]}->FontByNumber ($style))) {
  98.         carp "Unable to find font number $style in FontTable";
  99.         $font = '';
  100.         }
  101.     } else {
  102.         $font = '';
  103.     }
  104.     }
  105.  
  106.     $text =~ s/ *$// if $strip & 1;    # Strip trailing spaces.
  107.     if ($strip & 2 and $text =~ s/^( +)//) {
  108.     $xbase += millipoint2draw
  109.        RISCOS::Font::StringBBox([$font, $xsize, $ysize], $1)->[2];
  110.     }
  111.     unless (length $text) {
  112.     return [] if $strip & 4;    # Flag set to quietly drop this
  113.     carp 'Attempt to create zero length text object';
  114.     return wantarray ? () : undef;
  115.     }
  116.     $self->{'__BBOX'} = $bbox;
  117.     $self->{'__FONTFLAG'} = $flag;
  118.     $self->{'__TRANSFORM'} = $trans if defined $trans;
  119.     $self->{'__FORE'} = $fore;
  120.     $self->{'__BACK'} = $back;
  121.     $self->{'__FONT'} = $font;
  122.     $self->{'__H'} = $xsize;
  123.     $self->{'__W'} = $ysize;
  124.     $self->{'__X'} = $xbase;
  125.     $self->{'__Y'} = $ybase;
  126.     $self->{'__TEXT'} = $text;
  127.  
  128.     wantarray ? ($self, $type) : $self;
  129. }
  130.  
  131. sub Type {
  132.     my $self = shift;
  133.     return 12 if defined $self->{'__TRANSFORM'} or $self->{'__FONTFLAG'};
  134.     1;
  135. }
  136.  
  137. # erk, convert from millipoints to Draw Units
  138. sub BBox_Calc {
  139.     my $self = shift;
  140.     my $bbox;
  141.     if ($self->{'__FONT'}) {
  142.     @$bbox #    need array context
  143.       = millipoint2draw
  144.         RISCOS::Font::StringBBox ([$self->{'__FONT'},
  145.                        $self->{'__H'}, $self->{'__W'}],
  146.                        $self->{'__TEXT'},
  147.                        $self->{'__FONTFLAG'},
  148.                        $self->{'__TRANSFORM'});
  149.     } else { # System font
  150.     $$bbox[0] = $$bbox[1] = 0;
  151.     $$bbox[2] = length ($self->{'__TEXT'}) * point2draw ($self->{'__W'});
  152.     $$bbox[3] = point2draw ($self->{'__H'});
  153.     }
  154.     $$bbox[0] += $self->{'__X'};
  155.     $$bbox[1] += $self->{'__Y'};
  156.     $$bbox[2] += $self->{'__X'};
  157.     $$bbox[3] += $self->{'__Y'};
  158.     # print STDERR 'was ' . join (', ', @{$self->{'__BBOX'}}) . "\n";
  159.     # print STDERR 'now ' . join (', ', @$bbox) . "\n";
  160.     $self->{'__BBOX'} = $bbox;
  161. }
  162.  
  163. sub Translate ($$$$) {
  164.     my ($self, $x, $y) = @_;
  165.     my $bbox = $self->{'__BBOX'};
  166.     if (defined $bbox) {
  167.     $$bbox[0] += $x;
  168.     $$bbox[1] += $y;
  169.     $$bbox[2] += $x;
  170.     $$bbox[3] += $y;
  171.     }
  172.     $self->{'__X'} += $x;
  173.     $self->{'__Y'} += $y;
  174.     ();
  175. }
  176.  
  177. sub PrePack {
  178.     my $self = shift;
  179.     # hash key is font name, value is number of users.
  180.     # only really need zero/non-zero
  181.     ++$_[0]->{$self->{'__FONT'}};
  182.     $self->BBox (@_);
  183. }
  184. sub Size {
  185.     my $self = shift;
  186.     # 28 for transform & flags if present
  187.     # 28 for text colour to baseline coords
  188.     # 24 for type, length and bbox
  189.     # 4 for '\0' and padding.
  190.     my $size = (($self->Type == 12) ? (28 + 28 + 24 + 4)
  191.                  : (28 + 24 + 4))
  192.         + length $self->{'__TEXT'};
  193.     $size & ~3;
  194. }
  195.  
  196. sub Pack ($$) {
  197.     my $self = shift;
  198.     my $font = $_[1];
  199.     my $type = $self->Type;
  200. #    my ($xxx, $yyy, $XXX, $YYY) = map {pack 'i', $_} @{$self->BBox};
  201.     $self->PackTypeSizeBBox($type)
  202.       . (($type == 12) ? (pack_transform_block (defined $self->{'__TRANSFORM'}
  203.                         ? $self->{'__TRANSFORM'}
  204.                         : (0,0,0,0,0,0))
  205.              . pack 'i', $self->{'__FONTFLAG'})
  206.               : '')
  207.       . pack ('a4a4I3i2', $self->{'__FORE'}, $self->{'__BACK'},
  208.             $self->{'__FONT'} ? $font->NameToNumber ($self->{'__FONT'})
  209.                       : 0,    # System font
  210.             $self->{'__H'} * 640, $self->{'__W'} * 640,
  211.             $self->{'__X'}, $self->{'__Y'})
  212.       . $self->{'__TEXT'} . "\0" x (4 - (length ($self->{'__TEXT'}) & 3))
  213. #      . "l$xxx$yyy$XXX$YYYÿÿÿÿB $xxx$YYY$XXX$YYY$XXX$yyy$xxx$yyy$xxx$YYY"
  214. }
  215.  
  216. sub ForeColour {
  217.     my $self = shift;
  218.     my $old = $self->{'__FORE'};
  219.     # Don't need to be able to pass undef
  220.     $self->{'__FORE'} = pack_colour ($_[0]) if defined $_[0];
  221.     unpack_colour $old;
  222. }
  223.  
  224. sub BackColour {
  225.     my $self = shift;
  226.     my $old = $self->{'__BACK'};
  227.     # Don't need to be able to pass undef
  228.     $self->{'__BACK'} = pack_colour ($_[0]) if defined $_[0];
  229.     unpack_colour $old;
  230. }
  231.  
  232. sub Font {
  233.     my $self = shift;
  234.     my $old = $self->{'__FONT'};
  235.     if (@_) {
  236.     $self->{'__FONT'} = defined $_[0] ? $_[0] : '';
  237.     undef $self->{'__BBOX'}
  238.     }
  239.     $old;
  240. }
  241.  
  242. sub Text {
  243.     my $self = shift;
  244.     my $old = $self->{'__TEXT'};
  245.     if (@_) {
  246.     $self->{'__TEXT'} = $_[0];
  247.     undef $self->{'__BBOX'}
  248.     }
  249.     $old;
  250. }
  251.  
  252. sub X {
  253.     my $self = shift;
  254.     my $old = $self->{'__X'};
  255.     if (@_) {
  256.     $self->{'__X'} = $_[0];
  257.     undef $self->{'__BBOX'}
  258.     }
  259.     $old;
  260. }
  261.  
  262. sub Y {
  263.     my $self = shift;
  264.     my $old = $self->{'__Y'};
  265.     if (@_) {
  266.     $self->{'__Y'} = $_[0];
  267.     undef $self->{'__BBOX'}
  268.     }
  269.     $old;
  270. }
  271.  
  272. sub W {
  273.     my $self = shift;
  274.     my $old = $self->{'__W'};
  275.     if (@_) {
  276.     $self->{'__W'} = defined $_[0] ? $_[0] : $self->{'__H'};
  277.     undef $self->{'__BBOX'}
  278.     }
  279.     $old;
  280. }
  281.  
  282. sub H {
  283.     my $self = shift;
  284.     my $old = $self->{'__H'};
  285.     if (@_) {
  286.     $self->{'__H'} = defined $_[0] ? $_[0] : $self->{'__W'};
  287.     undef $self->{'__BBOX'}
  288.     }
  289.     $old;
  290. }
  291.  
  292. sub Kern {
  293.     my $self = shift;
  294.     my $old = $self->{'__FONTFLAG'};
  295.     $old = 0 unless defined $old;
  296.     if (@_) {
  297.     $self->{'__FONTFLAG'} = ($old & 0xFFFFFFFE) | ($_[0] ? 1 : 0);
  298.     undef $self->{'__BBOX'}
  299.     }
  300.     $old & 1;
  301. }
  302. 1;
  303. __END__
  304.  
  305. =head1 NAME
  306.  
  307. RISCOS::Drawfile
  308.  
  309. =head1 SYNOPSIS
  310.  
  311. =head1 DESCRIPTION
  312.  
  313. =head1 BUGS
  314.  
  315. =head1 AUTHOR
  316.  
  317. Nicholas Clark <F<nick@unfortu.net>>
  318.