home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Non-RPC
/
!Perl
/
riscos
/
RISCOS
/
Font.pm
< prev
next >
Wrap
Text File
|
1999-02-20
|
11KB
|
334 lines
package RISCOS::Font;
use RISCOS::SWI;
use RISCOS::Units 'pack_transform_block';
use Carp;
# use SelfLoader;
require Exporter;
use strict;
use vars qw (@ISA @EXPORT_OK $VERSION $findfont $losefont $scanstring $charbbox
$readmetrics %openfonts);
@ISA = qw(Exporter);
$VERSION = 0.03;
@EXPORT_OK = qw(font_string_bbox font_char_bbox font_split_string
font_read_metrics font_max_bbox);
# 0.02 hacks things so that ScanString does what *I* expect which is to return
# the width of the string
$findfont = SWINumberFromString('XFont_FindFont');
$losefont = SWINumberFromString('XFont_LoseFont');
$scanstring = SWINumberFromString('XFont_ScanString');
$charbbox = SWINumberFromString('XFont_CharBBox');
$readmetrics = SWINumberFromString('XFont_ReadFontMetrics');
*font_char_bbox = \&CharBBox;
*font_string_bbox = \&StringBBox;
*font_split_string = \&Split;
*font_read_metrics = \&ReadMetrics;
*font_max_bbox = \&MaxBBox;
# $findfont && $losefont && $scanstring && $charbbox && $readmetrics;
#__DATA__
# Openfonts is a hash back from known font handle to RISCOS::Font objects
sub new ($$;$$$) {
my $proto = shift;
my $class = ref($proto) || $proto;
my ($name, $xpoints, $ypoints, $xdpi, $ydpi) = @_;
$xdpi |= 0; # Cull "Use of unitialized value" and ensure numeric
$ydpi |= 0;
# If only one is defined it gives both width and height.
$ypoints = $xpoints unless defined $ypoints;
$xpoints = $ypoints unless defined $xpoints;
my $handle = kernelswi ($findfont, 0, $name, $xpoints * 16,
$ypoints * 16, $xdpi, $ydpi);
return undef unless defined $handle;
($handle, $xdpi, $ydpi) = unpack 'Ix12I2', $handle;
my $self = $openfonts {$handle};
if (defined $self) {
kernelswi ($losefont, $handle);
return $self;
}
$self = {};
# print STDERR "Found '$name'\n";
$self->{'__NAME'} = $name;
$self->{'__HANDLE'} = $handle;
$self->{'__XPOINTS'} = $xpoints;
$self->{'__YPOINTS'} = $ypoints;
$self->{'__XDPI'} = $xdpi;
$self->{'__YDPI'} = $ydpi;
return $openfonts{$handle} = bless ($self, $class);
}
sub Clone { $_[0] } # Return ourself if we are asked to make a copy
sub DESTROY {
my $self = shift;
if (defined (my $handle = $self->{'__HANDLE'})) {
warn $^E unless defined kernelswi ($losefont, $handle);
delete $openfonts{$handle};
# print STDERR
# "Lose '$self->{__NAME}' $self->{__XPOINTS}×$self->{__YPOINTS}\n"
}
}
sub PointX {
$_[0]->{'__XPOINTS'};
}
sub PointY {
$_[0]->{'__YPOINTS'};
}
sub Name {
wantarray ? ($_[0]->{'__NAME'}, $_[0]->{'__XPOINTS'}, $_[0]->{'__YPOINTS'})
: $_[0]->{'__NAME'};
}
# Font
# text
# split
# flags
# x
# y
# transform
sub scanstring ($$;$$$$$) {
my $self = shift;
if ('ARRAY' eq ref $self) {
$self = new RISCOS::Font (@$self);
# Make a temporary font object - this will get destroyed on exit.
}
return () unless defined $self;
my ($text, $split, $flag, $x, $y, $trans) = @_;
my $spacing = pack 'x16ix16', ((defined $split && length $split)
? ord $split : -1);
$x = 0x40000000 unless defined $x; # Width, or x of mouse click
$y = 0x40000000 unless defined $y;
my $transblock = pack_transform_block $trans if defined $trans;
my $flags = 0x00140120 # bit 5 R5 in
# bit 8 R0 in
# bit 18 return box
# bit 20 return count of chars
| (defined $transblock ? 0x40 : 0)
| (defined $flag ? (($flag & 0xFF) << 9) : 0);
my $result = kernelswi ($scanstring, $self->{'__HANDLE'}, $text, $flags, $x,
$y, $spacing, defined $transblock ? $transblock
: 0);
defined ($result) ? ($result, $spacing,
unpack ('x4I', $result)
- unpack ('I', pack 'P', $text)) : ();
# Work out how long the string is (including all the control chars)
}
sub CharBBox ($$) {
my $self = shift;
if ('ARRAY' eq ref $self) {
$self = new RISCOS::Font (@$self);
# Make a temporary font object - this will get destroyed on exit.
}
return ()
unless defined $self and defined $_[0]
and defined (my $result = kernelswi ($charbbox, $self->{'__HANDLE'},
ord $_[0], 0x00));
# Bit 4 clear in R2 to use millipoints
wantarray ? unpack 'x4i4', $result : [unpack 'x4i4', $result]
}
# Font
# text
# # baseline x
# # baseline y
# flags
# transform
sub StringBBox ($$;$$) {
my ($result, $spacing)
= scanstring ($_[0],$_[1],undef,$_[2],undef,undef,$_[3]);
return () unless defined $result;
my $count = unpack 'x28I', $result;
if ($count) {
my $hack = unpack 'x12i', $result;
$result = [unpack 'x20i4', $spacing];
# Hack for trailing space
# "foo " and "foo" have the same width
# "foo " has the width you would expect of "foo "
# Until you realise that the algorithm ingores a single trailing
# character with no black (eg space, hard space)
$$result[2] = $hack if $hack > $$result[2];
} else {
# Seems that stringwidth of '' gives a very messy value
# &20000000 ~&20000000 &20000000 ~&20000000
$result = [0, 0, 0, 0];
}
wantarray ? @$result : $result;
}
# Font
# text
# split
# flags
# x
# y
# transform
sub Split {
my ($text) = $_[1];
my ($result, $spacing, $length) = &scanstring;
return () unless defined $result;
my $count = unpack 'x28I', $result;
my ($x, $y);
substr ($text, $length) = ''; # This is messy.
if (length $text) {
($x,$y) = unpack 'x12i2', $result;
$result = [unpack 'x20i4', $spacing];
} else {
# Seems that stringwidth of '' gives a very messy value
# &20000000 ~&20000000 &20000000 ~&20000000
$result = [0, 0, 0, 0];
}
wantarray ? ($text, $x, $y, $result) : $text;
}
sub ReadMetrics ($;$$$$$$$) {
my $self = shift;
if ('ARRAY' eq ref $self) {
$self = new RISCOS::Font (@$self);
# Make a temporary font object - this will get destroyed on exit.
}
return () unless my $result = kernelswi ($readmetrics, $self->{'__HANDLE'},
0, 0, 0 ,0 ,0, 0, 0);
@_ = (1, 1, 1, 1, 1) unless @_;
my @size = unpack 'x4I5', $result; # Get sizes of 5 buffers.
# Will be 7 someday
for (my $count = 5; $count--; ) {
if (defined $_[$count]) {
# Passing the same scalar more than once is going to break this
$_[$count] = ' ' x $size[$count] # Read this one
} else {
$_[$count] = 0 # Read its size (again)
}
}
return () unless $result = kernelswi ($readmetrics, $self->{'__HANDLE'},
@_[0..4], 0, 0);
wantarray ? (unpack ('I', $result), @_[0..4]) : unpack ('I', $result);
}
sub MaxBBox ($) {
my $misc = '';
return () unless defined ReadMetrics ($_[0], undef, undef, undef, $misc);
wantarray ? (unpack 'i4', $misc) : [unpack 'i4', $misc];
}
$findfont && $losefont && $scanstring && $charbbox && $readmetrics;
__END__
=head1 NAME
RISCOS::Font -- perl interface to fonts and the font manager
=head1 SYNOPSIS
use RISCOS::Font;
$font = RISCOS::Font->new('Homerton.Medium',12);
@bbox = $font->StringBBox('Hello World');
=head1 DESCRIPTION
C<RISCOS::Font> provides an interface to the Font manager allowing programs to
use outline fonts. Currently only functions to calculate the dimensions of
strings and characters are implemented, principally for the DrawFile Text object
and the TextArea parser. C<RISCOS::Font> automatically keeps track of the fonts
in use, freeing a font handle with C<XFont_LoseFont> when the last reference
goes out of scope. Functionality is provided both as methods on C<RISCOS::Font>
objects and as functions that take a text description of the font to use. This
description is passed as a reference to an array of parameters for C<new>.
=head2 Subroutines/Methods
=over 4
=item new <name> <xpoints> <ypoints> <xdpi> <ydpi>
C<new> returns a C<RISCOS::Font> object referring to the specifed font, creating
a new object if necessary. As object's destructor calls C<XFont_LoseFont> when
the last reference to it is destroyed, C<RISCOS::Font> keeps track of font
handles without programmer intervention. One out of I<xpoints> and I<ypoints>
must be specified, and if only one is specified both default to this value.
If I<xdpi> or I<ydpi> are undefined then 0 is passed to C<XFont_FindFont> to use
the default dpi.
=item Clone
C<Clone> returns a copy of the C<RISCOS::Font> object.
=item PointX
=item PointX
C<PointX> and C<PointY> return the X and Y point sizes respectively.
=item Name
In B<scalar> context C<Name> returns the font's name. In array context returns
C<(I<Name>, I<PointX>, I<PointY>)>.
=item CharBBox <character>
=item font_char_bbox <font> <character>
returns the bounding box of the specified character in millipoints.
=item StringBBox <text> [<flags> [<transform>]]
=item font_string_bbox <font> <text> [<flags> [<transform>]]
returns the bounding box (in millipoints) of the specified text(which may
contain font control sequences). In array context returns the bounding box, in
scalar context a reference to the bounding box array. This function is similar
to C<XFont_StringBBox> B<except> that it will return C<(0,0,0,0>) for an empty
string and that it B<will> add the width of any trailing space. I<transform> if
defined should point to a transformation matrix, and I<flags> are:
=over 8
bit 0 perform kerning
bit 1 wrting direction is right to left
=back
=item Split <text> <split> <flags> <x> <y> <transform>
=item font_split_string <font> <text> <split> <flags> <x> <y> <transform>
returns the longest substring that fits within the specified coordinates,
splitting the text at the specified character (or any if C<undef> is specified).
In scalar context returns the split string, in list context returns
C<(I<text>, I<x>, I<y>, C<\@bbox>)> where I<x>, I<y> gives the position of the
split, and I<bbox> is a reference to an array containing the bounding box of the
split string (the string starts at 0,0). I<flags> and I<transform> are as for
C<StringBBox>.
=back
=head1 BUGS
C<StringBBox> doesn't match the behaviour of C<XFont_ScanString>, because
C<XFont_ScanString> is illogical when it comes to spaces. The "raw" bounding
box of C<"a "> is eqivalent to C<"a">, while the "raw" bounding box of C<"a ">
is equivalent to the total width of C<"a "> (I<i.e.> the position where the next
character would start). This is presumably because spaces are stated as having a
bounding box of (0, 0, 0, 0) and the SWI naïvely positions each space at the
correct place along the string and merges the bounding box. Hence strings like
C<"_ "> have a "bounding box" that neither gives the region of printed ink, nor
the total width of the string. This is a bug on Acorn's part, because the
bounding box is defined as (inclusive, inclusive, B<ex>clusive, B<ex>clusive),
hence (0, 0, 0, 0) should be recognised as illegal (and hence special case).
=head1 AUTHOR
Nicholas Clark <F<nick@unfortu.net>>
=cut