File Coverage

Declare.xs
Criterion Covered Total %
statement 50 50 100.0
branch 23 28 82.1
condition n/a
subroutine n/a
pod n/a
total 73 78 93.5


line stmt bran cond sub pod time code
1             #include "EXTERN.h"
2             #include "perl.h"
3             #include "XSUB.h"
4             #include "ppport.h" /* backports OpSIBLING / pad_add_name_pvn etc. to 5.14-5.20 */
5              
6             /* pad_add_name_pvn was a 5.15.1 rename of pad_add_name; the 5.14 function has
7             * the identical (name, len, flags, typestash, ourstash) signature. */
8             #if PERL_VERSION < 16
9             # define pad_add_name_pvn(name, len, flags, typestash, ourstash) \
10             Perl_pad_add_name(aTHX_ (name), (len), (flags), (typestash), (ourstash))
11             #endif
12              
13             /* Previous keyword plugin in the chain. */
14             static int (*dd_next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
15              
16             /* The destructuring pattern engine (parser, codegen, custom ops). Canonical
17             * source for this dist and, via ExtUtils::Depends, for consumers. */
18             #include "destructure.h"
19              
20             /* True if the Destructure::Declare lexical pragma is in scope here. */
21 65           static int dd_in_scope(pTHX) {
22 65           HV *hints = GvHV(PL_hintgv);
23             SV **ent;
24 65 50         if (!hints) return 0;
25 65           ent = hv_fetchs(hints, "Destructure::Declare", 0);
26 65 100         return ent && SvTRUE(*ent);
    50          
27             }
28              
29             /* ---- the keyword entry point ----------------------------------------------- */
30              
31 64           static OP *dd_parse_let(pTHX) {
32             dd_pat pat;
33             OP *rhs, *seq, *store, *lhs;
34             PADOFFSET src;
35             I32 c;
36              
37 64           lex_read_space(0);
38 64           dd_parse_pattern(aTHX_ &pat);
39              
40 59           lex_read_space(0);
41 59           c = lex_peek_unichar(0);
42 59 100         if (c != '=' || PL_parser->bufptr[1] == '>')
    50          
43 1           croak("let: expected '=' after pattern");
44 58           lex_read_unichar(0);
45 58           lex_read_space(0);
46              
47 58           rhs = parse_fullexpr(0);
48              
49             /* consume the terminating ';' */
50 58           lex_read_space(0);
51 58 50         if (lex_peek_unichar(0) == ';') lex_read_unichar(0);
52              
53             /* Fast path: a flat array/list pattern is a single native list-assignment.
54             * A bare constant array source (let [$x] = "str") is excluded: @{CONST}
55             * constant-folds to a symbolic deref that dies at compile time under strict;
56             * it falls through to the per-element path, which gives the usual runtime
57             * "Can't use string as an ARRAY reference" instead. (DD_LIST has no deref.) */
58 58 100         if (dd_is_listassign(&pat)
59 32 100         && !(pat.shape == DD_ARRAY && rhs->op_type == OP_CONST)) {
    50          
60 32           OP *llist = dd_listassign_lhs(aTHX_ &pat);
61             OP *rv;
62 32 100         if (pat.shape == DD_LIST) {
63 6           rv = rhs; /* my (LHS) = LIST */
64             } else {
65             /* my (LHS) = @{ SRC // [] }; the // [] keeps an undef source
66             * yielding empties (no warning), matching the per-element path. */
67 26           rv = newUNOP(OP_RV2AV, 0,
68             newLOGOP(OP_DOR, 0, rhs, dd_empty_aref(aTHX)));
69             }
70 32           dd_free_pat(aTHX_ &pat);
71 32           return newSTATEOP(0, NULL,
72             newASSIGNOP(OPf_STACKED, llist, 0, rv));
73             }
74              
75             /* A ( ... ) pattern destructures a *list*: evaluate the RHS in list
76             * context and capture it into an anonymous arrayref, then reuse the exact
77             * positional codegen as for an [ ... ] arrayref pattern. */
78 26 100         if (pat.shape == DD_LIST)
79 2           rhs = op_convert_list(OP_ANONLIST, OPf_SPECIAL, rhs); /* [ LIST ] */
80              
81             /* my $src = RHS; (the once-only source ref) */
82 26           src = dd_temp(aTHX);
83 26           lhs = dd_padsv(aTHX_ src);
84 26           lhs->op_private |= OPpLVAL_INTRO;
85 26           store = newSTATEOP(0, NULL, newASSIGNOP(OPf_STACKED, lhs, 0, rhs));
86              
87 26           seq = store;
88 26           dd_emit(aTHX_ &pat, src, &seq);
89              
90 26           dd_free_pat(aTHX_ &pat);
91              
92             /* No op_scope: the introduced lexicals must remain visible in the
93             * enclosing block, exactly like `my`. */
94 26           return seq;
95             }
96              
97 64756           static int dd_keyword_plugin(pTHX_ char *kw, STRLEN kwlen, OP **op_ptr) {
98 64756 100         if (kwlen == 3 && memEQ(kw, "let", 3) && dd_in_scope(aTHX)) {
    100          
    100          
99 64           *op_ptr = dd_parse_let(aTHX);
100 58           return KEYWORD_PLUGIN_STMT;
101             }
102 64692           return dd_next_keyword_plugin(aTHX_ kw, kwlen, op_ptr);
103             }
104              
105             MODULE = Destructure::Declare PACKAGE = Destructure::Declare
106             PROTOTYPES: DISABLE
107              
108             BOOT:
109 13           dd_next_keyword_plugin = PL_keyword_plugin;
110 13           PL_keyword_plugin = dd_keyword_plugin;
111 13           XopENTRY_set(&dd_tail_xop, xop_name, "dd_tail");
112 13           XopENTRY_set(&dd_tail_xop, xop_desc, "Destructure::Declare slurpy tail");
113 13           XopENTRY_set(&dd_tail_xop, xop_class, OA_BINOP);
114 13           Perl_custom_op_register(aTHX_ dd_pp_tail, &dd_tail_xop);
115 13           XopENTRY_set(&dd_hrest_xop, xop_name, "dd_hrest");
116 13           XopENTRY_set(&dd_hrest_xop, xop_desc, "Destructure::Declare hash %rest");
117 13           XopENTRY_set(&dd_hrest_xop, xop_class, OA_LISTOP);
118 13           Perl_custom_op_register(aTHX_ dd_pp_hrest, &dd_hrest_xop);