home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Non-RPC
/
!Perl
/
riscos
/
RISCOS
/
DrawFile
/
Container.pm
< prev
next >
Wrap
Text File
|
1999-01-20
|
19KB
|
632 lines
package RISCOS::DrawFile::Container;
require RISCOS::DrawFile::Common;
require RISCOS::DrawFile::FontTable;
require RISCOS::DrawFile::Text;
require RISCOS::DrawFile::TextArea;
require RISCOS::DrawFile::OpaqueObject;
require RISCOS::DrawFile::Group;
require RISCOS::DrawFile::TagObject;
require RISCOS::DrawFile::Options;
require RISCOS::DrawFile::Path;
require RISCOS::DrawFile::Sprite;
require RISCOS::DrawFile::JPEG;
use Carp;
use strict;
use vars qw ($VERSION @ISA %objs @EXPORT_OK);
@ISA = qw(RISCOS::DrawFile::Common Exporter);
@EXPORT_OK = 'split_drawobjs';
$VERSION = 0.07;
# 0.07 adds Translate, MoreStuff
# 0.06
# Replace returns () not undef. Bozo
# localise $_ in map (by hook or by crook)
# 0.05
# split_drawobjs as a function.
# 0.04
# Name changes along with copy constructor.
# 0.03
# Added Replace. Documentation up to date
# 0.02
# Remember to undef the bounding box if we change the 'stuff'
# Now copes elegantly if container contains no objects with valid bboxes.
sub Objfunc {
\%objs;
}
%objs = (
0 => sub { RISCOS::DrawFile::FontTable->new (@_) }, # FontTable
2 => sub { RISCOS::DrawFile::Path->new (@_) }, # Path
6 => sub { new RISCOS::DrawFile::Group @_ }, # Group
7 => sub { new RISCOS::DrawFile::TagObject @_ }, # Tag
9 => sub { new RISCOS::DrawFile::TextArea @_ }, # Text Area
16 => sub { new RISCOS::DrawFile::JPEG @_ }, # JPEG
);
$objs{1} = # Text
$objs{12} = # Transformed Text
sub { new RISCOS::DrawFile::Text @_ };
$objs{5} = # Sprite
$objs{13} = # Transformed Sprite
sub { new RISCOS::DrawFile::Sprite @_ };
$objs{11} = # Draw options
$objs{101} = # DrawPlus options
sub { new RISCOS::DrawFile::Options @_ };
### use SelfLoader;
sub RISCOS::DrawFile::Container::new ;
sub RISCOS::DrawFile::Container::Stuff ;
sub RISCOS::DrawFile::Container::MoreStuff ;
sub RISCOS::DrawFile::Container::PrePack ;
sub RISCOS::DrawFile::Container::Size ;
sub RISCOS::DrawFile::Container::Pack ;
sub RISCOS::DrawFile::Container::Write ;
sub RISCOS::DrawFile::Container::_split_drawobjs ($$$$$$$);
sub RISCOS::DrawFile::Container::split_drawobjs ($$;$$$$$);
sub RISCOS::DrawFile::Container::Second_Font_Table ;
sub RISCOS::DrawFile::Container::Unknown_Obj ;
sub RISCOS::DrawFile::Container::BBox_Calc ;
sub RISCOS::DrawFile::Container::Translate ;
sub RISCOS::DrawFile::Container::DoToAll ;
sub RISCOS::DrawFile::Container::Do ;
sub RISCOS::DrawFile::Container::Replace ;
sub RISCOS::DrawFile::Container::Change ;
sub RISCOS::DrawFile::Container::ChangeString ;
1;
### __DATA__
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
$self->{'__STUFF'} = (ref($_[0]) eq 'ARRAY') ? $_[0] : [@_];
return bless ($self, $class);
}
sub Stuff {
my $self = shift;
my $stuff = $self->{'__STUFF'};
my $newstuff = (ref($_[0]) eq 'ARRAY') ? $_[0] : \@_;
if (@$newstuff) {
my $use = [];
foreach (@$newstuff) {
push @$use, $_ if defined $_;
}
$self->{'__STUFF'} = $use;
undef $self->{'__BBOX'};
}
$stuff;
}
sub MoreStuff {
my $self = shift;
my $stuff = $self->{'__STUFF'};
my $newstuff = (ref($_[0]) eq 'ARRAY') ? $_[0] : \@_;
if (@$newstuff) {
foreach (@$newstuff) {
push @$stuff, $_ if defined $_;
}
undef $self->{'__BBOX'};
}
$stuff;
}
# For me when I'm feeling daft - this recursively calls PrePack, not BBox_Calc.
# So don't try to change (read break) it.
sub PrePack {
my $self = shift;
return undef unless @{$self->{'__STUFF'}};
my $box;
foreach (@{$self->{'__STUFF'}}) {
next unless (my $subbox = $_->PrePack (@_));
confess "$#$subbox $_" unless defined $$subbox[3];
if (defined $box) {
$$box[0] = $$subbox[0] if $$box[0] > $$subbox[0]; # min
$$box[1] = $$subbox[1] if $$box[1] > $$subbox[1];
$$box[2] = $$subbox[2] if $$box[2] < $$subbox[2]; # max
$$box[3] = $$subbox[3] if $$box[3] < $$subbox[3];
} else {
$box = [@$subbox];
}
}
$self->{'__BBOX'} = $box; # Return the bbox we made, and store it
}
sub Size {
my $self = shift;
my $size = 0;
foreach (@{$self->{'__STUFF'}}) {
$size += $_->Size;
}
$size;
}
# fonttable (as param 2)
sub Pack {
my $self = shift;
join '', map { $_->Pack (@_)} (@{$self->{'__STUFF'}});
}
# handle
# fonttable
sub Write {
my $self = shift;
my $good = 0;
foreach (@{$self->{'__STUFF'}}) {
$good &= $_->Write (@_);
}
$good;
}
# Data scalar data
# scalar ref type, length, bbox striped
# array ref array of objects for group
# array
# hash ref ?? array, name, type data ?? dunno...
# type split
# function ref pass unpslit type
# returns (type, layer, flags, spare) or (type)
# array ref (type, layer, flags, spare)
# ref to fonttable (starts as undef)
# sub constructors (array or hash - both!)
# duplicate font table
# unknown object constructor.
# Constructors return an array of
# single object / array ref to array of objects
# type (or undef)
# fonttable (if found)
sub _split_drawobjs ($$$$$$$) {
shift; # my $self = shift;
my $data = shift; # Don't want to clobber it.
my ($split, $fonttable, $subconst, $fontfunc, $unk) = @_;
unshift @_, undef;
carp "Can't split a " . ref ($data) . ' ref, only SCALAR refs'
unless ref ($data) eq 'LVALUE' || ref ($data) eq 'SCALAR';
my ($position, $stuff, $font) = (0);
while ($position < length ($$data)) {
my ($type, $length) = unpack 'I2', substr $$data, $position;
$type = &$split ($type) if defined $split;
my $func;
if (ref ($subconst) eq 'HASH') {
$func = $subconst->{$type};
} elsif (ref ($subconst) eq 'ARRAY') {
$func = $subconst->[$type];
} else {
carp "Can't lookup objects in a " . ref ($subconst) . ' ref';
}
$func = $unk unless (defined $func);
$_[0] = substr $$data, $position, $length;
my @result = $func->(@_);
# Pass on @_;
if (ref $result[2] eq 'RISCOS::DrawFile::FontTable') {
if (defined $$fonttable) {
$fontfunc->(@_); # Got one already
} else {
$$fonttable = $font = $result[2]; # Store FontTable ref
}
}
push @$stuff, (ref ($result[0]) eq 'ARRAY') ? @{$result[0]} : $result[0]
if defined $result[0];
$position += $length;
}
($stuff, undef, $font);
}
sub split_drawobjs ($$;$$$$$) {
if (defined ($_[2]) and $_[2] eq '+') {
$_[2] = \&RISCOS::DrawFile::Common::drawplus_split_type;
}
$_[3] = {} unless defined $_[3];
$_[4] = defined $_[0] ? $_[0]->Objfunc() : Objfunc() unless defined $_[4];
$_[5] = defined $_[0] ? $_[0]->can ('Second_Font_Table')
: \&Second_Font_Table
unless defined $_[5];
$_[6] = defined $_[0] ? $_[0]->can ('Unknown_Obj')
: \&Unknown_Obj
unless defined $_[6];
goto &_split_drawobjs;
}
sub Second_Font_Table {
carp 'Duplicate font table size ' . length ($_[0]) . ' found - will ignore';
();
}
sub Unknown_Obj {
carp sprintf 'Uknown object type &%08X size %d found - will treat as opaque',
unpack ('I', $_[0]), length ($_[0]);
new RISCOS::DrawFile::OpaqueObject @_;
}
sub BBox_Calc {
my $self = shift;
return undef unless @{$self->{'__STUFF'}};
my $box;
foreach (@{$self->{'__STUFF'}}) {
next unless (my $subbox = $_->BBox_Calc);
if (defined $box) {
$$box[0] = $$subbox[0] if $$box[0] > $$subbox[0]; # min
$$box[1] = $$subbox[1] if $$box[1] > $$subbox[1];
$$box[2] = $$subbox[2] if $$box[2] < $$subbox[2]; # max
$$box[3] = $$subbox[3] if $$box[3] < $$subbox[3];
} else {
$box = [@$subbox];
}
}
$self->{'__BBOX'} = $box; # Return the bbox we made, and store it
}
sub Translate {
my $self = shift;
foreach (@{$self->{'__STUFF'}}) {
$_->Translate (@_);
}
undef $self->{'__BBOX'};
()
}
sub DoToAll {
my $self = shift;
my $what = shift;
map {
my (@args, @result) = @_; # @args gobbles all of @_
my ($object, $method) = $_;
if (defined ($method = $object->can ('DoToAll'))) {
@result = &$method ($object, $what, @args);
}
if ('CODE' eq ref $what) {
push @result, &$what ($object, @args);
} elsif (defined ($method = $object->can ($what))) {
push @result, &$method ($object, @args)
}
$_ = $object; # In effect localise it
@result; # It's map, remember.
} (@{$self->{'__STUFF'}})
}
sub Do {
my $self = shift;
my $what = shift;
map {
my (@args, @result) = @_; # @args gobbles all of @_
my ($object, $method) = $_;
if (defined ($method = $object->can ('Do'))) {
@result = &$method ($object, $what, @args);
} else {
if ('CODE' eq ref $what) {
@result = &$what ($object, @args);
} elsif (defined ($method = $object->can ($what))) {
@result = &$method ($object, @args)
}
}
$_ = $object;
@result; # It's map, remember.
} (@{$self->{'__STUFF'}})
}
sub Replace {
my $self = shift;
my $what = shift;
@{$self->{'__STUFF'}} = map {
my (@args, @result) = @_; # @args gobbles all of @_
my ($object, $method) = $_;
if (defined ($method = $object->can ('Replace'))) {
@result = &$method ($object, $what, @args);
} else {
if ('CODE' eq ref $what) {
@result = &$what ($object, @args);
} elsif (defined ($method = $object->can ($what))) {
@result = &$method ($object, @args)
}
}
$_ = $object;
@result; # It's map, remember.
} (@{$self->{'__STUFF'}});
# If we still contain anything, return ourself.
@{$self->{'__STUFF'}} ? $self : ();
}
sub Change {
my $self = shift;
my $what = shift;
my $old = shift;
map {
my (@args, @result) = @_; # @args gobbles all of @_
my ($object, $method) = $_;
if (defined ($method = $object->can ('Change'))) {
@result = &$method ($object, $what, @args);
}
if (defined ($method = $object->can ($what))) {
push @result, &$method ($object, @args)
if $old = &$method ($object);
}
$_ = $object;
@result; # It's map, remember.
} (@{$self->{'__STUFF'}})
}
sub ChangeString {
my $self = shift;
my $what = shift;
my $old = shift;
map {
my (@args, @result) = @_; # @args gobbles all of @_
my ($object, $method) = $_;
if (defined ($method = $object->can ('ChangeString'))) {
@result = &$method ($object, $what, @args);
}
if (defined ($method = $object->can ($what))) {
push @result, &$method ($object, @args)
if $old eq &$method ($object);
}
$_ = $object;
@result; # It's map, remember.
} (@{$self->{'__STUFF'}})
}
1;
__END__
=head1 NAME
RISCOS::DrawFile::Container
=head1 SYNOPSIS
Abstract base class for classes that hold other DrawFile objects.
=head1 DESCRIPTION
C<RISCOS::DrawFile::Container> provides an abstract base class for classes that
hold other DrawFile objects (groups, tagged objects and DrawFiles themselves.
C<RISCOS::DrawFile::Container> itself is not a C<RISCOS::DrawFile::Object>, as
not all classes which derive from it are objects found in DrawFiles.
=head2 Methods
=over 4
=item new <contents>
creates a new object. If I<contents> is an array reference it is dereferenced.
The array of objects (if any) is used as the container's contents.
=item Stuff [<new_contents>]
returns a reference to the array of contents. If I<new_contents> are given, then
these replace the existing contents (and the old contents are returned). If
I<new_contents> is an array reference it is automatically dereferenced first.
=item MoreStuff [<additional_contents>]
adds I<new_contents> existing contents, returning a reference to the array of
contents. If I<additional_contents> is an array reference it is automatically
dereferenced first.
=item Do <what>, arguments...
recursively does something to all contained objects.
For each contained item:
=over 4
=item *
If it has a C<Do> method, calls it with the arguments passed to this method.
=item *
If <what> is a code reference, calls it as
&what (object, arguments...)
else looks for a method I<what> in the object, and if found calls that method
with the arguments given
=back
C<Do> returns the list of all results returned from all called subroutines.
This method is extremely powerful. For example, to set all line widths to thin
in the object C<$draw>
$draw->Do('Width', 0);
To change all occurrences of the font 'Homerton.Medium' to 'AvantG.Book' in all
text objects you could do:
$draw->Do(sub {$_[0]->Font ('AvantG.Book')
if $_[0]->can('Font')
and $_[0]->Font() eq 'Homerton.Medium'});
(note that if you pass code you need to check that the method exists with C<can>
before you try to call it) but you'd be much better off with
$draw->ChangeString('Font','Homerton.Medium','AvantG.Book');
(see below)
=item DoToAll <what>, arguments...
is like C<Do> except that it also calls the named method or code reference on
contained containers, unlike C<Do> which only calls it on objects which do not
possess their own C<Do> to recurse to. Unless you want to alter contained Groups
or Tag objects in some way, you probably don't want to call C<DoToAll> as it
will return an possibly unhelpful list of results - for example if the result
array is all objects inside a bounding box you may get objects within groups
multiple times; once when the check is performed on the object itself, and again
within each group that also meets the test condition.
=item Replace <what>, arguments...
is like C<Do> except it I<replaces> the contents of each container with the
return values of I<what>, so I<what> had better be returning DrawFile objects.
If a container contains at least one object afterwards it returns a reference to
itself, whereas an empty container returns C<undef>. Beware that this way a
container (I<e.g.> an entire DrawFile) can end up deleting itself, so B<do>
check the return value, before your script crashes when attempting to call a
method on a now undefined scalar.
=item Change <method_name>, <test_value> arguments...
is similar to C<Do>, but can only take a named method. The method is called with
no arguments in scalar context, and if the result is I<numerically> equal
(C<==>) to I<test_value> the method is called again with the arguments supplied.
So to change all 4 point lines to 6
$draw->Change('Width', 2560, 3840);
(without having to ungroup or regroup anything...)
=item ChangeString <method_name>, <test_value> arguments...
is identical to C<Change> except that the comparison is for a string (C<eq>).
$draw->ChangeString('Font','Homerton.Medium','AvantG.Book');
=item BBox
returns a reference to an array giving the bounding box, or C<undef> if there is
no bounding box for this object (I<e.g.> an empty group, a tagged empty path).
C<BBox> will call C<BBox_Calc> if the bounding box is currently unknown.
As the returned array reference B<is> the internal copy of the bounding box it
must not be modified.
=item BBox_Calc
recalculates and returns the bounding box, by calling C<BBox_Calc> for each
contained object and merging the bounding boxes. C<BBox_Calc> will return
C<undef> if no contained object returned a valid bounding box. (This is far more
elegant than returning (int_max, int_max, int_min, int_min), as is the wont of
C<Draw_ProcessPath> when presented with an empty path - yes, we're trapping this
one, and C<Font_ScanString> when given an empty string).
=item PrePack <hash_reference>
is provided as a hook to perform calculations immediately before saving a
DrawFile. The hash reference is used to store the names of fonts needed in the
FontTable by C<RISCOS::DrawFile::Text> objects. C<PrePack> calls
C<PrePack> for each contained object, and merges the bounding boxes.
=item Size
returns the size of the object when saved in a DrawFile, by summing the results
of calling C<Size> on the contents.
=item Pack <undef>, fonttable, ...
returns a scalar containing the object packed ready to save into a DrawFile, by
concatenating the results of calling C<Pack> on the contents.
=item Write <filehandle>, <fonttable>, ...
writes the object to the given filehandle. The default implementation calls
C<Write> with the remainder of the argument list for each item in the contents,
returning false if any call to C<Write> did not return true.
=item Second_Font_Table
prints a warning that a second font table has been found, and returns an empty
list. Mostly of use to the DrawFile class.
=item Objfunc
returns a reference to a hash of code references, keyed by object type. This
hash determines the correct object constructor to call when the DrawFile data is
split into objects. Mostly of use to the DrawFile class.
=item Unknown_Obj
prints a warning that an unknown object type has been found, and returns the
result of calling C<RISCOS::DrawFile::OpaqueObject>. Mostly of use to the
DrawFile class.
=item _split_drawobjs <data>, <split>, <fonttable>, <sub_constructors>, <duplicate_fonttable>, <unknown_object>
splits the data passed as a B<scalar reference> into a list of DrawFile objects.
I<split> is a split function as described in C<new> in
C<RISCOS::DrawFile::Object>. I<fonttable> is initially C<undef>, but for
recursive calls is replaced with the fonttable object once found.
I<sub_constructors> is a hash or array reference used to find code to construct
objects keyed by type. Usually this is supplied by calling C<Objfunc>, but a
custom hash/array can be used. I<duplicate_fonttable> is called as a constructor
when a second fonttable is found. Usually this is a reference to
C<&Second_Font_Table>. I<unknown_object> is called as a constructor for any
object type not found in I<sub_constructors>. Usually this is a reference to
I<&Unknown_Obj>.
C<_split_drawobjs> returns a list ([objects], undef, fonttable) as for a
DrawFile object constructor.
This method is used by groups and DrawFile objects to split their contents into
objects. It probably isn't needed by anyone else.
=item Do <what>, arguments...
recursively does something to all contained objects.
For each contained item:
=over 4
=item *
If it has a C<Do> method, calls it with the arguments passed to this method.
=item *
If <what> is a code reference, calls it as
&what (I<object>, I<arguments...>
else looks for a method I<what> in the object, and if found calls that method
with the arguments given
=back
C<Do> returns the list of all results returned from all called subroutines.
This method is extremely powerful. For example, to set all line widths to thin
in the object C<$draw>
$draw->Do('Width', 0);
To change all occurrences of the font 'Homerton.Medium' to 'AvantG.Book' in all
text objects:
$draw->Do(sub {$_[0]->Font ('AvantG.Book')
if $_[0]->can('Font')
and $_[0]->Font() eq 'Homerton.Medium'});
(note that if you pass code you need to check that the method exists with C<can>
before you try to call it)
=back
=head1 BUGS
Currently doesn't allow derived classes to limit the number of objects that they
can hold. (C<TagObject>s only hold one object)
=head1 AUTHOR
Nicholas Clark <F<nick@unfortu.net>>