1 /* 2 * trace-event-perl. Feed perf script 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 <inttypes.h> 23 #include <stdio.h> 24 #include <stdlib.h> 25 #include <string.h> 26 #include <ctype.h> 27 #include <errno.h> 28 #include <linux/bitmap.h> 29 #include <linux/time64.h> 30 #include <traceevent/event-parse.h> 31 32 #include <stdbool.h> 33 /* perl needs the following define, right after including stdbool.h */ 34 #define HAS_BOOL 35 #include <EXTERN.h> 36 #include <perl.h> 37 38 #include "../callchain.h" 39 #include "../dso.h" 40 #include "../machine.h" 41 #include "../map.h" 42 #include "../symbol.h" 43 #include "../thread.h" 44 #include "../event.h" 45 #include "../trace-event.h" 46 #include "../evsel.h" 47 #include "../debug.h" 48 49 void boot_Perf__Trace__Context(pTHX_ CV *cv); 50 void boot_DynaLoader(pTHX_ CV *cv); 51 typedef PerlInterpreter * INTERP; 52 53 void xs_init(pTHX); 54 55 void xs_init(pTHX) 56 { 57 const char *file = __FILE__; 58 dXSUB_SYS; 59 60 newXS("Perf::Trace::Context::bootstrap", boot_Perf__Trace__Context, 61 file); 62 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); 63 } 64 65 INTERP my_perl; 66 67 #define TRACE_EVENT_TYPE_MAX \ 68 ((1 << (sizeof(unsigned short) * 8)) - 1) 69 70 static DECLARE_BITMAP(events_defined, TRACE_EVENT_TYPE_MAX); 71 72 extern struct scripting_context *scripting_context; 73 74 static char *cur_field_name; 75 static int zero_flag_atom; 76 77 static void define_symbolic_value(const char *ev_name, 78 const char *field_name, 79 const char *field_value, 80 const char *field_str) 81 { 82 unsigned long long value; 83 dSP; 84 85 value = eval_flag(field_value); 86 87 ENTER; 88 SAVETMPS; 89 PUSHMARK(SP); 90 91 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 92 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 93 XPUSHs(sv_2mortal(newSVuv(value))); 94 XPUSHs(sv_2mortal(newSVpv(field_str, 0))); 95 96 PUTBACK; 97 if (get_cv("main::define_symbolic_value", 0)) 98 call_pv("main::define_symbolic_value", G_SCALAR); 99 SPAGAIN; 100 PUTBACK; 101 FREETMPS; 102 LEAVE; 103 } 104 105 static void define_symbolic_values(struct tep_print_flag_sym *field, 106 const char *ev_name, 107 const char *field_name) 108 { 109 define_symbolic_value(ev_name, field_name, field->value, field->str); 110 if (field->next) 111 define_symbolic_values(field->next, ev_name, field_name); 112 } 113 114 static void define_symbolic_field(const char *ev_name, 115 const char *field_name) 116 { 117 dSP; 118 119 ENTER; 120 SAVETMPS; 121 PUSHMARK(SP); 122 123 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 124 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 125 126 PUTBACK; 127 if (get_cv("main::define_symbolic_field", 0)) 128 call_pv("main::define_symbolic_field", G_SCALAR); 129 SPAGAIN; 130 PUTBACK; 131 FREETMPS; 132 LEAVE; 133 } 134 135 static void define_flag_value(const char *ev_name, 136 const char *field_name, 137 const char *field_value, 138 const char *field_str) 139 { 140 unsigned long long value; 141 dSP; 142 143 value = eval_flag(field_value); 144 145 ENTER; 146 SAVETMPS; 147 PUSHMARK(SP); 148 149 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 150 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 151 XPUSHs(sv_2mortal(newSVuv(value))); 152 XPUSHs(sv_2mortal(newSVpv(field_str, 0))); 153 154 PUTBACK; 155 if (get_cv("main::define_flag_value", 0)) 156 call_pv("main::define_flag_value", G_SCALAR); 157 SPAGAIN; 158 PUTBACK; 159 FREETMPS; 160 LEAVE; 161 } 162 163 static void define_flag_values(struct tep_print_flag_sym *field, 164 const char *ev_name, 165 const char *field_name) 166 { 167 define_flag_value(ev_name, field_name, field->value, field->str); 168 if (field->next) 169 define_flag_values(field->next, ev_name, field_name); 170 } 171 172 static void define_flag_field(const char *ev_name, 173 const char *field_name, 174 const char *delim) 175 { 176 dSP; 177 178 ENTER; 179 SAVETMPS; 180 PUSHMARK(SP); 181 182 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 183 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 184 XPUSHs(sv_2mortal(newSVpv(delim, 0))); 185 186 PUTBACK; 187 if (get_cv("main::define_flag_field", 0)) 188 call_pv("main::define_flag_field", G_SCALAR); 189 SPAGAIN; 190 PUTBACK; 191 FREETMPS; 192 LEAVE; 193 } 194 195 static void define_event_symbols(struct tep_event *event, 196 const char *ev_name, 197 struct tep_print_arg *args) 198 { 199 if (args == NULL) 200 return; 201 202 switch (args->type) { 203 case TEP_PRINT_NULL: 204 break; 205 case TEP_PRINT_ATOM: 206 define_flag_value(ev_name, cur_field_name, "0", 207 args->atom.atom); 208 zero_flag_atom = 0; 209 break; 210 case TEP_PRINT_FIELD: 211 free(cur_field_name); 212 cur_field_name = strdup(args->field.name); 213 break; 214 case TEP_PRINT_FLAGS: 215 define_event_symbols(event, ev_name, args->flags.field); 216 define_flag_field(ev_name, cur_field_name, args->flags.delim); 217 define_flag_values(args->flags.flags, ev_name, cur_field_name); 218 break; 219 case TEP_PRINT_SYMBOL: 220 define_event_symbols(event, ev_name, args->symbol.field); 221 define_symbolic_field(ev_name, cur_field_name); 222 define_symbolic_values(args->symbol.symbols, ev_name, 223 cur_field_name); 224 break; 225 case TEP_PRINT_HEX: 226 case TEP_PRINT_HEX_STR: 227 define_event_symbols(event, ev_name, args->hex.field); 228 define_event_symbols(event, ev_name, args->hex.size); 229 break; 230 case TEP_PRINT_INT_ARRAY: 231 define_event_symbols(event, ev_name, args->int_array.field); 232 define_event_symbols(event, ev_name, args->int_array.count); 233 define_event_symbols(event, ev_name, args->int_array.el_size); 234 break; 235 case TEP_PRINT_BSTRING: 236 case TEP_PRINT_DYNAMIC_ARRAY: 237 case TEP_PRINT_DYNAMIC_ARRAY_LEN: 238 case TEP_PRINT_STRING: 239 case TEP_PRINT_BITMASK: 240 break; 241 case TEP_PRINT_TYPE: 242 define_event_symbols(event, ev_name, args->typecast.item); 243 break; 244 case TEP_PRINT_OP: 245 if (strcmp(args->op.op, ":") == 0) 246 zero_flag_atom = 1; 247 define_event_symbols(event, ev_name, args->op.left); 248 define_event_symbols(event, ev_name, args->op.right); 249 break; 250 case TEP_PRINT_FUNC: 251 default: 252 pr_err("Unsupported print arg type\n"); 253 /* we should warn... */ 254 return; 255 } 256 257 if (args->next) 258 define_event_symbols(event, ev_name, args->next); 259 } 260 261 static SV *perl_process_callchain(struct perf_sample *sample, 262 struct evsel *evsel, 263 struct addr_location *al) 264 { 265 AV *list; 266 267 list = newAV(); 268 if (!list) 269 goto exit; 270 271 if (!symbol_conf.use_callchain || !sample->callchain) 272 goto exit; 273 274 if (thread__resolve_callchain(al->thread, &callchain_cursor, evsel, 275 sample, NULL, NULL, scripting_max_stack) != 0) { 276 pr_err("Failed to resolve callchain. Skipping\n"); 277 goto exit; 278 } 279 callchain_cursor_commit(&callchain_cursor); 280 281 282 while (1) { 283 HV *elem; 284 struct callchain_cursor_node *node; 285 node = callchain_cursor_current(&callchain_cursor); 286 if (!node) 287 break; 288 289 elem = newHV(); 290 if (!elem) 291 goto exit; 292 293 if (!hv_stores(elem, "ip", newSVuv(node->ip))) { 294 hv_undef(elem); 295 goto exit; 296 } 297 298 if (node->ms.sym) { 299 HV *sym = newHV(); 300 if (!sym) { 301 hv_undef(elem); 302 goto exit; 303 } 304 if (!hv_stores(sym, "start", newSVuv(node->ms.sym->start)) || 305 !hv_stores(sym, "end", newSVuv(node->ms.sym->end)) || 306 !hv_stores(sym, "binding", newSVuv(node->ms.sym->binding)) || 307 !hv_stores(sym, "name", newSVpvn(node->ms.sym->name, 308 node->ms.sym->namelen)) || 309 !hv_stores(elem, "sym", newRV_noinc((SV*)sym))) { 310 hv_undef(sym); 311 hv_undef(elem); 312 goto exit; 313 } 314 } 315 316 if (node->ms.map) { 317 struct map *map = node->ms.map; 318 struct dso *dso = map ? map__dso(map) : NULL; 319 const char *dsoname = "[unknown]"; 320 321 if (dso) { 322 if (symbol_conf.show_kernel_path && dso->long_name) 323 dsoname = dso->long_name; 324 else 325 dsoname = dso->name; 326 } 327 if (!hv_stores(elem, "dso", newSVpv(dsoname,0))) { 328 hv_undef(elem); 329 goto exit; 330 } 331 } 332 333 callchain_cursor_advance(&callchain_cursor); 334 av_push(list, newRV_noinc((SV*)elem)); 335 } 336 337 exit: 338 return newRV_noinc((SV*)list); 339 } 340 341 static void perl_process_tracepoint(struct perf_sample *sample, 342 struct evsel *evsel, 343 struct addr_location *al) 344 { 345 struct thread *thread = al->thread; 346 struct tep_event *event = evsel->tp_format; 347 struct tep_format_field *field; 348 static char handler[256]; 349 unsigned long long val; 350 unsigned long s, ns; 351 int pid; 352 int cpu = sample->cpu; 353 void *data = sample->raw_data; 354 unsigned long long nsecs = sample->time; 355 const char *comm = thread__comm_str(thread); 356 357 dSP; 358 359 if (evsel->core.attr.type != PERF_TYPE_TRACEPOINT) 360 return; 361 362 if (!event) { 363 pr_debug("ug! no event found for type %" PRIu64, (u64)evsel->core.attr.config); 364 return; 365 } 366 367 pid = raw_field_value(event, "common_pid", data); 368 369 sprintf(handler, "%s::%s", event->system, event->name); 370 371 if (!__test_and_set_bit(event->id, events_defined)) 372 define_event_symbols(event, handler, event->print_fmt.args); 373 374 s = nsecs / NSEC_PER_SEC; 375 ns = nsecs - s * NSEC_PER_SEC; 376 377 ENTER; 378 SAVETMPS; 379 PUSHMARK(SP); 380 381 XPUSHs(sv_2mortal(newSVpv(handler, 0))); 382 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context)))); 383 XPUSHs(sv_2mortal(newSVuv(cpu))); 384 XPUSHs(sv_2mortal(newSVuv(s))); 385 XPUSHs(sv_2mortal(newSVuv(ns))); 386 XPUSHs(sv_2mortal(newSViv(pid))); 387 XPUSHs(sv_2mortal(newSVpv(comm, 0))); 388 XPUSHs(sv_2mortal(perl_process_callchain(sample, evsel, al))); 389 390 /* common fields other than pid can be accessed via xsub fns */ 391 392 for (field = event->format.fields; field; field = field->next) { 393 if (field->flags & TEP_FIELD_IS_STRING) { 394 int offset; 395 if (field->flags & TEP_FIELD_IS_DYNAMIC) { 396 offset = *(int *)(data + field->offset); 397 offset &= 0xffff; 398 if (tep_field_is_relative(field->flags)) 399 offset += field->offset + field->size; 400 } else 401 offset = field->offset; 402 XPUSHs(sv_2mortal(newSVpv((char *)data + offset, 0))); 403 } else { /* FIELD_IS_NUMERIC */ 404 val = read_size(event, data + field->offset, 405 field->size); 406 if (field->flags & TEP_FIELD_IS_SIGNED) { 407 XPUSHs(sv_2mortal(newSViv(val))); 408 } else { 409 XPUSHs(sv_2mortal(newSVuv(val))); 410 } 411 } 412 } 413 414 PUTBACK; 415 416 if (get_cv(handler, 0)) 417 call_pv(handler, G_SCALAR); 418 else if (get_cv("main::trace_unhandled", 0)) { 419 XPUSHs(sv_2mortal(newSVpv(handler, 0))); 420 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context)))); 421 XPUSHs(sv_2mortal(newSVuv(cpu))); 422 XPUSHs(sv_2mortal(newSVuv(nsecs))); 423 XPUSHs(sv_2mortal(newSViv(pid))); 424 XPUSHs(sv_2mortal(newSVpv(comm, 0))); 425 XPUSHs(sv_2mortal(perl_process_callchain(sample, evsel, al))); 426 call_pv("main::trace_unhandled", G_SCALAR); 427 } 428 SPAGAIN; 429 PUTBACK; 430 FREETMPS; 431 LEAVE; 432 } 433 434 static void perl_process_event_generic(union perf_event *event, 435 struct perf_sample *sample, 436 struct evsel *evsel) 437 { 438 dSP; 439 440 if (!get_cv("process_event", 0)) 441 return; 442 443 ENTER; 444 SAVETMPS; 445 PUSHMARK(SP); 446 XPUSHs(sv_2mortal(newSVpvn((const char *)event, event->header.size))); 447 XPUSHs(sv_2mortal(newSVpvn((const char *)&evsel->core.attr, sizeof(evsel->core.attr)))); 448 XPUSHs(sv_2mortal(newSVpvn((const char *)sample, sizeof(*sample)))); 449 XPUSHs(sv_2mortal(newSVpvn((const char *)sample->raw_data, sample->raw_size))); 450 PUTBACK; 451 call_pv("process_event", G_SCALAR); 452 SPAGAIN; 453 PUTBACK; 454 FREETMPS; 455 LEAVE; 456 } 457 458 static void perl_process_event(union perf_event *event, 459 struct perf_sample *sample, 460 struct evsel *evsel, 461 struct addr_location *al, 462 struct addr_location *addr_al) 463 { 464 scripting_context__update(scripting_context, event, sample, evsel, al, addr_al); 465 perl_process_tracepoint(sample, evsel, al); 466 perl_process_event_generic(event, sample, evsel); 467 } 468 469 static void run_start_sub(void) 470 { 471 dSP; /* access to Perl stack */ 472 PUSHMARK(SP); 473 474 if (get_cv("main::trace_begin", 0)) 475 call_pv("main::trace_begin", G_DISCARD | G_NOARGS); 476 } 477 478 /* 479 * Start trace script 480 */ 481 static int perl_start_script(const char *script, int argc, const char **argv, 482 struct perf_session *session) 483 { 484 const char **command_line; 485 int i, err = 0; 486 487 scripting_context->session = session; 488 489 command_line = malloc((argc + 2) * sizeof(const char *)); 490 command_line[0] = ""; 491 command_line[1] = script; 492 for (i = 2; i < argc + 2; i++) 493 command_line[i] = argv[i - 2]; 494 495 my_perl = perl_alloc(); 496 perl_construct(my_perl); 497 498 if (perl_parse(my_perl, xs_init, argc + 2, (char **)command_line, 499 (char **)NULL)) { 500 err = -1; 501 goto error; 502 } 503 504 if (perl_run(my_perl)) { 505 err = -1; 506 goto error; 507 } 508 509 if (SvTRUE(ERRSV)) { 510 err = -1; 511 goto error; 512 } 513 514 run_start_sub(); 515 516 free(command_line); 517 return 0; 518 error: 519 perl_free(my_perl); 520 free(command_line); 521 522 return err; 523 } 524 525 static int perl_flush_script(void) 526 { 527 return 0; 528 } 529 530 /* 531 * Stop trace script 532 */ 533 static int perl_stop_script(void) 534 { 535 dSP; /* access to Perl stack */ 536 PUSHMARK(SP); 537 538 if (get_cv("main::trace_end", 0)) 539 call_pv("main::trace_end", G_DISCARD | G_NOARGS); 540 541 perl_destruct(my_perl); 542 perl_free(my_perl); 543 544 return 0; 545 } 546 547 static int perl_generate_script(struct tep_handle *pevent, const char *outfile) 548 { 549 int i, not_first, count, nr_events; 550 struct tep_event **all_events; 551 struct tep_event *event = NULL; 552 struct tep_format_field *f; 553 char fname[PATH_MAX]; 554 FILE *ofp; 555 556 sprintf(fname, "%s.pl", outfile); 557 ofp = fopen(fname, "w"); 558 if (ofp == NULL) { 559 fprintf(stderr, "couldn't open %s\n", fname); 560 return -1; 561 } 562 563 fprintf(ofp, "# perf script event handlers, " 564 "generated by perf script -g perl\n"); 565 566 fprintf(ofp, "# Licensed under the terms of the GNU GPL" 567 " License version 2\n\n"); 568 569 fprintf(ofp, "# The common_* event handler fields are the most useful " 570 "fields common to\n"); 571 572 fprintf(ofp, "# all events. They don't necessarily correspond to " 573 "the 'common_*' fields\n"); 574 575 fprintf(ofp, "# in the format files. Those fields not available as " 576 "handler params can\n"); 577 578 fprintf(ofp, "# be retrieved using Perl functions of the form " 579 "common_*($context).\n"); 580 581 fprintf(ofp, "# See Context.pm for the list of available " 582 "functions.\n\n"); 583 584 fprintf(ofp, "use lib \"$ENV{'PERF_EXEC_PATH'}/scripts/perl/" 585 "Perf-Trace-Util/lib\";\n"); 586 587 fprintf(ofp, "use lib \"./Perf-Trace-Util/lib\";\n"); 588 fprintf(ofp, "use Perf::Trace::Core;\n"); 589 fprintf(ofp, "use Perf::Trace::Context;\n"); 590 fprintf(ofp, "use Perf::Trace::Util;\n\n"); 591 592 fprintf(ofp, "sub trace_begin\n{\n\t# optional\n}\n\n"); 593 fprintf(ofp, "sub trace_end\n{\n\t# optional\n}\n"); 594 595 596 fprintf(ofp, "\n\ 597 sub print_backtrace\n\ 598 {\n\ 599 my $callchain = shift;\n\ 600 for my $node (@$callchain)\n\ 601 {\n\ 602 if(exists $node->{sym})\n\ 603 {\n\ 604 printf( \"\\t[\\%%x] \\%%s\\n\", $node->{ip}, $node->{sym}{name});\n\ 605 }\n\ 606 else\n\ 607 {\n\ 608 printf( \"\\t[\\%%x]\\n\", $node{ip});\n\ 609 }\n\ 610 }\n\ 611 }\n\n\ 612 "); 613 614 nr_events = tep_get_events_count(pevent); 615 all_events = tep_list_events(pevent, TEP_EVENT_SORT_ID); 616 617 for (i = 0; all_events && i < nr_events; i++) { 618 event = all_events[i]; 619 fprintf(ofp, "sub %s::%s\n{\n", event->system, event->name); 620 fprintf(ofp, "\tmy ("); 621 622 fprintf(ofp, "$event_name, "); 623 fprintf(ofp, "$context, "); 624 fprintf(ofp, "$common_cpu, "); 625 fprintf(ofp, "$common_secs, "); 626 fprintf(ofp, "$common_nsecs,\n"); 627 fprintf(ofp, "\t $common_pid, "); 628 fprintf(ofp, "$common_comm, "); 629 fprintf(ofp, "$common_callchain,\n\t "); 630 631 not_first = 0; 632 count = 0; 633 634 for (f = event->format.fields; f; f = f->next) { 635 if (not_first++) 636 fprintf(ofp, ", "); 637 if (++count % 5 == 0) 638 fprintf(ofp, "\n\t "); 639 640 fprintf(ofp, "$%s", f->name); 641 } 642 fprintf(ofp, ") = @_;\n\n"); 643 644 fprintf(ofp, "\tprint_header($event_name, $common_cpu, " 645 "$common_secs, $common_nsecs,\n\t " 646 "$common_pid, $common_comm, $common_callchain);\n\n"); 647 648 fprintf(ofp, "\tprintf(\""); 649 650 not_first = 0; 651 count = 0; 652 653 for (f = event->format.fields; f; f = f->next) { 654 if (not_first++) 655 fprintf(ofp, ", "); 656 if (count && count % 4 == 0) { 657 fprintf(ofp, "\".\n\t \""); 658 } 659 count++; 660 661 fprintf(ofp, "%s=", f->name); 662 if (f->flags & TEP_FIELD_IS_STRING || 663 f->flags & TEP_FIELD_IS_FLAG || 664 f->flags & TEP_FIELD_IS_SYMBOLIC) 665 fprintf(ofp, "%%s"); 666 else if (f->flags & TEP_FIELD_IS_SIGNED) 667 fprintf(ofp, "%%d"); 668 else 669 fprintf(ofp, "%%u"); 670 } 671 672 fprintf(ofp, "\\n\",\n\t "); 673 674 not_first = 0; 675 count = 0; 676 677 for (f = event->format.fields; f; f = f->next) { 678 if (not_first++) 679 fprintf(ofp, ", "); 680 681 if (++count % 5 == 0) 682 fprintf(ofp, "\n\t "); 683 684 if (f->flags & TEP_FIELD_IS_FLAG) { 685 if ((count - 1) % 5 != 0) { 686 fprintf(ofp, "\n\t "); 687 count = 4; 688 } 689 fprintf(ofp, "flag_str(\""); 690 fprintf(ofp, "%s::%s\", ", event->system, 691 event->name); 692 fprintf(ofp, "\"%s\", $%s)", f->name, 693 f->name); 694 } else if (f->flags & TEP_FIELD_IS_SYMBOLIC) { 695 if ((count - 1) % 5 != 0) { 696 fprintf(ofp, "\n\t "); 697 count = 4; 698 } 699 fprintf(ofp, "symbol_str(\""); 700 fprintf(ofp, "%s::%s\", ", event->system, 701 event->name); 702 fprintf(ofp, "\"%s\", $%s)", f->name, 703 f->name); 704 } else 705 fprintf(ofp, "$%s", f->name); 706 } 707 708 fprintf(ofp, ");\n\n"); 709 710 fprintf(ofp, "\tprint_backtrace($common_callchain);\n"); 711 712 fprintf(ofp, "}\n\n"); 713 } 714 715 fprintf(ofp, "sub trace_unhandled\n{\n\tmy ($event_name, $context, " 716 "$common_cpu, $common_secs, $common_nsecs,\n\t " 717 "$common_pid, $common_comm, $common_callchain) = @_;\n\n"); 718 719 fprintf(ofp, "\tprint_header($event_name, $common_cpu, " 720 "$common_secs, $common_nsecs,\n\t $common_pid, " 721 "$common_comm, $common_callchain);\n"); 722 fprintf(ofp, "\tprint_backtrace($common_callchain);\n"); 723 fprintf(ofp, "}\n\n"); 724 725 fprintf(ofp, "sub print_header\n{\n" 726 "\tmy ($event_name, $cpu, $secs, $nsecs, $pid, $comm) = @_;\n\n" 727 "\tprintf(\"%%-20s %%5u %%05u.%%09u %%8u %%-20s \",\n\t " 728 "$event_name, $cpu, $secs, $nsecs, $pid, $comm);\n}\n"); 729 730 fprintf(ofp, 731 "\n# Packed byte string args of process_event():\n" 732 "#\n" 733 "# $event:\tunion perf_event\tutil/event.h\n" 734 "# $attr:\tstruct perf_event_attr\tlinux/perf_event.h\n" 735 "# $sample:\tstruct perf_sample\tutil/event.h\n" 736 "# $raw_data:\tperf_sample->raw_data\tutil/event.h\n" 737 "\n" 738 "sub process_event\n" 739 "{\n" 740 "\tmy ($event, $attr, $sample, $raw_data) = @_;\n" 741 "\n" 742 "\tmy @event\t= unpack(\"LSS\", $event);\n" 743 "\tmy @attr\t= unpack(\"LLQQQQQLLQQ\", $attr);\n" 744 "\tmy @sample\t= unpack(\"QLLQQQQQLL\", $sample);\n" 745 "\tmy @raw_data\t= unpack(\"C*\", $raw_data);\n" 746 "\n" 747 "\tuse Data::Dumper;\n" 748 "\tprint Dumper \\@event, \\@attr, \\@sample, \\@raw_data;\n" 749 "}\n"); 750 751 fclose(ofp); 752 753 fprintf(stderr, "generated Perl script: %s\n", fname); 754 755 return 0; 756 } 757 758 struct scripting_ops perl_scripting_ops = { 759 .name = "Perl", 760 .dirname = "perl", 761 .start_script = perl_start_script, 762 .flush_script = perl_flush_script, 763 .stop_script = perl_stop_script, 764 .process_event = perl_process_event, 765 .generate_script = perl_generate_script, 766 }; 767