swig/Tools/WAD/Wad/wadpl.cxx

/* ----------------------------------------------------------------------------- 
 * 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((char*)"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 = (char*)"Segmentation fault.";
    break;
  case SIGBUS:
    type = (char*)"Bus error.";
    break;
  case SIGABRT:
    type = (char*)"Abort.";
    break;
  case SIGFPE:
    type = (char*)"Math.";
  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);
}