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