1/* vi: set ft=c : */
2
3#ifndef parse_subsignature
4
5#define PERL_EXT
6#include "feature.h"
7
8#include "make_argcheck_aux.c.inc"
9
10/*
11 * Need to grab some things that aren't quite core perl API
12 */
13
14/* yyerror() is a long function and hard to emulate or copy-paste for our
15 * purposes; we'll reïmplement a smaller version of it
16 */
17
18#define LEX_IGNORE_UTF8_HINTS   0x00000002
19
20#define PL_linestr (PL_parser->linestr)
21
22#ifdef USE_UTF8_SCRIPTS
23#   define UTF cBOOL(!IN_BYTES)
24#else
25#   define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
26#endif
27
28#define yyerror(s)  S_yyerror(aTHX_ s)
29void S_yyerror(pTHX_ const char *s)
30{
31  SV *message = sv_2mortal(newSVpvs_flags("", 0));
32
33  char *context = PL_parser->oldbufptr;
34  STRLEN contlen = PL_parser->bufptr - PL_parser->oldbufptr;
35
36  sv_catpvf(message, "%s at %s line %" IVdf,
37      s, OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
38
39  if(context)
40    sv_catpvf(message, ", near \"%" UTF8f "\"",
41        UTF8fARG(UTF, contlen, context));
42
43  sv_catpvf(message, "\n");
44
45  PL_parser->error_count++;
46  warn_sv(message);
47}
48
49/* Stolen from op.c */
50#define OpTYPE_set(op, type)         \
51  STMT_START {                       \
52    op->op_type   = (OPCODE)type;    \
53    op->op_ppaddr = PL_ppaddr[type]; \
54  } STMT_END
55
56#define alloc_LOGOP(a,b,c)  S_alloc_LOGOP(aTHX_ a,b,c)
57static LOGOP *S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
58{
59  dVAR;
60  LOGOP *logop;
61  OP *kid = first;
62  NewOp(1101, logop, 1, LOGOP);
63  OpTYPE_set(logop, type);
64  logop->op_first = first;
65  logop->op_other = other;
66  if (first)
67    logop->op_flags = OPf_KIDS;
68  while (kid && OpHAS_SIBLING(kid))
69    kid = OpSIBLING(kid);
70  if (kid)
71    OpLASTSIB_set(kid, (OP*)logop);
72  return logop;
73}
74
75#define parse_sigelem()  S_parse_sigelem(aTHX)
76static OP *S_parse_sigelem(pTHX)
77{
78  yy_parser *parser = PL_parser;
79
80  int c = lex_peek_unichar(0);
81  int flags;
82
83  switch(c) {
84    case '$': flags = OPpARGELEM_SV; break;
85    case '@': flags = OPpARGELEM_AV; break;
86    case '%': flags = OPpARGELEM_HV; break;
87    default:
88      croak("Expected a signature element at <%s>\n", parser->bufptr);
89  }
90
91  char *lexname = parser->bufptr;
92  OP *varop = NULL;
93
94  /* Consume sigil */
95  lex_read_unichar(0);
96
97  if(isIDFIRST_uni(lex_peek_unichar(0))) {
98    lex_read_unichar(0);
99    while(isALNUM_uni(lex_peek_unichar(0)))
100      lex_read_unichar(0);
101
102    varop = newUNOP_AUX(OP_ARGELEM, 0, NULL, INT2PTR(UNOP_AUX_item *, (parser->sig_elems)));
103    varop->op_private |= flags;
104
105    varop->op_targ = pad_add_name_pvn(lexname, PL_parser->bufptr - lexname, 0, NULL, NULL);
106
107    lex_read_space(0);
108  }
109
110  if(c == '$') {
111    if(parser->sig_slurpy)
112      yyerror("Slurpy parameters not last");
113
114    parser->sig_elems++;
115
116    if(lex_peek_unichar(0) == '=') {
117      lex_read_unichar(0);
118      lex_read_space(0);
119
120      parser->sig_optelems++;
121
122      OP *defexpr = parse_termexpr(0);
123
124      OP *defop = (OP *)alloc_LOGOP(OP_ARGDEFELEM, defexpr, LINKLIST(defexpr));
125      defop->op_targ = (PADOFFSET)(parser->sig_elems - 1);
126
127      varop->op_flags |= OPf_STACKED;
128      op_sibling_splice(varop, NULL, 0, defop);
129      defop = op_contextualize(defop, G_SCALAR);
130
131      LINKLIST(varop);
132
133      varop->op_next = defop;
134      defexpr->op_next = varop;
135    }
136    else {
137      if(parser->sig_optelems)
138        yyerror("Mandatory parameter follows optional parameter");
139    }
140  }
141  else {
142    if(parser->sig_slurpy)
143      yyerror("Multiple slurpy parameters not allowed");
144
145    parser->sig_slurpy = c;
146
147    if(lex_peek_unichar(0) == '=')
148      yyerror("A slurpy parameter may not have a default value");
149  }
150
151  return varop ? newSTATEOP(0, NULL, varop) : NULL;
152}
153
154#define parse_subsignature(flags)  S_parse_subsignature(aTHX_ flags)
155static OP *S_parse_subsignature(pTHX_ int flags)
156{
157  /* Mostly reconstructed logic from perl 5.28.0's toke.c and perly.y
158   */
159  yy_parser *parser = PL_parser;
160
161  ENTER;
162  SAVEIV(parser->sig_elems);
163  SAVEIV(parser->sig_optelems);
164  SAVEI8(parser->sig_slurpy);
165
166  parser->sig_elems = 0;
167  parser->sig_optelems = 0;
168  parser->sig_slurpy = 0;
169
170  OP *elems = NULL;
171  while(lex_peek_unichar(0) != ')') {
172    lex_read_space(0);
173    OP *elem = parse_sigelem();
174    elems = op_append_list(OP_LINESEQ, elems, elem);
175
176    if(PL_parser->error_count) {
177      LEAVE;
178      return NULL;
179    }
180
181    lex_read_space(0);
182    switch(lex_peek_unichar(0)) {
183      case ')': goto endofelems;
184      case ',': break;
185      default:
186        fprintf(stderr, "ARGH unsure how to proceed parse_subsignature at <%s>\n",
187            parser->bufptr);
188        croak("ARGH");
189        break;
190    }
191
192    lex_read_unichar(0);
193    lex_read_space(0);
194  }
195endofelems:
196
197  if (!FEATURE_SIGNATURES_IS_ENABLED)
198    croak("Experimental subroutine signatures not enabled");
199
200  Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SIGNATURES),
201    "The signatures feature is experimental");
202
203  UNOP_AUX_item *aux = make_argcheck_aux(
204    parser->sig_elems, parser->sig_optelems, parser->sig_slurpy);
205
206  OP *checkop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux);
207
208  checkop = op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL),
209      op_prepend_elem(OP_LINESEQ, checkop, elems));
210
211  /* a nextstate at the end handles context correctly for an empty
212   * sub body */
213  checkop = op_append_elem(OP_LINESEQ, checkop, newSTATEOP(0, NULL, NULL));
214
215  LEAVE;
216
217  return checkop;
218}
219
220#endif
221