home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / Sprite.pm < prev    next >
Text File  |  1998-07-27  |  3KB  |  129 lines
  1. package RISCOS::Sprite;
  2.  
  3. use RISCOS::SWI;
  4. require Exporter;
  5. use Carp;
  6. use strict;
  7. # use SelfLoader;
  8. use RISCOS::Units qw(pack_transform_block inch2draw inch2os);
  9. use RISCOS::Mode 'mode_read_vars';
  10.  
  11. use vars qw (@ISA @EXPORT_OK $VERSION $sprite_op &sprite_op &sprite_info
  12.          &sprite_size $inch2os);
  13.  
  14. @ISA = qw(Exporter);
  15. $VERSION = 0.01;
  16. @EXPORT_OK = qw(sprite_op sprite_info sprite_size);
  17.  
  18. # for ops with R0 < 256
  19. # R1 = undef ->    scalar ref ->    sprite in scalar
  20. #                else system by name
  21. # R1 = 0 or '' -> dummy sprite area, pointer in R2, or ref is data
  22. # R1 defined && true -> sprite area, R2 groked for tr/0-9//c;
  23. #    R1 as ref is sprite area, else taken as a numeric pointer.
  24.  
  25. $inch2os = inch2os (1);
  26.  
  27. sub sprite_op {
  28.     my ($op, $area, $name, @args) = @_;
  29.     return unless defined $op;
  30.     return if (($op & 0x300) == 0x300);
  31.     if (($op & 0x300) == 0) {
  32.     unless (defined $area) {
  33.         # No area, so scalar ref is taken as actual sprite data.
  34.         if (ref $name) {
  35.         return kernelswi ($op | 0x200, 0x200, $$name, @args);
  36.         }
  37.         return kernelswi ($op, 0, $name . '', @args);
  38.     } elsif (!$area) {
  39.         # Fake a dummy sprite area and do it by pointer
  40.         return kernelswi ($op | 0x200, 0x200, ref ($name) ? $$name
  41.                                   : $name + 0,
  42.                   @args);
  43.     } else {
  44.         if ($name =~ tr/0-9//c) {
  45.         # It has a non-numeric
  46.         $name .= '';
  47.         } else {
  48.         $name += 0;
  49.         }
  50.         return kernelswi ($op | 0x100, ref ($area) ? $$area
  51.                                : $area + 0,
  52.                   $name, @args);
  53.     }
  54.     } elsif (($op & 0x300) == 0x200) {
  55.     return kernelswi ($op, ref ($area) ? $$area
  56.                        : $area + 0, $name + 0, @args)
  57.     } else {
  58.     return kernelswi ($op, ref ($area) ? $$area
  59.                        : $area + 0, $name . '', @args)
  60.     }
  61. }
  62.  
  63. sub sprite_decode_type ($) {
  64.     return unless defined $_[0];
  65.     my ($xdpi, $ydpi, $format);
  66.  
  67.     if ($_[0] & 0x08000000) {
  68.     # New type
  69.     $xdpi = ($_[0] >> 1) & 0x1FFF;
  70.     $ydpi = ($_[0] >> 14) & 0x1FFF;
  71.     $format = ($_[0] >> 27);
  72.     } else {
  73.     ($xdpi, $ydpi, $format) = mode_read_vars ( 'XEigFactor', 'YEigFactor',
  74.                            'Log2BPP' );
  75.     return () unless defined $format;
  76.     $xdpi = $inch2os / (1 << $xdpi);
  77.     $ydpi = $inch2os / (1 << $ydpi);
  78.     $format++;
  79.     }
  80.     ($xdpi, $ydpi, $format)
  81. }
  82.  
  83. sub sprite_info {
  84.     return unless defined (my $result = sprite_op (40, @_));
  85.     unpack 'x12I4', $result;
  86. }
  87.  
  88. sub sprite_size {
  89.     my ($xpix, $ypix, $mode) = &sprite_info;
  90.     my ($xdpi, $ydpi) = sprite_decode_type ($mode);
  91.     return unless defined $xdpi;
  92.     inch2draw ($xpix / $xdpi, $ypix / $ydpi)
  93. }
  94.  
  95.  
  96. $sprite_op = SWINumberFromString('XOS_SpriteOp');
  97. __END__
  98.  
  99. =head1 NAME
  100.  
  101. RISCOS::Sprite -- perl interface to Sprites
  102.  
  103. =head1 SYNOPSIS
  104.  
  105.     use RISCOS::Sprite 'sprite_size';
  106.     ($hieght, $width) = sprite_size ($sprite)
  107.  
  108. =head1 DESCRIPTION
  109.  
  110. C<RISCOS::Draw> provides an interface to
  111.  
  112. =head2 Subroutines
  113.  
  114. =over 4
  115.  
  116. =item what <type> <default> <values...>
  117.  
  118. =back
  119.  
  120. =head1 BUGS
  121.  
  122. Definitely not tested enough yet. Some bits not tested at all, I believe.
  123.  
  124. =head1 AUTHOR
  125.  
  126. Nicholas Clark <F<nick@unfortu.net>>
  127.  
  128. =cut
  129.