[p5sagit/Gather-Once.git] / Once.xs

#include "EXTERN.h"
#include "perl.h"
#include "callchecker0.h"
#include "callparser.h"
#include "XSUB.h"

typedef struct payload_St {
  bool topicalise;
  CV *predicate_cv;
} payload_t;

#define SVt_PADNAME SVt_PVMG

#ifndef COP_SEQ_RANGE_LOW_set
# define COP_SEQ_RANGE_LOW_set(sv,val) \
  do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = val; } while(0)
# define COP_SEQ_RANGE_HIGH_set(sv,val) \
  do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = val; } while(0)
#endif /* !COP_SEQ_RANGE_LOW_set */

#ifndef PERL_PADSEQ_INTRO
# define PERL_PADSEQ_INTRO I32_MAX
#endif /* !PERL_PADSEQ_INTRO */

#define pad_add_my_scalar_pvn(namepv, namelen) \
    THX_pad_add_my_scalar_pvn(aTHX_ namepv, namelen)
static PADOFFSET
THX_pad_add_my_scalar_pvn(pTHX_ char const *namepv, STRLEN namelen)
{
  PADOFFSET offset;
  SV *namesv, *myvar;
  myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1);
  offset = AvFILLp(PL_comppad);
  SvPADMY_on(myvar);
  PL_curpad = AvARRAY(PL_comppad);
  namesv = newSV_type(SVt_PADNAME);
  sv_setpvn(namesv, namepv, namelen);
  COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax);
  COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO);
  PL_cop_seqmax++;
  av_store(PL_comppad_name, offset, namesv);
  return offset;
}

#define DEMAND_IMMEDIATE 0x00000001
#define DEMAND_NOCONSUME 0x00000002
#define demand_unichar(c, f) THX_demand_unichar(aTHX_ c, f)
static void
THX_demand_unichar (pTHX_ I32 c, U32 flags)
{
  if(!(flags & DEMAND_IMMEDIATE))
    lex_read_space(0);

  if(lex_peek_unichar(0) != c)
    croak("syntax error");

  if(!(flags & DEMAND_NOCONSUME))
    lex_read_unichar(0);
}

#define CXt_MOO 12
#define CXt_KOOH 13

static OP *
pp_entertake (pTHX)
{
  dSP;
  register PERL_CONTEXT *cx;
  const I32 gimme = GIMME_V;

  if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
    RETURNOP(cLOGOP->op_other->op_next);

  ENTER;

  PUSHBLOCK(cx, CXt_KOOH, SP);
  cx->blk_givwhen.leave_op = cLOGOP->op_other;

  RETURN;
}

STATIC I32
S_dopoptogather(pTHX_ I32 startingblock)
{
    dVAR;
    I32 i;
    for (i = startingblock; i >= 0; i--) {
  register const PERL_CONTEXT *cx = &cxstack[i];
  switch (CxTYPE(cx)) {
  default:
      continue;
  case CXt_MOO:
      DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
      return i;

  case CXt_LOOP_PLAIN:
      assert(!CxFOREACHDEF(cx));
      break;
  case CXt_LOOP_LAZYIV:
  case CXt_LOOP_LAZYSV:
  case CXt_LOOP_FOR:/* FIXME */
      if (CxFOREACHDEF(cx)) {
    DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
    return i;
      }
  }
    }
    return i;
}

static OP *
pp_leavetake (pTHX)
{
  dSP;
  I32 cxix;
  register PERL_CONTEXT *cx;
  I32 gimme;
  SV **newsp;
  PMOP *newpm;

  cxix = S_dopoptogather(aTHX_ cxstack_ix);
  if (cxix < 0)
  /* diag_listed_as: Can't "when" outside a topicalizer */
  DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
      PL_op->op_flags & OPf_SPECIAL ? "default" : "when");

  POPBLOCK(cx,newpm);
  assert(CxTYPE(cx) == CXt_KOOH);

  LEAVE;

  if (cxix < cxstack_ix)
    dounwind(cxix);

  cx = &cxstack[cxix];

  RETURNOP(cx->blk_givwhen.leave_op);
}

