tools/perf/util/scripting-engines/trace-event-perl.c

   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_format *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_format *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_format *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 };