/* Copyright (c) 1997-2006			 -*- C -*-
   Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
   http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.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.
*/

#ident "$Project: polymake $$Id: Scope.xs 6949 2006-02-06 16:29:16Z gawrilow $"

#include "Ext.h"

CV *avoid_db_sub=0;

static
void localize_marker(pTHX_ void *p)
{
   if (PL_in_eval & ~(EVAL_INREQUIRE))	/* functionality of $^S less the lex test */
      croak("Scope::end missing");
}

typedef struct local_var_ptrs {
   SV *var;
   void *orig_any;
   SV *temp_owner;
} local_var_ptrs;

static
local_var_ptrs* do_local_var(SV *var, SV *value)
{
   local_var_ptrs *ptrs;
   New(0, ptrs, 1, local_var_ptrs);
   ptrs->var=var;
   ptrs->orig_any=SvANY(var);
   SvANY(var)=SvANY(value);
   ptrs->temp_owner=value;
   SvREFCNT_inc(var);
   SvREFCNT_inc(value);
   return ptrs;
}

static
void undo_local_var(pTHX_ void *p)
{
   local_var_ptrs *ptrs=(local_var_ptrs*)p;
   SvANY(ptrs->var)=ptrs->orig_any;
   SvREFCNT_dec(ptrs->var);
   SvREFCNT_dec(ptrs->temp_owner);
   Safefree(p);
}

typedef struct local_scalar_ptrs {
   SV *var;
   SV orig;
} local_scalar_ptrs;

static
local_scalar_ptrs* do_local_scalar(SV *var, SV *value)
{
   local_scalar_ptrs *ptrs;
   New(0, ptrs, 1, local_scalar_ptrs);
   ptrs->var=var;
   ptrs->orig.sv_any=var->sv_any;
   ptrs->orig.sv_refcnt=var->sv_refcnt;
   ptrs->orig.sv_flags=var->sv_flags;
   var->sv_any=0;
   var->sv_flags=0;
   var->sv_refcnt=1;
   sv_setsv(var,value);
   return ptrs;
}

static
void undo_local_scalar(pTHX_ void *p)
{
   local_scalar_ptrs *ptrs=(local_scalar_ptrs*)p;
   if (SvREFCNT(ptrs->var)>1) {
      SvREFCNT_dec(ptrs->var);
   } else {
      SvREFCNT(ptrs->var)=0;  sv_clear(ptrs->var);
   }
   ptrs->var->sv_any=ptrs->orig.sv_any;
   ptrs->var->sv_refcnt=ptrs->orig.sv_refcnt;
   ptrs->var->sv_flags=ptrs->orig.sv_flags;
   Safefree(p);
}

typedef struct local_incr_ptrs {
   SV *var;
   I32 incr;
} local_incr_ptrs; 

static
local_incr_ptrs* do_local_incr(SV *var, I32 incr)
{
   local_incr_ptrs *ptrs;
   New(0, ptrs, 1, local_incr_ptrs);
   ptrs->var=var;
   ptrs->incr=incr;
   if (SvIOK(var) || SvPOK(var))
      sv_setiv(var, SvIV(var)+incr);
   else if (SvNOK(var))
      sv_setnv(var, SvNVX(var)+incr);
   else
      sv_setiv(var,incr);
   return ptrs;
}

static
void undo_local_incr(pTHX_ void *p)
{
   local_incr_ptrs *ptrs=(local_incr_ptrs*)p;
   SV *var=ptrs->var;
   if (SvIOK(var))
      sv_setiv(var, SvIVX(var)-ptrs->incr);
   else if (SvNOK(ptrs->var))
      sv_setnv(var, SvNVX(var)-ptrs->incr);
   else
      Safefree(p), croak("undoing local increment: variable is no more numerical");
   Safefree(p);
}

