File Coverage

blib/lib/Net/Tshark/Field.pm

Criterion	Covered	Total	%
statement	15	115	13.0
branch	0	32	0.0
condition	0	12	0.0
subroutine	5	28	17.8
pod	7	9	77.7
total	27	196	13.7

package Net::Tshark::Field;
use strict;
use warnings;

our $VERSION = '0.04';

use List::MoreUtils qw(any all uniq after);
use List::Util qw(reduce);

use overload (
    q("") => sub {
        my $self = tied %{ $_[0] };
        $self->{__value};
    }
);

sub new
{
    my ($class, $field_data) = @_;
    return if (!defined $field_data);

    # Extract the value, and child nodes of this field
    my $value =
      (defined $field_data->{show})
      ? $field_data->{show}
      : $field_data->{showname};
    my @child_nodes =
      (@{ $field_data->{field} || [] }, @{ $field_data->{proto} || [] });

    # If this node has no children, we can just return a scalar
    return $value if (!@child_nodes);

    # If a field doesn't have a name, give it a name based on
    # its showname or show attribute.
    foreach (@child_nodes)
    {
        if (!defined $_->{name} || !length $_->{name})
        {
            $_->{name} =
              defined $_->{showname} && length($_->{showname}) ? $_->{showname}
              : defined $_->{show} ? $_->{show}
              :                      q();
        }
    }

    my $data = {
        show          => $field_data->{show},
        showname      => $field_data->{showname},
        name          => $field_data->{name},
        size          => $field_data->{size},
        value         => $field_data->{value},
        __value       => $value,
        __child_nodes => \@child_nodes,
    };

    # Tie a new hash to this package so we can access parts of the parsed
    # PDML using hash notation (e.g. $packet->{ip}). Note that the TIEHASH
    # subroutine does the actual construction of the object.
    my $self = {};
    tie %{$self}, $class, $data;
    return bless $self, $class;
}

sub fields
{
    my ($field) = @_;
    my $self = tied %{$field};
    return map { Net::Tshark::Field->new($_) } @{ $self->{__child_nodes} };
}

sub show
{
    my ($field) = @_;
    my $self = tied %{$field};
    return $self->{show};
}

sub showname
{
    my ($field) = @_;
    my $self = tied %{$field};
    return $self->{showname};
}

sub name
{
    my ($field) = @_;
    my $self = tied %{$field};
    return $self->{name};
}

sub size
{
    my ($field) = @_;
    my $self = tied %{$field};
    return $self->{size};
}

sub value
{
    my ($field) = @_;
    my $self = tied %{$field};
    return $self->{value};
}

sub hash
{
    my ($field) = @_;

    my %hash = %{$field};
    while (my ($key, $value) = each %hash)
    {
        if (ref $hash{$key})
        {
            my $sub_hash = $hash{$key}->hash;
            $hash{$key} = $sub_hash;
        }
    }

    return \%hash;
}

sub TIEHASH
{
    my ($class, $self) = @_;
    return bless $self, $class;
}

sub STORE
{

    # Do nothing. If someone tries to access a field that doesn't exist,
    # Perl will try to create it via autovilification. We don't want to
    # create anything, but we also don't want this to trigger any warnings.
}

sub FETCH
{
    my ($self, $key) = @_;
    my @nodes = $self->__fields($key);

    # If nothing was found, do a deep search in the child nodes for a name match
    if (!@nodes)
    {
        foreach my $child (@{ $self->{__child_nodes} })
        {
            push @nodes,
              grep { $_->{name} =~ /^(?:.*\.)?$key$/i }
              (@{ $child->{field} || [] }, @{ $child->{proto} || [] });
        }
    }

    # If all the matching fields are leaves, append all their values and
    # return them as a constructed field
    if (all { !defined $_->{field} && !defined $_->{proto} } @nodes)
    {
        my $show = join(q(),
            map { (defined $_->{show}) ? $_->{show} : $_->{showname} } @nodes);
        return Net::Tshark::Field->new({ show => $show });
    }

    # Otherwise, return the first matching node
    return Net::Tshark::Field->new($nodes[0]);
}

sub EXISTS
{
    my ($self, $key) = @_;
    return any { $_->{name} =~ /^(?:.*\.)?$key$/i } @{ $self->{__child_nodes} };
}

sub DEFINED
{
    return EXISTS(@_);
}

sub CLEAR
{
    warn 'You cannot clear a ' . __PACKAGE__ . ' object';
    return;
}

sub DELETE
{
    warn 'You cannot delete from a ' . __PACKAGE__ . ' object';
    return;
}

sub FIRSTKEY
{
    my ($self) = @_;
    return (@{ $self->{__child_nodes} })[0]->{name};
}

sub NEXTKEY
{
    my ($self, $last_key) = @_;

    # Get a set of all the names of the child nodes, with no repeats
    my @keys = uniq(map { $_->{name} } @{ $self->{__child_nodes} });
    return (after { $_ eq $last_key } (@keys))[0];
}

sub __fields
{
    my ($self, $key) = @_;

    # Message bodies are named differently in different versions of Wireshark
    if ($key eq 'Message body' || $key eq 'msg_body')
    {
        $key = qr/Message body|msg_body/;
    }

    # Find all the fields with a name that matches $key.
    my @matching_nodes =
      grep { $_->{name} =~ /^(?:.*\.)?$key$/i } @{ $self->{__child_nodes} };

    # Choose the shortest matching field name
    my $shortestName = reduce { length($a) < length($b) ? $a : $b }
    map { $_->{name} } @matching_nodes;

    # If there are more than one matching field, choose the
    # field or protocol with the shortest name.
    my @nodes = grep { $_->{name} eq $shortestName } (@matching_nodes);

    return @nodes;
}

1;

__END__