File Coverage

blib/lib/NetPacket/SpanningTree.pm

Criterion	Covered	Total	%
statement	18	53	33.9
branch	0	8	0.0
condition			n/a
subroutine	6	9	66.6
pod			n/a
total	24	70	34.2

#
# NetPacket::SpanningTree - Decode and encode spanning tree protocol packets
#
# Comments/suggestions to [e-mail]
#

package NetPacket::SpanningTree;

#
# Copyright (c) 2002 Chander Ganesan.
#
# This package is free software and is provided "as is" without express
# or implied warranty.  It may be used, redistributed and/or modified
# under the terms of the Perl Artistic License (see
# http://www.perl.com/perl/misc/Artistic.html)
#
# This software and all associated data and documentation
# ('Software') is available free of charge.  You may make copies of the
# Software but you must include all of this notice on any copy.
#
# The Software was developed for research purposes does not
# warrant that it is error free or fit for any purpose.  The author
# disclaims any liability for all claims, expenses, losses, damages
# and costs any user may incur as a result of using, copying or
# modifying the Software.
#

use 5.006;
use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

my $myclass;
BEGIN {
    $myclass = __PACKAGE__;
    $VERSION = "0.01";
}
sub Version () { "$myclass v$VERSION" }

BEGIN {
    @ISA = qw(Exporter NetPacket);

# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)

    @EXPORT = qw(
    );

# Other items we are prepared to export if requested

    @EXPORT_OK = qw(st_strip
                    );

# Tags:

    %EXPORT_TAGS = (
    ALL         => [@EXPORT, @EXPORT_OK],
    strip       => [qw(st_strip)],
    types       => [qw(
                       )],
);

}

#
# Decode the packet
#

sub decode {
    my $class = shift;
    my($pkt, $parent, @rest) = @_;
    my $self = {};

    # Class fields

    $self->{_parent} = $parent;
    $self->{_frame} = $pkt;

    # Decode Spanning Tree packet

    if (defined($pkt)) {
        my ($root_pri, $bridge_pri, $port_pri, $port_num, $root_path_cost,
            $message_age, $max_age, $bpdu_type,
            $fwd_delay, $hello_time ,
            $root_mac, $bridge_mac, $version, $version_length);

	($self->{protocol_id}, $version, $bpdu_type,
         $self->{bpdu_flags},
         $root_pri, $self->{root_mac}, $self->{root_path_cost},
         $bridge_pri, $bridge_mac, $port_pri, $port_num,
         $message_age, $max_age, $hello_time, $fwd_delay, $version_length) =
             unpack('nH2H2a1H4H12NH4H12H2H2nnnnH2' , $pkt);
#        print "unpacked: " . unpack ("H*" ,  $pkt) . "\n";
        $self->{protocol_version} = hex($version);
        $self->{bpdu_type} = hex ($bpdu_type);
        if ($self->{bpdu_type} != 128) { # This isn't a topology change...
            if ($self->{bpdu_type} == 2) { # Rapid...
                my ($prole1, $prole2);
                $self->{version_1_length} = hex($version_length);
                ($self->{topology_change_ack},
                 $self->{agreement},
                 $self->{forwarding},
                 $self->{learning},
                 $prole1,
                 $prole2,
                 $self->{proposal},
                 $self->{topology_change}) =
                     split //, unpack ("B*", $self->{bpdu_flags});
                $self->{port_role} = $prole1*2 + $prole2;
            } elsif ($self->{bpdu_type} == 0) {
                ($self->{topology_change_ack},
                 undef, undef, undef, undef, undef, undef,
                 $self->{topology_change}) =
                     split //, unpack ("B*", $self->{bpdu_flags});
            }
            $self->{data} = undef;
            $self->{root_priority} = hex($root_pri);
            $self->{root_id} = $root_pri . $self->{root_mac};
            $self->{bridge_id} = $bridge_pri . $bridge_mac;
            $self->{bridge_priority} = hex($bridge_pri);
            $self->{bridge_mac} = $bridge_mac;
            $self->{port_priority} = hex($port_pri);
            $self->{port_num} = hex($port_num);
            $self->{port_id} = sprintf("%02lx%02lx", hex($port_pri) , hex($port_num));


            $self->{bpdu_flags} = unpack ("B*", $self->{bpdu_flags});

            $self->{message_age} = $message_age/256;
            $self->{max_age} = $max_age/256;
            $self->{forward_delay} = $fwd_delay/256;
            $self->{hello_time} = $hello_time/256;
        }
    }
    # Return a blessed object

    bless($self, $class);
    return $self;
}

