Once.xs

   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);