callflowcanvas.pm

来自「radius协议源码÷The Radius Stack will connect」· PM 代码 · 共 1,127 行 · 第 1/3 页

package CallFlowCanvas;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
use Tk;
use Carp;

use constant DEBUG                 => 0;
use constant DEBUG_GUI             => 0;
use constant DEBUG_SIP_MESSAGES    => 0;
use constant DEBUG_LOGICAL_NAMES   => 0;
use constant DEBUG_SNAPSHOTS       => 0;
use constant UEBER_DEBUG_SNAPSHOTS => 0;
use constant DEBUG_POSTSCRIPT      => 0;

@ISA = qw (Exporter AutoLoader);
@EXPORT = qw ( add_sip_message change_snapshot_preferences readjust_width );
@EXPORT_OK = qw ( get_call_id _construct_canvas );
$VERSION = '0.01';


# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
#__END__

#Protected methods and class variables
#!#!#!{
    my $batch_process = 0;
    #Side-effected by &$_draw_arrow
    my %settings = (arrow_start_vposition    => 15,
		    canvas_default_font      => '-Adobe-Courier-Medium-R-Normal--12-120-75-75-M-70-ISO8859-1',
		    break_font               => '-Adobe-Courier-Medium--Normal--24-120-75-75-M-70-ISO8859-1',
		    canvas_width             => 500, #minimum; adjusted below
		    canvas_height            => 400, #minimum; adjusted below
		    space_between_arrows     => 40,
		    server_start_hposition   => 50,
		    server_vposition         => 20,
		    space_between_servers    => 50,
		    server_box_hsize         => 170, #! Later, scale to text of name
		    server_box_vsize         => 50,
		    break_width              => 10,
		    break_offset_space       => 15
		    );
    
    my %colors =   (INVITE     => 'brown4', 
		    ACK        => 'green3',
		    OPTIONS    => 'orange',
		    BYE        => 'darkgoldenrod4',
		    REGISTER   => 'purple',

		    '1xx'      => 'black',
		    '200'      => 'forest green',
		    '3xx'      => 'blue',
		    '4xx'      => 'red',
		    '5xx'      => 'dark red',

		    sip_header_name    => 'black',
		    sip_header_value   => 'blue',
		    sdp_header_name    => 'dark slate grey',
		    sdp_header_value   => 'green',

		    canvas_background  => 'light yellow',
		    canvas_foreground  => 'black',
		    server_box_fill    => 'white',
		    server_box_outline => 'black',
		    
		    break              => 'black');

    #parameters that control the Postscript printing functionality
    #These are just defaults; if the user has a .tricorderrc, preferences
    #are loaded from there and passed in to the constructor, overriding
    #these values.
    my %default_snapshot_preferences = (file           => 'call_flow.eps',
					colormode      => 'mono',
					scaling_factor => 1,
					rotate         => 1, #landscape orientation
					page_length    => 1100, #pixels
					page_width     => 800, #pixels
					);

    my ($page_width, $page_length);

    #Protected methods
    my $_set_initial_positions =
    sub
    {
	my ($self) = @_;
	$self->{arrow_vposition} = $settings{server_box_vsize}
                                 + $settings{server_vposition}
                                 + $settings{arrow_start_vposition};
	$self->{arrow_number} = 1;
	$self->{server_box_hposition} = $settings{server_start_hposition};
    };

    #Apply the user's choice of heuristics to the recipient or sender of a
    #SIP message to guess whether it is coming from a server or just from
    #some random endpoint.
    my $_looks_like_a_server =
    sub
    {
	my ($self, $message, $endpoint) = @_;
	my $heuristic = $self->{heuristic} || '';

	if (ref $message ne 'Telephony::SipMessage')
	{
	    warn "\&\$_looks_like_a_server got an argument of type " . ref $message
		. "\n, which is not a SipMessage.  Skipping...";
	    return;
	}
    
	#default:  Treat everything as a server.
	return 1 if ($heuristic eq 'assume-server');

	#another option:  Discriminate between servers and endpoints based on
	#their IPs

	if ($heuristic eq 'use-vovida-ip-numbering-scheme')
	{
	    my $ip = $message->{"${endpoint}_ip"};
	    
	    #Check to see if its IP fits the Vovida SIP server numbering
	    #scheme.
	    $ip =~ m|\.(.+)$|m;  #Look at the
	    my $last_octet = $1; #last octet only.
	    if ($last_octet == 180 || #a UA marshal, by Vovida conventions
		$last_octet == 200 || #a redirect server, by Vovida
		                      #conventions
		$last_octet == 110 || #a 5300 marshal, by Vovida conventions
		$last_octet == 210)   #a 5300, by Vovida conventions
	    {
		return 1;
	    }
	    else
	    {
		return 0;
	    }
	}
	#another option:  Be really clever and look at the actual SIP message.
	elsif ($heuristic eq 'use-sip-hints')
	{
	    my $ip = $message->{"${endpoint}_ip"};
	    if ($message->{sip_uri} =~ /@(\.+?):/)
	    {
		#works for both hostnames and IPs...
		my $ip_from_URI = inet_ntoa (gethostbyname ($1));
		
		if ($endpoint eq 'destination')
		{
		    #Check to see if the IP from the SIP-URI matches the
		    #destination IP; if so, it's an endpoint, not a server.
		    if ($ip_from_URI eq $ip) { return 0; }
		    else { return 1; }
		}
		else #by deduction, ($endpoint eq $SOURCE)
		{
		    #Check to see if the host in the SIP-URI matches
		    #the From header;
		    #if so, it's an endpoint, not a server
		    my $ip_from_From = $message->get_sip_header ('From');
		    if ($ip_from_From eq $ip) { return 0; }
		    else { return 1; }
		}
	    }
	    else
	    {
		warn "Got a SIP message with an invalid SIP-URI:  \n"
		    . Data::Dumper->Dump ([ $message ]);
	    }
	}
	else
	{
	    #Default:  Assume it's a server, just to be safe.
	    return 1;
	}
    };

    my $_draw_server_box =
    sub
    {
	my ($self, $server) = @_;
	my $canvas = $self->{canvas};

	print "in \&\$_draw_server_box\n" if DEBUG;

	#! Later, make customizable through --naming-scheme option
	my $server_name = $server->{logical_name}
                       || $server->{ip} . ':' . $server->{port};
	print "server $server_name is\n" . Data::Dumper->Dump ([ $server ]) if DEBUG_SIP_MESSAGES;

	my $x1 = $self->{server_box_hposition};
	my $y1 = $settings{server_vposition};
	my $x2 = $self->{server_box_hposition} + $settings{server_box_hsize};
	my $y2 = $y1 + $settings{server_box_vsize};

	print "Drawing box from ($x1, $y1) to ($x2, $y2) (for $server_name)\n" if DEBUG;
	my $box = $canvas->createRectangle
	                    ($x1,
			     $y1,
			     $x2,
			     $y2,
			     fill    => $colors{server_box_fill},
			     outline => $colors{server_box_outline},
			     tags    => [ 'server_box' ]
			     );
    
	if (DEBUG)
	{
	    my @coords = $canvas->bbox (\$box);
	    print "Drew box with bounding coordinates " . @coords;
	}
	my $horizontal_midpoint = $x1 + $settings{server_box_hsize} / 2;
	my $vertical_midpoint   = $y1 + $settings{server_box_vsize} / 2;
	
	#Record the horizontal coordinate of the _center_ of the server box
	#so &$_draw_arrow can recall it later.
	$server->{hposition} = $horizontal_midpoint;

	$canvas->createText ($horizontal_midpoint,
			     $vertical_midpoint,
			     text    => $server_name,
			     #! width   => $settings{server_hsize},
			     fill    => $colors{server_box_outline},
			     font    => $settings{canvas_default_font},
			     justify => 'center',
			     tags    => 'server_label'
			     );

	my $bottom_of_the_canvas = $canvas->cget ('-height');
	$self->{server_box_hposition} += ($settings{server_box_hsize}
					  + $settings{space_between_servers});
    };

    my $_draw_lines_under_server_boxes =
    sub
    {
	my ($self, $bottom_of_the_canvas) = @_;
	my $canvas = $self->{canvas};
	map
	{
	    $canvas->createLine ($_->{hposition},
				 $settings{server_vposition}
				 + $settings{server_box_vsize},
				 $_->{hposition},
				 $bottom_of_the_canvas,
				 fill   => $colors{server_box_outline},
				 smooth => 1,
				 tags   => [ 'vertical_line' ]
				 );
	} @{$self->{server_list}};
    };

    #Resize the canvas to make it large enough for all that has been
    #drawn on it.
    my $_resize_canvas =
    sub
    {
	my ($self) = @_;
	my $canvas = $self->{canvas};
	my ($x1, $y1, $x2, $y2) = my @bounding_coordinates = $canvas->bbox ('all');
	print "Resizing canvas:  ($x1, $y1), ($x2, $y2)\n" if DEBUG;
	$canvas->configure (scrollregion => \@bounding_coordinates);
	&$_draw_lines_under_server_boxes ($self, $y2); #bottom of the canvas
    };

    my $_handle_new_servers =
    sub
    {
	my ($self, $message, $endpoint, $draw) = @_;

	#Add the source and destination servers if they do not already
	#exist.
	my $ip          = $message->{"${endpoint}_ip"} || '';
	my $port        = $message->{"${endpoint}_port"};
	my $ip_and_port = $ip . ':' . $port;
	print "Examining server $ip:$port\n" if DEBUG_SIP_MESSAGES;

	if ($ip &&
            ! exists ($self->{server_hash}->{$ip_and_port})
	    && &$_looks_like_a_server ($self, $message, $endpoint))
	{
	    my $logical_name = undef;
	    if ($self->{logical_names})
	    {
		$logical_name = $self->{server_map}->{$ip_and_port};
		print "Got logical name $logical_name for server $ip_and_port\n" if DEBUG_LOGICAL_NAMES;
	    }
	    my $server = Telephony::SipServer->new ($ip,
						    $port,
						    $logical_name);
	    $self->{server_hash}->{$ip_and_port} = $server;
	    push @{$self->{server_list}}, $server;
	    print "Found new server (IP $ip, port $port):\n"
		. Data::Dumper->Dump ([ $server ]) if DEBUG;
	    &$_draw_server_box ($self, $server);
	    &$_resize_canvas ($self);
	}
    };

    my $_draw_header_balloons =
    sub
    {
	my ($self, $message_number, $message, $x, $y) = @_;
	my $canvas = $self->{canvas};

	print "After call to \$&_draw_header_balloons, \$message_number is $message_number\n" if DEBUG;

	defined $message->{sip_headers}
        or return;

	my $sip_balloon = FancyBalloon->new ($message->{sip_headers},
					     $colors{sip_header_name},
					     $colors{sip_header_value},
					     $canvas);
	if (! defined $sip_balloon)
	{
	    warn "FancyBalloon->new returned undef; there is no SIP balloon to display.";
	    return;
	}

	print "Constructed a SIP FancyBalloon:\n" . Data::Dumper->Dump ([ $sip_balloon ]) if DEBUG;
    
	$sip_balloon->title ("$message_number. $message->{reqres}");
	#! $sip_balloon->place (-x => $x, -y => $y + 5); #in $self->{canvas},
	#its parent
	#! Ouch, that doesn't work.  I'll have to fiddle with the window
	#! manager!
	if (defined $message->{sdp_headers})
	{
	    my $sdp_balloon = FancyBalloon->new ($message->{sdp_headers},
						 $colors{sdp_header_name},
						 $colors{sdp_header_value},
						 $canvas);
	    
	    if (! defined $sdp_balloon)
	    {
		warn "FancyBalloon->new returned undef; there is no SDP balloon to display.";
		return;
	    }
	
	    print "Constructed an SDP FancyBalloon:" . Data::Dumper->Dump ([ $sdp_balloon ]) if DEBUG;
	    $sdp_balloon->title ("$message_number. $message->{reqres}");
	    #! $sdp_balloon->place (-x => $x,
	    #!                      -y => $y + 5 + $sip_balloon->height());
	    #in $canvas, its parent
	    #! Ouch, that doesn't work.  I'll have to fiddle with the window manager!
	}
    };

    my $_get_arrow_color =
    sub
    {
	my ($self) = @_;
	my $color;

	my $reqres = shift();
        print "Getting color" if (DEBUG || DEBUG_SIP_MESSAGES);
        print " for $reqres arrow..." if DEBUG_SIP_MESSAGES;
        print "\n" if (DEBUG || DEBUG_SIP_MESSAGES);

        #Response codes:  Match on the first digit (which indicates the
        #general type of response)
        if ($reqres =~ /^(\d)/)
        {
            $color = $colors{(grep /$1/, (keys %colors))[0]};
        }
        #Requests:  Match on the whole name
        else
        {
	    $color = $colors{$reqres};
        }