File Coverage

blib/lib/Net/SIP/Leg.pm
Criterion Covered Total %
statement 215 262 82.0
branch 93 166 56.0
condition 53 118 44.9
subroutine 30 33 90.9
pod 12 16 75.0
total 403 595 67.7


line stmt bran cond sub pod time code
1             ###########################################################################
2             # package Net::SIP::Leg
3             # a leg is a special kind of socket, which can send and receive SIP packets
4             # and manipulate transport relevant SIP header (Via,Record-Route)
5             ###########################################################################
6              
7 43     43   240 use strict;
  43         62  
  43         965  
8 43     43   174 use warnings;
  43         56  
  43         1408  
9              
10             package Net::SIP::Leg;
11 43     43   230 use Digest::MD5 'md5_hex';
  43         92  
  43         2472  
12 43     43   21876 use Socket;
  43         131520  
  43         16415  
13 43     43   16413 use Net::SIP::Debug;
  43         97  
  43         218  
14 43     43   18233 use Net::SIP::Util ':all';
  43         130  
  43         8601  
15 43     43   20406 use Net::SIP::SocketPool;
  43         117  
  43         235  
16 43     43   274 use Net::SIP::Packet;
  43         78  
  43         836  
17 43     43   18751 use Net::SIP::Request;
  43         91  
  43         1301  
18 43     43   17296 use Net::SIP::Response;
  43         101  
  43         1064  
19 43     43   232 use Errno qw(EHOSTUNREACH EINVAL);
  43         77  
  43         1868  
20 43     43   217 use Hash::Util 'lock_ref_keys';
  43         61  
  43         388  
21 43     43   2002 use Carp;
  43         76  
  43         1970  
22              
23 43     43   210 use fields qw(contact branch via proto src socketpool);
  43         72  
  43         240  
