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 = &regmask([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