static OP *
myparse_args_take (pTHX_ GV *namegv, SV *args, U32 *flagsp)
{
  OP *condop, *blkop, *leaveop;
  LOGOP *enterop;
  SV *predicate_cv_ref;
  int blk_floor;
  bool topicalise;

  PERL_UNUSED_ARG(namegv);
  PERL_UNUSED_ARG(flagsp);

  demand_unichar('(', 0);
  condop = parse_fullexpr(0);
  demand_unichar(')', 0);

  demand_unichar('{', DEMAND_NOCONSUME);
  blk_floor = Perl_block_start(aTHX_ 1);
  blkop = parse_block(0);
  blkop = Perl_block_end(aTHX_ blk_floor, blkop);

  NewOp(1101, enterop, 1, LOGOP);
  enterop->op_type = OP_ENTERWHEN;
  enterop->op_ppaddr = pp_entertake;
  enterop->op_flags = OPf_KIDS;
  enterop->op_targ = -1;
  enterop->op_private = 0;

  leaveop = newUNOP(OP_LEAVEWHEN, 0, (OP *)enterop);
  leaveop->op_ppaddr = pp_leavetake;

  topicalise = SvTRUE(*av_fetch((AV *)SvRV(args), 0, 0));
  if (topicalise) {
    OP *pvarop;

    pvarop = newOP(OP_PADSV, 0);
    pvarop->op_targ = pad_findmy("$Gather::Once::current_topic",
                                 sizeof("$Gather::Once::current_topic")-1, 0);

    if (pvarop->op_targ == NOT_IN_PAD)
      croak("outside topicaliser"); /* FIXME */

    condop = op_append_elem(OP_LIST, condop, pvarop);
  }

  predicate_cv_ref = *av_fetch((AV *)SvRV(args), 1, 0);
  condop = newUNOP(OP_ENTERSUB, OPf_STACKED,
                   op_append_elem(OP_LIST, condop,
                                  newCVREF(0, newSVOP(OP_CONST, 0,
                                                      predicate_cv_ref))));

  enterop->op_first = condop;
  enterop->op_first->op_sibling = op_scope(blkop);
  leaveop->op_next = LINKLIST(enterop->op_first);
  enterop->op_first->op_next = (OP *)enterop;

  enterop->op_next = LINKLIST(enterop->op_first->op_sibling);
  enterop->op_first->op_sibling->op_next = enterop->op_other = leaveop;

  return leaveop;
}

static OP *
pp_entergather (pTHX)
{
  dSP; dTARGET;
  register PERL_CONTEXT *cx;
  const I32 gimme = GIMME_V;

  ENTER;
  if (PL_op->op_targ != NOT_IN_PAD)
    sv_setsv(TARG, POPs);

  PUSHBLOCK(cx, CXt_MOO, SP);
  cx->blk_givwhen.leave_op = cLOGOP->op_other;

  RETURN;
}

static OP *
pp_leavegather (pTHX)
{
  dSP;
  register PERL_CONTEXT *cx;
  I32 gimme;
  SV **newsp;
  PMOP *newpm;

  POPBLOCK(cx,newpm);
  assert(CxTYPE(cx) == CXt_MOO);

  //SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
  //PL_curpm = newpm; /* Don't pop $1 et al till now */

  LEAVE;
  RETURN;
}

static OP *
myparse_args_gather (pTHX_ GV *namegv, SV *topicalise, U32 *flagsp)
{
  OP *topicaliser, *blkop, *initop = NULL;
  int blk_floor;

  PERL_UNUSED_ARG(namegv);
  PERL_UNUSED_ARG(flagsp);

  if (SvTRUE(topicalise)) {
    demand_unichar('(', 0);
    topicaliser = parse_fullexpr(0);
    demand_unichar(')', 0);
  }

  demand_unichar('{', DEMAND_NOCONSUME);
  blk_floor = Perl_block_start(aTHX_ 1);
  if (SvTRUE(topicalise)) {
    initop = newOP(OP_PADSV, (OPpLVAL_INTRO<<8));
    initop->op_targ = pad_add_my_scalar_pvn("$Gather::Once::current_topic",
                                            sizeof("$Gather::Once::current_topic")-1);
  }

  blkop = parse_block(0);
  if (initop)
    blkop = op_prepend_elem(OP_LINESEQ, initop, blkop);

  blkop = Perl_block_end(aTHX_ blk_floor, blkop);

  LOGOP *enterop;
  NewOp(1101, enterop, 1, LOGOP);
  enterop->op_type = OP_ENTERGIVEN;
  enterop->op_ppaddr = pp_entergather;
  enterop->op_flags = OPf_KIDS;
  enterop->op_targ = SvTRUE(topicalise) ? initop->op_targ : NOT_IN_PAD;
  enterop->op_private = 0;

  OP *leaveop;
  leaveop = newUNOP(OP_LEAVEGIVEN, 0, (OP *)enterop);
  leaveop->op_ppaddr = pp_leavegather;

  enterop->op_first = SvTRUE(topicalise) ? topicaliser : newOP(OP_NULL, 0);
  enterop->op_first->op_sibling = op_scope(blkop);
  leaveop->op_next = LINKLIST(enterop->op_first);
  enterop->op_first->op_next = (OP *)enterop;

  enterop->op_next = LINKLIST(enterop->op_first->op_sibling);
  enterop->op_first->op_sibling->op_next = enterop->op_other = leaveop;

  return leaveop;
}