static
local_incr_ptrs* do_local_push(pTHX_ SV *av, SV **src, int n, int side)
{
   local_incr_ptrs *ptrs;
   SV **dst, **src_end;
   New(0, ptrs, 1, local_incr_ptrs);
   ptrs->var=av;
   ptrs->incr=side*n;
   av_extend((AV*)av, AvFILLp(av)+n);
   if (side<0) {
      dst=AvARRAY(av);
      Move(dst, dst+n, AvFILLp(av)+1, SV*);
   } else {
      dst=AvARRAY(av)+AvFILLp(av)+1;
   }
   for (src_end=src+n; src<src_end; ++src, ++dst) {
      SV *d=*src;
      if (SvREADONLY(d) || !SvTEMP(d))
	 *dst=newSVsv(d);
      else
	 *dst=SvREFCNT_inc(d);
   }
   AvFILLp(av)+=n;
   return ptrs;
}

static
void undo_local_push(pTHX_ void *p)
{
   local_incr_ptrs *ptrs=(local_incr_ptrs*)p;
   SV *av=ptrs->var;
   I32 n=ptrs->incr;
   SV **e, **eend;
   if (n>0) {
      for (e=AvARRAY(av)+AvFILLp(av), eend=e-n; e>eend; --e) {
	 SvREFCNT_dec(*e);
	 *e=&PL_sv_undef;
      }
      AvFILLp(av)-=n;
   } else {
      for (eend=AvARRAY(av)-1, e=eend-n; e>eend; --e)
	 SvREFCNT_dec(*e);
      AvFILLp(av)+=n;
      ++eend;
      Move(eend-n, eend, AvFILLp(av)+1, SV*);
      for (e=eend+AvFILLp(av)+1, eend=e-n; e<eend; ++e)
	 *e=&PL_sv_undef;
   }
   Safefree(p);
}

MODULE = Poly::Scope		PACKAGE = Poly::Scope

void
begin_locals(scope)
   SV *scope=SvRV(ST(0));
CODE:
LEAVE;
{
   save_destructor_x(&localize_marker, scope);
}
ENTER;

void
end_locals(scope)
   SV *scope=SvRV(ST(0));
CODE:
LEAVE;
{
   ANY *mainstack=PL_savestack;
   I32 frame_top=PL_savestack_ix, frame_bottom=PL_scopestack[PL_scopestack_ix-1], f, to_save;

   /* find the marker or resign */
   for (f=frame_top-3; f >= frame_bottom; --f)
      if (mainstack[f].any_ptr == (void*)&localize_marker
	  && f+2 < frame_top
	  && mainstack[f+2].any_i32 == SAVEt_DESTRUCTOR_X) {

	 if (scope != (SV*)mainstack[f+1].any_ptr) break;

	 to_save=frame_top-(f+3);
	 if (to_save > 0) {
	    SV *marker=*av_fetch((AV*)scope, 0, 0);
	    sv_catpvn(marker, (char*)&(mainstack[f+3]), to_save*sizeof(ANY));
	    PL_savestack_ix=f;	/* pop the marker and the saved locals quickly */
	 }
	    scope=0;
	    break;
      }
   if (scope)
      croak("Scope: begin-end mismatch");
}
ENTER;

void
unwind(marker)
   SV *marker=ST(0);
CODE:
{
   I32 saved=SvCUR(marker)/sizeof(ANY);
   if (saved) {
      LEAVE;
      SSCHECK(saved);
      Copy(SvPVX(marker), &(PL_savestack[PL_savestack_ix]), saved, ANY);
      PL_savestack_ix+=saved;
      ENTER;
   }
}

MODULE = Poly::Scope		PACKAGE = Poly

void
local_scalar(var, value)
   SV *var;
   SV *value;
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=GvSV(var))
	           : SvTYPE(var) >= SVt_PVAV) ||
	SvTYPE(value) >= SVt_PVAV )
      croak("usage: local_scalar(*glob || $var, value)");
   LEAVE;
   save_destructor_x(&undo_local_scalar, do_local_scalar(var, value));
   ENTER;
}

