home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / RPC / !Perl / riscos / RISCOS / Throwback.pm < prev    next >
Encoding:
Perl POD Document  |  1998-07-26  |  6.6 KB  |  216 lines
  1. package RISCOS::Throwback;
  2. use RISCOS::SWI;
  3. use Carp;
  4. use strict;
  5.  
  6. use vars qw ($VERSION @ISA @EXPORT_OK $null $send $send_mask %seen $last_die);
  7. require Exporter;
  8.  
  9. $VERSION = 0.11;
  10. @ISA = 'Exporter';
  11. @EXPORT_OK = qw(throwback throwback_info);
  12.  
  13. $send = SWINumberFromString('DDEUtils_ThrowbackSend');
  14. $send_mask = ®mask([0,2..5]);
  15.  
  16. # Version 0.11
  17. # Stop 'Invalid Wimp operation in this context' error
  18. # Transpires that even with <Wimp$State> = "commands" you can still call
  19. # Throwback_Start an F12 * prompt. Reason - there is a current task handle.
  20. # Solution - read the task handle, if it is 0, (eg during an obey file's
  21. # execution) then don't attempt to start throwback
  22. # Version 0.10
  23. # Bodged to stop multiple copies of the same message when modules are nested.
  24. # Not perfect, as may still get a stream of alternating (BEGIN failed, message)
  25. # Version 0.09
  26. # Wrapped throwback start and end SWIs in eval, so that END does not fail, and
  27. # start does confess.
  28. # check $^S in an attempt to avoid multiple errors. partial success. still gives
  29. # multiple reports for "Compilation failed in require"
  30. # Version 0.08
  31. # removed , and \. from two regexps that match messages in throw_die
  32. # It would seem that \. is no longer present in "at <file> line 20"
  33. # Version 0.07
  34. # Follow the protocol and call Throwback processing before the first message
  35. # Version 0.06
  36. # Calls RISCOS::Filespec::convert_internal
  37. # Version 0.05
  38. # Ignore execution of * aborted due to compilation errors
  39. # Version 0.04
  40. # Cope with
  41. # syntax error at /PerlDevArchLib:/RISCOS/Module.pm line 68, near "if wantarray"
  42. # Version 0.03
  43. # Force riscosify in sig handlers
  44. # Throwback info is 2 not 0
  45. # Check for undef messages
  46. # Version 0.02
  47. # Swapped (.*) to (\d*) for line number in regular expression
  48.  
  49. # Some warnings and yyerror() don't seem to feed this way
  50. # bummer.
  51.  
  52. BEGIN
  53. {
  54.     croak "You need port 1·04 or later"
  55.       unless defined &RISCOS::Filespec::convert_internal;
  56.     # Error if we don't have the XS
  57. }
  58.  
  59. $last_die = $null = '';
  60. # SWI can't be passed constant strings
  61.  
  62.  
  63. sub throwback_processing ($) {
  64.     swi ($send, regmask ([0,2]), 0, $_[0]);
  65.     $seen{$_[0]} = 1;    # Mark that we've seen this file
  66. }
  67.  
  68. sub throwback ($$$$) {
  69.     my ($filename, $line, $seriousness, $message) = @_;
  70.     throwback_processing ($filename) unless $seen{$filename};
  71.     swi ($send, $send_mask, 1, defined ($filename) ? $filename : $null, 0+$line,
  72.          0+$seriousness, defined ($message) ? $message : $null);
  73. }
  74.  
  75. sub throwback_info ($$$) {
  76.     my ($filename, $line, $message) = @_;
  77.     throwback_processing ($filename) unless $seen{$filename};
  78.     swi ($send, $send_mask, 2, defined ($filename) ? $filename : $null, 0+$line,
  79.          0, defined ($message) ? $message : $null);
  80. }
  81.  
  82. sub throw_warn ($) {
  83.     return if $^S;
  84.     my ($message, $file, $line, $near) = $_[0] =~ /(.*) at (.+) line (\d*)([.,].*)/;
  85. #    if ($file =~ /^\(eval \d+\)$/) {
  86. #        my $package;
  87. #        ($package, $file, $line) = (caller);
  88. #        confess "$package $file $line";
  89. #    }
  90.     if (defined $message)
  91.     {
  92.         $message .= $near unless ($near eq '.');
  93.         throwback_info (RISCOS::Filespec::riscosify($file,
  94.           RISCOS::Filespec::convert_internal()), $line, $message);
  95.     }
  96.     warn @_;
  97.  };
  98.  
  99. sub throw_die ($) {
  100.     return if $^S;
  101.     $_ = shift;
  102.     # Bodge    use Blah; when nested will call $SIG{DIE} as each module exits.
  103.     # Last copy will be "${last_die}BEGIN failed"
  104.     # This way we print the first copy. And get throwback on the single line
  105.     # BEGIN failed
  106.     s/^\Q$last_die\E//s;
  107.     return unless length;
  108.     $last_die = $_;
  109.     return if /Execution of .* aborted due to compilation errors/;
  110.     
  111.     my ($message, $file, $line, $near) = /(.*) at (.+) line (\d+)\,(.*)/;
  112.     if (defined $message) {
  113.         $message .= $near if defined $near;
  114.     } else {
  115.         ($message, $file, $line) = /(.*) at (.+) line (\d+)/;
  116.     }
  117.     unless ($message)
  118.     {
  119.         $message = $_;
  120.         $file = $0 unless $file;
  121.     }
  122.     $line = 0 unless (defined $line);
  123.     throwback (RISCOS::Filespec::riscosify($file,
  124.       RISCOS::Filespec::convert_internal()), $line, 1, $message);
  125.  };
  126.  
  127.  
  128. # Not good enough. ShellCLI is OK, running from an obey file is not.
  129. # if ($ENV{'Wimp$State'} eq 'commands') {
  130.  
  131. my $handle = kernelswi ('Wimp_ReadSysInfo',5);
  132. unless (defined $handle and unpack 'I', $handle) {
  133.     carp 'Outside desktop, throwback unavailable' if $^W;
  134. } else {
  135.     if (defined (eval {swix ('DDEUtils_ThrowbackStart')})) {
  136.         $SIG{'__WARN__'} = \&throw_warn;
  137.     $SIG{'__DIE__'} = \&throw_die;
  138.     } else {
  139.     confess $^E if $^W;
  140.     }
  141.  
  142.     END { eval {swix ('DDEUtils_ThrowbackEnd')} }
  143. }
  144.  
  145. $send;    # Return true if we got the SWI
  146.  
  147. __END__
  148.  
  149. =head1 NAME
  150.  
  151. RISCOS::Throwback -- provide throwback for perl
  152.  
  153. =head1 SYNOPSIS
  154.  
  155.     use RISCOS::Throwback;
  156.  
  157. =head1 DESCRIPTION
  158.  
  159. C<RISCOS::Throwback> attaches handlers to capture messages generated by C<die>
  160. and C<warn> and send them via the throwback system to a text editor, providing a
  161. rapid way to go to the source code that generated the error.
  162.  
  163. The module works by attaching to perl's C<$SIG{__DIE__}> and C<$SIG{__WARN__}>
  164. handlers, parsing the error messages that it receives, and forwarding them to
  165. C<DDEUtils>. Unfortunately messages generated by C<yyerror> due to syntax errors
  166. detected by the lexer do not use C<$SIG{__DIE__}>, but are printed direct to
  167. C<STDERR>, so there is no simple way to capture this text.
  168.  
  169. The module provides two subroutines to allow the user to generate throwback.
  170.  
  171. =over 4
  172.  
  173. =item throwback <filename>, <line>, <seriousness>, <message>
  174.  
  175. Send an "error" message for the specified file.
  176. I<seriousness> values are:
  177.  
  178. =over 4
  179.  
  180. =item 0 warning
  181.  
  182. =item 1 error
  183.  
  184. =item 2 serious error
  185.  
  186. =back
  187.  
  188. =item throwback_info <filename>, <line>, <message>
  189.  
  190. Sends an "informational message" for the specified file.
  191.  
  192. =back
  193.  
  194. =head1 BUGS
  195.  
  196. As noted, perl doesn't (yet) allow capture of all errors found while parsing the
  197. script. Also, the pattern matcher doesn't always correctly extract the line
  198. number from the message, which creates spurious line numbers in the text
  199. editor's throwback window. Ultimately what is needed is a well defined C<C> hook
  200. inside perl for capturing diagnostic output.
  201.  
  202. There is no option to make the line-number and filename in runtime errors and
  203. warnings refer to the last filehandle and line, rather than the script line.
  204.  
  205. Throwback naïvely assumes that a script name of 'F<->', 'F<-e>' or 'F<eval 1>'
  206. refers to a file.
  207.  
  208. Throwback appears to be giving double messages for syntax errors inside modules.
  209. I presume this is due to problems with C<eval> and C<__DIE__> handlers.
  210. (the handler is called once inside the C<eval>, and a second time from the
  211. cleanup performed by C<use> after (failing) to pass the module).
  212.  
  213. =head1 AUTHOR
  214.  
  215. Nicholas Clark <F<nick@unfortu.net>>
  216.