home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / Font.pm < prev    next >
Encoding:
Perl POD Document  |  1999-02-20  |  10.6 KB  |  334 lines
  1. package RISCOS::Font;
  2.  
  3. use RISCOS::SWI;
  4. use RISCOS::Units 'pack_transform_block';
  5. use Carp;
  6. # use SelfLoader;
  7. require Exporter;
  8. use strict;
  9. use vars qw (@ISA @EXPORT_OK $VERSION $findfont $losefont $scanstring $charbbox
  10.          $readmetrics %openfonts);
  11.  
  12. @ISA = qw(Exporter);
  13. $VERSION = 0.03;
  14. @EXPORT_OK = qw(font_string_bbox font_char_bbox font_split_string
  15.         font_read_metrics font_max_bbox);
  16.  
  17. # 0.02 hacks things so that ScanString does what *I* expect which is to return
  18. # the width of the string
  19.  
  20. $findfont    = SWINumberFromString('XFont_FindFont');
  21. $losefont    = SWINumberFromString('XFont_LoseFont');
  22. $scanstring    = SWINumberFromString('XFont_ScanString');
  23. $charbbox    = SWINumberFromString('XFont_CharBBox');
  24. $readmetrics    = SWINumberFromString('XFont_ReadFontMetrics');
  25.  
  26. *font_char_bbox = \&CharBBox;
  27. *font_string_bbox = \&StringBBox;
  28. *font_split_string = \&Split;
  29.  
  30. *font_read_metrics = \&ReadMetrics;
  31. *font_max_bbox = \&MaxBBox;
  32.  
  33. # $findfont && $losefont && $scanstring && $charbbox && $readmetrics;
  34. #__DATA__
  35.  
  36. # Openfonts is a hash back from known font handle to RISCOS::Font objects
  37. sub new ($$;$$$) {
  38.     my $proto = shift;
  39.     my $class = ref($proto) || $proto;
  40.     my ($name, $xpoints, $ypoints, $xdpi, $ydpi) = @_;
  41.     $xdpi |= 0;    # Cull "Use of unitialized value" and ensure numeric
  42.     $ydpi |= 0;
  43.     # If only one is defined it gives both width and height.
  44.     $ypoints = $xpoints unless defined $ypoints;
  45.     $xpoints = $ypoints unless defined $xpoints;
  46.     my $handle = kernelswi ($findfont, 0, $name, $xpoints * 16,
  47.                 $ypoints * 16, $xdpi, $ydpi);
  48.  
  49.  
  50.     return undef unless defined $handle;
  51.  
  52.     ($handle, $xdpi, $ydpi) = unpack 'Ix12I2', $handle;
  53.     my $self = $openfonts {$handle};
  54.     if (defined $self) {
  55.     kernelswi ($losefont, $handle);
  56.     return $self;
  57.     }
  58.  
  59.     $self = {};
  60. #    print STDERR "Found '$name'\n";
  61.     $self->{'__NAME'} = $name;
  62.     $self->{'__HANDLE'} = $handle;
  63.     $self->{'__XPOINTS'} = $xpoints;
  64.     $self->{'__YPOINTS'} = $ypoints;
  65.     $self->{'__XDPI'} = $xdpi;
  66.     $self->{'__YDPI'} = $ydpi;
  67.     return $openfonts{$handle} = bless ($self, $class);
  68. }
  69.  
  70. sub Clone { $_[0] }    # Return ourself if we are asked to make a copy
  71.  
  72. sub DESTROY {
  73.     my $self = shift;
  74.     if (defined (my $handle = $self->{'__HANDLE'})) {
  75.     warn $^E unless defined kernelswi ($losefont, $handle);
  76.     delete $openfonts{$handle};
  77.     # print STDERR
  78.     #    "Lose '$self->{__NAME}' $self->{__XPOINTS}×$self->{__YPOINTS}\n"
  79.     }
  80. }
  81. sub PointX {
  82.     $_[0]->{'__XPOINTS'};
  83. }
  84. sub PointY {
  85.     $_[0]->{'__YPOINTS'};
  86. }
  87.  
  88. sub Name {
  89.     wantarray ? ($_[0]->{'__NAME'}, $_[0]->{'__XPOINTS'}, $_[0]->{'__YPOINTS'})
  90.           : $_[0]->{'__NAME'};
  91. }
  92. # Font
  93. # text
  94. # split
  95. # flags
  96. # x
  97. # y
  98. # transform
  99. sub scanstring ($$;$$$$$) {
  100.     my $self = shift;
  101.     if ('ARRAY' eq ref $self) {
  102.     $self = new RISCOS::Font (@$self);
  103.     # Make a temporary font object - this will get destroyed on exit.
  104.     }
  105.     return () unless defined $self;
  106.     my ($text, $split, $flag, $x, $y, $trans) = @_;
  107.     my $spacing = pack 'x16ix16', ((defined $split && length $split)
  108.                     ? ord $split : -1);
  109.     $x = 0x40000000 unless defined $x;    # Width, or x of mouse click
  110.     $y = 0x40000000 unless defined $y;
  111.     my $transblock = pack_transform_block $trans if defined $trans;
  112.     my $flags = 0x00140120    # bit  5    R5 in
  113.                 # bit  8    R0 in
  114.                 # bit 18    return box
  115.                 # bit 20    return count of chars
  116.         | (defined $transblock ? 0x40 : 0)
  117.         | (defined $flag ? (($flag & 0xFF) << 9) : 0);
  118.  
  119.     my $result = kernelswi ($scanstring, $self->{'__HANDLE'}, $text, $flags, $x,
  120.                 $y, $spacing, defined $transblock ? $transblock
  121.                                   : 0);
  122.     defined ($result) ? ($result, $spacing,
  123.              unpack ('x4I', $result)
  124.              - unpack ('I', pack 'P', $text)) : ();
  125.     # Work out how long the string is (including all the control chars)
  126. }
  127.  
  128. sub CharBBox ($$) {
  129.     my $self = shift;
  130.     if ('ARRAY' eq ref $self) {
  131.     $self = new RISCOS::Font (@$self);
  132.     # Make a temporary font object - this will get destroyed on exit.
  133.     }
  134.     return ()
  135.       unless defined $self and defined $_[0]
  136.      and defined (my $result = kernelswi ($charbbox, $self->{'__HANDLE'},
  137.                           ord $_[0], 0x00));
  138.     # Bit 4 clear in R2 to use millipoints
  139.     wantarray ? unpack 'x4i4', $result : [unpack 'x4i4', $result]
  140. }
  141.  
  142. # Font
  143. # text
  144. # # baseline x
  145. # # baseline y
  146. # flags
  147. # transform
  148. sub StringBBox ($$;$$) {
  149.     my ($result, $spacing)
  150.       = scanstring ($_[0],$_[1],undef,$_[2],undef,undef,$_[3]);
  151.     return () unless defined $result;
  152.     my $count = unpack 'x28I', $result;
  153.     if ($count) {
  154.     my $hack = unpack 'x12i', $result;
  155.     $result = [unpack 'x20i4', $spacing];
  156.     # Hack for trailing space
  157.     # "foo " and "foo" have the same width
  158.     # "foo  " has the width you would expect of "foo "
  159.     # Until you realise that the algorithm ingores a single trailing
  160.     # character with no black (eg space, hard space)
  161.     $$result[2] = $hack if $hack > $$result[2];
  162.     } else {
  163.     # Seems that stringwidth of '' gives a very messy value
  164.     # &20000000 ~&20000000 &20000000 ~&20000000
  165.     $result = [0, 0, 0, 0];
  166.     }
  167.     wantarray ? @$result : $result;
  168. }
  169.  
  170. # Font
  171. # text
  172. # split
  173. # flags
  174. # x
  175. # y
  176. # transform
  177. sub Split {
  178.     my ($text) = $_[1];
  179.     my ($result, $spacing, $length) = &scanstring;
  180.     return () unless defined $result;
  181.     my $count = unpack 'x28I', $result;
  182.     my ($x, $y);
  183.     substr ($text, $length) = '';    # This is messy.
  184.     if (length $text) {
  185.     ($x,$y) = unpack 'x12i2', $result;
  186.     $result = [unpack 'x20i4', $spacing];
  187.  
  188.     } else {
  189.     # Seems that stringwidth of '' gives a very messy value
  190.     # &20000000 ~&20000000 &20000000 ~&20000000
  191.     $result = [0, 0, 0, 0];
  192.     }
  193.     wantarray ? ($text, $x, $y, $result) : $text;
  194. }
  195.  
  196. sub ReadMetrics ($;$$$$$$$) {
  197.     my $self = shift;
  198.     if ('ARRAY' eq ref $self) {
  199.     $self = new RISCOS::Font (@$self);
  200.     # Make a temporary font object - this will get destroyed on exit.
  201.     }
  202.     return () unless my $result = kernelswi ($readmetrics, $self->{'__HANDLE'},
  203.                          0, 0, 0 ,0 ,0, 0, 0);
  204.     @_ = (1, 1, 1, 1, 1) unless @_;
  205.     my @size = unpack 'x4I5', $result;    # Get sizes of 5 buffers.
  206.     # Will be 7 someday
  207.     for (my $count = 5; $count--; ) {
  208.     if (defined $_[$count]) {
  209.         # Passing the same scalar more than once is going to break this
  210.         $_[$count] = ' ' x $size[$count]    # Read this one
  211.     } else {
  212.         $_[$count] = 0            # Read its size (again)
  213.     }
  214.     }
  215.     return () unless $result = kernelswi ($readmetrics, $self->{'__HANDLE'},
  216.                       @_[0..4], 0, 0);
  217.     wantarray ? (unpack ('I', $result), @_[0..4]) : unpack ('I', $result);
  218. }
  219. sub MaxBBox ($) {
  220.     my $misc = '';
  221.     return () unless defined ReadMetrics ($_[0], undef, undef, undef, $misc);
  222.     wantarray ? (unpack 'i4', $misc) : [unpack 'i4', $misc];
  223. }
  224. $findfont && $losefont && $scanstring && $charbbox && $readmetrics;
  225. __END__
  226.  
  227. =head1 NAME
  228.  
  229. RISCOS::Font -- perl interface to fonts and the font manager
  230.  
  231. =head1 SYNOPSIS
  232.  
  233.      use RISCOS::Font;
  234.      $font = RISCOS::Font->new('Homerton.Medium',12);
  235.      @bbox = $font->StringBBox('Hello World');
  236.  
  237. =head1 DESCRIPTION
  238.  
  239. C<RISCOS::Font> provides an interface to the Font manager allowing programs to
  240. use outline fonts. Currently only functions to calculate the dimensions of
  241. strings and characters are implemented, principally for the DrawFile Text object
  242. and the TextArea parser. C<RISCOS::Font> automatically keeps track of the fonts
  243. in use, freeing a font handle with C<XFont_LoseFont> when the last reference
  244. goes out of scope. Functionality is provided both as methods on C<RISCOS::Font>
  245. objects and as functions that take a text description of the font to use. This
  246. description is passed as a reference to an array of parameters for C<new>.
  247.  
  248. =head2 Subroutines/Methods
  249.  
  250. =over 4
  251.  
  252. =item new <name> <xpoints> <ypoints> <xdpi> <ydpi>
  253.  
  254. C<new> returns a C<RISCOS::Font> object referring to the specifed font, creating
  255. a new object if necessary. As object's destructor calls C<XFont_LoseFont> when
  256. the last reference to it is destroyed, C<RISCOS::Font> keeps track of font
  257. handles without programmer intervention. One out of I<xpoints> and I<ypoints>
  258. must be specified, and if only one is specified both default to this value.
  259. If I<xdpi> or I<ydpi> are undefined then 0 is passed to C<XFont_FindFont> to use
  260. the default dpi.
  261.  
  262. =item Clone
  263.  
  264. C<Clone> returns a copy of the C<RISCOS::Font> object.
  265.  
  266. =item PointX
  267.  
  268. =item PointX
  269.  
  270. C<PointX> and C<PointY> return the X and Y point sizes respectively.
  271.  
  272. =item Name
  273.  
  274. In B<scalar> context C<Name> returns the font's name. In array context returns
  275. C<(I<Name>, I<PointX>, I<PointY>)>.
  276.  
  277. =item CharBBox <character>
  278.  
  279. =item font_char_bbox <font> <character>
  280.  
  281. returns the bounding box of the specified character in millipoints.
  282.  
  283. =item StringBBox <text> [<flags> [<transform>]]
  284.  
  285. =item font_string_bbox <font> <text> [<flags> [<transform>]]
  286.  
  287. returns the bounding box (in millipoints) of the specified text(which may
  288. contain font control sequences). In array context returns the bounding box, in
  289. scalar context a reference to the  bounding box array. This function is similar
  290. to C<XFont_StringBBox> B<except> that it will return C<(0,0,0,0>) for an empty
  291. string and that it B<will> add the width of any trailing space. I<transform> if
  292. defined should point to a transformation matrix, and I<flags> are:
  293.  
  294. =over 8
  295.  
  296.     bit 0    perform kerning
  297.     bit 1    wrting direction is right to left
  298.  
  299. =back
  300.  
  301. =item Split <text> <split> <flags> <x> <y> <transform>
  302.  
  303. =item font_split_string <font> <text> <split> <flags> <x> <y> <transform>
  304.  
  305. returns the longest substring that fits within the specified coordinates,
  306. splitting the text at the specified character (or any if C<undef> is specified).
  307. In scalar context returns the split string, in list context returns
  308. C<(I<text>, I<x>, I<y>, C<\@bbox>)> where I<x>, I<y> gives the position of the
  309. split, and I<bbox> is a reference to an array containing the bounding box of the
  310. split string (the string starts at 0,0). I<flags> and I<transform> are as for
  311. C<StringBBox>.
  312.  
  313. =back
  314.  
  315. =head1 BUGS
  316.  
  317. C<StringBBox> doesn't match the behaviour of C<XFont_ScanString>, because
  318. C<XFont_ScanString> is illogical when it comes to spaces. The "raw" bounding
  319. box of C<"a "> is eqivalent to C<"a">, while the "raw" bounding box of C<"a  ">
  320. is equivalent to the total width of C<"a "> (I<i.e.> the position where the next
  321. character would start). This is presumably because spaces are stated as having a
  322. bounding box of (0, 0, 0, 0) and the SWI naïvely positions each space at the
  323. correct place along the string and merges the bounding box. Hence strings like
  324. C<"_  "> have a "bounding box" that neither gives the region of printed ink, nor
  325. the total width of the string. This is a bug on Acorn's part, because the
  326. bounding box is defined as (inclusive, inclusive, B<ex>clusive, B<ex>clusive),
  327. hence (0, 0, 0, 0) should be recognised as illegal (and hence special case).
  328.  
  329. =head1 AUTHOR
  330.  
  331. Nicholas Clark <F<nick@unfortu.net>>
  332.  
  333. =cut
  334.