home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Non-RPC
/
!Perl
/
riscos
/
RISCOS
/
Mode.pm
< prev
next >
Wrap
Text File
|
1998-07-26
|
6KB
|
221 lines
package RISCOS::Mode;
require Exporter;
use strict;
use vars qw (@ISA @EXPORT $VERSION @EXPORT_OK @mode_var %mode_var
$readmodevar $mask $screenmode $osbyte @pix_depth %pix_depth
@pix_string %pix_string);
use RISCOS::SWI ':DEFAULT', '&C_Flag';
@ISA = qw(Exporter);
@EXPORT_OK = qw (mode_read_vars mode_string2block mode_block2string
mode_read_current mode_number2block mode_number2string
mode_read_block_from_pointer);
$VERSION = 0.01;
@mode_var = (
'ModeFlags',
'ScrRCol',
'ScrBRow',
'NColour',
'XEigFactor',
'YEigFactor',
'LineLength',
'ScreenSize',
'YShftFactor',
'Log2BPP',
'Log2BPC',
'XWindLimit',
'YWindLimit'
);
@pix_depth = ( 1, 2, 4, 8, 16, 24);
@pix_string = ( 2, 4, 16, 256, '32K', '16M');
foreach my $name (qw (mode_var pix_depth pix_string)) {
no strict 'refs';
for (my $i = @{$name}; $i--; ) {
${$name}{${$name}[$i]} = $i; # Reverse lookup by name.
${$name}{$i} = $i;
}
}
sub mode_read_block_from_pointer ($) {
my $pointer = pack 'I', shift;
my $len = 24;
my $block = '';
# Who said perl was safe?
while ($block !~ /ÿÿÿÿ$/s) {
$block = unpack "P$len", $pointer;
$len += 8;
}
$block
}
sub mode_read_current () {
my ($mode, $result);
if ($screenmode && defined ($result = kernelswi ($screenmode, 1))) {
$mode = unpack 'x4I', $result;
} else {
return undef unless (defined ($result = kernelswi ($osbyte, 135)));
$mode = unpack 'x8I', $result; # Worked when tested. :-)
}
($mode < 256) ? $mode : mode_read_block_from_pointer ($mode);
}
sub mode_number2string ($) {
my $number = shift;
my ($xres, $yres, $pix, $xeig, $yeig)
= mode_read_vars ($number, 'XWindLimit','YWindLimit', 'Log2BPP',
'XEigFactor', 'YEigFactor');
return undef unless defined $xres;
$xres += 1;
$yres += 1;
"X$xres Y$yres C$pix_string[$pix] EX$xeig EY$yeig";
}
sub mode_number2block ($) {
my $number = shift;
my ($xres, $yres, $pix, $xeig, $yeig)
= mode_read_vars ($number, 'XWindLimit','YWindLimit', 'Log2BPP',
'XEigFactor', 'YEigFactor');
return undef unless defined $xres;
$xres += 1;
$yres += 1;
# Can't find out the frame rate, use -1 to use first match
pack 'I4iI4i', 1, $xres, $yres, $pix, -1, 4, $xeig, 5, $yeig, -1;
}
sub mode_block2string ($) {
my $block = shift;
return unless defined $block;
if (length $block < 20) {
return $block = mode_number2string $block;
}
my ($selector, $xres, $yres, $pix, $frame) = unpack 'I4i', $block;
if ($selector != 1) {
warn "Unknown mode selector flags $selector";
return undef;
}
my $string = "X$xres Y$yres C$pix_string[$pix]";
$string .= " F$frame" unless $frame == -1;
$block = substr ($block, 20);
while (length $block) {
last if $block =~ /^ÿÿÿÿ/;
my ($var, $val) = unpack 'I2', $block;
if ($var == 4) {
$string .= " EX$val";
} elsif ($var == 5) {
$string .= " EY$val";
} else {
warn "Don't know how to code mode variable $var ('$mode_var[$var]') in a mode selector string";
}
$block = substr ($block, 8);
}
$string
}
sub mode_read_vars {
my ($val, $pc, $mode) = ('xxxx', 'xxxx', shift);
$mode = -1 unless defined $mode;
my @result;
@result = map {
my $var = $mode_var{$_};
(defined $var
and defined (swix ($readmodevar, $mask, $mode, $var + 0, $val, $pc))
and not ((unpack ('I', $pc)) & &C_Flag)) ? unpack 'I', $val : undef;
} @_;
wantarray ? @result : $result[0];
}
$mask = ®mask([0,1],[2,15]);
$screenmode = SWINumberFromString('XOS_ScreenMode'); # 3.5 or later.
$readmodevar = SWINumberFromString('XOS_ReadModeVariable')
and $osbyte = SWINumberFromString('XOS_Byte');
__END__
=head1 NAME
RISCOS::Mode -- perl interface to S<RISC OS> screen modes
=head1 SYNOPSIS
use RISCOS::Mode qw(mode_block2string mode_read_current);
print &mode_block2string (mode_read_current), "\n";
=head1 DESCRIPTION
This module provides a perl interface to S<RISC OS> screen modes, using both
old-style mode numbers and new-style mode descriptor blocks.
=over 4
=item mode_read_block_from_pointer <pointer>
I<pointer> is B<assumed> to be the numeric address of a mode descriptor block
in memory, which is read from memory and returned as a 24 + 4I<n> byte scalar.
Fatal address exceptions are likely if <pointer> is invalid.
=item mode_read_current
returns the current mode, either as a mode number or a mode descriptor string.
(What you get depends on what C<OS_ScreenMode 1> or C<OS_Byte 135> return.)
=item mode_number2string <mode>
"fakes" a mode descriptor string from a mode number by reading the mode
variables C<XWindLimit>, C<YWindLimit>, C<Log2BPP>, C<XEigFactor> and
C<YEigFactor>. Unlike a "true" mode descriptor string there is no framerate, as
this cannot be determined from the mode variables. Returns C<undef> on error,
most likely if the mode number is unknown.
=item mode_number2block <mode>
"fakes" a mode descriptor block from a mode number by reading its mode
variables. The frame rate is set to -1 which matches the first available
framerate.
=item mode_block2string <block>
converts a mode block to a mode string. If the "mode block" is under 20 bytes
long it is assumed to be a mode number, and a call to C<mode_number2string> is
substituted.
=item mode_read_vars <mode>, [variable...]
reads the values of the mode variables for the mode number specified. Mode
variables can be specified by (case sensitive) name or number:
0 ModeFlags
1 ScrRCol
2 ScrBRow
3 NColour
4 XEigFactor
5 YEigFactor
6 LineLength
7 ScreenSize
8 YShftFactor
9 Log2BPP
10 Log2BPC
11 XWindLimit
12 YWindLimit
In array context returns an array corresponding the variables, in scalar context
the value of the first variable requested. C<undef> will be returned for unknown
modes or variables.
=back
=head1 BUGS
Not tested enough.
=head1 AUTHOR
Nicholas Clark <F<nick@unfortu.net>>
=cut