File Coverage

blib/lib/Net/BGP/ASPath/AS.pm
Criterion Covered Total %
statement 105 123 85.3
branch 40 56 71.4
condition 19 22 86.3
subroutine 13 16 81.2
pod 0 6 0.0
total 177 223 79.3


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package Net::BGP::ASPath::AS;
4 7     7   3116 use bytes;
  7         81  
  7         47  
5              
6 7     7   222 use strict;
  7         15  
  7         144  
7 7     7   34 use Carp;
  7         13  
  7         380  
8 7     7   38 use Exporter;
  7         14  
  7         254  
9 7         515 use vars qw(
10             $VERSION @ISA
11 7     7   37 );
  7         42  
12              
13             use overload
14 7         75 '<=>' => \&compare,
15             '""' => \&as_string,
16 7     7   41 'fallback' => 1;
  7         13  
17              
18             # DO NOT OVERLOAD @{} - it's an array - we need this!
19              
20             $VERSION = '0.18';
21              
22 7     7   3164 use Net::BGP::Notification qw( :errors );
  7         18  
  7         11412  
23              
24             @Net::BGP::ASPath::AS_SEQUENCE::ISA = qw( Exporter );
25              
26             ## BGP AS_PATH Path Attribute Type Classes ##
27              
28             my @BGP_PATH_ATTR_CLASS = (
29             undef, # unused
30             'Net::BGP::ASPath::AS_SET', # BGP_PATH_ATTR_AS_SET
31             'Net::BGP::ASPath::AS_SEQUENCE', # BGP_PATH_ATTR_AS_SEQUENCE
32             'Net::BGP::ASPath::AS_CONFED_SEQUENCE', # BGP_PATH_ATTR_AS_CONFED_SEQUENCE
33             'Net::BGP::ASPath::AS_CONFED_SET' # BGP_PATH_ATTR_AS_CONFED_SET
34             );
35              
36             ## Public Class Methods ##
37              
38             sub new {
39 664     664 0 3162 my ($class, $value) = (shift, shift);
40              
41 664 50       1365 return $value->clone if (ref $value) =~ /^Net::BGP::ASPath::AS_/;
42              
43 664         964 my ($this, $realclass);
44              
45 664 100       1117 $value = '' unless defined($value);
46              
47 664 50       1213 if (ref $value eq 'HASH') {
48              
49             # Construct SET from HASH
50 0 0       0 croak "Hash argument given for a non-set AS_PATH element"
51             unless $class =~ /_SET$/;
52 0         0 $this->{ keys %{$value} } = values(%{$value});
  0         0  
  0         0  
53 0         0 bless($this, $class);
54 0         0 return $this;
55             }
56              
57 664 100       1155 if (ref $value eq 'ARRAY') {
58              
59             # Construct SET from HASH
60 301 100       888 if ($class =~ /_SEQUENCE$/) {
61 208         276 push(@{$this}, @{$value});
  208         332  
  208         889  
62             } else {
63 93         171 $this = {};
64 93         126 foreach my $a (@{$value}) { $this->{$a} = 1; }
  93         164  
  229         420  
65             }
66 301         545 bless($this, $class);
67 301         1122 return $this;
68             }
69              
70 363 50       554 croak "Unknown argument type ("
71             . (ref $value)
72             . ") parsed as argument to AS_PATH construtor."
73             if (ref $value);
74              
75             # Only a scalar left - Parse string!
76 363         500 my $confed = '';
77 363 100 100     1191 if ( ($value =~ /^\((.*)\)$/)
      100        
78             || ($value eq '' && $class =~ /_CONFED_/))
79             {
80 134 100       345 $value = $1 if defined($1);
81 134         209 $confed = '_CONFED';
82             }
83 363 100 100     1591 if ( ($value =~ /^\{([0-9,]*)\}$/)
    50 100        
84             || ($value eq '' && $class =~ /_SET$/))
85             {
86 102 100       236 my $set = defined $1 ? $1 : $value;
87 102         194 $realclass = 'Net::BGP::ASPath::AS' . $confed . '_SET';
88 102         141 $this = {};
89 102         303 foreach my $a (split(/,/, $set)) { $this->{$a} = 1; }
  270         491  
90             } elsif ($value =~ /^[0-9 ]*$/) {
91 261         534 $realclass = 'Net::BGP::ASPath::AS' . $confed . '_SEQUENCE';
92 261         1381 $this = [ split(' ', $value) ];
93             } else {
94 0         0 croak "$value is not a valid AS_PATH segment";
95             }
96              
97 363 50 66     1261 croak "AS_PATH segment is a $realclass but was constructed as $class"
98             if $class !~ /::AS$/ && $class ne $realclass;
99              
100 363         608 bless($this, $realclass);
101 363         833 return ($this);
102             }
103              
104             sub _new_from_msg
105              
106             # Constructor - returns object AND buffer with data removed
107             {
108 44     44   105 my ($class, $buffer, $args) = @_;
109              
110 44 50       89 if (!defined($args)) { $args = {}; }
  0         0  
111 44   100     156 $args->{as4} ||= 0;
112              
113 44 100       81 my $size = $args->{as4} ? 4 : 2;
114              
115 44         149 my ($type, $len) = unpack('CC', $buffer);
116              
117 44 50       129 if ( ($len * $size + 2) > length($buffer)) {
118 0         0 Net::BGP::Notification->throw(
119             ErrorCode => BGP_ERROR_CODE_UPDATE_MESSAGE,
120             ErrorSubCode => BGP_ERROR_SUBCODE_BAD_AS_PATH
121             );
122             }
123              
124 44         67 my @list;
125 44 100       84 if ($args->{as4}) {
126 9         37 @list = unpack('N*', substr($buffer,2,(4*$len)) );
127             } else {
128 35         132 @list = unpack('n*', substr($buffer,2,(2*$len)) );
129             }
130 44         95 $class = $BGP_PATH_ATTR_CLASS[$type];
131              
132 44 100       106 if (length($buffer) > 2+($size*$len)) {
133 10         21 $buffer = substr($buffer, 2+($size*$len));
134             } else {
135 34         65 $buffer = '';
136             }
137 44         167 return ($class->new(\@list), $buffer);
138             }
139              
140             # This encodes the standard AS Path
141             # TODO: Note that if AS4 != True, then there is an issue with this code.
142             # In particular, it will stick 23456 into the confederation types. In
143             # theory, no confederation using AS4 should be transmitting confed types
144             # to any node that is NOT using AS4, per RFC4893.
145             #
146             # But when this breaks the internet, it's not my fault.
147             sub _encode {
148 35     35   70 my ($this, $args) = @_;
149 35 50       78 if (!defined($args)) { $args = {}; }
  0         0  
150 35   100     130 $args->{as4} ||= 0;
151              
152 35         105 my $list = $this->asarray;
153 35         54 my $len = scalar @{$list};
  35         58  
154 35         92 my $type = $this->type;
155              
156 35         50 my $msg;
157 35 100       79 if (!($args->{as4})) {
158 29         81 $msg = pack('CC', $type, $len);
159 29         41 foreach my $as ( @{$list} ) {
  29         52  
160 371 100       702 $msg .= ($as <= 65535) ? pack('n', $as) : pack('n', 23456);
161             }
162             } else {
163 6         10 $msg = pack('CCN*', $type, $len, @{$list});
  6         22  
164             }
165              
166 35         131 return $msg;
167             }
168              
169             # Determines if the path element has any ASNs > 23456
170             sub _has_as4 {
171 33     33   58 my ($this) = @_;
172            
173 33 100       120 if ( ref($this) =~ /_CONFED_/) {
174             # No confeds in AS4_ paths
175 10         35 return 0;
176             }
177              
178 23         51 my $list = $this->asarray;
179 23         39 foreach my $as ( @{$list} ) {
  23         42  
180 342 100       581 if ($as > 65535) { return 1; }
  6         25  
181             }
182              
183 17         61 return 0;
184             }
185              
186             sub compare {
187 0     0 0 0 my ($this, $other) = @_;
188 0 0       0 return undef unless defined($other);
189 0         0 return $this->length <=> $other->length;
190             }
191              
192             sub clone {
193 253     253 0 356 my $proto = shift;
194 253   33     522 my $class = ref $proto || $proto;
195 253 50       456 $proto = shift unless ref $proto;
196              
197 253         347 my $clone;
198 253 100       690 if ($class =~ /_SET$/) {
199 81         105 return $class->new([ keys %{$proto} ]);
  81         315  
200             } else {
201 172         218 return $class->new([ @{$proto} ]); # Unblessed!
  172         826  
202             }
203             }
204              
205             sub asstring {
206 0     0 0 0 my $this = shift;
207 0         0 return $this->as_string(@_);
208             }
209              
210             sub as_string {
211 8     8 0 11 my $this = shift;
212 8 50       21 croak 'Instance of ASPath::AS should not exist!'
213             if (ref $this eq 'Net::BGP::ASPath::AS');
214 8         19 return $this->as_string;
215             }
216              
217             sub asarray {
218 0     0 0   my $this = shift;
219 0 0         croak 'Instance of ASPath::AS should not exist!'
220             if (ref $this eq 'Net::BGP::ASPath::AS');
221 0           return $this->asarray;
222             }
223              
224             1;