linux/tools/perf/scripts/perl/Perf-Trace-Util/lib/Perf/Trace/Core.pm

package Perf::Trace::Core;

use 5.010000;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
define_flag_field define_flag_value flag_str dump_flag_fields
define_symbolic_field define_symbolic_value symbol_str dump_symbolic_fields
trace_flag_str
);

our $VERSION = '0.01';

my %trace_flags = (0x00 => "NONE",
		   0x01 => "IRQS_OFF",
		   0x02 => "IRQS_NOSUPPORT",
		   0x04 => "NEED_RESCHED",
		   0x08 => "HARDIRQ",
		   0x10 => "SOFTIRQ");

sub trace_flag_str
{
    my ($value) = @_;

    my $string;

    my $print_delim = 0;

    foreach my $idx (sort {$a <=> $b} keys %trace_flags) {
	if (!$value && !$idx) {
	    $string .= "NONE";
	    last;
	}

	if ($idx && ($value & $idx) == $idx) {
	    if ($print_delim) {
		$string .= " | ";
	    }
	    $string .= "$trace_flags{$idx}";
	    $print_delim = 1;
	    $value &= ~$idx;
	}
    }

    return $string;
}

my %flag_fields;
my %symbolic_fields;

sub flag_str
{
    my ($event_name, $field_name, $value) = @_;

    my $string;

    if ($flag_fields{$event_name}{$field_name}) {
	my $print_delim = 0;
	foreach my $idx (sort {$a <=> $b} keys %{$flag_fields{$event_name}{$field_name}{"values"}}) {
	    if (!$value && !$idx) {
		$string .= "$flag_fields{$event_name}{$field_name}{'values'}{$idx}";
		last;
	    }
	    if ($idx && ($value & $idx) == $idx) {
		if ($print_delim && $flag_fields{$event_name}{$field_name}{'delim'}) {
		    $string .= " $flag_fields{$event_name}{$field_name}{'delim'} ";
		}
		$string .= "$flag_fields{$event_name}{$field_name}{'values'}{$idx}";
		$print_delim = 1;
		$value &= ~$idx;
	    }
	}
    }

    return $string;
}

sub define_flag_field
{
    my ($event_name, $field_name, $delim) = @_;

    $flag_fields{$event_name}{$field_name}{"delim"} = $delim;
}

sub define_flag_value
{
    my ($event_name, $field_name, $value, $field_str) = @_;

    $flag_fields{$event_name}{$field_name}{"values"}{$value} = $field_str;
}

sub dump_flag_fields
{
    for my $event (keys %flag_fields) {
	print "event $event:\n";
	for my $field (keys %{$flag_fields{$event}}) {
	    print "    field: $field:\n";
	    print "        delim: $flag_fields{$event}{$field}{'delim'}\n";
	    foreach my $idx (sort {$a <=> $b} keys %{$flag_fields{$event}{$field}{"values"}}) {
		print "        value $idx: $flag_fields{$event}{$field}{'values'}{$idx}\n";
	    }
	}
    }
}

sub symbol_str
{
    my ($event_name, $field_name, $value) = @_;

    if ($symbolic_fields{$event_name}{$field_name}) {
	foreach my $idx (sort {$a <=> $b} keys %{$symbolic_fields{$event_name}{$field_name}{"values"}}) {
	    if (!$value && !$idx) {
		return "$symbolic_fields{$event_name}{$field_name}{'values'}{$idx}";
		last;
	    }
	    if ($value == $idx) {
		return "$symbolic_fields{$event_name}{$field_name}{'values'}{$idx}";
	    }
	}
    }

    return undef;
}

sub define_symbolic_field
{
    my ($event_name, $field_name) = @_;

    # nothing to do, really
}

sub define_symbolic_value
{
    my ($event_name, $field_name, $value, $field_str) = @_;

    $symbolic_fields{$event_name}{$field_name}{"values"}{$value} = $field_str;
}

sub dump_symbolic_fields
{
    for my $event (keys %symbolic_fields) {
	print "event $event:\n";
	for my $field (keys %{$symbolic_fields{$event}}) {
	    print "    field: $field:\n";
	    foreach my $idx (sort {$a <=> $b} keys %{$symbolic_fields{$event}{$field}{"values"}}) {
		print "        value $idx: $symbolic_fields{$event}{$field}{'values'}{$idx}\n";
	    }
	}
    }
}

1;
__END__
=head1 NAME

Perf::Trace::Core - Perl extension for perf script

=head1 SYNOPSIS

  use Perf::Trace::Core

=head1 SEE ALSO

Perf (script) documentation

=head1 AUTHOR

Tom Zanussi, E<lt>[email protected]<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 by Tom Zanussi

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

Alternatively, this software may be distributed under the terms of the
GNU General Public License ("GPL") version 2 as published by the Free
Software Foundation.

=cut