Core.pm

  1package Perf::Trace::Core;
  2
  3use 5.010000;
  4use strict;
  5use warnings;
  6
  7require Exporter;
  8
  9our @ISA = qw(Exporter);
 10
 11our %EXPORT_TAGS = ( 'all' => [ qw(
 12) ] );
 13
 14our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 15
 16our @EXPORT = qw(
 17define_flag_field define_flag_value flag_str dump_flag_fields
 18define_symbolic_field define_symbolic_value symbol_str dump_symbolic_fields
 19trace_flag_str
 20);
 21
 22our $VERSION = '0.01';
 23
 24my %trace_flags = (0x00 => "NONE",
 25		   0x01 => "IRQS_OFF",
 26		   0x02 => "IRQS_NOSUPPORT",
 27		   0x04 => "NEED_RESCHED",
 28		   0x08 => "HARDIRQ",
 29		   0x10 => "SOFTIRQ");
 30
 31sub 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
 58my %flag_fields;
 59my %symbolic_fields;
 60
 61sub 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
 88sub define_flag_field
 89{
 90    my ($event_name, $field_name, $delim) = @_;
 91
 92    $flag_fields{$event_name}{$field_name}{"delim"} = $delim;
 93}
 94
 95sub 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
102sub 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
116sub 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
135sub define_symbolic_field
136{
137    my ($event_name, $field_name) = @_;
138
139    # nothing to do, really
140}
141
142sub 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
149sub 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
1621;
163__END__
164=head1 NAME
165
166Perf::Trace::Core - Perl extension for perf script
167
168=head1 SYNOPSIS
169
170  use Perf::Trace::Core
171
172=head1 SEE ALSO
173
174Perf (script) documentation
175
176=head1 AUTHOR
177
178Tom Zanussi, E<lt>tzanussi@gmail.com<gt>
179
180=head1 COPYRIGHT AND LICENSE
181
182Copyright (C) 2009 by Tom Zanussi
183
184This library is free software; you can redistribute it and/or modify
185it under the same terms as Perl itself, either Perl version 5.10.0 or,
186at your option, any later version of Perl 5 you may have available.
187
188Alternatively, this software may be distributed under the terms of the
189GNU General Public License ("GPL") version 2 as published by the Free
190Software Foundation.
191
192=cut