← Back to branch summary

~ubuntu-branches/ubuntu/natty/libsignatures-perl/natty

« back to all changes in this revision

Viewing changes to signatures.xs

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur
  • Date: 2009-05-18 20:34:44 UTC
  • Revision ID: james.westby@ubuntu.com-20090518203444-ee3iqibpk6uxo7u8
Tags: upstream-0.05
Import upstream version 0.05

Show diffs side-by-side

added added

removed removed

Lines of Context:
signatures.xs
 
1
#include "EXTERN.h"
 
2
#include "perl.h"
 
3
#include "XSUB.h"
 
4
 
 
5
#define NEED_PL_parser
 
6
#include "ppport.h"
 
7
 
 
8
/* this should go into ppport */
 
9
#if PERL_BCDVERSION >= 0x5009005
 
10
#define PL_oldbufptr D_PPP_my_PL_parser_var(oldbufptr)
 
11
#endif
 
12
 
 
13
#if PERL_REVISION == 5 && PERL_VERSION >= 10
 
14
#define HAS_HINTS_HASH
 
15
#endif
 
16
 
 
17
#include "hook_op_check.h"
 
18
#include "hook_op_ppaddr.h"
 
19
#include "hook_parser.h"
 
20
 
 
21
typedef struct userdata_St {
 
22
        char *f_class;
 
23
        SV *class;
 
24
        hook_op_check_id eval_hook;
 
25
        hook_op_check_id parser_id;
 
26
} userdata_t;
 
27
 
 
28
STATIC void
 
29
call_to_perl (SV *class, UV offset, char *proto) {
 
30
        dSP;
 
31
 
 
32
        ENTER;
 
33
        SAVETMPS;
 
34
 
 
35
        PUSHMARK (SP);
 
36
        EXTEND (SP, 3);
 
37
        PUSHs (class);
 
38
        mPUSHu (offset);
 
39
        mPUSHp (proto, strlen (proto));
 
40
        PUTBACK;
 
41
 
 
42
        call_method ("callback", G_VOID|G_DISCARD);
 
43
 
 
44
        FREETMPS;
 
45
        LEAVE;
 
46
}
 
47
 
 
48
STATIC SV *
 
49
qualify_func_name (const char *s) {
 
50
        SV *ret = newSVpvs ("");
 
51
 
 
52
        if (strstr (s, ":") == NULL) {
 
53
                sv_catpv (ret, SvPVX (PL_curstname));
 
54
                sv_catpvs (ret, "::");
 
55
        }
 
56
 
 
57
        sv_catpv (ret, s);
 
58
 
 
59
        return ret;
 
60
}
 
61
 
 
62
STATIC int
 
63
enabled (SV *class) {
 
64
        STRLEN len;
 
65
        char *key;
 
66
        HV *hints = GvHV (PL_hintgv);
 
67
        SV **sv, *tmp = newSVsv (class);
 
68
 
 
69
        sv_catpv (tmp, "::enabled");
 
70
        key = SvPV (tmp, len);
 
71
 
 
72
        if (!hints) {
 
73
                return 0;
 
74
        }
 
75
 
 
76
        sv = hv_fetch (hints, key, len, 0);
 
77
        SvREFCNT_dec (tmp);
 
78
 
 
79
        if (!sv || !*sv) {
 
80
                return 0;
 
81
        }
 
82
 
 
83
        return SvOK (*sv);
 
84
}
 
85
 
 
86
STATIC OP *
 