#
# Strip header from packet and return the data contained in it.  Spanning
# Tree packets contain no encapsulated data.
#

undef &st_strip;        # Create st_strip alias
*st_strip = \&strip;

sub strip {
    return undef;
}

#
# Encode a packet
#

sub encode {
    my ($self, $data) = @_;
    my $defaults = {
        protocol_id => 0,
        protocol_version => 0,
        bpdu_type => 0,
        topology_change_ack => 1,
        root_priority => 32768,
        bridge_priority => 32768,
        port_priority => 128,
        port_num => 1,
        root_mac => "000000000000",
        root_path_cost => 10,
        bridge_mac => "000000000000",
        message_age => 0,
        max_age => 20,
        hello_time => 2,
        forward_delay => 15,
        topology_change => 0,
    };

    my $packStruct = {
        1 => { 'protocol_id' => 'n' },
        2 => { 'protocol_version' => 'H2' },
        3 => { 'bpdu_type' => 'H2' },
        4 => { 'bpdu_flags' => 'B8' },
        5 => { 'root_priority' => 'n' },
        6 => { 'root_mac' => 'H12' },
        7 => { 'root_path_cost' => 'N', },
        8 => { 'bridge_priority' => 'n', },
        9 => { 'bridge_mac' => 'H12', },
        10 => { 'port_id' => 'H4', },
        12 => { 'message_age' => 'n', },
        13 => { 'max_age' => 'n', },
        14 => { 'hello_time' => 'n', },
        15 => { 'forward_delay' => 'n', },
    };


    #
    # Ensure all required parameters are passed, and those that aren't
    # are defaulted.
    #
    foreach my $name (keys %$defaults) {
        if (defined $data->{$name}) {
            next;
        } else {
            if (defined $defaults->{$name}) { # We have a default...
                $data->{$name} = $defaults->{$name};
            } else {
                die "$name parameter is required to encode spanning tree\n";
            }
        }
    }


    $data->{bpdu_type} = sprintf("%02lx", $data->{bpdu_type});
    if ($data->{bpdu_type} eq "80") { # topo change notification
        return pack("nH2H2", $data->{protocol_id},
                    $data->{protocol_version},
                    $data->{bpdu_type});
    }

    #
    # Build a port ID from the number and priority.
    #

    $data->{port_id} = sprintf("%02lx%02lx",
                               $data->{port_priority},
                               $data->{port_num});
    #
    # Build the Bridge PDU flags.
    #
    if ($data->{bpdu_type} == 0) {
        $data->{bpdu_flags} = $data->{topology_change_ack} . "000000" .
            $data->{topology_change};
    } elsif ($data->{bpdu_type} == 2) {
        my $prole2=$data->{port_role} % 2;
        my $prole1=int ($data->{port_role}/2);
        $data->{bpdu_flags} = $data->{topology_change_ack} .
            $data->{agreement} .
            $data->{forwarding} .
            $data->{learning} .
            $prole1 .
            $prole2 .
            $data->{proposal} .
            $data->{topology_change};
    }

    #
    # Invert the message age for encoding.
    #

    foreach my $name qw(message_age hello_time max_age forward_delay) {
        $data->{$name} = $data->{$name} * 256;
    }

    my $packed_data = "";
    foreach my $key (sort { $a <=> $b; } keys %$packStruct) {
        foreach my $subkey (keys %{$packStruct->{$key}}) {
            $packed_data .= pack ($packStruct->{$key}{$subkey},
                                  $data->{$subkey});
        }
    }

    if ($data->{bpdu_type} == 2) { # Rapid Spanning Tree
        my $len = sprintf("%02lx", $data->{version_1_length});
        $packed_data .= pack('H2', $len);
    }

    #
    # Put back the message age.
    #
    foreach my $name qw(message_age hello_time max_age forward_delay) {
        $data->{$name} = $data->{$name} / 256;
    }
    $data->{bpdu_type} = hex ($data->{bpdu_type});
    return $packed_data;
}

#
# Module return value
#
1;

# autoloaded methods go after the END token (&& pod) below

__END__