static OP *
myck_gathertake (pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
  OP *rv2cvop, *pushop, *blkop;

  PERL_UNUSED_ARG(namegv);
  PERL_UNUSED_ARG(ckobj);

  pushop = cUNOPx(entersubop)->op_first;
  if (!pushop->op_sibling)
    pushop = cUNOPx(pushop)->op_first;

  blkop = pushop->op_sibling;

  rv2cvop = blkop->op_sibling;
  blkop->op_sibling = NULL;
  pushop->op_sibling = rv2cvop;
  op_free(entersubop);

  return blkop;
}

MODULE = Gather::Once  PACKAGE = Gather::Once

void
setup_gather_hook (CV *gather_cv, SV *topicalise)
  CODE:
    cv_set_call_parser(gather_cv, myparse_args_gather, topicalise);
    cv_set_call_checker(gather_cv, myck_gathertake, &PL_sv_undef);

void
setup_take_hook (CV *take_cv, SV *args)
  CODE:
    cv_set_call_parser(take_cv, myparse_args_take, args);
    cv_set_call_checker(take_cv, myck_gathertake, &PL_sv_undef);
Commit	Line	Data
14342f72	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "callchecker0.h"
	4	#include "callparser.h"
	5	#include "XSUB.h"
	6
	7	typedef struct payload_St {
	8	bool topicalise;
	9	CV *predicate_cv;
	10	} payload_t;
	11
	12	#define SVt_PADNAME SVt_PVMG
	13
	14	#ifndef COP_SEQ_RANGE_LOW_set
	15	# define COP_SEQ_RANGE_LOW_set(sv,val) \
	16	do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = val; } while(0)
	17	# define COP_SEQ_RANGE_HIGH_set(sv,val) \
	18	do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = val; } while(0)
	19	#endif /* !COP_SEQ_RANGE_LOW_set */
	20
	21	#ifndef PERL_PADSEQ_INTRO
	22	# define PERL_PADSEQ_INTRO I32_MAX
	23	#endif /* !PERL_PADSEQ_INTRO */
	24
	25	#define pad_add_my_scalar_pvn(namepv, namelen) \
	26	THX_pad_add_my_scalar_pvn(aTHX_ namepv, namelen)
	27	static PADOFFSET
	28	THX_pad_add_my_scalar_pvn(pTHX_ char const *namepv, STRLEN namelen)
	29	{
	30	PADOFFSET offset;
	31	SV namesv, myvar;
	32	myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1);
	33	offset = AvFILLp(PL_comppad);
	34	SvPADMY_on(myvar);
	35	PL_curpad = AvARRAY(PL_comppad);
	36	namesv = newSV_type(SVt_PADNAME);
	37	sv_setpvn(namesv, namepv, namelen);
	38	COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax);
	39	COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO);
	40	PL_cop_seqmax++;
	41	av_store(PL_comppad_name, offset, namesv);
	42	return offset;
	43	}
	44
	45	#define DEMAND_IMMEDIATE 0x00000001
	46	#define DEMAND_NOCONSUME 0x00000002
	47	#define demand_unichar(c, f) THX_demand_unichar(aTHX_ c, f)
	48	static void
	49	THX_demand_unichar (pTHX_ I32 c, U32 flags)
	50	{
	51	if(!(flags & DEMAND_IMMEDIATE))
	52	lex_read_space(0);
	53
	54	if(lex_peek_unichar(0) != c)
	55	croak("syntax error");
	56
	57	if(!(flags & DEMAND_NOCONSUME))
	58	lex_read_unichar(0);
	59	}
	60
	61	#define CXt_MOO 12
	62	#define CXt_KOOH 13
	63
	64	static OP *
