*** empty log message ***

git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@953 626c5289-ae23-0410-ae9c-e8d60b6d4f22

Tools/WAD/Include/wad.h

@@ -83,6 +83,7 @@ extern void wad_signalhandler(int, siginfo_t *, void *);
 extern void wad_signal_init();
 extern void wad_set_return(const char *name, long value);
 extern void wad_set_return_value(long value);
+extern void wad_set_return_func(void (*f)(void));
 
 extern int  wad_elf_check(WadObjectFile *wo);
 extern void wad_elf_debug(WadObjectFile *wo);

Tools/WAD/Wad/Makefile

@@ -8,6 +8,7 @@ LIBS =
 #PYINCLUDE = -I/usr/local/include/python2.0
 PYINCLUDE = -I/usr/local/include/python1.5
 TCLINCLUDE = -I/usr/local/include
+PERLINCLUDE = -I/usr/local/lib/perl5/5.6.0/sun4-solaris/CORE
 
 all::
 	CC -Kpic -c $(OPT) $(INCLUDE) main.cxx
@@ -28,6 +29,13 @@ tcl::
 	cp wad.so libwadtcl.so
 	cp libwadtcl.so ..
 
+perl::
+	makehandler.py
+	cc -c $(OPT) $(INCLUDE) $(SRCS)
+	CC -Kpic -c $(INCLUDE) $(PERLINCLUDE) wadpl.cxx
+	CC -G $(OBJS) wadpl.o -o libwadpl.so $(LIBS)
+	cp libwadpl.so ..
+
 linux::
 	g++ -fpic -c -DWAD_LINUX $(INCLUDE) main.cxx
 	gcc -g -c -DWAD_LINUX $(INCLUDE) $(SRCS)

Tools/WAD/Wad/libwadpl.pm

@@ -0,0 +1,8 @@
+package libwadpl;
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+package libwadpl;
+bootstrap libwadpl;
+@EXPORT = qw( );
+1;

Tools/WAD/Wad/makehandler.py

@@ -0,0 +1,20 @@
+#!/usr/local/bin/python
+import string
+f = open("wadhandler.pl")
+data = f.read()
+f.close()
+
+data = string.replace(data,"\\", "\\\\")
+data = string.replace(data,"\"", "\\\"")
+data = string.replace(data,"\n", "\\n\\\n")
+
+f = open("wad_perl_handler.c","w")
+
+f.write("static char wad_perl_handler[] = \"")
+f.write(data)
+f.write("\";\n");
+f.close()
+
+
+
+

Tools/WAD/Wad/signal.c

