File Coverage

blib/lib/Net/SIP/Dropper.pm
Criterion Covered Total %
statement 25 26 96.1
branch 3 4 75.0
condition 2 5 40.0
subroutine 7 7 100.0
pod 1 2 50.0
total 38 44 86.3


line stmt bran cond sub pod time code
1              
2             =head1 NAME
3              
4             Net::SIP::Dropper - drops SIP messages based on callback
5              
6             =head1 SYNOPSIS
7              
8             use Net::SIP::Dropper::ByIPPort;
9             my $drop_by_ipport = Net::SIP::Dropper::ByIPPort->new(
10             database => '/path/to/database.drop',
11             methods => [ 'REGISTER', '...', '' ],
12             attempts => 10,
13             interval => 60,
14             );
15              
16             use Net::SIP::Dropper::ByField;
17             my $drop_by_field = Net::SIP::Dropper::ByField->new(
18             methods => [ 'REGISTER', '...', '' ],
19             'From' => qr/sip(?:vicious|sscuser)/,
20             'User-Agent' => qr/^friendly-scanner$/,
21             );
22              
23             my $drop_subscribe = sub {
24             my ($packet,$leg,$from) = @_;
25             # drop all subscribe requests and responses
26             return $packet->method eq 'SUBSCRIBE' ? 1:0;
27             };
28              
29             my $dropper = Net::SIP::Dropper->new(
30             cbs => [ $drop_by_ipport, $drop_by_field, $drop_subscribe ]);
31              
32             my $chain = Net::SIP::ReceiveChain->new(
33             [ $dropper, ... ]
34             );
35              
36             =head1 DESCRIPTION
37              
38             Drops messages. This means, does no further processing in the Net::SIP chain
39             and does not send something back if the incoming message match the
40             settings.
41              
42             Some useful droppers are defined in L and
43             L.
44              
45             =head1 CONSTRUCTOR
46              
47             =over 4
48              
49             =item new ( ARGS )
50              
51             ARGS is a hash with key C I C. C is a single callback to be
52             processed, C is an arrayref with callbacks. If one of the callbacks returns
53             true the message will be dropped. If all callbacks return false the message will
54             be forwarded in the chain.
55              
56             Returns a new dropper object to be used in the chain.
57              
58              
59             =back
60              
61             =cut
62              
63 3     3   1074 use strict;
  3         8  
  3         68  
64 3     3   14 use warnings;
  3         4  
  3         89  
65              
66             package Net::SIP::Dropper;
67              
68 3     3   14 use fields qw( cbs );
  3         5  
  3         13  
69 3     3   141 use Carp 'croak';
  3         19  
  3         134  
70 3     3   24 use Net::SIP::Util qw( invoke_callback );
  3         6  
  3         647  
71              
72              
73             ################################################################################
74             # creates new Dropper object
75             # Args: ($class,%args)
76             # %args:
77             # One of cb or cbs must be set.
78             # cb: A single callback. Will be ignored if cbs is also set.
79             # cbs: An arrayref with callbacks.
80             # Returns: Net::SIP::Dropper object
81             ################################################################################
82             sub new {
83 1     1 1 36 my ($class, %args) = @_;
84 1         5 my Net::SIP::Dropper $self = fields::new($class);
85              
86 1 50 33     75 croak('argument cb or cbs must exist') unless $args{cb} || $args{cbs};
87 1   50     5 $self->{cbs} = $args{cbs} || [ $args{cb} ];
88 1         3 return $self;
89             }
90              
91              
92             ################################################################################
93             # Drops SIP-messages excluded by the settings
94             # Args: ($self,$packet,$leg,$from)
95             # args as usual for sub receive
96             # Returns: 1 (stop chain) | (proceed in chain)
97             ################################################################################
98             sub receive {
99 2     2 0 4 my Net::SIP::Dropper $self = shift;
100 2         5 my ($packet, $leg, $from) = @_;
101              
102 2         4 for (@{ $self->{cbs} }) {
  2         6  
103 4 100       14 return 1 if invoke_callback($_, $packet, $leg, $from);
104             }
105 0           return;
106             }
107              
108              
109              
110             1;