87
handle_proto (pTHX_ OP *op, void *user_data) {
 
88
        OP *ret;
 
89
        SV *op_sv, *name;
 
90
        char *s, *tmp, *tmp2;
 
91
        char tmpbuf[sizeof (PL_tokenbuf)], proto[sizeof (PL_tokenbuf)];
 
92
        STRLEN retlen = 0;
 
93
        userdata_t *ud = (userdata_t *)user_data;
 
94
 
 
95
        if (strNE (ud->f_class, SvPVX (PL_curstname))) {
 
96
                return op;
 
97
        }
 
98
 
 
99
        if (!enabled (ud->class)) {
 
100
                return op;
 
101
        }
 
102
 
 
103
        if (!PL_parser) {
 
104
                return op;
 
105
        }
 
106
 
 
107
        if (!PL_lex_stuff) {
 
108
                return op;
 
109
        }
 
110
 
 
111
        op_sv = cSVOPx (op)->op_sv;
 
112
 
 
113
        if (!SvPOK (op_sv)) {
 
114
                return op;
 
115
        }
 
116
 
 
117
        /* sub $name */
 
118
        s = PL_oldbufptr;
 
119
        s = hook_toke_skipspace (aTHX_ s);
 
120
 
 
121
        if (strnNE (s, "sub", 3)) {
 
122
                return op;
 
123
        }
 
124
 
 
125
        if (!isSPACE (s[3])) {
 
126
                return op;
 
127
        }
 
128
 
 
129
        s = hook_toke_skipspace (aTHX_ s + 4);
 
130
 
 
131
        if (strNE (SvPVX (PL_subname), "?")) {
 
132
                (void)hook_toke_scan_word (aTHX_ (s - SvPVX (PL_linestr)), 1, tmpbuf, sizeof (tmpbuf), &retlen);
 
133
 
 
134
                if (retlen < 1) {
 
135
                        return op;
 
136
                }
 
137
 
 
138
                name = qualify_func_name (tmpbuf);
 
139
 
 
140
                if (!sv_eq (PL_subname, name)) {
 
141
                        SvREFCNT_dec (name);
 
142
                        return op;
 
143
                }
 
144
 
 
145
                SvREFCNT_dec (name);
 
146
        }
 
147
 
 
148
        /* ($proto) */
 
149
        s = hook_toke_skipspace (aTHX_ s + retlen);
 
150
        if (s[0] != '(') {
 
151
                return op;
 
152
        }
 
153
 
 
154
        tmp = hook_toke_scan_str (aTHX_ s);
 
155
        tmp2 = hook_parser_get_lex_stuff (aTHX);
 
156
        hook_parser_clear_lex_stuff (aTHX);
 
157
 
 
158
        if (s == tmp || !tmp2) {
 
159
                return op;
 
160
        }
 
161
 
 
162
        strncpy (proto, s + 1, tmp - s - 2);
 
163
        proto[tmp - s - 2] = '\0';
 
164
 
 
165
        s++;
 
166
 
 
167
        while (tmp > s + 1) {
 
168
                if (isSPACE (s[0])) {
 
169
                        s++;
 
170
                        continue;
 
171
                }
 
172
 
 
173
                if (*tmp2 != *s) {
 
174
                        return op;
 
175
                }
 
176
 
 
177
                tmp2++;
 
178
                s++;
 
179
        }
 
180
 
 
181
        ret = NULL;
 
182
 
 
183
        s = hook_toke_skipspace (aTHX_ s + 1);
 
184
        if (s[0] == ':') {
 
185
                s++;
 
186
                while (s[0] != '{') {
 
187
                        char *attr_start;
 
188
                        s = hook_toke_skipspace (aTHX_ s);
 
189
                        attr_start = s;
 
190
                        (void)hook_toke_scan_word (aTHX_ (s - SvPVX (PL_linestr)), 0, tmpbuf, sizeof (tmpbuf), &retlen);
 
191
 
 
192
                        if (retlen < 1) {
 
193
                                return op;
 
194
                        }
 
195
 
 
196
                        s += retlen;
 
197
                        if (s[0] == '(') {
 
198
                                tmp = hook_toke_scan_str (aTHX_ s);
 
199
                                tmp2 = hook_parser_get_lex_stuff (aTHX);
 
200
                                hook_parser_clear_lex_stuff (aTHX);
 
201
 
 
202
                                if (s == tmp) {
 
203
                                        return op;
 
204
                                }
 
205
 
 
206
                                s += strlen (tmp2);
 
207
 
 
208
                                if (strEQ (tmpbuf, "proto")) {
 
209
                                        while (attr_start < tmp) {
 
210
                                                *attr_start = ' ';
 
211
                                                attr_start++;
 
212
                                        }
 
213
 
 
214
                                        ret = op;
 
215
                                        sv_setpv (op_sv, tmp2);
 
216
                                }
 
217
                        }
 
218
                        else if (strEQ (tmpbuf, "proto")) {
 
219
                                croak ("proto attribute requires argument");
 
220
                        }
 
221
 
 
222
                        s = hook_toke_skipspace (aTHX_ s);
 
223
 
 
224
            if (s[0] == ':') {
 
225
                s++;
 
226
            }
 
227
                }
 
228
        }
 
229
 
 
230
        if (s[0] != '{') {
 
231
                /* croak as we already messed with op when :proto is given? */
 
232
                return op;
 
233
        }
 
234
 
 
235
        call_to_perl (ud->class, s - hook_parser_get_linestr (aTHX), proto);
 
236
 
 
237
        if (!ret) {
 
238
                op_free (op);
 
239
        }
 
240
 
 
241
        return ret;
 
242
}
 
