home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / DrawFile / JPEG.pm < prev    next >
Text File  |  1999-01-20  |  4KB  |  173 lines
  1. package RISCOS::DrawFile::JPEG;
  2. @ISA = 'RISCOS::DrawFile::Object';
  3.  
  4. use strict;
  5. require RISCOS::DrawFile::Object;
  6. use RISCOS::Units qw(pack_transform_block unpack_transform_block inch2draw);
  7. use RISCOS::JPEG 'jpeg_info';
  8. use vars '$VERSION';
  9. $VERSION = 0.01;
  10. # 0.01 adds Translate
  11.  
  12. ### use SelfLoader;
  13. sub RISCOS::DrawFile::JPEG::new ($$);
  14. sub RISCOS::DrawFile::JPEG::Type ;
  15. sub RISCOS::DrawFile::JPEG::BBox_Calc ;
  16. sub RISCOS::DrawFile::JPEG::Size ;
  17. sub RISCOS::DrawFile::JPEG::__pack ($);
  18. sub RISCOS::DrawFile::JPEG::Pack ($$);
  19. sub RISCOS::DrawFile::JPEG::Write ;
  20. sub RISCOS::DrawFile::JPEG::Translate ($$$$);
  21. 1;
  22. ### __DATA__
  23. sub new ($$) {
  24.     my $proto = shift;
  25.     my $class = ref($proto) || $proto;
  26.  
  27.     my ($self, $type) = $class->SUPER::new (@_);
  28.     return $self if ref ($self) eq 'ARRAY';
  29.  
  30.     my ($height, $width, $xdpi, $ydpi, $trans, $length, $jpeg, $data);
  31.     return wantarray ? () : undef unless defined $_[0];
  32.     if (ref ($_[0]) eq 'ARRAY') {
  33.     # [JPEG, dpi, dpi, transform], x, y
  34.     # only if transform absent default from x, y
  35.     ($jpeg, $xdpi, $ydpi, $trans) = @{$_[0]};
  36.     my ($x, $y, $ratio);
  37.     ($width, $height, $x, $y, undef, undef, $ratio) = jpeg_info $jpeg;
  38.     return () unless defined $height;    # doesn't smell like a JPEG.
  39.     if (defined $xdpi) {
  40.         unless (defined $ydpi) {
  41.         $ydpi = $xdpi * $y / $x;
  42.         } # else they are both forced
  43.     } else {
  44.         if (defined $ydpi) {
  45.         $xdpi = $ydpi * $x / $y;
  46.         } else {
  47.         # Neither was given.
  48.         if ($ratio) {
  49.             # Wing it.
  50.             $xdpi = 90;
  51.             $ydpi = 90 * $y / $x
  52.         } else {
  53.             $xdpi = $x;
  54.             $ydpi = $y;
  55.         }
  56.         }
  57.     }
  58.     ($width, $height) = inch2draw ($width / $xdpi, $height / $ydpi);
  59.     # Copy it if needs be.
  60.     $trans = $trans ? [@$trans] : [1, 0, 0, 1, $_[1] || 0, $_[2] || 0];
  61.     } else {
  62.     # Time to unpack data
  63.     if (ref ($_[0]) eq 'SCALAR' or ref ($_[0]) eq 'LVALUE') {
  64.         # Has bounding box stripped
  65.         $data = ${$_[0]};
  66.     } else {
  67.         ($length, @{$self->{'__BBOX'}}) = unpack 'x4Ii4', $_[0];
  68.         return undef unless length ($_[0]) == $length or $length & 3;
  69.         $data = substr $_[0], 24;
  70.     }
  71.     ($height, $width, $xdpi, $ydpi, $length) = unpack 'I4x24I', $data;
  72.     $trans = unpack_transform_block substr ($data, 16, 24);
  73.     $jpeg = substr ($data, 44, $length);
  74.     }
  75.  
  76.     $self->{'__H'} = $height;
  77.     $self->{'__W'} = $width;
  78.     $self->{'__XDPI'} = $xdpi;
  79.     $self->{'__YDPI'} = $ydpi;
  80.     $self->{'__TRANSFORM'} = $trans;
  81.     $self->{'__JPEG'} = $jpeg;
  82.     wantarray ? ($self, $type) : $self;
  83. }
  84.  
  85. sub Type { 16 }
  86.  
  87. sub BBox_Calc {
  88.     my $self = shift;
  89.     my $trans = $self->{'__TRANSFORM'};
  90.     my ($h, $w, $x, $y) = ($self->{'__H'}, $self->{'__W'});
  91.     my $bbox = [0, 0, 0, 0];
  92.  
  93.     foreach ([$w, 0], [$w, $h], [0, $h]) {
  94.     $x = $$_[0] * $$trans[0] + $$_[1] * $$trans[1];
  95.     $y = $$_[0] * $$trans[2] + $$_[1] * $$trans[3];
  96.     $$bbox[0] = $x if $x < $$bbox[0];
  97.     $$bbox[1] = $y if $y < $$bbox[1];
  98.     $$bbox[2] = $x if $x > $$bbox[2];
  99.     $$bbox[3] = $y if $y > $$bbox[3];
  100.     }
  101.     $$bbox[0] += $$trans[4];
  102.     $$bbox[1] += $$trans[5];
  103.     $$bbox[2] += $$trans[4];
  104.     $$bbox[3] += $$trans[5];
  105.     $self->{'__BBOX'} = $bbox;
  106. }
  107.  
  108. sub Size {
  109.     my $self = shift;
  110.     # 24 for transform & flags if present
  111.     # 24 for type, length and bbox
  112.     (68 + 3 + length $self->{'__JPEG'}) & ~3;
  113. }
  114.  
  115. sub __pack ($) {
  116.     my $self = shift;
  117.     $self->PackTypeSizeBBox(16) . pack ('I4', $self->{'__H'}, $self->{'__W'},
  118.                     $self->{'__XDPI'}, $self->{'__YDPI'})
  119.     . pack_transform_block ($self->{'__TRANSFORM'})
  120.     . pack 'I', length $self->{'__JPEG'}
  121. }
  122.  
  123. sub Pack ($$) {
  124.     my $self = $_[0];
  125.     &__pack . $self->{'__JPEG'} . ("\0" x (-length ($self->{'__JPEG'}) & 3))
  126. }
  127.  
  128. sub Write {
  129.     my $self = $_[0];
  130.     print {$_[1]} &__pack, $self->{'__JPEG'},
  131.           ("\0" x (-length ($self->{'__JPEG'}) & 3))
  132. }
  133.  
  134. sub Translate ($$$$) {
  135.     my $self = $_[0];
  136.     my $bbox = $self->{'__BBOX'};
  137.     if (defined $bbox) {
  138.     $$bbox[0] += $_[1];
  139.     $$bbox[1] += $_[2];
  140.     $$bbox[2] += $_[1];
  141.     $$bbox[3] += $_[2];
  142.     }
  143.     my $trans = $self->{'__TRANSFORM'};
  144.     if (defined $trans) {
  145.     $$trans[4] += $_[1];
  146.     $$trans[5] += $_[2];
  147.     }
  148.     ();
  149. }
  150.  
  151. 1;
  152. __END__
  153.  
  154. =head1 NAME
  155.  
  156. RISCOS::DrawFile::JPEG
  157.  
  158. =head1 SYNOPSIS
  159.  
  160. Class to handle JPEG objects in DrawFiles
  161.  
  162. =head1 DESCRIPTION
  163.  
  164. C<RISCOS::DrawFile::JPEG> provides a class that stores JPEGs.
  165.  
  166. =head1 BUGS
  167.  
  168. None known.
  169.  
  170. =head1 AUTHOR
  171.  
  172. Nicholas Clark <F<nick@unfortu.net>>
  173.