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