243
 
 
244
STATIC OP *
 
245
before_eval (pTHX_ OP *op, void *user_data) {
 
246
        dSP;
 
247
        SV *sv, **stack;
 
248
        SV *class = (SV *)user_data;
 
249
 
 
250
#ifdef HAS_HINTS_HASH
 
251
        if (PL_op->op_private & OPpEVAL_HAS_HH) {
 
252
                stack = &SP[-1];
 
253
        }
 
254
        else {
 
255
                stack = &SP[0];
 
256
        }
 
257
#else
 
258
        stack = &SP[0];
 
259
#endif
 
260
 
 
261
        sv = *stack;
 
262
 
 
263
        if (SvPOK (sv)) {
 
264
                /* FIXME: this leaks the new scalar */
 
265
                SV *new = newSVpvs ("use ");
 
266
                sv_catsv (new, class);
 
267
                sv_catpvs (new, ";");
 
268
                sv_catsv (new, sv);
 
269
                *stack = new;
 
270
        }
 
271
 
 
272
        return op;
 
273
}
 
274
 
 
275
STATIC OP *
 
276
handle_eval (pTHX_ OP *op, void *user_data) {
 
277
        userdata_t *ud = (userdata_t *)user_data;
 
278
 
 
279
        if (enabled (ud->class)) {
 
280
                hook_op_ppaddr_around (op, before_eval, NULL, newSVsv (ud->class));
 
281
        }
 
282
 
 
283
        return op;
 
284
}
 
285
 
 
286
MODULE = signatures  PACKAGE = signatures
 
287
 
 
288
PROTOTYPES: DISABLE
 
289
 
 
290
UV
 
291
setup (class, f_class)
 
292
                SV *class
 
293
                char *f_class
 
294
        PREINIT:
 
295
                userdata_t *ud;
 
296
        INIT:
 
297
                Newx (ud, 1, userdata_t);
 
298
                ud->class = newSVsv (class);
 
299
                ud->f_class = f_class;
 
300
        CODE:
 
301
                ud->parser_id = hook_parser_setup ();
 
302
                ud->eval_hook = hook_op_check (OP_ENTEREVAL, handle_eval, ud);
 
303
                RETVAL = (UV)hook_op_check (OP_CONST, handle_proto, ud);
 
304
        OUTPUT:
 
305
                RETVAL
 
306
 
 
307
void
 
308
teardown (class, id)
 
309
                UV id
 
310
        PREINIT:
 
311
                userdata_t *ud;
 
312
        CODE:
 
313
                ud = (userdata_t *)hook_op_check_remove (OP_CONST, id);
 
314
 
 
315
                if (ud) {
 
316
                        hook_op_check_remove (OP_ENTEREVAL, ud->eval_hook);
 
317
                        hook_parser_teardown (ud->parser_id);
 
318
                        SvREFCNT_dec (ud->class);
 
319
                        Safefree (ud);
 
320
                }