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 >
Wrap
Text File
|
1999-01-20
|
8KB
|
318 lines
package RISCOS::DrawFile::Text;
use Carp;
use strict;
use vars qw ($VERSION @ISA);
use RISCOS::Units qw(pack_transform_block unpack_transform_block
millipoint2draw point2draw);
require RISCOS::DrawFile::Object;
require RISCOS::Font;
use RISCOS::Colour qw(pack_colour unpack_colour);
$VERSION = 0.05;
# 0.02 Change pack template to I5i2 as x,y are *signed*
# 0.03 PrePack calls BBox, not BBoxCalc
# 0.04 if font passed to new is a font object then read its details, ignore
# xsize, ysize
# flags to strip spaces and return empty objects
# 0.05 adds Translate
@ISA = 'RISCOS::DrawFile::Object';
### use SelfLoader;
sub RISCOS::DrawFile::Text::new ($$);
sub RISCOS::DrawFile::Text::Type ;
sub RISCOS::DrawFile::Text::BBox_Calc ;
sub RISCOS::DrawFile::Text::Translate ($$$$);
sub RISCOS::DrawFile::Text::PrePack ;
sub RISCOS::DrawFile::Text::Size ;
sub RISCOS::DrawFile::Text::Pack ($$);
sub RISCOS::DrawFile::Text::ForeColour ;
sub RISCOS::DrawFile::Text::BackColour ;
sub RISCOS::DrawFile::Text::Font ;
sub RISCOS::DrawFile::Text::Text ;
sub RISCOS::DrawFile::Text::X ;
sub RISCOS::DrawFile::Text::Y ;
sub RISCOS::DrawFile::Text::W ;
sub RISCOS::DrawFile::Text::H ;
sub RISCOS::DrawFile::Text::Kern ;
1;
### __DATA__
sub new ($$) {
my $proto = shift;
my $class = ref($proto) || $proto;
my ($self, $type) = $class->SUPER::new (@_);
return $self if ref ($self) eq 'ARRAY';
my ($flag, $strip, $bbox, $length, $fore, $back, $font, $xsize, $ysize,
$xbase, $ybase, $text, $kern, $r2l, $trans) = (0);
return wantarray ? () : undef unless defined $_[0];
$strip = $_[1] || 0;
if (ref ($_[0]) eq 'ARRAY') {
($fore, $back, $font, $xsize, $ysize, $xbase, $ybase, $text, $kern,
$r2l, $trans) = @{$_[0]};
$flag |= 1 if $kern;
$flag |= 2 if $r2l;
if (ref ($font) eq 'RISCOS::Font') {
if ($strip & 2 and $text =~ s/^( +)//) {
$xbase += millipoint2draw $font->StringBBox($1)->[2];
}
($font, $xsize, $ysize) = $font->Name();
} else {
$ysize = $xsize unless defined $ysize;
}
($fore, $back) = pack_colour ($fore, $back);
$trans = [@$trans] if defined $trans; # Copy it.
} else {
# Time to unpack data
my $data = 0;
if (ref ($_[0]) eq 'SCALAR' or ref ($_[0]) eq 'LVALUE') {
# Has bounding box stripped
$data = ${$_[0]};
} else {
($length, @$bbox) = unpack 'x4Ii4', $_[0];
return undef unless length ($_[0]) == $length or $length & 3;
$data = substr $_[0], 24;
}
if ($type == 12) {
$data =~ s/^(.{24})(....)//s;
$trans = unpack_transform_block $1;
$flag = unpack 'I', $2;
# $kern = $flag & 0;
# $r2l = $flag & 1;
carp sprintf 'DrawFile object 12 (transformed text) flag is %X '
. '(reserved bits not zero)', $flag if $flag & ~3;
# Note that the low byte of this flag word is passed unmasked << 9
# to Font_ScanString in R2
}
my $style;
($fore, $back, $style, $xsize, $ysize, $xbase, $ybase, $text)
= unpack 'a4a4I3i2a*', $data;
$xsize /= 640;
$ysize /= 640;
$text =~ s/\0.*//s;
if ($style) {
croak 'No FontTable' unless defined ${$_[2]};
unless (defined ($font = ${$_[2]}->FontByNumber ($style))) {
carp "Unable to find font number $style in FontTable";
$font = '';
}
} else {
$font = '';
}
}
$text =~ s/ *$// if $strip & 1; # Strip trailing spaces.
if ($strip & 2 and $text =~ s/^( +)//) {
$xbase += millipoint2draw
RISCOS::Font::StringBBox([$font, $xsize, $ysize], $1)->[2];
}
unless (length $text) {
return [] if $strip & 4; # Flag set to quietly drop this
carp 'Attempt to create zero length text object';
return wantarray ? () : undef;
}
$self->{'__BBOX'} = $bbox;
$self->{'__FONTFLAG'} = $flag;
$self->{'__TRANSFORM'} = $trans if defined $trans;
$self->{'__FORE'} = $fore;
$self->{'__BACK'} = $back;
$self->{'__FONT'} = $font;
$self->{'__H'} = $xsize;
$self->{'__W'} = $ysize;
$self->{'__X'} = $xbase;
$self->{'__Y'} = $ybase;
$self->{'__TEXT'} = $text;
wantarray ? ($self, $type) : $self;
}
sub Type {
my $self = shift;
return 12 if defined $self->{'__TRANSFORM'} or $self->{'__FONTFLAG'};
1;
}
# erk, convert from millipoints to Draw Units
sub BBox_Calc {
my $self = shift;
my $bbox;
if ($self->{'__FONT'}) {
@$bbox # need array context
= millipoint2draw
RISCOS::Font::StringBBox ([$self->{'__FONT'},
$self->{'__H'}, $self->{'__W'}],
$self->{'__TEXT'},
$self->{'__FONTFLAG'},
$self->{'__TRANSFORM'});
} else { # System font
$$bbox[0] = $$bbox[1] = 0;
$$bbox[2] = length ($self->{'__TEXT'}) * point2draw ($self->{'__W'});
$$bbox[3] = point2draw ($self->{'__H'});
}
$$bbox[0] += $self->{'__X'};
$$bbox[1] += $self->{'__Y'};
$$bbox[2] += $self->{'__X'};
$$bbox[3] += $self->{'__Y'};
# print STDERR 'was ' . join (', ', @{$self->{'__BBOX'}}) . "\n";
# print STDERR 'now ' . join (', ', @$bbox) . "\n";
$self->{'__BBOX'} = $bbox;
}
sub Translate ($$$$) {
my ($self, $x, $y) = @_;
my $bbox = $self->{'__BBOX'};
if (defined $bbox) {
$$bbox[0] += $x;
$$bbox[1] += $y;
$$bbox[2] += $x;
$$bbox[3] += $y;
}
$self->{'__X'} += $x;
$self->{'__Y'} += $y;
();
}
sub PrePack {
my $self = shift;
# hash key is font name, value is number of users.
# only really need zero/non-zero
++$_[0]->{$self->{'__FONT'}};
$self->BBox (@_);
}
sub Size {
my $self = shift;
# 28 for transform & flags if present
# 28 for text colour to baseline coords
# 24 for type, length and bbox
# 4 for '\0' and padding.
my $size = (($self->Type == 12) ? (28 + 28 + 24 + 4)
: (28 + 24 + 4))
+ length $self->{'__TEXT'};
$size & ~3;
}
sub Pack ($$) {
my $self = shift;
my $font = $_[1];
my $type = $self->Type;
# my ($xxx, $yyy, $XXX, $YYY) = map {pack 'i', $_} @{$self->BBox};
$self->PackTypeSizeBBox($type)
. (($type == 12) ? (pack_transform_block (defined $self->{'__TRANSFORM'}
? $self->{'__TRANSFORM'}
: (0,0,0,0,0,0))
. pack 'i', $self->{'__FONTFLAG'})
: '')
. pack ('a4a4I3i2', $self->{'__FORE'}, $self->{'__BACK'},
$self->{'__FONT'} ? $font->NameToNumber ($self->{'__FONT'})
: 0, # System font
$self->{'__H'} * 640, $self->{'__W'} * 640,
$self->{'__X'}, $self->{'__Y'})
. $self->{'__TEXT'} . "\0" x (4 - (length ($self->{'__TEXT'}) & 3))
# . " l $xxx$yyy$XXX$YYYÿÿÿÿ B $xxx$YYY $XXX$YYY $XXX$yyy $xxx$yyy $xxx$YYY "
}
sub ForeColour {
my $self = shift;
my $old = $self->{'__FORE'};
# Don't need to be able to pass undef
$self->{'__FORE'} = pack_colour ($_[0]) if defined $_[0];
unpack_colour $old;
}
sub BackColour {
my $self = shift;
my $old = $self->{'__BACK'};
# Don't need to be able to pass undef
$self->{'__BACK'} = pack_colour ($_[0]) if defined $_[0];
unpack_colour $old;
}
sub Font {
my $self = shift;
my $old = $self->{'__FONT'};
if (@_) {
$self->{'__FONT'} = defined $_[0] ? $_[0] : '';
undef $self->{'__BBOX'}
}
$old;
}
sub Text {
my $self = shift;
my $old = $self->{'__TEXT'};
if (@_) {
$self->{'__TEXT'} = $_[0];
undef $self->{'__BBOX'}
}
$old;
}
sub X {
my $self = shift;
my $old = $self->{'__X'};
if (@_) {
$self->{'__X'} = $_[0];
undef $self->{'__BBOX'}
}
$old;
}
sub Y {
my $self = shift;
my $old = $self->{'__Y'};
if (@_) {
$self->{'__Y'} = $_[0];
undef $self->{'__BBOX'}
}
$old;
}
sub W {
my $self = shift;
my $old = $self->{'__W'};
if (@_) {
$self->{'__W'} = defined $_[0] ? $_[0] : $self->{'__H'};
undef $self->{'__BBOX'}
}
$old;
}
sub H {
my $self = shift;
my $old = $self->{'__H'};
if (@_) {
$self->{'__H'} = defined $_[0] ? $_[0] : $self->{'__W'};
undef $self->{'__BBOX'}
}
$old;
}
sub Kern {
my $self = shift;
my $old = $self->{'__FONTFLAG'};
$old = 0 unless defined $old;
if (@_) {
$self->{'__FONTFLAG'} = ($old & 0xFFFFFFFE) | ($_[0] ? 1 : 0);
undef $self->{'__BBOX'}
}
$old & 1;
}
1;
__END__
=head1 NAME
RISCOS::Drawfile
=head1 SYNOPSIS
=head1 DESCRIPTION
=head1 BUGS
=head1 AUTHOR
Nicholas Clark <F<nick@unfortu.net>>