65	pp_entertake (pTHX)
66	{
67	dSP;
68	register PERL_CONTEXT *cx;
69	const I32 gimme = GIMME_V;
70
71	if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
72	RETURNOP(cLOGOP->op_other->op_next);
73
74	ENTER;
75
76	PUSHBLOCK(cx, CXt_KOOH, SP);
77	cx->blk_givwhen.leave_op = cLOGOP->op_other;
78
79	RETURN;
80	}
81
82	STATIC I32
83	S_dopoptogather(pTHX_ I32 startingblock)
84	{
85	dVAR;
86	I32 i;
87	for (i = startingblock; i >= 0; i--) {
88	register const PERL_CONTEXT *cx = &cxstack[i];
89	switch (CxTYPE(cx)) {
90	default:
91	continue;
92	case CXt_MOO:
93	DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
94	return i;
95
96	case CXt_LOOP_PLAIN:
97	assert(!CxFOREACHDEF(cx));
98	break;
99	case CXt_LOOP_LAZYIV:
100	case CXt_LOOP_LAZYSV:
101	case CXt_LOOP_FOR:/* FIXME */
102	if (CxFOREACHDEF(cx)) {
103	DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
104	return i;
105	}
106	}
107	}
108	return i;
109	}
110
111	static OP *
112	pp_leavetake (pTHX)
113	{
114	dSP;
115	I32 cxix;
116	register PERL_CONTEXT *cx;
117	I32 gimme;
118	SV **newsp;
119	PMOP *newpm;
120
121	cxix = S_dopoptogather(aTHX_ cxstack_ix);
122	if (cxix < 0)
123	/* diag_listed_as: Can't "when" outside a topicalizer */
124	DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
125	PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
126
127	POPBLOCK(cx,newpm);
128	assert(CxTYPE(cx) == CXt_KOOH);
129
130	LEAVE;
131
132	if (cxix < cxstack_ix)
133	dounwind(cxix);
134
135	cx = &cxstack[cxix];
136
137	RETURNOP(cx->blk_givwhen.leave_op);
138	}
139
140	static OP *
141	myparse_args_take (pTHX_ GV namegv, SV args, U32 *flagsp)
142	{
143	OP condop, blkop, *leaveop;
144	LOGOP *enterop;
145	SV *predicate_cv_ref;
146	int blk_floor;
147	bool topicalise;
148
149	PERL_UNUSED_ARG(namegv);
150	PERL_UNUSED_ARG(flagsp);
151
152	demand_unichar('(', 0);
153	condop = parse_fullexpr(0);
154	demand_unichar(')', 0);
155
156	demand_unichar('{', DEMAND_NOCONSUME);
157	blk_floor = Perl_block_start(aTHX_ 1);
158	blkop = parse_block(0);
159	blkop = Perl_block_end(aTHX_ blk_floor, blkop);
160
161	NewOp(1101, enterop, 1, LOGOP);
162	enterop->op_type = OP_ENTERWHEN;
163	enterop->op_ppaddr = pp_entertake;
164	enterop->op_flags = OPf_KIDS;
165	enterop->op_targ = -1;
166	enterop->op_private = 0;
167
168	leaveop = newUNOP(OP_LEAVEWHEN, 0, (OP *)enterop);
169	leaveop->op_ppaddr = pp_leavetake;
170
171	topicalise = SvTRUE(av_fetch((AV )SvRV(args), 0, 0));
172	if (topicalise) {
173	OP *pvarop;
174
175	pvarop = newOP(OP_PADSV, 0);
176	pvarop->op_targ = pad_findmy("$Gather::Once::current_topic",
177	sizeof("$Gather::Once::current_topic")-1, 0);
178
179	if (pvarop->op_targ == NOT_IN_PAD)
180	croak("outside topicaliser"); /* FIXME */
181
182	condop = op_append_elem(OP_LIST, condop, pvarop);
183	}
184
185	predicate_cv_ref = av_fetch((AV )SvRV(args), 1, 0);
186	condop = newUNOP(OP_ENTERSUB, OPf_STACKED,
187	op_append_elem(OP_LIST, condop,
188	newCVREF(0, newSVOP(OP_CONST, 0,
189	predicate_cv_ref))));
190
191	enterop->op_first = condop;
192	enterop->op_first->op_sibling = op_scope(blkop);
193	leaveop->op_next = LINKLIST(enterop->op_first);
194	enterop->op_first->op_next = (OP *)enterop;
195
196	enterop->op_next = LINKLIST(enterop->op_first->op_sibling);
197	enterop->op_first->op_sibling->op_next = enterop->op_other = leaveop;
198
199	return leaveop;
200	}
201
202	static OP *
203	pp_entergather (pTHX)
204	{
205	dSP; dTARGET;
206	register PERL_CONTEXT *cx;
207	const I32 gimme = GIMME_V;
208
209	ENTER;
210	if (PL_op->op_targ != NOT_IN_PAD)
211	sv_setsv(TARG, POPs);
212
213	PUSHBLOCK(cx, CXt_MOO, SP);
214	cx->blk_givwhen.leave_op = cLOGOP->op_other;
215
216	RETURN;
217	}
218
219	static OP *
220	pp_leavegather (pTHX)
221	{
222	dSP;
223	register PERL_CONTEXT *cx;
224	I32 gimme;
225	SV **newsp;
226	PMOP *newpm;
227
228	POPBLOCK(cx,newpm);
229	assert(CxTYPE(cx) == CXt_MOO);
230
231	//SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP\|SVs_TEMP);
232	//PL_curpm = newpm; /* Don't pop $1 et al till now */
233
234	LEAVE;
235	RETURN;
236	}
237
238	static OP *
239	myparse_args_gather (pTHX_ GV namegv, SV topicalise, U32 *flagsp)
240	{
241	OP topicaliser, blkop, *initop = NULL;
242	int blk_floor;
243
244	PERL_UNUSED_ARG(namegv);
245	PERL_UNUSED_ARG(flagsp);
246
247	if (SvTRUE(topicalise)) {
248	demand_unichar('(', 0);
249	topicaliser = parse_fullexpr(0);
250	demand_unichar(')', 0);
251	}
252
253	demand_unichar('{', DEMAND_NOCONSUME);
254	blk_floor = Perl_block_start(aTHX_ 1);
255	if (SvTRUE(topicalise)) {
256	initop = newOP(OP_PADSV, (OPpLVAL_INTRO<<8));
257	initop->op_targ = pad_add_my_scalar_pvn("$Gather::Once::current_topic",
258	sizeof("$Gather::Once::current_topic")-1);
259	}
260
261	blkop = parse_block(0);
262	if (initop)
263	blkop = op_prepend_elem(OP_LINESEQ, initop, blkop);
264
265	blkop = Perl_block_end(aTHX_ blk_floor, blkop);
266
267	LOGOP *enterop;
268	NewOp(1101, enterop, 1, LOGOP);
269	enterop->op_type = OP_ENTERGIVEN;
270	enterop->op_ppaddr = pp_entergather;
271	enterop->op_flags = OPf_KIDS;
272	enterop->op_targ = SvTRUE(topicalise) ? initop->op_targ : NOT_IN_PAD;
273	enterop->op_private = 0;
274
275	OP *leaveop;
276	leaveop = newUNOP(OP_LEAVEGIVEN, 0, (OP *)enterop);
277	leaveop->op_ppaddr = pp_leavegather;
278
279	enterop->op_first = SvTRUE(topicalise) ? topicaliser : newOP(OP_NULL, 0);
280	enterop->op_first->op_sibling = op_scope(blkop);
281	leaveop->op_next = LINKLIST(enterop->op_first);
282	enterop->op_first->op_next = (OP *)enterop;
283
284	enterop->op_next = LINKLIST(enterop->op_first->op_sibling);
285	enterop->op_first->op_sibling->op_next = enterop->op_other = leaveop;
286
287	return leaveop;
288	}
289
290	static OP *
291	myck_gathertake (pTHX_ OP entersubop, GV namegv, SV *ckobj)
292	{
293	OP rv2cvop, pushop, *blkop;
294
295	PERL_UNUSED_ARG(namegv);
296	PERL_UNUSED_ARG(ckobj);
297
298	pushop = cUNOPx(entersubop)->op_first;
299	if (!pushop->op_sibling)
300	pushop = cUNOPx(pushop)->op_first;
301
302	blkop = pushop->op_sibling;
303
304	rv2cvop = blkop->op_sibling;
305	blkop->op_sibling = NULL;
306	pushop->op_sibling = rv2cvop;
307	op_free(entersubop);
308
309	return blkop;
310	}
311
312	MODULE = Gather::Once PACKAGE = Gather::Once
313
314	void
315	setup_gather_hook (CV gather_cv, SV topicalise)
316	CODE:
317	cv_set_call_parser(gather_cv, myparse_args_gather, topicalise);
318	cv_set_call_checker(gather_cv, myck_gathertake, &PL_sv_undef);
319
320	void
321	setup_take_hook (CV take_cv, SV args)
322	CODE:
323	cv_set_call_parser(take_cv, myparse_args_take, args);
324	cv_set_call_checker(take_cv, myck_gathertake, &PL_sv_undef);