use
fields
qw( helper callbacks cfd commands )
;
use
Net::SIP
qw(invoke_callback :debug)
;
my
%default_commands
= (
allocate
=>
sub
{
shift
->allocate_sockets(
@_
) },
activate
=>
sub
{
shift
->activate_session(
@_
) },
close
=>
sub
{
shift
->close_session(
@_
) },
);
sub
new {
my
$class
=
shift
;
my
$helper
;
if
(
@_
&& UNIVERSAL::isa(
$_
[0],
'Net::SIP::NATHelper::Base'
)) {
$helper
=
shift
;
}
else
{
$helper
= Net::SIP::NATHelper::Base->new;
}
my
$self
= fields::new(
$class
);
%$self
= (
helper
=>
$helper
,
callbacks
=> [],
cfd
=> \
@_
,
commands
=> {
%default_commands
},
);
return
$self
,
}
sub
do_command {
my
Net::SIP::NATHelper::Server
$self
=
shift
;
my
$cfd
=
shift
;
my
$sock
=
$cfd
->
accept
||
do
{
DEBUG( 50,
"accept failed: $!"
);
return
;
};
$sock
->autoflush;
read
(
$sock
,
my
$buf
, 4 ) ||
do
{
DEBUG( 50,
"read of 4 bytes len failed: $!"
);
return
;
};
my
$len
=
unpack
(
"N"
,
$buf
);
DEBUG( 50,
"len=$len"
);
if
(
$len
> 32768 ) {
warn
(
"tooo much data to read, unbelievable len=$len"
);
return
;
}
read
(
$sock
,
$buf
,
$len
) ||
do
{
DEBUG( 50,
"read of $len bytes failed: $!"
);
return
;
};
my
(
$cmd
,
@args
) =
eval
{ @{ thaw(
$buf
) } } or
do
{
DEBUG( 50,
"thaw failed: $@"
);
return
;
};
DEBUG( 100,
"request="
.Dumper([
$cmd
,
@args
]));
my
$cb
=
$self
->{commands}{
$cmd
} or
do
{
DEBUG( 10,
"unknown command: $cmd"
);
return
;
};
my
$reply
= invoke_callback(
$cb
,
$self
,
@args
);
unless
(
defined
(
$reply
)) {
DEBUG( 10,
"no reply for $cmd"
);
}
DEBUG( 100,
"reply="
.Dumper(
$reply
));
print
$sock
pack
(
"N/a*"
,nfreeze(\
$reply
));
close
(
$sock
);
}
sub
loop {
my
Net::SIP::NATHelper::Server
$self
=
shift
;
my
$rin
;
my
$last_expire
= 0;
my
$helper
=
$self
->{helper};
while
(1) {
my
$callbacks
=
$self
->{callbacks};
my
$timeout
= 1;
if
( !
@$callbacks
) {
foreach
(
$helper
->callbacks ) {
my
(
$fd
,
$cb
) =
@$_
;
$callbacks
->[
fileno
(
$fd
) ] =
$cb
;
}
if
( !
@$callbacks
&& !
$helper
->number_of_calls ) {
$timeout
=
undef
;
DEBUG( 50,
"no RTP socks: set timeout to infinite"
);
}
foreach
my
$cfd
( @{
$self
->{cfd} } ) {
$callbacks
->[
fileno
(
$cfd
) ] = [ \
&do_command
,
$self
,
$cfd
];
}
$rin
=
''
;
for
(
my
$i
=0;
$i
<
@$callbacks
;
$i
++ ) {
vec
(
$rin
,
$i
,1 ) = 1
if
$callbacks
->[
$i
]
}
}
$rin
||
die
;
defined
(
select
(
my
$rout
=
$rin
,
undef
,
undef
,
$timeout
) ) ||
die
$!;
my
$now
=
time
();
if
(
$rout
) {
for
(
my
$i
=0;
$i
<
@$callbacks
;
$i
++ ) {
invoke_callback(
$callbacks
->[
$i
] )
if
vec
(
$rout
,
$i
,1 );
}
}
if
(
$now
-
$last_expire
>= 1 ) {
$last_expire
=
$now
;
$self
->expire;
DEBUG( 100,
$helper
->
dump
);
}
}
}
sub
expire {
my
Net::SIP::NATHelper::Server
$self
=
shift
;
my
@expired
=
$self
->{helper}->expire(
@_
);
@expired
&&
$self
->_update_callbacks;
return
int
(
@expired
);
}
sub
allocate_sockets {
my
Net::SIP::NATHelper::Server
$self
=
shift
;
my
$media
=
$self
->{helper}->allocate_sockets(
@_
) ||
return
;
return
$media
;
}
sub
activate_session {
my
Net::SIP::NATHelper::Server
$self
=
shift
;
my
(
$info
,
$duplicate
) =
$self
->{helper}->activate_session(
@_
)
or
return
;
$self
->_update_callbacks;
return
$duplicate
? -1:1;
}
sub
close_session {
my
Net::SIP::NATHelper::Server
$self
=
shift
;
my
@info
=
$self
->{helper}->close_session(
@_
) or
return
;
$self
->_update_callbacks;
return
scalar
(
@info
);
}
sub
_update_callbacks {
my
Net::SIP::NATHelper::Server
$self
=
shift
;
@{
$self
->{callbacks} } = ();
}
1;