home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Non-RPC
/
!Perl
/
riscos
/
RISCOS
/
DrawFile
/
TextArea.pm
< prev
Wrap
Text File
|
1999-01-20
|
5KB
|
192 lines
package RISCOS::DrawFile::TextArea;
use Carp;
use strict;
use vars qw ($VERSION @ISA $default_header $user_default_header);
#use RISCOS::Units qw(pack_transform_block unpack_transform_block
# millipoint2draw point2draw);
require RISCOS::DrawFile::Object;
# require RISCOS::Font;
$VERSION = 0.04;
# 0.04 adds Translate
# 0.03 adds TextArea method
# 0.02 keep colours internally as 4 bytes packed
@ISA = 'RISCOS::DrawFile::Object';
$default_header = <<'Wizzo';
\! 1
\F 0 Trinity.Medium 12
\F 1 Corpus.Medium 12
\0\AD/\L12
Wizzo
### use SelfLoader;
sub RISCOS::DrawFile::TextArea::DefaultHeader ($);
sub RISCOS::DrawFile::TextArea::new ($$);
sub RISCOS::DrawFile::TextArea::Type ;
sub RISCOS::DrawFile::TextArea::Cols ;
sub RISCOS::DrawFile::TextArea::ShiftCols ;
sub RISCOS::DrawFile::TextArea::TextArea ;
sub RISCOS::DrawFile::TextArea::Translate ($$$$);
sub RISCOS::DrawFile::TextArea::BBox_Calc ;
sub RISCOS::DrawFile::TextArea::Size ;
sub RISCOS::DrawFile::TextArea::Pack ($$);
sub RISCOS::DrawFile::TextArea::DefaultHeader ($);
sub RISCOS::DrawFile::TextArea::new ($$);
sub RISCOS::DrawFile::TextArea::Type ;
sub RISCOS::DrawFile::TextArea::Cols ;
sub RISCOS::DrawFile::TextArea::ShiftCols ;
sub RISCOS::DrawFile::TextArea::TextArea ;
sub RISCOS::DrawFile::TextArea::Translate ($$$$);
sub RISCOS::DrawFile::TextArea::BBox_Calc ;
sub RISCOS::DrawFile::TextArea::Size ;
sub RISCOS::DrawFile::TextArea::Pack ($$);
1;
### __DATA__
sub DefaultHeader ($) {
my $result = defined $user_default_header ? $user_default_header
: $default_header;
$user_default_header = shift if (@_);
$result;
}
sub new ($$) {
my $proto = shift;
my $class = ref($proto) || $proto;
my ($self, $type) = $class->SUPER::new (@_);
return $self if ref ($self) eq 'ARRAY';
my ($bbox, $fore, $back, $text, $cols) = ([]);
return wantarray ? () : undef unless defined $_[0];
if (ref $_[0] eq 'ARRAY') {
($text, $fore, $back, $cols) = @{$_[0]};
$cols = [@$cols]; # Copy theirs, rather than taking a reference.
$text = $self->DefaultHeader() unless $text =~ /^\\!/;
$text .= "\n" unless $text =~ /\n$/s;
} else {
# Time to unpack data
my $data;
if (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'LVALUE') {
# Has bounding box stripped
$data = ${$_[0]};
} else {
my $length;
($length, @$bbox) = unpack 'x4Ii4', $_[0];
return undef unless length ($_[0]) == $length or $length & 3;
$data = substr $_[0], 24;
}
while (length $data) {
# Hmm. I think that I know why there are two reserved words...
my ($ctype, $sublength, @box) = unpack 'I2i4', $data;
# Text area is at least 24 bytes after the columns
last if ($ctype == 0);
if ($ctype != 10 or $sublength != 24) {
warn sprintf "Tag &%X length $sublength when expecting text " .
'column object', $ctype;
return wantarray ? () : undef;
}
push @$cols, [@box];
$data = substr $data, 24;
}
my ($res1, $res2);
($res1, $res2, $fore, $back, $text) = unpack 'x4I2a4a4a*', $data;
carp sprintf 'Text area reserved words area &%08X &%08X - should be 0',
$res1, $res2 if $res1 or $res2;
$text =~ s/\0.*//s;
}
$self->{'__BBOX'} = $bbox;
$self->{'__COLS'} = $cols;
$self->{'__FORE'} = $fore;
$self->{'__BACK'} = $back;
$self->{'__TEXT'} = $text;
wantarray ? ($self, $type) : $self;
}
sub Type { 9; }
sub Cols {
my $self = shift;
my $old = $self->{'__COLS'};
$self->{'__COLS'} = $_[0] if (@_);
$old;
}
sub ShiftCols {
my $self = shift;
shift @{$self->{'__COLS'}};
}
sub TextArea {
my $self = shift;
my $old = $self->{'__TEXT'};
$self->{'__TEXT'} = $_[0] if (@_);
$old;
}
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;
}
foreach (@{$self->{'__COLS'}}) {
$$_[0] += $x;
$$_[1] += $y;
$$_[2] += $x;
$$_[3] += $y;
}
();
}
sub BBox_Calc {
my $self = shift;
my $box = [0x7FFFFFFF, 0x7FFFFFFF, -0x7FFFFFF, -0x7FFFFFF];
foreach (@{$self->{'__COLS'}}) {
$$box[0] = $$_[0] if $$box[0] > $$_[0]; # min
$$box[1] = $$_[1] if $$box[1] > $$_[1];
$$box[2] = $$_[2] if $$box[2] < $$_[2]; # max
$$box[3] = $$_[3] if $$box[3] < $$_[3];
}
$self->{'__BBOX'} = $box; # Return the bbox we made, and store it
}
sub Size {
my $self = shift;
# 4 for '\0' and padding.
(24 + 24 * @{$self->{'__COLS'}} + 20 + 4 + length $self->{'__TEXT'}) & ~3;
}
sub Pack ($$) {
my $self = shift;
$self->PackTypeSizeBBox(9)
. join ('', map { $self->PackTypeSizeBBox(10, 24, $_) }
@{$self->{'__COLS'}})
. pack ('I3a4a4', 0, 0, 0, $self->{'__FORE'}, $self->{'__BACK'})
. $self->{'__TEXT'} . "\0" x (4 - (length ($self->{'__TEXT'}) & 3))
}
1;
__END__
=head1 NAME
RISCOS::Drawfile
=head1 SYNOPSIS
=head1 DESCRIPTION
=head1 BUGS
=head1 AUTHOR
Nicholas Clark <F<nick@unfortu.net>>