@@ -31,12 +31,18 @@ void wad_set_callback(void (*s)(int,WadFrame *,char *ret)) {
 static int            nlr_levels = 0;
 static volatile int  *volatile nlr_p = &nlr_levels;
 static long           nlr_value = 0;
+static void          (*nlr_func)(void) = 0;
 
 /* Set the return value from another module */
 void wad_set_return_value(long value) {
   nlr_value = value;
 }
 
+/* Set the return function */
+void wad_set_return_func(void(*f)(void)) {
+  nlr_func = f;
+}
+
 #ifdef WAD_SOLARIS
 static void nonlocalret() {
   long a;
@@ -62,6 +68,12 @@ static void nonlocalret() {
   asm("or %o0, %lo(nlr_value), %o0");
   asm("ld [%o0], %i0");
 
+  /* If there is a non-local return function.  We're going to go ahead
+     and transfer control to it */
+  
+  if (nlr_func) 
+    (*nlr_func)();
+
   asm("jmp %i7 + 8");
   asm("restore");
   asm(".size	_returnsignal,(.-_returnsignal)");
@@ -75,6 +87,10 @@ static void nonlocalret() {
     (*nlr_p)--;
     asm("leave");
   }
+
+  if (nlr_func) 
+    (*nlr_func)();
+
   asm("movl nlr_value, %eax");
   asm("leave");
   asm("ret");
@@ -99,6 +115,8 @@ void wad_signalhandler(int sig, siginfo_t *si, void *vcontext) {
   char      *framedata;
   char      *retname = 0;
 
+  nlr_func = 0;
+
   wad_object_init();
 
   context = (ucontext_t *) vcontext;

Tools/WAD/Wad/wadhandler.pl

@@ -0,0 +1,36 @@
+package libwadpl;
+sub wad_handler_traceback {
+    package DB;
+    my $es = "";
+    ($pack,$file,$line) = caller(1);
+
+    for ($i = 2; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
+        @a = ();
+        for $arg (@args) {
+            $_ = "$arg";
+            s/([\'\\])/\\$1/g;
+            s/([^\0]*)/'$1'/
+              unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+            s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+            s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+            push(@a, $_);
+        }
+        $w = $w ? '@ = ' : '$ = ';
+        $a = $h ? '(' . join(', ', @a) . ')' : '';
+        $e =~ s/\n\s*\;\s*\Z// if $e;
+        $e =~ s/[\\\']/\\$1/g if $e;
+        if ($r) {
+            $s = "require '$e'";
+        } elsif (defined $r) {
+            $s = "eval '$e'";
+        } elsif ($s eq '(eval)') {
+            $s = "eval {...}";
+        }
+        $f = "file `$f'" unless $f eq '-e';
+        $mess = "$w$s$a called from $f line $l\n";
+	$es = $mess . $es;
+
+    }
+    $es = "Signal at $file line $line\n" . $es;
+    return $es;
+}

Tools/WAD/Wad/wadpl.cxx

@@ -0,0 +1,174 @@
+/* ----------------------------------------------------------------------------- 
+ * wadpl.cxx
+ *
+ *     Dynamically loadable module for Perl.
+ * 
+ * Author(s) : David Beazley (beazley@cs.uchicago.edu)
+ *
+ * Copyright (C) 2000.  The University of Chicago
+ * See the file LICENSE for information on usage and redistribution.	
+ * ----------------------------------------------------------------------------- */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "wad.h"
+#ifdef __cplusplus
+}
+#endif
+
+#include <signal.h>
+
+#include "wad_perl_handler.c"
+
+/* Error message returned to perl */
+
+static char message[65536];
+static int  global_signo = 0;
+
+static void returnfunc(void) {
+  SV     *s;
+  s = perl_eval_pv("libwadpl::wad_handler_traceback(0)", 0);
+  croak("%s\n%s",SvPV(s,PL_na),message);
+  return;
+}
+
+/* Handler function */	
+static void handler(int signo, WadFrame *frame, char *ret) {
+
+  static char temp[1024];
+  int  len = 0;
+  char *name;
+  char *fd;
+  WadFrame *f;
+  WadFrame *fline = 0;
+  int err;
+  char  *type;
+
+  if (!ret) {
+    wad_default_callback(signo, frame, ret);
+    return;
+  }
+
+
+  switch(signo) {
+  case SIGSEGV:
+    type = "Segmentation fault.";
+    break;
+  case SIGBUS:
+    type = "Bus error.";
+    break;
+  case SIGABRT:
+    type = "Abort.";
+    break;
+  default:
+    break;
+  }
+  strcpy(message,type);
+  strcat(message,"\n[ C stack trace ]\n\n");
+  fd = (char *) frame;
+  f = (WadFrame *) fd;
+
+  /* Find the last exception frame */
+  while (!f->last) {
+    fd = fd + f->size;
+    f = (WadFrame *) fd;
+  }
+  /* Now work backwards */
+  fd = fd - f->lastsize;
+  f = (WadFrame *) fd;
+  while (1) {
+    sprintf(temp,"#%-3d 0x%08x in ", f->frameno, f->pc);
+    strcat(message,temp);
+    strcat(message,*(fd + f->sym_off) ? fd+f->sym_off : "?");
+    strcat(message,"()");
+    if (strlen(SRCFILE(f))) {
+      strcat(message," in '");
+      strcat(message, wad_strip_dir(SRCFILE(f)));
+      strcat(message,"'");
+      if (f->line_number > 0) {
+	sprintf(temp,", line %d", f->line_number);
+	strcat(message,temp);
+	fline = f;
+      }
+    } else {
+      if (strlen(fd+f->obj_off)) {
+	strcat(message," from '");
+	strcat(message, wad_strip_dir(OBJFILE(f)));
+	strcat(message,"'");
+      }
+    }
+    strcat(message,"\n");
+    if (!f->lastsize) break;
+    fd = fd - f->lastsize;
+    f = (WadFrame *) fd;
+  }
+  if (fline) {
+    int first;
+    int last;
+    char *line, *c;
+    int i;
+    first = fline->line_number - 2;
+    last  = fline->line_number + 2;
+    if (first < 1) first = 1;
+    
+    line = wad_load_source(SRCFILE(fline),first);
+    if (line) {
+      strcat(message,"\n");
+      strcat(message, SRCFILE(fline));
+      sprintf(temp,", line %d\n\n", fline->line_number);
+      strcat(message, temp);
+      for (i = first; i <= last; i++) {
+	if (i == fline->line_number) strcat(message," => ");
+	else                         strcat(message,"    ");
+	c = strchr(line,'\n');
+	if (c) {
+	  *c = 0;
+	  strcat(message,line);
+	  strcat(message,"\n");
+	  *c = '\n';
+	} else {
+	  strcat(message,line);
+	  strcat(message,"\n");
+	  break;
+	}
+	line = c+1;
+      }
+      wad_release_source();
+      strcat(message,"\n");
+    }
+  }
+  wad_set_return_func(returnfunc);
+  wad_release_trace();
+}
+
+static void perlwadinit() {
+  printf("WAD Enabled\n");
+  wad_init();
+  wad_set_callback(handler);
+  wad_set_return("Perl_pp_entersub", 0);
+  perl_eval_pv(wad_perl_handler, 0);
+}
+
+/* This hack is used to auto-initialize wad regardless of whether we are
+   used as an imported module or as a link-library for another module */
+   
+class wadinitializer {
+public:
+  wadinitializer() {
+    perlwadinit();
+  }
+};
+
+static wadinitializer wi;
+
+extern "C"
+XS(boot_libwadpl) {
+  dXSARGS;
+  ST(0) = &PL_sv_yes;
+  XSRETURN(1);
+}