aboutsummaryrefslogtreecommitdiffstats
path: root/tools/perf/util/trace-event-perl.c
diff options
context:
space:
mode:
authorTom Zanussi <tzanussi@gmail.com>2010-01-27 03:27:55 -0500
committerFrederic Weisbecker <fweisbec@gmail.com>2010-02-23 14:49:55 -0500
commit82d156cd5e817055c63ec50247a425c195f4cb14 (patch)
treeed41a42df0ea13472acd0ce806d4070f188fa468 /tools/perf/util/trace-event-perl.c
parent7397d80ddde8eef3b1dce6c29e0c53bd322ef824 (diff)
perf/scripts: Move Perl scripting files to scripting-engines dir
Create a scripting-engines directory to contain scripting engine implementation code, in anticipation of the addition of new scripting support. Also removes trace-event-perl.h. Signed-off-by: Tom Zanussi <tzanussi@gmail.com> Cc: Ingo Molnar <mingo@elte.hu> Cc: Steven Rostedt <rostedt@goodmis.org> Cc: Keiichi KII <k-keiichi@bx.jp.nec.com> Cc: Peter Zijlstra <a.p.zijlstra@chello.nl> Cc: Paul Mackerras <paulus@samba.org> Cc: Arnaldo Carvalho de Melo <acme@redhat.com> LKML-Reference: <1264580883-15324-5-git-send-email-tzanussi@gmail.com> Signed-off-by: Frederic Weisbecker <fweisbec@gmail.com>
Diffstat (limited to 'tools/perf/util/trace-event-perl.c')
-rw-r--r--tools/perf/util/trace-event-perl.c634
1 files changed, 0 insertions, 634 deletions
diff --git a/tools/perf/util/trace-event-perl.c b/tools/perf/util/trace-event-perl.c
deleted file mode 100644
index 5b49df067df0..000000000000
--- a/tools/perf/util/trace-event-perl.c
+++ /dev/null
@@ -1,634 +0,0 @@
1/*
2 * trace-event-perl. Feed perf trace events to an embedded Perl interpreter.
3 *
4 * Copyright (C) 2009 Tom Zanussi <tzanussi@gmail.com>
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, write to the Free Software
18 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 *
20 */
21
22#include <stdio.h>
23#include <stdlib.h>
24#include <string.h>
25#include <ctype.h>
26#include <errno.h>
27
28#include "../perf.h"
29#include "util.h"
30#include "trace-event.h"
31#include "trace-event-perl.h"
32
33void xs_init(pTHX);
34
35void xs_init(pTHX)
36{
37 const char *file = __FILE__;
38 dXSUB_SYS;
39
40 newXS("Perf::Trace::Context::bootstrap", boot_Perf__Trace__Context,
41 file);
42 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
43}
44
45INTERP my_perl;
46
47#define FTRACE_MAX_EVENT \
48 ((1 << (sizeof(unsigned short) * 8)) - 1)
49
50struct event *events[FTRACE_MAX_EVENT];
51
52static struct scripting_context *scripting_context;
53
54static char *cur_field_name;
55static int zero_flag_atom;
56
57static void define_symbolic_value(const char *ev_name,
58 const char *field_name,
59 const char *field_value,
60 const char *field_str)
61{
62 unsigned long long value;
63 dSP;
64
65 value = eval_flag(field_value);
66
67 ENTER;
68 SAVETMPS;
69 PUSHMARK(SP);
70
71 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
72 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
73 XPUSHs(sv_2mortal(newSVuv(value)));
74 XPUSHs(sv_2mortal(newSVpv(field_str, 0)));
75
76 PUTBACK;
77 if (get_cv("main::define_symbolic_value", 0))
78 call_pv("main::define_symbolic_value", G_SCALAR);
79 SPAGAIN;
80 PUTBACK;
81 FREETMPS;
82 LEAVE;
83}
84
85static void define_symbolic_values(struct print_flag_sym *field,
86 const char *ev_name,
87 const char *field_name)
88{
89 define_symbolic_value(ev_name, field_name, field->value, field->str);
90 if (field->next)
91 define_symbolic_values(field->next, ev_name, field_name);
92}
93
94static void define_symbolic_field(const char *ev_name,
95 const char *field_name)
96{
97 dSP;
98
99 ENTER;
100 SAVETMPS;
101 PUSHMARK(SP);
102
103 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
104 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
105
106 PUTBACK;
107 if (get_cv("main::define_symbolic_field", 0))
108 call_pv("main::define_symbolic_field", G_SCALAR);
109 SPAGAIN;
110 PUTBACK;
111 FREETMPS;
112 LEAVE;
113}
114
115static void define_flag_value(const char *ev_name,
116 const char *field_name,
117 const char *field_value,
118 const char *field_str)
119{
120 unsigned long long value;
121 dSP;
122
123 value = eval_flag(field_value);
124
125 ENTER;
126 SAVETMPS;
127 PUSHMARK(SP);
128
129 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
130 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
131 XPUSHs(sv_2mortal(newSVuv(value)));
132 XPUSHs(sv_2mortal(newSVpv(field_str, 0)));
133
134 PUTBACK;
135 if (get_cv("main::define_flag_value", 0))
136 call_pv("main::define_flag_value", G_SCALAR);
137 SPAGAIN;
138 PUTBACK;
139 FREETMPS;
140 LEAVE;
141}
142
143static void define_flag_values(struct print_flag_sym *field,
144 const char *ev_name,
145 const char *field_name)
146{
147 define_flag_value(ev_name, field_name, field->value, field->str);
148 if (field->next)
149 define_flag_values(field->next, ev_name, field_name);
150}
151
152static void define_flag_field(const char *ev_name,
153 const char *field_name,
154 const char *delim)
155{
156 dSP;
157
158 ENTER;
159 SAVETMPS;
160 PUSHMARK(SP);
161
162 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
163 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
164 XPUSHs(sv_2mortal(newSVpv(delim, 0)));
165
166 PUTBACK;
167 if (get_cv("main::define_flag_field", 0))
168 call_pv("main::define_flag_field", G_SCALAR);
169 SPAGAIN;
170 PUTBACK;
171 FREETMPS;
172 LEAVE;
173}
174
175static void define_event_symbols(struct event *event,
176 const char *ev_name,
177 struct print_arg *args)
178{
179 switch (args->type) {
180 case PRINT_NULL:
181 break;
182 case PRINT_ATOM:
183 define_flag_value(ev_name, cur_field_name, "0",
184 args->atom.atom);
185 zero_flag_atom = 0;
186 break;
187 case PRINT_FIELD:
188 if (cur_field_name)
189 free(cur_field_name);
190 cur_field_name = strdup(args->field.name);
191 break;
192 case PRINT_FLAGS:
193 define_event_symbols(event, ev_name, args->flags.field);
194 define_flag_field(ev_name, cur_field_name, args->flags.delim);
195 define_flag_values(args->flags.flags, ev_name, cur_field_name);
196 break;
197 case PRINT_SYMBOL:
198 define_event_symbols(event, ev_name, args->symbol.field);
199 define_symbolic_field(ev_name, cur_field_name);
200 define_symbolic_values(args->symbol.symbols, ev_name,
201 cur_field_name);
202 break;
203 case PRINT_STRING:
204 break;
205 case PRINT_TYPE:
206 define_event_symbols(event, ev_name, args->typecast.item);
207 break;
208 case PRINT_OP:
209 if (strcmp(args->op.op, ":") == 0)
210 zero_flag_atom = 1;
211 define_event_symbols(event, ev_name, args->op.left);
212 define_event_symbols(event, ev_name, args->op.right);
213 break;
214 default:
215 /* we should warn... */
216 return;
217 }
218
219 if (args->next)
220 define_event_symbols(event, ev_name, args->next);
221}
222
223static inline struct event *find_cache_event(int type)
224{
225 static char ev_name[256];
226 struct event *event;
227
228 if (events[type])
229 return events[type];
230
231 events[type] = event = trace_find_event(type);
232 if (!event)
233 return NULL;
234
235 sprintf(ev_name, "%s::%s", event->system, event->name);
236
237 define_event_symbols(event, ev_name, event->print_fmt.args);
238
239 return event;
240}
241
242static void perl_process_event(int cpu, void *data,
243 int size __unused,
244 unsigned long long nsecs, char *comm)
245{
246 struct format_field *field;
247 static char handler[256];
248 unsigned long long val;
249 unsigned long s, ns;
250 struct event *event;
251 int type;
252 int pid;
253
254 dSP;
255
256 type = trace_parse_common_type(data);
257
258 event = find_cache_event(type);
259 if (!event)
260 die("ug! no event found for type %d", type);
261
262 pid = trace_parse_common_pid(data);
263
264 sprintf(handler, "%s::%s", event->system, event->name);
265
266 s = nsecs / NSECS_PER_SEC;
267 ns = nsecs - s * NSECS_PER_SEC;
268
269 scripting_context->event_data = data;
270
271 ENTER;
272 SAVETMPS;
273 PUSHMARK(SP);
274
275 XPUSHs(sv_2mortal(newSVpv(handler, 0)));
276 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
277 XPUSHs(sv_2mortal(newSVuv(cpu)));
278 XPUSHs(sv_2mortal(newSVuv(s)));
279 XPUSHs(sv_2mortal(newSVuv(ns)));
280 XPUSHs(sv_2mortal(newSViv(pid)));
281 XPUSHs(sv_2mortal(newSVpv(comm, 0)));
282
283 /* common fields other than pid can be accessed via xsub fns */
284
285 for (field = event->format.fields; field; field = field->next) {
286 if (field->flags & FIELD_IS_STRING) {
287 int offset;
288 if (field->flags & FIELD_IS_DYNAMIC) {
289 offset = *(int *)(data + field->offset);
290 offset &= 0xffff;
291 } else
292 offset = field->offset;
293 XPUSHs(sv_2mortal(newSVpv((char *)data + offset, 0)));
294 } else { /* FIELD_IS_NUMERIC */
295 val = read_size(data + field->offset, field->size);
296 if (field->flags & FIELD_IS_SIGNED) {
297 XPUSHs(sv_2mortal(newSViv(val)));
298 } else {
299 XPUSHs(sv_2mortal(newSVuv(val)));
300 }
301 }
302 }
303
304 PUTBACK;
305
306 if (get_cv(handler, 0))
307 call_pv(handler, G_SCALAR);
308 else if (get_cv("main::trace_unhandled", 0)) {
309 XPUSHs(sv_2mortal(newSVpv(handler, 0)));
310 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
311 XPUSHs(sv_2mortal(newSVuv(cpu)));
312 XPUSHs(sv_2mortal(newSVuv(nsecs)));
313 XPUSHs(sv_2mortal(newSViv(pid)));
314 XPUSHs(sv_2mortal(newSVpv(comm, 0)));
315 call_pv("main::trace_unhandled", G_SCALAR);
316 }
317 SPAGAIN;
318 PUTBACK;
319 FREETMPS;
320 LEAVE;
321}
322
323static void run_start_sub(void)
324{
325 dSP; /* access to Perl stack */
326 PUSHMARK(SP);
327
328 if (get_cv("main::trace_begin", 0))
329 call_pv("main::trace_begin", G_DISCARD | G_NOARGS);
330}
331
332/*
333 * Start trace script
334 */
335static int perl_start_script(const char *script, int argc, const char **argv)
336{
337 const char **command_line;
338 int i, err = 0;
339
340 command_line = malloc((argc + 2) * sizeof(const char *));
341 command_line[0] = "";
342 command_line[1] = script;
343 for (i = 2; i < argc + 2; i++)
344 command_line[i] = argv[i - 2];
345
346 my_perl = perl_alloc();
347 perl_construct(my_perl);
348
349 if (perl_parse(my_perl, xs_init, argc + 2, (char **)command_line,
350 (char **)NULL)) {
351 err = -1;
352 goto error;
353 }
354
355 if (perl_run(my_perl)) {
356 err = -1;
357 goto error;
358 }
359
360 if (SvTRUE(ERRSV)) {
361 err = -1;
362 goto error;
363 }
364
365 run_start_sub();
366
367 free(command_line);
368 fprintf(stderr, "perf trace started with Perl script %s\n\n", script);
369 return 0;
370error:
371 perl_free(my_perl);
372 free(command_line);
373
374 return err;
375}
376
377/*
378 * Stop trace script
379 */
380static int perl_stop_script(void)
381{
382 dSP; /* access to Perl stack */
383 PUSHMARK(SP);
384
385 if (get_cv("main::trace_end", 0))
386 call_pv("main::trace_end", G_DISCARD | G_NOARGS);
387
388 perl_destruct(my_perl);
389 perl_free(my_perl);
390
391 fprintf(stderr, "\nperf trace Perl script stopped\n");
392
393 return 0;
394}
395
396static int perl_generate_script(const char *outfile)
397{
398 struct event *event = NULL;
399 struct format_field *f;
400 char fname[PATH_MAX];
401 int not_first, count;
402 FILE *ofp;
403
404 sprintf(fname, "%s.pl", outfile);
405 ofp = fopen(fname, "w");
406 if (ofp == NULL) {
407 fprintf(stderr, "couldn't open %s\n", fname);
408 return -1;
409 }
410
411 fprintf(ofp, "# perf trace event handlers, "
412 "generated by perf trace -g perl\n");
413
414 fprintf(ofp, "# Licensed under the terms of the GNU GPL"
415 " License version 2\n\n");
416
417 fprintf(ofp, "# The common_* event handler fields are the most useful "
418 "fields common to\n");
419
420 fprintf(ofp, "# all events. They don't necessarily correspond to "
421 "the 'common_*' fields\n");
422
423 fprintf(ofp, "# in the format files. Those fields not available as "
424 "handler params can\n");
425
426 fprintf(ofp, "# be retrieved using Perl functions of the form "
427 "common_*($context).\n");
428
429 fprintf(ofp, "# See Context.pm for the list of available "
430 "functions.\n\n");
431
432 fprintf(ofp, "use lib \"$ENV{'PERF_EXEC_PATH'}/scripts/perl/"
433 "Perf-Trace-Util/lib\";\n");
434
435 fprintf(ofp, "use lib \"./Perf-Trace-Util/lib\";\n");
436 fprintf(ofp, "use Perf::Trace::Core;\n");
437 fprintf(ofp, "use Perf::Trace::Context;\n");
438 fprintf(ofp, "use Perf::Trace::Util;\n\n");
439
440 fprintf(ofp, "sub trace_begin\n{\n\t# optional\n}\n\n");
441 fprintf(ofp, "sub trace_end\n{\n\t# optional\n}\n\n");
442
443 while ((event = trace_find_next_event(event))) {
444 fprintf(ofp, "sub %s::%s\n{\n", event->system, event->name);
445 fprintf(ofp, "\tmy (");
446
447 fprintf(ofp, "$event_name, ");
448 fprintf(ofp, "$context, ");
449 fprintf(ofp, "$common_cpu, ");
450 fprintf(ofp, "$common_secs, ");
451 fprintf(ofp, "$common_nsecs,\n");
452 fprintf(ofp, "\t $common_pid, ");
453 fprintf(ofp, "$common_comm,\n\t ");
454
455 not_first = 0;
456 count = 0;
457
458 for (f = event->format.fields; f; f = f->next) {
459 if (not_first++)
460 fprintf(ofp, ", ");
461 if (++count % 5 == 0)
462 fprintf(ofp, "\n\t ");
463
464 fprintf(ofp, "$%s", f->name);
465 }
466 fprintf(ofp, ") = @_;\n\n");
467
468 fprintf(ofp, "\tprint_header($event_name, $common_cpu, "
469 "$common_secs, $common_nsecs,\n\t "
470 "$common_pid, $common_comm);\n\n");
471
472 fprintf(ofp, "\tprintf(\"");
473
474 not_first = 0;
475 count = 0;
476
477 for (f = event->format.fields; f; f = f->next) {
478 if (not_first++)
479 fprintf(ofp, ", ");
480 if (count && count % 4 == 0) {
481 fprintf(ofp, "\".\n\t \"");
482 }
483 count++;
484
485 fprintf(ofp, "%s=", f->name);
486 if (f->flags & FIELD_IS_STRING ||
487 f->flags & FIELD_IS_FLAG ||
488 f->flags & FIELD_IS_SYMBOLIC)
489 fprintf(ofp, "%%s");
490 else if (f->flags & FIELD_IS_SIGNED)
491 fprintf(ofp, "%%d");
492 else
493 fprintf(ofp, "%%u");
494 }
495
496 fprintf(ofp, "\\n\",\n\t ");
497
498 not_first = 0;
499 count = 0;
500
501 for (f = event->format.fields; f; f = f->next) {
502 if (not_first++)
503 fprintf(ofp, ", ");
504
505 if (++count % 5 == 0)
506 fprintf(ofp, "\n\t ");
507
508 if (f->flags & FIELD_IS_FLAG) {
509 if ((count - 1) % 5 != 0) {
510 fprintf(ofp, "\n\t ");
511 count = 4;
512 }
513 fprintf(ofp, "flag_str(\"");
514 fprintf(ofp, "%s::%s\", ", event->system,
515 event->name);
516 fprintf(ofp, "\"%s\", $%s)", f->name,
517 f->name);
518 } else if (f->flags & FIELD_IS_SYMBOLIC) {
519 if ((count - 1) % 5 != 0) {
520 fprintf(ofp, "\n\t ");
521 count = 4;
522 }
523 fprintf(ofp, "symbol_str(\"");
524 fprintf(ofp, "%s::%s\", ", event->system,
525 event->name);
526 fprintf(ofp, "\"%s\", $%s)", f->name,
527 f->name);
528 } else
529 fprintf(ofp, "$%s", f->name);
530 }
531
532 fprintf(ofp, ");\n");
533 fprintf(ofp, "}\n\n");
534 }
535
536 fprintf(ofp, "sub trace_unhandled\n{\n\tmy ($event_name, $context, "
537 "$common_cpu, $common_secs, $common_nsecs,\n\t "
538 "$common_pid, $common_comm) = @_;\n\n");
539
540 fprintf(ofp, "\tprint_header($event_name, $common_cpu, "
541 "$common_secs, $common_nsecs,\n\t $common_pid, "
542 "$common_comm);\n}\n\n");
543
544 fprintf(ofp, "sub print_header\n{\n"
545 "\tmy ($event_name, $cpu, $secs, $nsecs, $pid, $comm) = @_;\n\n"
546 "\tprintf(\"%%-20s %%5u %%05u.%%09u %%8u %%-20s \",\n\t "
547 "$event_name, $cpu, $secs, $nsecs, $pid, $comm);\n}");
548
549 fclose(ofp);
550
551 fprintf(stderr, "generated Perl script: %s\n", fname);
552
553 return 0;
554}
555
556struct scripting_ops perl_scripting_ops = {
557 .name = "Perl",
558 .start_script = perl_start_script,
559 .stop_script = perl_stop_script,
560 .process_event = perl_process_event,
561 .generate_script = perl_generate_script,
562};
563
564static void print_unsupported_msg(void)
565{
566 fprintf(stderr, "Perl scripting not supported."
567 " Install libperl and rebuild perf to enable it.\n"
568 "For example:\n # apt-get install libperl-dev (ubuntu)"
569 "\n # yum install perl-ExtUtils-Embed (Fedora)"
570 "\n etc.\n");
571}
572
573static int perl_start_script_unsupported(const char *script __unused,
574 int argc __unused,
575 const char **argv __unused)
576{
577 print_unsupported_msg();
578
579 return -1;
580}
581
582static int perl_stop_script_unsupported(void)
583{
584 return 0;
585}
586
587static void perl_process_event_unsupported(int cpu __unused,
588 void *data __unused,
589 int size __unused,
590 unsigned long long nsecs __unused,
591 char *comm __unused)
592{
593}
594
595static int perl_generate_script_unsupported(const char *outfile __unused)
596{
597 print_unsupported_msg();
598
599 return -1;
600}
601
602struct scripting_ops perl_scripting_unsupported_ops = {
603 .name = "Perl",
604 .start_script = perl_start_script_unsupported,
605 .stop_script = perl_stop_script_unsupported,
606 .process_event = perl_process_event_unsupported,
607 .generate_script = perl_generate_script_unsupported,
608};
609
610static void register_perl_scripting(struct scripting_ops *scripting_ops)
611{
612 int err;
613 err = script_spec_register("Perl", scripting_ops);
614 if (err)
615 die("error registering Perl script extension");
616
617 err = script_spec_register("pl", scripting_ops);
618 if (err)
619 die("error registering pl script extension");
620
621 scripting_context = malloc(sizeof(struct scripting_context));
622}
623
624#ifdef NO_LIBPERL
625void setup_perl_scripting(void)
626{
627 register_perl_scripting(&perl_scripting_unsupported_ops);
628}
629#else
630void setup_perl_scripting(void)
631{
632 register_perl_scripting(&perl_scripting_ops);
633}
634#endif
generated by cgit v1.2.2 (git 2.25.0) at 2025-04-29 01:06:20 -0400