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
193