File Coverage

blib/lib/Net/SIP/Dropper/ByField.pm
Criterion Covered Total %
statement 31 38 81.5
branch 3 12 25.0
condition n/a
subroutine 7 7 100.0
pod 2 2 100.0
total 43 59 72.8


line stmt bran cond sub pod time code
1              
2             =head1 NAME
3              
4             Net::SIP::Dropper::ByField - drops SIP messages based on fields in SIP header
5              
6             =head1 SYNOPSIS
7              
8             my $drop_by_field = Net::SIP::Dropper::ByField->new(
9             methods => [ 'REGISTER', '...', '' ],
10             'From' => qr/sip(?:vicious|sscuser)/,
11             'User-Agent' => qr/^friendly-scanner$/,
12             );
13              
14             my $dropper = Net::SIP::Dropper->new( cb => $drop_by_field );
15             my $chain = Net::SIP::ReceiveChain->new([ $dropper, ... ]);
16              
17             =head1 DESCRIPTION
18              
19             With C one can drop packets based on the contents of
20             the fields in the SIP header. This can be used to drop specific user agents.
21              
22             =cut
23              
24              
25 3     3   1117 use strict;
  3         6  
  3         74  
26 3     3   13 use warnings;
  3         4  
  3         121  
27              
28             package Net::SIP::Dropper::ByField;
29 3     3   18 use Net::SIP::Util 'invoke_callback';
  3         4  
  3         127  
30 3     3   15 use Net::SIP::Debug;
  3         6  
  3         13  
31 3     3   17 use fields qw(fields methods);
  3         4  
  3         38  
32              
33             =head1 CONSTRUCTOR
34              
35             =over 4
36              
37             =item new ( ARGS )
38              
39             ARGS is a hash with the following keys:
40              
41             =over 8
42              
43             =item methods
44              
45             Optional argument to restrict dropping to specific methods.
46              
47             Is array reference of method names, if one of the names is empty also responses
48             will be considered. If not given all packets will be checked.
49              
50             =item field-name
51              
52             Any argument other then C will be considered a field name.
53             The value is a callback given to C, like for instance a Regexp.
54              
55             =back
56              
57             =back
58              
59             =cut
60              
61             sub new {
62 1     1 1 34 my ($class,%fields) = @_;
63 1         2 my $methods = delete $fields{methods}; # optional
64              
65             # initialize object
66 1         3 my Net::SIP::Dropper::ByField $self = fields::new($class);
67 1         64 $self->{methods} = $methods;
68 1         4 $self->{fields} = [ map { ($_,$fields{$_}) } keys %fields ];
  1         4  
69              
70 1         3 return $self
71             }
72              
73             =head1 METHODS
74              
75             =over 4
76              
77             =item run ( PACKET, LEG, FROM )
78              
79             This method is called as a callback from the L object.
80             It returns true if the packet should be dropped, e.g. if at least one
81             of the in the constructor specified fields matches the specified value.
82              
83             =back
84              
85             =cut
86              
87             sub run {
88 2     2 1 4 my Net::SIP::Dropper::ByField $self = shift;
89 2         5 my ($packet,$leg,$from) = @_;
90              
91             # check if the packet type/method fits
92 2 50       6 if (my $m = $self->{methods}) {
93 0 0       0 if ($packet->is_response) {
94 0 0       0 return if ! grep { !$_ } @$m
  0         0  
95             } else {
96 0         0 my $met = $packet->method;
97 0 0       0 return if ! grep { $_ eq $met } @$m
  0         0  
98             }
99             };
100              
101 2         4 my $f = $self->{fields};
102 2         6 for(my $i=0;$i<@$f;$i+=2) {
103 2 50       18 my @v = $packet->get_header($f->[$i]) or next;
104 2 50       9 if ( invoke_callback( $f->[$i+1],@v) ) {
105 2         16 DEBUG(1,"message dropped because of header field <$f->[$i]> =~ ".$f->[$i+1]);
106 2         9 return 1;
107             }
108             }
109 0           return;
110             }
111              
112             1;