package RISCOS::Throwback;
use RISCOS::SWI;
use Carp;
use strict;

use vars qw ($VERSION @ISA @EXPORT_OK $null $send $send_mask %seen $last_die);
require Exporter;

$VERSION = 0.11;
@ISA = 'Exporter';
@EXPORT_OK = qw(throwback throwback_info);

$send = SWINumberFromString('DDEUtils_ThrowbackSend');
$send_mask = &regmask([0,2..5]);

# Version 0.11
# Stop 'Invalid Wimp operation in this context' error
# Transpires that even with <Wimp$State> = "commands" you can still call
# Throwback_Start an F12 * prompt. Reason - there is a current task handle.
# Solution - read the task handle, if it is 0, (eg during an obey file's
# execution) then don't attempt to start throwback
# Version 0.10
# Bodged to stop multiple copies of the same message when modules are nested.
# Not perfect, as may still get a stream of alternating (BEGIN failed, message)
# Version 0.09
# Wrapped throwback start and end SWIs in eval, so that END does not fail, and
# start does confess.
# check $^S in an attempt to avoid multiple errors. partial success. still gives
# multiple reports for "Compilation failed in require"
# Version 0.08
# removed , and \. from two regexps that match messages in throw_die
# It would seem that \. is no longer present in "at <file> line 20"
# Version 0.07
# Follow the protocol and call Throwback processing before the first message
# Version 0.06
# Calls RISCOS::Filespec::convert_internal
# Version 0.05
# Ignore execution of * aborted due to compilation errors
# Version 0.04
# Cope with
# syntax error at /PerlDevArchLib:/RISCOS/Module.pm line 68, near "if wantarray"
# Version 0.03
# Force riscosify in sig handlers
# Throwback info is 2 not 0
# Check for undef messages
# Version 0.02
# Swapped (.*) to (\d*) for line number in regular expression

# Some warnings and yyerror() don't seem to feed this way
# bummer.

BEGIN
{
    croak "You need port 1·04 or later"
      unless defined &RISCOS::Filespec::convert_internal;
    # Error if we don't have the XS
}

$last_die = $null = '';
# SWI can't be passed constant strings


sub throwback_processing ($) {
    swi ($send, regmask ([0,2]), 0, $_[0]);
    $seen{$_[0]} = 1;	# Mark that we've seen this file
}

sub throwback ($$$$) {
    my ($filename, $line, $seriousness, $message) = @_;
    throwback_processing ($filename) unless $seen{$filename};
    swi ($send, $send_mask, 1, defined ($filename) ? $filename : $null, 0+$line,
         0+$seriousness, defined ($message) ? $message : $null);
}

sub throwback_info ($$$) {
    my ($filename, $line, $message) = @_;
    throwback_processing ($filename) unless $seen{$filename};
    swi ($send, $send_mask, 2, defined ($filename) ? $filename : $null, 0+$line,
         0, defined ($message) ? $message : $null);
}

sub throw_warn ($) {
    return if $^S;
    my ($message, $file, $line, $near) = $_[0] =~ /(.*) at (.+) line (\d*)([.,].*)/;
#    if ($file =~ /^\(eval \d+\)$/) {
#        my $package;
#        ($package, $file, $line) = (caller);
#        confess "$package $file $line";
#    }
    if (defined $message)
    {
        $message .= $near unless ($near eq '.');
        throwback_info (RISCOS::Filespec::riscosify($file,
          RISCOS::Filespec::convert_internal()), $line, $message);
    }
    warn @_;
 };

sub throw_die ($) {
    return if $^S;
    $_ = shift;
    # Bodge	use Blah; when nested will call $SIG{DIE} as each module exits.
    # Last copy will be "${last_die}BEGIN failed"
    # This way we print the first copy. And get throwback on the single line
    # BEGIN failed
    s/^\Q$last_die\E//s;
    return unless length;
    $last_die = $_;
    return if /Execution of .* aborted due to compilation errors/;
    
    my ($message, $file, $line, $near) = /(.*) at (.+) line (\d+)\,(.*)/;
    if (defined $message) {
        $message .= $near if defined $near;
    } else {
        ($message, $file, $line) = /(.*) at (.+) line (\d+)/;
    }
    unless ($message)
    {
        $message = $_;
        $file = $0 unless $file;
    }
    $line = 0 unless (defined $line);
    throwback (RISCOS::Filespec::riscosify($file,
      RISCOS::Filespec::convert_internal()), $line, 1, $message);
 };


# Not good enough. ShellCLI is OK, running from an obey file is not.
# if ($ENV{'Wimp$State'} eq 'commands') {

my $handle = kernelswi ('Wimp_ReadSysInfo',5);
unless (defined $handle and unpack 'I', $handle) {
    carp 'Outside desktop, throwback unavailable' if $^W;
} else {
    if (defined (eval {swix ('DDEUtils_ThrowbackStart')})) {
        $SIG{'__WARN__'} = \&throw_warn;
	$SIG{'__DIE__'} = \&throw_die;
    } else {
	confess $^E if $^W;
    }

    END { eval {swix ('DDEUtils_ThrowbackEnd')} }
}

$send;	# Return true if we got the SWI

__END__

=head1 NAME

RISCOS::Throwback -- provide throwback for perl

=head1 SYNOPSIS

    use RISCOS::Throwback;

=head1 DESCRIPTION

C<RISCOS::Throwback> attaches handlers to capture messages generated by C<die>
and C<warn> and send them via the throwback system to a text editor, providing a
rapid way to go to the source code that generated the error.

The module works by attaching to perl's C<$SIG{__DIE__}> and C<$SIG{__WARN__}>
handlers, parsing the error messages that it receives, and forwarding them to
C<DDEUtils>. Unfortunately messages generated by C<yyerror> due to syntax errors
detected by the lexer do not use C<$SIG{__DIE__}>, but are printed direct to
C<STDERR>, so there is no simple way to capture this text.

The module provides two subroutines to allow the user to generate throwback.

=over 4

=item throwback <filename>, <line>, <seriousness>, <message>

Send an "error" message for the specified file.
I<seriousness> values are:

=over 4

=item 0 warning

=item 1 error

=item 2 serious error

=back

=item throwback_info <filename>, <line>, <message>

Sends an "informational message" for the specified file.

=back

=head1 BUGS

As noted, perl doesn't (yet) allow capture of all errors found while parsing the
script. Also, the pattern matcher doesn't always correctly extract the line
number from the message, which creates spurious line numbers in the text
editor's throwback window. Ultimately what is needed is a well defined C<C> hook
inside perl for capturing diagnostic output.

There is no option to make the line-number and filename in runtime errors and
warnings refer to the last filehandle and line, rather than the script line.

Throwback naïvely assumes that a script name of 'F<->', 'F<-e>' or 'F<eval 1>'
refers to a file.

Throwback appears to be giving double messages for syntax errors inside modules.
I presume this is due to problems with C<eval> and C<__DIE__> handlers.
(the handler is called once inside the C<eval>, and a second time from the
cleanup performed by C<use> after (failing) to pass the module).

=head1 AUTHOR

Nicholas Clark <F<nick@unfortu.net>>
