Acorn User 10/AU_CD10.iso/Updates/Perl/RPC/!Perl/riscos/RISCOS/DrawFile/TextArea.pm

Perl POD Document | 1999-01-20 | 4.9 KB | 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<[e-mail]>>