/* Copyright (c) 1997-2009                   -*- C -*-
   Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
   http://www.polymake.de

   This program is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by the
   Free Software Foundation; either version 2, or (at your option) any
   later version: http://www.gnu.org/licenses/gpl.txt.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
--------------------------------------------------------------------------------
   $Project: polymake $$Id: Ext.xs 9298 2009-09-02 23:10:56Z gawrilow $
*/

#include "Ext.h"
#include <stdio.h>

I32 pm_perl_skip_debug_cx=FALSE;

SV **pm_perl_get_cx_curpad(pTHX_ PERL_CONTEXT *cx, PERL_CONTEXT *cx_bottom)
{
   CV *cv;
   I32 d;
   while (--cx>=cx_bottom) {
      switch (CxTYPE(cx)) {
      case CXt_SUB:
	 cv=cx->blk_sub.cv;
	 if (SkipDebugSub(cv)) break;
	 d=cx->blk_sub.olddepth;
	 goto FOUND;
      case CXt_EVAL:
	 if (!CxTRYBLOCK(cx)) {
	    cv=PL_compcv;
	    d=0;
	    goto FOUND;
	 }
      }
   }
   cv=PL_main_cv;
   d=0;
 FOUND:
   return (SV**)AvARRAY(((AV**)AvARRAY(CvPADLIST(cv)))[d+1]);
}

CV* pm_perl_get_cur_cv(pTHX)
{
   PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix;
   while (cx>=cx_bottom) {
      switch (cx->cx_type) {
      case CXt_SUB: {
	 CV *cv=cx->blk_sub.cv;
	 if (!SkipDebugSub(cv)) return cv;
	 break;
      }
      case CXt_EVAL: {
	 CV *cv=cx->blk_eval.cv;
	 if (cv && CvEVAL(cv)) return cv;
	 break;
      }
      }
      --cx;
   }
   return PL_main_cv;
}

/* for debugging */
const char* pm_perl_get_stash_name(pTHX_ SV *x)
{
   if (SvROK(x)) x=SvRV(x);
   switch (SvTYPE(x)) {
   case SVt_PVGV:
      return HvNAME(GvSTASH(x));
   case SVt_PVCV:
      return HvNAME(CvSTASH(x));
   case SVt_PVHV:
      if (!SvOBJECT(x)) return HvNAME(x);
   default:
      if (SvOBJECT(x)) return HvNAME(SvSTASH(x));
   }
   return "*** neither an object/stash/glob/code ***";
}

const char* pm_perl_get_gv_name(pTHX_ GV *x)
{
   if (SvTYPE(x)==SVt_PVGV) return GvNAME(x);
   return "*** not a glob ***";
}

/******************************************************************************************************/
/* The obsolete stuff is left here only for teaching purposes */

#if 0

void
and_not(s1,s2)
   unsigned char *s1;
   unsigned char *s2;
PROTOTYPE: $$
CODE:
   {
      I32 l=min(SvCUR(ST(0)), SvCUR(ST(1)));
      for ( ; l>0; --l, ++s1, ++s2) {
	 *s1 &= ~ *s2;
      }
   }

void
includes(s1,s2)
   unsigned char *s1;
   unsigned char *s2;
PROTOTYPE: $$
CODE:
   {
      I32 l1=SvCUR(ST(0)), l2=SvCUR(ST(1));
      for ( ; l1>0 && l2>0; --l1, --l2, ++s1, ++s2) {
	 if ((*s1 & *s2) != *s2) XSRETURN_NO;
      }
      for ( ; l2>0; --l2, ++s2) {
	 if (*s2) XSRETURN_NO;
      }
   }
   XSRETURN_YES;

void
intersect(s1,s2)
   unsigned char *s1;
   unsigned char *s2;
PROTOTYPE: $$
CODE:
   {
      I32 l=min(SvCUR(ST(0)), SvCUR(ST(1)));
      for ( ; l>0; --l, ++s1, ++s2) {
	 if (*s1 & *s2) XSRETURN_YES;
      }
   }
   XSRETURN_NO;

void
empty(s)
   unsigned char *s;
PROTOTYPE: $
CODE:
   {
      I32 l=SvCUR(ST(0));
      for ( ; l>0; --l, ++s) {
	 if (*s) XSRETURN_NO;
      }
   }
   XSRETURN_YES;

#endif

MODULE = Polymake::Ext		PACKAGE = Polymake

PROTOTYPES: DISABLE

void
dump_sub(gv)
   SV *gv;
CODE:
{
#ifdef DEBUGGING
   Perl_dump_sub(aTHX_ (GV*)gv);
#else
   croak("this perl is compiled without DEBUGGING");
   gv=0;
#endif
}

BOOT:
if (PL_DBgv)
   pm_perl_skip_debug_cx=TRUE;
