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 >
Text File  |  1999-01-20  |  3KB  |  118 lines
  1. package RISCOS::DrawFile::TagObject;
  2.  
  3. use strict;
  4. use vars qw ($VERSION @ISA);
  5. use Carp;
  6.  
  7. require RISCOS::DrawFile::Container;
  8. require RISCOS::DrawFile::Object;
  9.  
  10. $VERSION = 0.03;
  11. # 0.03 does Translate
  12. # I think that this is no longer stuffed.
  13. # There was a good reason why Group has Container before Object in @ISA
  14. # I believe that it was to get the inheritence of Write and Pack correct
  15. # (ie from Containter, not Object). new has to come from Object.
  16. # Cure wass to re-write with same order as Group
  17. # Also bug in that no check is made with Stuff() method that only a single
  18. # object is being tagged.
  19. @ISA =  qw (RISCOS::DrawFile::Container RISCOS::DrawFile::Object);
  20.  
  21. ###use SelfLoader;
  22. sub RISCOS::DrawFile::TagObject::new ($);
  23. sub RISCOS::DrawFile::TagObject::Translate ($$$$);
  24. sub RISCOS::DrawFile::TagObject::Size ;
  25. sub RISCOS::DrawFile::TagObject::Pack ;
  26. sub RISCOS::DrawFile::TagObject::Write ;
  27. sub RISCOS::DrawFile::TagObject::Tag ;
  28. sub RISCOS::DrawFile::TagObject::TagData ;
  29. 1;
  30. ###__DATA__
  31. sub new ($) {
  32.     my $proto = shift;
  33.     my $class = ref($proto) || $proto;
  34.  
  35.     my ($self, $type) = $class->RISCOS::DrawFile::Object::new (@_);
  36.     return $self if ref ($self) eq 'ARRAY';
  37.  
  38.     my ($tag, $length) = unpack 'x24Ix4I', $_[0];
  39.     $self->{'__TAGDATA'} = substr $_[0], 28 + $length;
  40.     $self->{'__TAG'} = $tag;
  41.     local $_[0] = \(substr $_[0], 28, $length);
  42.     my ($stuff, $a, $font) = $class->_split_drawobjs (@_);
  43. #    use Data::Dumper;
  44. #    print Dumper $stuff;
  45. #    warn $self;
  46. #    print Dumper $self;
  47.     $self->Stuff ($stuff);
  48.     $self->{'__TYPE'} = $type;
  49.     
  50.     wantarray ? ($self, $type, $font) : $self;
  51. }
  52.  
  53.  
  54. sub Translate ($$$$) {
  55.     if (ref ($_[3]) eq 'CODE') {
  56.     &{$_[3]}($_[0], $_[1], $_[2]);
  57.     } elsif (not defined $_[3]) {
  58.     warn "Cannot translate $_[0] by ($_[1], $_[2])\n";
  59.     } elsif ($_[3] eq '') {
  60.     $_[0]->SUPER::Translate ($_[1], $_[2], $_[3]);
  61.     } else {
  62.     confess "Illegal third argument to translate ('$_[3]') when attempting to translate $_[0] by ($_[1], $_[2])";
  63.     }
  64.     ();
  65. }
  66.  
  67. sub Size {
  68.     my $self = shift;
  69.     28 + $self->SUPER::Size + length $self->{'__TAGDATA'};
  70. }
  71.  
  72. sub Pack {
  73.     my $self = shift;
  74.     $self->PackTypeSizeBBox()
  75.      . pack ('I', $self->{'__TAG'})
  76.      . $self->SUPER::Stuff(@_)
  77.      . $self->{'__TAGDATA'};
  78. }
  79.  
  80. sub Write {
  81.     my $self = shift;
  82.     my $good = print {$_[0]} $self->PackTypeSizeBBox(),
  83.                  pack ('I', $self->{'__TAG'});
  84.     $good &= $self->SUPER::Write (@_);    # Pass on args
  85.     print {$_[0]} $self->{'__TAGDATA'};
  86. }
  87.  
  88. sub Tag {
  89.     my $self = shift;
  90.     my $tag = $self->{'__TAG'};
  91.     $self->{'__TAG'} = $_[0] if defined $_[0];
  92.     $tag;
  93. }
  94.  
  95. sub TagData {
  96.     my $self = shift;
  97.     my $tagdata = $self->{'__TAGDATA'};
  98.     $self->{'__TAGDATA'} = $_[0] if defined $_[0];
  99.     $tagdata;
  100. }
  101.  
  102. 1;
  103. __END__
  104.  
  105. =head1 NAME
  106.  
  107. RISCOS::Drawfile
  108.  
  109. =head1 SYNOPSIS
  110.  
  111. =head1 DESCRIPTION
  112.  
  113. =head1 BUGS
  114.  
  115. =head1 AUTHOR
  116.  
  117. Nicholas Clark <F<nick@unfortu.net>>
  118.