home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / Mode.pm < prev    next >
Encoding:
Perl POD Document  |  1998-07-26  |  5.8 KB  |  221 lines
  1. package RISCOS::Mode;
  2.  
  3. require Exporter;
  4. use strict;
  5. use vars qw (@ISA @EXPORT $VERSION @EXPORT_OK @mode_var %mode_var
  6.          $readmodevar $mask $screenmode $osbyte @pix_depth %pix_depth
  7.          @pix_string %pix_string);
  8. use RISCOS::SWI ':DEFAULT', '&C_Flag';
  9.  
  10. @ISA = qw(Exporter);
  11. @EXPORT_OK = qw (mode_read_vars mode_string2block mode_block2string
  12.          mode_read_current mode_number2block mode_number2string
  13.          mode_read_block_from_pointer);
  14. $VERSION = 0.01;
  15.  
  16. @mode_var = (
  17.   'ModeFlags',
  18.   'ScrRCol',
  19.   'ScrBRow',
  20.   'NColour',
  21.   'XEigFactor',
  22.   'YEigFactor',
  23.   'LineLength',
  24.   'ScreenSize',
  25.   'YShftFactor',
  26.   'Log2BPP',
  27.   'Log2BPC',
  28.   'XWindLimit',
  29.   'YWindLimit'
  30. );
  31.  
  32. @pix_depth = (    1,    2,    4,    8,    16,    24);
  33. @pix_string = (    2,    4,    16,    256,    '32K',    '16M');
  34.  
  35. foreach my $name (qw (mode_var pix_depth pix_string)) {
  36.     no strict 'refs';
  37.  
  38.     for (my $i = @{$name}; $i--; ) {
  39.     ${$name}{${$name}[$i]} = $i;    # Reverse lookup by name.
  40.     ${$name}{$i} = $i;
  41.     }
  42. }
  43.  
  44. sub mode_read_block_from_pointer ($) {
  45.     my $pointer = pack 'I', shift;
  46.     my $len = 24;
  47.     my $block = '';
  48.     # Who said perl was safe?
  49.     while ($block !~ /ÿÿÿÿ$/s) {
  50.     $block = unpack "P$len", $pointer;
  51.     $len += 8;
  52.     }
  53.  
  54.     $block
  55. }
  56.  
  57. sub mode_read_current () {
  58.     my ($mode, $result);
  59.     if ($screenmode && defined ($result = kernelswi ($screenmode, 1))) {
  60.     $mode = unpack 'x4I', $result;
  61.     } else {
  62.     return undef unless (defined ($result = kernelswi ($osbyte, 135)));
  63.     $mode = unpack 'x8I', $result;    # Worked when tested. :-)
  64.     }
  65.     ($mode < 256) ? $mode : mode_read_block_from_pointer ($mode);
  66. }
  67.  
  68. sub mode_number2string ($) {
  69.     my $number = shift;
  70.     my ($xres, $yres, $pix, $xeig, $yeig)
  71.       = mode_read_vars ($number, 'XWindLimit','YWindLimit', 'Log2BPP',
  72.             'XEigFactor', 'YEigFactor');
  73.     return undef unless defined $xres;
  74.     $xres += 1;
  75.     $yres += 1;
  76.     "X$xres Y$yres C$pix_string[$pix] EX$xeig EY$yeig";
  77. }
  78.  
  79. sub mode_number2block ($) {
  80.     my $number = shift;
  81.     my ($xres, $yres, $pix, $xeig, $yeig)
  82.       = mode_read_vars ($number, 'XWindLimit','YWindLimit', 'Log2BPP',
  83.             'XEigFactor', 'YEigFactor');
  84.     return undef unless defined $xres;
  85.     $xres += 1;
  86.     $yres += 1;
  87.     # Can't find out the frame rate, use -1 to use first match
  88.     pack 'I4iI4i', 1, $xres, $yres, $pix, -1, 4, $xeig, 5, $yeig, -1;
  89. }
  90.  
  91. sub mode_block2string ($) {
  92.     my $block = shift;
  93.     return unless defined $block;
  94.     if (length $block < 20) {
  95.     return $block = mode_number2string $block;
  96.     }
  97.     my ($selector, $xres, $yres, $pix, $frame) = unpack 'I4i', $block;
  98.     if ($selector != 1) {
  99.     warn "Unknown mode selector flags $selector";
  100.     return undef;
  101.     }
  102.     my $string = "X$xres Y$yres C$pix_string[$pix]";
  103.     $string .= " F$frame" unless $frame == -1;
  104.     $block = substr ($block, 20);
  105.     while (length $block) {
  106.     last if $block =~ /^ÿÿÿÿ/;
  107.     my ($var, $val) = unpack 'I2', $block;
  108.     if ($var == 4) {
  109.         $string .= " EX$val";
  110.     } elsif ($var == 5) {
  111.         $string .= " EY$val";
  112.     } else {
  113.         warn "Don't know how to code mode variable $var ('$mode_var[$var]') in a mode selector string";
  114.     }
  115.     $block = substr ($block, 8);
  116.     }
  117.     $string
  118. }
  119.  
  120. sub mode_read_vars {
  121.     my ($val, $pc, $mode) = ('xxxx', 'xxxx', shift);
  122.     $mode = -1 unless defined $mode;
  123.     my @result;
  124.     
  125.     @result = map {
  126.         my $var = $mode_var{$_};
  127.         (defined $var
  128.          and defined (swix ($readmodevar, $mask, $mode, $var + 0, $val, $pc))
  129.          and not ((unpack ('I', $pc)) & &C_Flag)) ? unpack 'I', $val : undef;
  130.     } @_;
  131.     wantarray ? @result : $result[0];
  132. }
  133.  
  134. $mask = ®mask([0,1],[2,15]);
  135. $screenmode = SWINumberFromString('XOS_ScreenMode');    # 3.5 or later.
  136. $readmodevar = SWINumberFromString('XOS_ReadModeVariable')
  137. and $osbyte = SWINumberFromString('XOS_Byte');
  138. __END__
  139.  
  140. =head1 NAME
  141.  
  142. RISCOS::Mode -- perl interface to S<RISC OS> screen modes
  143.  
  144. =head1 SYNOPSIS
  145.  
  146.     use RISCOS::Mode qw(mode_block2string mode_read_current);
  147.     print &mode_block2string (mode_read_current), "\n";
  148.     
  149. =head1 DESCRIPTION
  150.  
  151. This module provides a perl interface to S<RISC OS> screen modes, using both
  152. old-style mode numbers and new-style mode descriptor blocks.
  153.  
  154. =over 4
  155.  
  156. =item mode_read_block_from_pointer <pointer>
  157.  
  158. I<pointer> is B<assumed> to be the numeric address of a mode descriptor block
  159. in memory, which is read from memory and returned as a 24 + 4I<n> byte scalar.
  160. Fatal address exceptions are likely if <pointer> is invalid.
  161.  
  162. =item mode_read_current
  163.  
  164. returns the current mode, either as a mode number or a mode descriptor string.
  165. (What you get depends on what C<OS_ScreenMode 1> or C<OS_Byte 135> return.)
  166.  
  167. =item mode_number2string <mode>
  168.  
  169. "fakes" a mode descriptor string from a mode number by reading the mode
  170. variables C<XWindLimit>, C<YWindLimit>, C<Log2BPP>, C<XEigFactor> and
  171. C<YEigFactor>. Unlike a "true" mode descriptor string there is no framerate, as
  172. this cannot be determined from the mode variables. Returns C<undef> on error,
  173. most likely if the mode number is unknown.
  174.  
  175. =item mode_number2block <mode>
  176.  
  177. "fakes" a mode descriptor block from a mode number by reading its mode
  178. variables. The frame rate is set to -1 which matches the first available
  179. framerate.
  180.  
  181. =item mode_block2string <block>
  182.  
  183. converts a mode block to a mode string. If the "mode block" is under 20 bytes
  184. long it is assumed to be a mode number, and a call to C<mode_number2string> is
  185. substituted.
  186.  
  187. =item mode_read_vars <mode>, [variable...]
  188.  
  189. reads the values of the mode variables for the mode number specified. Mode
  190. variables can be specified by (case sensitive) name or number:
  191.  
  192.      0    ModeFlags
  193.      1    ScrRCol
  194.      2    ScrBRow
  195.      3    NColour
  196.      4    XEigFactor
  197.      5    YEigFactor
  198.      6    LineLength
  199.      7    ScreenSize
  200.      8    YShftFactor
  201.      9    Log2BPP
  202.     10    Log2BPC
  203.     11    XWindLimit
  204.     12    YWindLimit
  205.  
  206. In array context returns an array corresponding the variables, in scalar context
  207. the value of the first variable requested. C<undef> will be returned for unknown
  208. modes or variables.
  209.  
  210. =back
  211.  
  212. =head1 BUGS
  213.  
  214. Not tested enough.
  215.  
  216. =head1 AUTHOR
  217.  
  218. Nicholas Clark <F<nick@unfortu.net>>
  219.  
  220. =cut
  221.