The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
###########################################################################
# package Net::SIP::Blocker
###########################################################################

use strict;
use warnings;


package Net::SIP::Blocker;

use fields qw( dispatcher block );
use Carp 'croak';
use Net::SIP::Debug;


###########################################################################
# creates new Blocker object
# Args: ($class,%args)
#   %args
#     block: \%hash where the blocked method is the key and its value
#       is a number with three digits with optional message
#       e.g. { 'SUBSCRIBE' => 405 }
#     dispatcher: the Net::SIP::Dispatcher object
# Returns: $self
###########################################################################
sub new {
    my ($class,%args) = @_;
    my $self = fields::new( $class );

    my $map = delete $args{block}
	or croak("no mapping between method and code");
    while (my ($method,$code) = each %$map) {
	$method = uc($method);
	($code, my $msg) = $code =~m{^(\d\d\d)(?:\s+(.+))?$} or
	    croak("block code for $method must be DDD [text]");
	$self->{block}{$method} = defined($msg) ? [$code,$msg]:[$code];
    }

    $self->{dispatcher} = delete $args{dispatcher}
	or croak('no dispatcher given');

    return $self;
}


###########################################################################
# Blocks methods not wanted and sends a response back over the same leg
# with the Error-Message of the block_code
# Args: ($self,$packet,$leg,$from)
#   args as usual for sub receive
# Returns: block_code | NONE
###########################################################################
sub receive {
    my Net::SIP::Blocker $self = shift;
    my ($packet,$leg,$from) = @_;

    $packet->is_request or return;

    my $method = $packet->method;
    if ( $method eq 'ACK' and my $block = $self->{block}{INVITE} ) {
	$self->{dispatcher}->cancel_delivery($packet->tid);
	return $block->[0];
    }

    my $block = $self->{block}{$method} or return;

    DEBUG( 10,"block $method with code @$block" );
    $self->{dispatcher}->deliver(
	$packet->create_response(@$block),
	leg => $leg,
	dst_addr => $from
    );
    return $block->[0]
}

1;