home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Non-RPC
/
!Perl
/
riscos
/
RISCOS
/
DrawFile
/
TagObject.pm
< prev
next >
Wrap
Text File
|
1999-01-20
|
3KB
|
118 lines
package RISCOS::DrawFile::TagObject;
use strict;
use vars qw ($VERSION @ISA);
use Carp;
require RISCOS::DrawFile::Container;
require RISCOS::DrawFile::Object;
$VERSION = 0.03;
# 0.03 does Translate
# I think that this is no longer stuffed.
# There was a good reason why Group has Container before Object in @ISA
# I believe that it was to get the inheritence of Write and Pack correct
# (ie from Containter, not Object). new has to come from Object.
# Cure wass to re-write with same order as Group
# Also bug in that no check is made with Stuff() method that only a single
# object is being tagged.
@ISA = qw (RISCOS::DrawFile::Container RISCOS::DrawFile::Object);
###use SelfLoader;
sub RISCOS::DrawFile::TagObject::new ($);
sub RISCOS::DrawFile::TagObject::Translate ($$$$);
sub RISCOS::DrawFile::TagObject::Size ;
sub RISCOS::DrawFile::TagObject::Pack ;
sub RISCOS::DrawFile::TagObject::Write ;
sub RISCOS::DrawFile::TagObject::Tag ;
sub RISCOS::DrawFile::TagObject::TagData ;
1;
###__DATA__
sub new ($) {
my $proto = shift;
my $class = ref($proto) || $proto;
my ($self, $type) = $class->RISCOS::DrawFile::Object::new (@_);
return $self if ref ($self) eq 'ARRAY';
my ($tag, $length) = unpack 'x24Ix4I', $_[0];
$self->{'__TAGDATA'} = substr $_[0], 28 + $length;
$self->{'__TAG'} = $tag;
local $_[0] = \(substr $_[0], 28, $length);
my ($stuff, $a, $font) = $class->_split_drawobjs (@_);
# use Data::Dumper;
# print Dumper $stuff;
# warn $self;
# print Dumper $self;
$self->Stuff ($stuff);
$self->{'__TYPE'} = $type;
wantarray ? ($self, $type, $font) : $self;
}
sub Translate ($$$$) {
if (ref ($_[3]) eq 'CODE') {
&{$_[3]}($_[0], $_[1], $_[2]);
} elsif (not defined $_[3]) {
warn "Cannot translate $_[0] by ($_[1], $_[2])\n";
} elsif ($_[3] eq '') {
$_[0]->SUPER::Translate ($_[1], $_[2], $_[3]);
} else {
confess "Illegal third argument to translate ('$_[3]') when attempting to translate $_[0] by ($_[1], $_[2])";
}
();
}
sub Size {
my $self = shift;
28 + $self->SUPER::Size + length $self->{'__TAGDATA'};
}
sub Pack {
my $self = shift;
$self->PackTypeSizeBBox()
. pack ('I', $self->{'__TAG'})
. $self->SUPER::Stuff(@_)
. $self->{'__TAGDATA'};
}
sub Write {
my $self = shift;
my $good = print {$_[0]} $self->PackTypeSizeBBox(),
pack ('I', $self->{'__TAG'});
$good &= $self->SUPER::Write (@_); # Pass on args
print {$_[0]} $self->{'__TAGDATA'};
}
sub Tag {
my $self = shift;
my $tag = $self->{'__TAG'};
$self->{'__TAG'} = $_[0] if defined $_[0];
$tag;
}
sub TagData {
my $self = shift;
my $tagdata = $self->{'__TAGDATA'};
$self->{'__TAGDATA'} = $_[0] if defined $_[0];
$tagdata;
}
1;
__END__
=head1 NAME
RISCOS::Drawfile
=head1 SYNOPSIS
=head1 DESCRIPTION
=head1 BUGS
=head1 AUTHOR
Nicholas Clark <F<nick@unfortu.net>>