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 static OP *
  62 pp_stub_marker (pTHX)
  63 {
  64   croak("FAIL");
  65 }
  66
  67 static OP *
  68 myparse_args_take (pTHX_ GV *namegv, SV *args, U32 *flagsp)
  69 {
  70   OP *condop, *blkop, *leaveop;
  71   LOGOP *enterop;
  72   SV *predicate_cv_ref;
  73   int blk_floor;
  74   bool topicalise;
  75
  76   PERL_UNUSED_ARG(namegv);
  77   PERL_UNUSED_ARG(flagsp);
  78
  79   demand_unichar('(', 0);
  80   condop = parse_fullexpr(0);
  81   demand_unichar(')', 0);
  82
  83   demand_unichar('{', DEMAND_NOCONSUME);
  84   blk_floor = Perl_block_start(aTHX_ 1);
  85   blkop = parse_block(0);
  86   blkop = Perl_block_end(aTHX_ blk_floor, blkop);
  87
  88   topicalise = SvTRUE(*av_fetch((AV *)SvRV(args), 0, 0));
  89   if (topicalise) {
  90     OP *pvarop;
  91
  92     pvarop = newOP(OP_PADSV, 0);
  93     pvarop->op_targ = pad_findmy_pvs("$Gather::Once::current_topic", 0);
  94
  95     if (pvarop->op_targ == NOT_IN_PAD)
  96       croak("outside topicaliser"); /* FIXME */
  97
  98     condop = op_append_elem(OP_LIST, condop, pvarop);
  99   }
 100
 101   predicate_cv_ref = *av_fetch((AV *)SvRV(args), 1, 0);
 102   condop = newUNOP(OP_ENTERSUB, OPf_STACKED,
 103                    op_append_elem(OP_LIST, condop,
 104                                   newCVREF(0, newSVOP(OP_CONST, 0,
 105                                                       SvREFCNT_inc(predicate_cv_ref)))));
 106
 107   OP *stub = newSTATEOP(0, NULL, newOP(OP_NULL, 0));
 108   condop = newCONDOP(0, condop, blkop, stub);
 109   condop->op_ppaddr = pp_stub_marker;
 110
 111   return condop;
 112 }
 113
 114 static OP *
 115 is_take_stmt (pTHX_ OP *stmt)
 116 {
 117   if (stmt->op_type != OP_LINESEQ
 118       || !cLISTOPx(stmt)->op_last
 119       || cLISTOPx(stmt)->op_last->op_type == OP_COND_EXPR)
 120     return NULL;
 121
 122   OP *nullop = cLISTOPx(stmt)->op_last;
 123   if (nullop->op_type != OP_NULL
 124       || !(nullop->op_flags & OPf_KIDS)
 125       || !cLISTOPx(nullop)->op_first
 126       || nullop->op_ppaddr != pp_stub_marker)
 127     return NULL;
 128
 129   OP *condop = cLISTOPx(nullop)->op_first;
 130   if (condop->op_type != OP_COND_EXPR || !(condop->op_flags & OPf_KIDS))
 131     return NULL;
 132
 133   return condop;
 134   OP *stub = condop->op_next; /* falseop */
 135
 136   return stub;
 137 }
 138
 139 static OP *
 140 myparse_args_gather (pTHX_ GV *namegv, SV *topicalise, U32 *flagsp)
 141 {
 142   OP *topicaliser, *topblkop, *curblkop, *initop, *assignop;
 143   int blk_floor;
 144
 145   PERL_UNUSED_ARG(namegv);
 146   PERL_UNUSED_ARG(flagsp);
 147
 148   if (SvTRUE(topicalise)) {
 149     demand_unichar('(', 0);
 150     topicaliser = parse_fullexpr(0);
 151     demand_unichar(')', 0);
 152   }
 153
 154   demand_unichar('{', 0);
 155   blk_floor = Perl_block_start(aTHX_ 1);
 156
 157   if (SvTRUE(topicalise)) {
 158     initop = newOP(OP_PADSV, (OPpLVAL_INTRO<<8));
 159     initop->op_targ = pad_add_my_scalar_pvn("$Gather::Once::current_topic",
 160                                             sizeof("$Gather::Once::current_topic")-1);
 161
 162     assignop = newASSIGNOP(0, initop, 0, topicaliser);
 163   }
 164
 165   topblkop = curblkop = parse_fullstmt(0);
 166   lex_read_space(0);
 167   while (lex_peek_unichar(0) != '}') {
 168     OP *stub, *stmt = parse_fullstmt(0);
 169
 170     curblkop = op_append_elem(OP_LINESEQ, curblkop, stmt);
 171
 172     if ((stub = is_take_stmt(aTHX_ stmt))) {
 173       curblkop = stub->op_next;
 174     }
 175
 176     //op_dump(curblkop);
 177     lex_read_space(0);
 178   }
 179
 180   demand_unichar('}', DEMAND_IMMEDIATE);
 181
 182   if (SvTRUE(topicalise))
 183     topblkop = op_prepend_elem(OP_LINESEQ, assignop, topblkop);
 184
 185   topblkop = op_scope(Perl_block_end(aTHX_ blk_floor, topblkop));
 186
 187   //return newGIVENOP(SvTRUE(topicalise) ? topicaliser : newOP(OP_NULL, 0),
 188   //blkop, initop->op_targ);
 189
 190   return topblkop;
 191 }
 192
 193 static OP *
 194 myck_gathertake (pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 195 {
 196   OP *rv2cvop, *pushop, *blkop;
 197
 198   PERL_UNUSED_ARG(namegv);
 199   PERL_UNUSED_ARG(ckobj);
 200
 201   pushop = cUNOPx(entersubop)->op_first;
 202   if (!pushop->op_sibling)
 203     pushop = cUNOPx(pushop)->op_first;
 204
 205   blkop = pushop->op_sibling;
 206
 207   rv2cvop = blkop->op_sibling;
 208   blkop->op_sibling = NULL;
 209   pushop->op_sibling = rv2cvop;
 210   op_free(entersubop);
 211
 212   return blkop;
 213 }
 214
 215 MODULE = Gather::Once  PACKAGE = Gather::Once
 216
 217 void
 218 setup_gather_hook (CV *gather_cv, SV *topicalise)
 219   CODE:
 220     cv_set_call_parser(gather_cv, myparse_args_gather, topicalise);
 221     cv_set_call_checker(gather_cv, myck_gathertake, &PL_sv_undef);
 222
 223 void
 224 setup_take_hook (CV *take_cv, SV *args)
 225   CODE:
 226     cv_set_call_parser(take_cv, myparse_args_take, args);
 227     cv_set_call_checker(take_cv, myck_gathertake, &PL_sv_undef);