24              
25             # sock: the socket for the leg
26             # src: hash addr,port,family where it receives data and sends data from
27             # proto: udp|tcp
28             # contact: to identify myself (default from addr:port)
29             # branch: base for branch-tag for via header
30             # via: precomputed part of via value
31              
32             ###########################################################################
33             # create a new leg
34             # Args: ($class,%args)
35             # %args: hash, the following keys will be used and deleted from hash
36             # proto: udp|tcp|tls. If not given will be determined from 'sock' or will
37             # default to 'udp' or 'tls' (if 'tls' arg is used)
38             # host,addr,port,family: source of outgoing and destination of
39             # incoming data.
40             # If IP address addr not given these values will be determined from
41             # 'sock'. Otherwise port will default to 5060 or 5061 (tls) and family
42             # will be determined from addr syntax. host will default to addr
43             # dst: destination for this leg in case a fixed destination is used
44             # if not given 'sock' will be checked if connected
45             # sock: socket which can just be used
46             # if not given will create new socket based on proto, addr, port
47             # if dst is given this new socket will be connected (udp only)
48             # socketpool: socketpool which can just be used
49             # if not given a new SocketPool object will be created based on the given
50             # 'sock' or the created socket (addr, port...). 'sock' and 'socketpool'
51             # must not be given both.
52             # tls: optional configuration parameters for IO::Socket::SSL. Implies
53             # use of proto 'tls'.
54             # contact: contact information
55             # default will be based on addr and port
56             # branch: branch informaton
57             # default will be based on proto, addr, port
58             # Returns: $self - new leg object
59             ###########################################################################
60             sub new {
61 143     143 1 58940 my ($class,%args) = @_;
62 143         1745 my $self = fields::new($class);
63              
64 143         23139 my $proto = delete $args{proto};
65 143         412 my $dst = delete $args{dst};
66 143         532 my $tls = delete $args{tls};
67 143 100 50     1479 $proto ||= 'tls' if $tls;
68              
69 143 100 100     1190 my ($sip_proto,$default_port) = $proto && $proto eq 'tls'
70             ? ('sips',5061) : ('sip',5060);
71              
72 143         370 my $family;
73 143         358 my $host = delete $args{host};
74 143 100       845 if (my $addr = delete $args{addr}) {
75 4         6 my $port = delete $args{port};
76 4         7 my $family = delete $args{family};
77 4 50       10 if (!$family) {
78 4         14 ($addr,my $port_a, $family) = ip_string2parts($addr);
79 4 50 66     16 die "port given both as argument and contained in address"
      33        
80             if $port && $port_a && $port != $port_a;
81 4 50       8 $port = $port_a if $port_a;
82             }
83             # port defined and 0 -> get port from system
84 4 50       8 $port = $default_port if ! defined $port;
85 4   33     26 $self->{src} = lock_ref_keys({
86             host => $host || $addr,
87             addr => $addr,
88             port => $port,
89             family => $family
90             });
91             }
92              
93 143 50 33     1031 if ($dst && !ref($dst)) {
94 0         0 my ($ip,$port,$family) = ip_string2parts($dst);
95 0 0       0 $family or die "destination must contain IP address";
96 0         0 $dst = lock_ref_keys({
97             host => $ip,
98             addr => $ip,
99             port => $port,
100             family => $family,
101             });
102             }
103              
104 143         330 my $sock = delete $args{sock};
105 143         344 my $socketpool = delete $args{socketpool};
106 143 50 66     1071 die "only socketpool or sock should be given" if $sock && $socketpool;
107 143   33     435 $sock ||= $socketpool && $socketpool->master;
      66        
108              
109 143         363 my $sockpeer = undef;
110 143 100       465 if (!$sock) {
111             # create new socket
112 3   50     10 $proto ||= 'udp';
113 3         4 my $src = $self->{src};
114 3 50       16 if (!$src) {
115             # no src given, try to get useable soure from dst
116 0 0       0 die "neither source, destination nor socket given" if !$dst;
117 0 0       0 my $srcip = laddr4dst($dst->{addr}) or die
118             "cannot find local IP when connecting to $dst->{addr}";
119             $src = $self->{src} = lock_ref_keys({
120             host => $host || $srcip,
121             addr => $srcip,
122             port => 0,
123             family => $dst->{family},
124 0   0     0 });
125             }
126              
127 3 50       9 croak("addr must be IP address") if ! ip_is_v46($src->{addr});
128              
129             my %sockargs = (
130             Proto => $proto eq 'tls' ? 'tcp' : $proto,
131             Family => $src->{family},
132             LocalAddr => $src->{addr},
133 3 50       15 Reuse => 1, ReuseAddr => 1,
134             );
135 3 50 33     13 if ($proto eq 'tcp' or $proto eq 'tls') {
    50          
136             # with TCP we create a listening socket
137 0         0 $sockargs{Listen} = 100;
138             } elsif ($dst) {
139             # with UDP we can create a connected socket if dst is given
140 0         0 $sockargs{PeerAddr} = $dst->{addr};
141 0   0     0 $sockargs{PeerPort} = $dst->{port} ||= $default_port;
142 0         0 $sockpeer = $dst;
143             }
144              
145             # create a socket with the given local port
146             # if no port is given try 5060,5062.. or let the system pick one
147 3 50       12 for my $port ($src->{port}
148             ? $src->{port}
149             : ($default_port, 5062..5100, 0)) {
150 3 50       11 last if $sock = INETSOCK(%sockargs, LocalPort => $port);
151             }
152              
153 3 50       1613 $sock or die "failed to bind to " . ip_parts2string($src).": $!";
154 3   33     17 $src->{port} ||= $sock->sockport;
155 3         140 DEBUG(90,"created socket on ".ip_parts2string($src));
156              
157             } else {
158             # get proto from socket
159 140 100 66     1922 $proto ||= $sock->socktype == SOCK_DGRAM ? 'udp':'tcp';
160              
161             # get src from socket
162 140 100       2168 if (!$self->{src}) {
163 139 50       1749 my $saddr = getsockname($sock) or die
164             "cannot get local name from provided socket: $!";
165 139         1246 $self->{src} = ip_sockaddr2parts($saddr);
166 139 50       559 $self->{src}{host} = $host if $host;
167             }
168 140 50 33     2706 if (!$dst and my $saddr = getpeername($sock)) {
169             # set dst from connected socket
170 0         0 $sockpeer = $dst = ip_sockaddr2parts($saddr);
171             }
172             }
173              
174             # create socketpool and add primary socket of leg to it if needed
175 143   33     3267 $self->{socketpool} = $socketpool ||= Net::SIP::SocketPool->new(
176             $proto, $sock, $dst, $sockpeer, $tls);
177              
178             my $leg_addr = ip_parts2string({
179 143         272 %{$self->{src}},
  143         2869  
180             use_host => 1, # prefer hostname
181             default_port => $default_port,
182             }, 1); # use "[ipv6]" even if no port is given
183 143   33     1015 $self->{contact} = delete $args{contact} || "$sip_proto:$leg_addr";
184              
185             $self->{branch} = 'z9hG4bK'. (
186             delete $args{branch}
187 143   33     889 || md5_hex(@{$self->{src}}{qw(addr port)}, $proto) # ip, port, proto
188             );
189              
190 143         873 $self->{via} = sprintf( "SIP/2.0/%s %s;branch=",
191             uc($proto),$leg_addr );
192 143         326 $self->{proto} = $proto;
193              
194 143 50       529 die "unhandled arguments: ".join(", ", keys %args) if %args;
195              
196 143         2267 return $self;
197             }
198              
199             ###########################################################################
200             # do we need retransmits on this leg?
201             # Args: $self
202             # Returns: 1|0
203             # 1: need retransmits (UDP)
204             # 0: don't need retransmits (TCP, TLS)
205             ###########################################################################
206             sub do_retransmits {
207 213     213 0 456 my Net::SIP::Leg $self = shift;
208 213 100       1410 return $self->{proto} eq 'udp' ? 1 : 0;
209             }
210              
211             ###########################################################################
212             # prepare incoming packet for forwarding
213             # Args: ($self,$packet)
214             # $packet: incoming Net::SIP::Packet, gets modified in-place
215             # Returns: undef | [code,text]
216             # code: error code (can be empty if just drop packet on error)
217             # text: error description (e.g max-forwards reached..)
218             ###########################################################################
219             sub forward_incoming {
220 7     7 1 10 my Net::SIP::Leg $self = shift;
221 7         11 my ($packet) = @_;
222              
223 7 50       15 if ( $packet->is_response ) {
224             # remove top via
225 0         0 my $via;
226             $packet->scan_header( via => [ sub {
227 0     0   0 my ($vref,$hdr) = @_;
228 0 0       0 if ( !$$vref ) {
229 0         0 $$vref = $hdr->{value};
230 0         0 $hdr->remove;
231             }
232 0         0 }, \$via ]);
233              
234             } else {
235             # Request
236              
237             # Max-Fowards
238 7         23 my $maxf = $packet->get_header( 'max-forwards' );
239             # we don't want to put somebody Max-Forwards: 7363535353 into the header
240             # and then crafting a loop, so limit it to the default value
241 7 100 66     26 $maxf = 70 if !$maxf || $maxf>70;
242 7         14 $maxf--;
243 7 50       21 if ( $maxf <= 0 ) {
244             # just drop
245 0         0 DEBUG( 10,'reached max-forwards. DROP' );
246 0         0 return [ undef,'max-forwards reached 0, dropping' ];
247             }
248 7         25 $packet->set_header( 'max-forwards',$maxf );
249              
250             # check if last hop was strict router
251             # remove myself from route
252 7         19 my $uri = $packet->uri;
253 7 50       21 $uri = $1 if $uri =~m{^<(.*)>};
254 7         19 ($uri) = sip_hdrval2parts( route => $uri );
255 7         15 my $remove_route;
256 7 50       26 if ( $uri eq $self->{contact} ) {
257             # last router placed myself into URI -> strict router
258             # get original URI back from last Route-header
259 0         0 my @route = $packet->get_header( 'route' );
260 0 0       0 if ( !@route ) {
261             # ooops, no route headers? -> DROP
262 0         0 return [ '','request from strict router contained no route headers' ];
263             }
264 0         0 $remove_route = $#route;
265 0         0 $uri = $route[-1];
266 0 0       0 $uri = $1 if $uri =~m{^<(.*)>};
267 0         0 $packet->set_uri($uri);
268              
269             } else {
270             # last router was loose,remove top route if it is myself
271 7         18 my @route = $packet->get_header( 'route' );
272 7 100       15 if ( @route ) {
273 1         2 my $route = $route[0];
274 1 50       6 $route = $1 if $route =~m{^<(.*)>};
275 1         11 ($route) = sip_hdrval2parts( route => $route );
276 1 50       5 if ( sip_uri_eq( $route,$self->{contact}) ) {
277             # top route was me
278 1         2 $remove_route = 0;
279             }
280             }
281             }
282 7 100       14 if ( defined $remove_route ) {
283             $packet->scan_header( route => [ sub {
284 2     2   3 my ($rr,$hdr) = @_;
285 2 100       15 $hdr->remove if $$rr-- == 0;
286 1         11 }, \$remove_route]);
287             }
288              
289             # Add Record-Route to request, except
290             # to REGISTER (RFC3261, 10.2)
291 7 50       19 $packet->insert_header( 'record-route', '<'.$self->{contact}.';lr>' )
292             if $packet->method ne 'REGISTER';
293             }
294              
295 7         50 return;
296             }
297              
298             ###########################################################################
299             # prepare packet which gets forwarded through this leg
300             # packet was processed before by forward_incoming on (usually) another
301             # leg on the same dispatcher.
302             # Args: ($self,$packet,$incoming_leg)
303             # $packet: outgoing Net::SIP::Packet, gets modified in-place
304             # $incoming_leg: leg where packet came in
305             # Returns: undef | [code,text]
306             # code: error code (can be empty if just drop packet on error)
307             # text: error description (e.g max-forwards reached..)
308             ###########################################################################
309             sub forward_outgoing {
310 7     7 1 13 my Net::SIP::Leg $self = shift;
311 7         17 my ($packet,$incoming_leg) = @_;
312              
313 7 50       17 if ( $packet->is_request ) {
314             # check if myself is already in Via-path
315             # in this case drop the packet, because a loop is detected
316 7 50       16 if ( my @via = $packet->get_header( 'via' )) {
317 7         19 my $branch = $self->via_branch($packet,3);
318 7         16 foreach my $via ( @via ) {
319 7         16 my (undef,$param) = sip_hdrval2parts( via => $via );
320             # ignore via header w/o branch, although these don't conform to
321             # RFC 3261, sect 8.1.1.7
322 7 50       20 defined $param->{branch} or next;
323 7 50       28 if ( substr( $param->{branch},0,length($branch) ) eq $branch ) {
324 0         0 DEBUG( 10,'loop detected because outgoing leg is in Via. DROP' );
325 0         0 return [ undef,'loop detected on outgoing leg, dropping' ];
326             }
327             }
328             }
329              
330             # Add Record-Route to request, except
331             # to REGISTER (RFC3261, 10.2)
332             # This is necessary, because these information are used in in new requests
333             # from UAC to UAS, but also from UAS to UAC and UAS should talk to this leg
334             # and not to the leg, where the request came in.
335             # don't add if the upper record-route is already me, this is the case
336             # when incoming and outgoing leg are the same
337 7 50       19 if ( $packet->method ne 'REGISTER' ) {
338 7         8 my $rr;
339 7 50 33     24 unless ( (($rr) = $packet->get_header( 'record-route' ))
340             and sip_uri_eq( $rr,$self->{contact} )) {
341 0         0 $packet->insert_header( 'record-route', '<'.$self->{contact}.';lr>' )
342             }
343             }
344              
345             # strip myself from route header, because I'm done
346 7 100       23 if ( my @route = $packet->get_header( 'route' ) ) {
347 1         2 my $route = $route[0];
348 1 50       8 $route = $1 if $route =~m{^<(.*)>};
349 1         4 ($route) = sip_hdrval2parts( route => $route );
350 1 50       5 if ( sip_uri_eq( $route,$self->{contact} )) {
351             # top route was me, remove it
352 0         0 my $remove_route = 0;
353             $packet->scan_header( route => [ sub {
354 0     0   0 my ($rr,$hdr) = @_;
355 0 0       0 $hdr->remove if $$rr-- == 0;
356 0         0 }, \$remove_route]);
357             }
358             }
359             }
360 7         23 return;
361             }
362              
363              
364             ###########################################################################
365             # deliver packet through this leg to specified addr
366             # add local Via header to requests
367             # Args: ($self,$packet,$dst;$callback)
368             # $packet: Net::SIP::Packet
369             # $dst: target for delivery as hash host,addr,port,family
370             # $callback: optional callback, if an error occurred the callback will
371             # be called with $! as argument. If no error occurred and the
372             # proto is tcp the callback will be called with error=0 to show
373             # that the packet was definitely delivered (and there's no need to retry)
374             ###########################################################################
375             sub deliver {
376 195     195 1 382 my Net::SIP::Leg $self = shift;
377 195         531 my ($packet,$dst,$callback) = @_;
378              
379 195         946 my $isrq = $packet->is_request;
380 195 100       545 if ( $isrq ) {
381             # add via,
382             # clone packet, because I don't want to change the original
383             # one because it might be retried later
384             # (could skip this for tcp?)
385 117         875 $packet = $packet->clone;
386 117         1278 $self->add_via($packet);
387             }
388              
389             # 2xx responses to INVITE requests and the request itself must have a
390             # Contact, Allow and Supported header, 2xx Responses to OPTIONS need
391             # Allow and Supported, 405 Responses should have Allow and Supported
392              
393 195         425 my ($need_contact,$need_allow,$need_supported);
394 195         598 my $method = $packet->method;
395 195   66     1069 my $code = ! $isrq && $packet->code;
396 195 100 100     2622 if ( $method eq 'INVITE' and ( $isrq or $code =~m{^2} )) {
    100 100        
      66        
      66        
397 61         185 $need_contact = $need_allow = $need_supported =1;
398             } elsif ( !$isrq and (
399             $code == 405 or
400             ( $method eq 'OPTIONS' and $code =~m{^2} ))) {
401 1         3 $need_allow = $need_supported =1;
402             }
403 195 100 66     1519 if ( $need_contact && ! ( my @a = $packet->get_header( 'contact' ))) {
404             # needs contact header, create from this leg and user part of from/to
405 61 100       236 my ($user) = sip_hdrval2parts( $isrq
406             ? ( from => scalar($packet->get_header('from')) )
407             : ( to => scalar($packet->get_header('to')) )
408             );
409 61         781 my ($proto,$addr) = $self->{contact} =~m{^(\w+):(?:.*\@)?(.*)$};
410 61 50       940 my $contact = ( $user =~m{([^<>\@\s]+)\@} ? $1 : $user ).
411             "\@$addr";
412 61 100       564 $contact = $proto.':'.$contact if $contact !~m{^\w+:};
413 61 50       199 $contact = "<$contact>" if $contact =~m{;};
414 61         435 $packet->insert_header( contact => $contact );
415             }
416 195 100 66     951 if ( $need_allow && ! ( my @a = $packet->get_header( 'allow' ))) {
417             # insert default methods
418 62         176 $packet->insert_header( allow => 'INVITE, ACK, OPTIONS, CANCEL, BYE' );
419             }
420 195 100 66     883 if ( $need_supported && ! ( my @a = $packet->get_header( 'supported' ))) {
421             # set as empty
422 62         180 $packet->insert_header( supported => '' );
423             }
424              
425             die "target protocol $dst->{proto} does not match leg $self->{proto}"
426 195 50 33     1322 if exists $dst->{proto} && $dst->{proto} ne $self->{proto};
427 195 0 33     841 $dst->{port} ||= $self->{proto} eq 'tls' ? 5061 : 5060;
428              
429             $DEBUG && DEBUG( 2, "delivery with %s from %s to %s:\n%s",
430             $self->{proto},
431 195 50       540 ip_parts2string($self->{src}),
432             ip_parts2string($dst),
433             $packet->dump( Net::SIP::Debug->level -2 ) );
434              
435 195         1196 return $self->sendto($packet,$dst,$callback);
436             }
437              
438             ###########################################################################
439             # send data to peer
440             # Args: ($self,$packet,$dst,$callback)
441             # $packet: SIP packet object
442             # $dst: target as hash host,addr,port,family
443             # $callback: callback for error|success, see method deliver
444             # Returns: $success
445             # $success: true if no problems occurred while sending (this does not
446             # mean that the packet was delivered reliable!)
447             ###########################################################################
448             sub sendto {
449 194     194 0 371 my Net::SIP::Leg $self = shift;
450 194         566 my ($packet,$dst,$callback) = @_;
451              
452 194 50       1186 $self->{socketpool}->sendto($packet,$dst,$callback)
453             && return 1;
454 194         2017 return;
455             }
456              
457             ###########################################################################
458             # Handle newly received packet.
459             # Currently just passes through the packet
460             # Args: ($self,$packet,$from)
461             # $packet: packet object
462             # $from: hash with proto,addr,port,family where the packet came from
463             # Returns: ($packet,$from)|()
464             # $packet: packet object
465             # $from: hash with proto,ip,port,family where the packet came from
466             ###########################################################################
467             sub receive {
468 209     209 1 422 my Net::SIP::Leg $self = shift;
469 209         771 my ($packet,$from) = @_;
470              
471             $DEBUG && DEBUG( 2,"received packet on %s from %s:\n%s",
472 0         0 sip_sockinfo2uri($self->{proto},@{$self->{src}}{qw(addr port family)}),
473 209 50       894 sip_sockinfo2uri(@{$from}{qw(proto addr port family)}),
  0         0  
474             $packet->dump( Net::SIP::Debug->level -2 )
475             );
476 209         848 return ($packet,$from);
477             }
478              
479              
480             ###########################################################################
481             # check if the top via header matches the transport of this call through
482             # this leg. Used to strip Via header in response.
483             # Args: ($self,$packet)
484             # $packet: Net::SIP::Packet (usually Net::SIP::Response)
485             # Returns: $bool
486             # $bool: true if the packets via matches this leg, else false
487             ###########################################################################
488             sub check_via {
489 138     138 1 366 my ($self,$packet) = @_;
490 138         418 my ($via) = $packet->get_header( 'via' );
491 138         758 my ($data,$param) = sip_hdrval2parts( via => $via );
492 138         598 my $cmp_branch = $self->via_branch($packet,2);
493 138         799 return substr( $param->{branch},0,length($cmp_branch)) eq $cmp_branch;
494             }
495              
496             ###########################################################################
497             # add myself as Via header to packet
498             # Args: ($self,$packet)
499             # $packet: Net::SIP::Packet (usually Net::SIP::Request)
500             # Returns: NONE
501             # modifies packet in-place
502             ###########################################################################
503             sub add_via {
504 123     123 1 256 my Net::SIP::Leg $self = shift;
505 123         206 my $packet = shift;
506 123         591 $packet->insert_header( via => $self->{via}.$self->via_branch($packet,3));
507             }
508              
509             ###########################################################################
510             # computes branch tag for via header
511             # Args: ($self,$packet,$level)
512             # $packet: Net::SIP::Packet (usually Net::SIP::Request)
513             # $level: level of detail: 1:leg, 2:call, 3:path
514             # Returns: $value
515             ###########################################################################
516             sub via_branch {
517 268     268 0 755 my Net::SIP::Leg $self = shift;
518 268         651 my ($packet,$level) = @_;
519 268         607 my $val = $self->{branch};
520 268 50       1116 $val .= substr( md5_hex( $packet->tid ),0,15 ) if $level>1;
521 268 100       809 if ($level>2) {
522 130         208 my @parts;
523             # RT#120816 - take only known constant values from proxy-authorization
524 130         366 for(sort $packet->get_header('proxy-authorization')) {
525 0         0 my ($typ,$param) = sip_hdrval2parts('proxy-authorization' => $_);
526 0         0 push @parts,$typ;
527 0         0 for(qw(realm username domain qop algorithm)) {
528 0 0       0 push @parts,"$_=$param->{$_}" if exists $param->{$_};
529             }
530             }
531              
532             # RT#120816 - include only the branch from via header if possible
533 130 100       495 if (my $via = ($packet->get_header('via'))[0]) {
534 8         18 my (undef,$param) = sip_hdrval2parts(via => $via);
535 8   33     39 push @parts, $param && $param->{branch} || $via;
536             }
537              
538 130         390 push @parts,
539             ( sort $packet->get_header('proxy-require')),
540             $packet->get_header('route'),
541             $packet->get_header('from'),
542             ($packet->as_parts())[1]; # URI
543 130         953 $val .= substr(md5_hex(@parts),0,15);
544             }
545 268         1505 return $val;
546             }
547              
548             ###########################################################################
549             # check if the leg could deliver to the specified addr
550             # Args: ($self,($addr|%spec))
551             # $addr: addr|proto:addr|addr:port|proto:addr:port
552             # %spec: hash with keys addr,proto,port
553             # Returns: $bool
554             # $bool: true if we can deliver to $ip with $proto
555             ###########################################################################
556             sub can_deliver_to {
557 199     199 1 434 my Net::SIP::Leg $self = shift;
558 199         373 my %spec;
559 199 50       660 if (@_>1) {
560 199         996 %spec = @_;
561             } else {
562 0         0 @spec{ qw(proto host port family) } = sip_uri2sockinfo(shift());
563 0 0       0 $spec{addr} = $spec{family} ? $spec{host} : undef;
564             }
565              
566             # return false if proto or family don't match
567 199 100 66     1462 return if $spec{proto} && $spec{proto} ne $self->{proto};
568             return if $spec{family} && $self->{src}
569 114 50 33     17186 && $self->{src}{family} != $spec{family};
      33        
570              
571             # XXXXX dont know how to find out if I can deliver to this addr from this
572             # leg without lookup up route
573             # therefore just return true and if you have more than one leg you have
574             # to figure out yourself where to send it
575 114         532 return 1
576             }
577              
578             ###########################################################################
579             # check if this leg matches given criteria (used in Dispatcher)
580             # Args: ($self,$args)
581             # $args: hash with any of 'addr', 'port', 'proto', 'sub'
582             # Returns: true if leg fits all args
583             ###########################################################################
584             sub match {
585 2     2 1 4 my Net::SIP::Leg $self = shift;
586 2         3 my $args = shift;
587             return if $args->{addr}
588             && $args->{addr} ne $self->{src}{addr}
589 2 50 33     16 && $args->{addr} ne $self->{src}{host};
      33        
590 0 0 0     0 return if $args->{port} && $args->{port} != $self->{src}{port};
591 0 0 0     0 return if $args->{proto} && $args->{proto} ne $self->{proto};
592 0 0 0     0 return if $args->{sub} && !invoke_callback($args->{sub},$self);
593 0         0 return 1;
594             }
595              
596             ###########################################################################
597             # returns SocketPool object on Leg
598             # Args: $self
599             # Returns: $socketpool
600             ###########################################################################
601             sub socketpool {
602 112     112 1 260 my Net::SIP::Leg $self = shift;
603 112         1394 return $self->{socketpool};
604             }
605              
606             ###########################################################################
607             # local address of the leg
608             # Args: $self;$parts
609             # $parts: number of parts to include
610             # 0 -> address only
611             # 1 -> address[:non_default_port]
612             # 2 -> host[:non_default_port]
613             # Returns: string
614             ###########################################################################
615             sub laddr {
616 57     57 1 127 my Net::SIP::Leg $self = shift;
617 57         111 my $parts = shift;
618 57 100       706 ! $parts and return $self->{src}{addr};
619             return ip_parts2string({
620 1         11 %{ $self->{src} },
621 1 50       2 default_port => $self->{proto} eq 'tls' ? 5061 : 5060,
    0          
    50          
622             $parts == 1 ? () :
623             $parts == 2 ? (use_host => 1) :
624             die "invalid parts specification $parts",
625             });
626             }
627              
628             ###########################################################################
629             # some info about the Leg for debugging
630             # Args: $self
631             # Returns: string
632             ###########################################################################
633             sub dump {
634 0     0 1 0 my Net::SIP::Leg $self = shift;
635             return ref($self)." $self->{proto}:"
636 0         0 . ip_parts2string($self->{src});
637             }
638              
639              
640             ###########################################################################
641             # returns key for leg
642             # Args: $self
643             # Returns: key (string)
644             ###########################################################################
645             sub key {
646 19     19 0 22 my Net::SIP::Leg $self = shift;
647             return ref($self).' '.join(':',$self->{proto},
648 19         38 @{$self->{src}}{qw(addr port)});
  19         89  
649             }
650              
651             1;