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