Home | History | Annotate | Download | only in Trace 
      1 package Perf::Trace::Core;
      2 
      3 use 5.010000;
      4 use strict;
      5 use warnings;
      6 
      7 require Exporter;
      8 
      9 our @ISA = qw(Exporter);
     10 
     11 our %EXPORT_TAGS = ( 'all' => [ qw(
     12 ) ] );
     13 
     14 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
     15 
     16 our @EXPORT = qw(
     17 define_flag_field define_flag_value flag_str dump_flag_fields
     18 define_symbolic_field define_symbolic_value symbol_str dump_symbolic_fields
     19 trace_flag_str
     20 );
     21 
     22 our $VERSION = '0.01';
     23 
     24 my %trace_flags = (0x00 => "NONE",
     25 		   0x01 => "IRQS_OFF",
     26 		   0x02 => "IRQS_NOSUPPORT",
     27 		   0x04 => "NEED_RESCHED",
     28 		   0x08 => "HARDIRQ",
     29 		   0x10 => "SOFTIRQ");
     30 
     31 sub trace_flag_str
     32 {
     33     my ($value) = @_;
     34 
     35     my $string;
     36 
     37     my $print_delim = 0;
     38 
     39     foreach my $idx (sort {$a <=> $b} keys %trace_flags) {
     40 	if (!$value && !$idx) {
     41 	    $string .= "NONE";
     42 	    last;
     43 	}
     44 
     45 	if ($idx && ($value & $idx) == $idx) {
     46 	    if ($print_delim) {
     47 		$string .= " | ";
     48 	    }
     49 	    $string .= "$trace_flags{$idx}";
     50 	    $print_delim = 1;
     51 	    $value &= ~$idx;
     52 	}
     53     }
     54 
     55     return $string;
     56 }
     57 
     58 my %flag_fields;
     59 my %symbolic_fields;
     60 
     61 sub flag_str
     62 {
     63     my ($event_name, $field_name, $value) = @_;
     64 
     65     my $string;
     66 
     67     if ($flag_fields{$event_name}{$field_name}) {
     68 	my $print_delim = 0;
     69 	foreach my $idx (sort {$a <=> $b} keys %{$flag_fields{$event_name}{$field_name}{"values"}}) {
     70 	    if (!$value && !$idx) {
     71 		$string .= "$flag_fields{$event_name}{$field_name}{'values'}{$idx}";
     72 		last;
     73 	    }
     74 	    if ($idx && ($value & $idx) == $idx) {
     75 		if ($print_delim && $flag_fields{$event_name}{$field_name}{'delim'}) {
     76 		    $string .= " $flag_fields{$event_name}{$field_name}{'delim'} ";
     77 		}
     78 		$string .= "$flag_fields{$event_name}{$field_name}{'values'}{$idx}";
     79 		$print_delim = 1;
     80 		$value &= ~$idx;
     81 	    }
     82 	}
     83     }
     84 
     85     return $string;
     86 }
     87 
     88 sub define_flag_field
     89 {
     90     my ($event_name, $field_name, $delim) = @_;
     91 
     92     $flag_fields{$event_name}{$field_name}{"delim"} = $delim;
     93 }
     94 
     95 sub define_flag_value
     96 {
     97     my ($event_name, $field_name, $value, $field_str) = @_;
     98 
     99     $flag_fields{$event_name}{$field_name}{"values"}{$value} = $field_str;
    100 }
    101 
    102 sub dump_flag_fields
    103 {
    104     for my $event (keys %flag_fields) {
    105 	print "event $event:\n";
    106 	for my $field (keys %{$flag_fields{$event}}) {
    107 	    print "    field: $field:\n";
    108 	    print "        delim: $flag_fields{$event}{$field}{'delim'}\n";
    109 	    foreach my $idx (sort {$a <=> $b} keys %{$flag_fields{$event}{$field}{"values"}}) {
    110 		print "        value $idx: $flag_fields{$event}{$field}{'values'}{$idx}\n";
    111 	    }
    112 	}
    113     }
    114 }
    115 
    116 sub symbol_str
    117 {
    118     my ($event_name, $field_name, $value) = @_;
    119 
    120     if ($symbolic_fields{$event_name}{$field_name}) {
    121 	foreach my $idx (sort {$a <=> $b} keys %{$symbolic_fields{$event_name}{$field_name}{"values"}}) {
    122 	    if (!$value && !$idx) {
    123 		return "$symbolic_fields{$event_name}{$field_name}{'values'}{$idx}";
    124 		last;
    125 	    }
    126 	    if ($value == $idx) {
    127 		return "$symbolic_fields{$event_name}{$field_name}{'values'}{$idx}";
    128 	    }
    129 	}
    130     }
    131 
    132     return undef;
    133 }
    134 
    135 sub define_symbolic_field
    136 {
    137     my ($event_name, $field_name) = @_;
    138 
    139     # nothing to do, really
    140 }
    141 
    142 sub define_symbolic_value
    143 {
    144     my ($event_name, $field_name, $value, $field_str) = @_;
    145 
    146     $symbolic_fields{$event_name}{$field_name}{"values"}{$value} = $field_str;
    147 }
    148 
    149 sub dump_symbolic_fields
    150 {
    151     for my $event (keys %symbolic_fields) {
    152 	print "event $event:\n";
    153 	for my $field (keys %{$symbolic_fields{$event}}) {
    154 	    print "    field: $field:\n";
    155 	    foreach my $idx (sort {$a <=> $b} keys %{$symbolic_fields{$event}{$field}{"values"}}) {
    156 		print "        value $idx: $symbolic_fields{$event}{$field}{'values'}{$idx}\n";
    157 	    }
    158 	}
    159     }
    160 }
    161 
    162 1;
    163 __END__
    164 =head1 NAME
    165 
    166 Perf::Trace::Core - Perl extension for perf script
    167 
    168 =head1 SYNOPSIS
    169 
    170   use Perf::Trace::Core
    171 
    172 =head1 SEE ALSO
    173 
    174 Perf (script) documentation
    175 
    176 =head1 AUTHOR
    177 
    178 Tom Zanussi, E<lt>tzanussi@gmail.com<gt>
    179 
    180 =head1 COPYRIGHT AND LICENSE
    181 
    182 Copyright (C) 2009 by Tom Zanussi
    183 
    184 This library is free software; you can redistribute it and/or modify
    185 it under the same terms as Perl itself, either Perl version 5.10.0 or,
    186 at your option, any later version of Perl 5 you may have available.
    187 
    188 Alternatively, this software may be distributed under the terms of the
    189 GNU General Public License ("GPL") version 2 as published by the Free
    190 Software Foundation.
    191 
    192 =cut
    193