1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
#define PERL_NO_GET_CONTEXT 1
#include "EXTERN.h"
#include "perl.h"
#include "listquote_callparser0.h"
#include "XSUB.h"
#ifndef op_append_elem
# define op_append_elem(t, f, l) THX_op_append_elem(aTHX_ t, f, l)
static OP *THX_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
{
if(!first) return last;
if(!last) return first;
if(first->op_type != (unsigned)type ||
(type == OP_LIST && (first->op_flags & OPf_PARENS)))
return newLISTOP(type, 0, first, last);
if(first->op_flags & OPf_KIDS) {
cLISTOPx(first)->op_last->op_sibling = last;
} else {
first->op_flags |= OPf_KIDS;
cLISTOPx(first)->op_first = last;
}
cLISTOPx(first)->op_last = last;
return first;
}
#endif /* !op_append_elem */
static OP *THX_parse_args_listquote(pTHX_ GV *namegv, SV *psobj, U32 *flags_p)
{
I32 qc;
OP *argsop;
PERL_UNUSED_ARG(namegv);
argsop = newLISTOP(OP_LIST, 0,
newSVOP(OP_CONST, 0, SvREFCNT_inc(psobj)),
NULL);
lex_read_space(0);
qc = lex_read_unichar(0);
if(qc == -1) croak("unexpected EOF");
while(1) {
I32 c = lex_read_unichar(0);
char cc;
SV *csv;
if(c == -1) croak("unexpected EOF");
if(c == qc) break;
if(c > 0xff) croak("can't handle non-Latin-1 character");
cc = (char)c;
csv = newSVpvn(&cc, 1);
argsop = op_append_elem(OP_LIST,
argsop, newSVOP(OP_CONST, 0, csv));
}
if(qc == '!') *flags_p |= CALLPARSER_STATEMENT;
return argsop;
}
MODULE = t::listquote PACKAGE = t::listquote
PROTOTYPES: DISABLE
void
cv_set_call_parser_listquote(CV *cv, SV *psobj)
PROTOTYPE: $$
CODE:
cv_set_call_parser(cv, THX_parse_args_listquote, psobj);
|