void
local_array(var, value)
   SV *var;
   SV *value;
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=(SV*)GvAV(var))
                   : !SvROK(var) || (var=SvRV(var), SvTYPE(var) != SVt_PVAV)) ||
	(!SvROK(value) || (value=SvRV(value), SvTYPE(value) != SVt_PVAV)) )
      croak("usage: local_array(*glob || \\@array, [ value ])");
   LEAVE;
   save_destructor_x(&undo_local_var, do_local_var(var, value));
   ENTER;
}

void
local_hash(var, value)
   SV *var;
   SV *value;
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=(SV*)GvHV(var))
	           : !SvROK(var) || (var=SvRV(var), SvTYPE(var) != SVt_PVHV)) ||
	(!SvROK(value) || (value=SvRV(value), SvTYPE(value) != SVt_PVHV)) )
      croak("usage: local_hash(*glob || \\%hash, { value })");
   LEAVE;
   save_destructor_x(&undo_local_var, do_local_var(var, value));
   ENTER;
}

void
local_sub(var, value)
   SV *var;
   SV *value=ST(1);
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=(SV*)GvCV(var))
	           : !SvROK(var) || (var=SvRV(var), SvTYPE(var) != SVt_PVCV)) ||
	(!SvROK(value) || (value=SvRV(value), SvTYPE(value) != SVt_PVCV)) )
      croak("usage: local_sub(*glob || \\&sub, sub { ... })");
   LEAVE;
   save_destructor_x(&undo_local_var, do_local_var(var, value));
   ENTER;
}

void
local_incr(var, ...)
   SV *var;
PROTOTYPE: $;$
CODE:
{
   SV *incr= items==2 ? ST(1) : 0;
   if ( items>2 ||
	(isGV(var) ? !(var=GvSV(var))
	           : SvTYPE(var) >= SVt_PVAV) ||
	(incr && SvTYPE(incr) >= SVt_PVAV) )
      croak("usage: local_incr(*glob || $var, incr(=1))");
   LEAVE;
   save_destructor_x(&undo_local_incr, do_local_incr(var, incr ? SvIV(incr) : 1));
   ENTER;
}

void
local_push(avref, ...)
   SV *avref;
PROTOTYPE: $@
CODE:
{
   SV *av=0;
   if (isGV(avref)
       ? !(av=(SV*)GvAV(avref))
       : !SvROK(avref) || (av=SvRV(avref), SvTYPE(av) != SVt_PVAV || SvMAGICAL(av)))
      croak("usage: local_push(\\@array, data ...");
   if (items>=2) {
      LEAVE;
      save_destructor_x(&undo_local_push, do_local_push(aTHX_ av, &ST(1), items-1, 1));
      ENTER;
   }
}

void
local_unshift(avref, ...)
   SV *avref;
PROTOTYPE: $@
CODE:
{
   SV *av=0;
   if (isGV(avref)
       ? !(av=(SV*)GvAV(avref))
       : !SvROK(avref) || (av=SvRV(avref), SvTYPE(av) != SVt_PVAV || SvMAGICAL(av)))
      croak("usage: local_unshift(\\@array, data ...");
   if (items>=2) {
      LEAVE;
      save_destructor_x(&undo_local_push, do_local_push(aTHX_ av, &ST(1), items-1, -1));
      ENTER;
   }
}

void
propagate_match()
PPCODE:
{
   PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix;
   while (cx >= cx_bottom) {
      if (CxTYPE(cx) == CXt_SUB) {
	 cx->blk_oldpm=PL_curpm;
	 if (!avoid_db_sub || cx->blk_sub.cv == avoid_db_sub)
	    break;
      }
      --cx;
   }
}

BOOT:
if (PL_DBgv) {
   CvNODEBUG_on(get_cv("Poly::Scope::begin_locals", FALSE));
   CvNODEBUG_on(get_cv("Poly::Scope::end_locals", FALSE));
   CvNODEBUG_on(get_cv("Poly::Scope::unwind", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_scalar", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_array", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_hash", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_incr", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_push", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_unshift", FALSE));
   CvNODEBUG_on(get_cv("Poly::propagate_match", FALSE));
   avoid_db_sub=GvCV(PL_DBsub);
}