File Coverage

blib/lib/Net/ACL/Match/Prefix.pm
Criterion Covered Total %
statement 46 49 93.8
branch 15 24 62.5
condition 4 9 44.4
subroutine 10 11 90.9
pod 4 4 100.0
total 79 97 81.4


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             # $Id: Prefix.pm,v 1.9 2003/06/06 18:45:02 unimlo Exp $
4              
5             package Net::ACL::Match::Prefix;
6              
7 2     2   21010 use strict;
  2         4  
  2         76  
8 2     2   11 use vars qw( $VERSION @ISA );
  2         4  
  2         146  
9              
10             ## Inheritance and Versioning ##
11              
12             @ISA = qw( Net::ACL::Match::IP );
13             $VERSION = '0.07';
14              
15             ## Module Imports ##
16              
17 2     2   11 use Carp;
  2         5  
  2         151  
18 2     2   830 use Net::ACL::Match::IP;
  2         4  
  2         80  
19 2     2   11 use Net::ACL::Rule qw( :rc );
  2         4  
  2         201  
20 2     2   12 use Scalar::Util qw(blessed);
  2         5  
  2         108  
21 2     2   13 use Net::Netmask;
  2         2  
  2         1364  
22              
23             ## Public Class Methods ##
24              
25             sub new
26             {
27 8     8 1 2977 my $proto = shift;
28 8   33     39 my $class = ref $proto || $proto;
29 8         12 my $size;
30 8         12 my $mode = 0;
31 8         18 my @arg = @_;
32 8 100       56 if ($arg[$#arg] =~ s/\W*([gl]e)\W+(\d+)$//i)
33             {
34 3         9 $mode = lc($1);
35 3         7 $size = $2;
36 3 50       11 pop(@arg) if $arg[$#arg] eq '';
37             };
38             # How to do this with out hardcoding name? This doesn't work!
39             # my $this = SUPER::new(@arg);
40 8         39 my $this = new Net::ACL::Match::IP(@arg);
41 8         19 $this->{_size} = $size;
42 8         12 $this->{_mode} = $mode;
43 8         54 return bless($this,$class);
44             };
45              
46             ## Public Object Methods ##
47              
48             sub match
49             {
50 16     16 1 968 my $this = shift;
51 16         62 my $other = $_[$this->index];
52 16 50 33     117 $other = (blessed $other && $other->isa('Net::Netmask')) ? $other : new Net::Netmask($other);
53              
54 16 100       1226 unless ($this->{_mode})
55             { # Normal mode of operation!
56 4 100 66     17 return ($this->{_net}->base eq $other->base)
57             && ($this->{_net}->bits == $other->bits) ? ACL_MATCH : ACL_NOMATCH;
58             };
59 12 100       50 return ACL_NOMATCH unless $this->{_net}->match($other->base); # Not within!
60 9 50       410 return ACL_NOMATCH if $this->{_net}->bits > $other->bits; # Larger then this!
61 9 50       103 return ACL_MATCH if $this->{_size} == $other->bits; # Right size!
62 9 100       73 return ($this->{_size} < $other->bits) == ($this->{_mode} eq 'ge') ? ACL_MATCH : ACL_NOMATCH;
63             }
64              
65             sub mode
66             {
67 4     4 1 5 my $this = shift;
68 4 0       18 $this->{_mode} = @_ ? (shift =~ /([lg]e)/ ? $1 : 0) : $this->{_mode};
    50          
69 4         15 return $this->{_mode};
70             }
71              
72             sub size
73             {
74 0     0 1   my $this = shift;
75 0 0         $this->{_size} = @_ ? shift : $this->{_size};
76 0           return $this->{_size};
77             }
78              
79             ## POD ##
80              
81             =pod
82              
83             =head1 NAME
84              
85             Net::ACL::Match::Prefix - Class matching IP network prefixes.
86              
87             =head1 SYNOPSIS
88              
89             use Net::ACL::Match::Prefix;
90              
91             # Constructor
92             $match = new Net::ACL::Match::Prefix('10.0.0.0/8');
93             $match = new Net::ACL::Match::Prefix('10.0.0.0/8 ge 25');
94              
95             # Accessor Methods
96             $rc = $match->match('10.0.0.0/16'); # ACL_NOMATCH
97             $rc = $match->match('127.0.0.0/8'); # ACL_NOMATCH
98             $rc = $match->match('10.0.0.0/8'); # ACL_MATCH
99              
100             =head1 DESCRIPTION
101              
102             This module is just a wrapper of the Net::Netmask module to allow it to
103             operate automatically with L.
104              
105             =head1 CONSTRUCTOR
106              
107             =over 4
108              
109             =item new() - create a new Net::ACL::Match::Prefix object
110              
111             $match = new Net::ACL::Match::Prefix(0,'10.0.0.0/8');
112              
113             This is the constructor for Net::ACL::Match::Prefix objects. It returns a
114             reference to the newly created object. The first argument is the argument
115             number of the match function that should be matched.
116              
117             Normally the remaining arguments is parsed directly to the constructor of
118             Net::Netmask. However if the last argument matches /(le|ge) \d+$/, the suffix
119             will be removed before the Net::Netmask constructor is called and the digits
120             will be used only allow prefixes greater then or equal (ge) OR less then or
121             equal (le) then that prefix length to match.
122              
123             =back
124              
125             =head1 ACCESSOR METHODS
126              
127             =over 4
128              
129             =item match()
130              
131             The method uses Net::Netmask to verify that the base address and the size of
132             the prefixes are the same.
133              
134             =item mode()
135              
136             This method returns the mode of the prefix match object. The mode could be
137             either 0 (normal), C for less then or equal compare, or C for
138             greater then or equal compare. If called with a value, the mode is
139             changed to that value.
140              
141             =item size()
142              
143             This method returns the size of the prefix to be matched if mode is C or
144             C. If called with a value, the size is changed to that value.
145              
146             =back
147              
148             =head1 EXAMPLES
149              
150             my $norm = new Net::ACL::Match::Prefix(0,'10.0.0.0/8');
151             my $ge24 = new Net::ACL::Match::Prefix(0,'10.0.0.0/8 ge 24');
152             my $le24 = new Net::ACL::Match::Prefix(0,'10.0.0.0/8 1e 24');
153              
154             $norm->match('10.0.0.0/8') == ACL_MATCH
155             $ge24->match('10.0.0.0/8') == ACL_MATCH
156             $le24->match('10.0.0.0/8') == ACL_MATCH
157             $norm->match('10.1.0.0/16') == ACL_NOMATCH
158             $ge24->match('10.1.0.0/16') == ACL_MATCH
159             $le24->match('10.1.0.0/16') == ACL_MATCH
160              
161             =head1 SEE ALSO
162              
163             Net::Netmask, Net::ACL,
164             Net::ACL::Rule, Net::ACL::Match::IP, Net::ACL::Match
165              
166             =head1 AUTHOR
167              
168             Martin Lorensen
169              
170             =cut
171              
172             ## End Package Net::ACL::Match::Prefix ##
173            
174             1;