callflowcanvas.pm

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

        #Set a default color for unknown reqres's.
        if (!defined $color)
        {
	    $color = 'black';
        }
        print "its color is $color\n" if DEBUG;
        return $color;
    };

    #! This function could be cleaned up considerably by making %server_hash
    #! into an object capable of returning false (i.e. '') when a value
    #! can't be looked up.
    my $_draw_arrow =
    sub
    {
	my ($self, $sip_message) = @_;
	unless (ref $sip_message eq 'Telephony::SipMessage')
	{
	    warn "\$sip_message is a " . ref ($sip_message);
	    return;
	}
	my $canvas = $self->{canvas};
	my $message_number = $self->{arrow_number};
	
	print "in \&\$_draw_arrow\n" if DEBUG;
	print "Drawing arrow for SIP message\n"
	    . Data::Dumper->Dump ([ $sip_message ])
	    if DEBUG_SIP_MESSAGES;
    
	my $source_ip   = $sip_message->{source_ip};
	my $source_port = $sip_message->{source_port};
	if (!defined $source_ip)
	{
	    warn "\&\$_draw_arrow got a message with no source IP; skipping...\n"
		. "\tthe message was " . Data::Dumper->Dump ([ $sip_message ]) . "\n\n" if DEBUG_SIP_MESSAGES;
	    return;
	}
	if (!defined $source_port)
	{
	    warn "\&\$_draw_arrow got a message with no source port; skipping...\n"
		. "\tthe message was " . Data::Dumper->Dump ([ $sip_message ]) . "\n\n" if DEBUG_SIP_MESSAGES;
	    return;
	}
	
	my $destination_ip   = $sip_message->{destination_ip};
	my $destination_port = $sip_message->{destination_port};
	if (!defined $destination_ip)
	{
	    warn "\&\$_draw_arrow got a message with no destination IP; skipping...\n"
	       . "\tthe message was " . Data::Dumper->Dump ([ $sip_message ]) . "\n\n" if DEBUG_SIP_MESSAGES;
	    return;
	}
	if (!defined $destination_port)
	{
	    warn "\&\$_draw_arrow got a message with no destination port; skipping...\n"
	       . "\tthe message was " . Data::Dumper->Dump ([ $sip_message ]) . "\n\n" if DEBUG_SIP_MESSAGES;
	    return;
	}

	my $source_ip_and_port      = $source_ip . ':' . $source_port;
	my $destination_ip_and_port = $destination_ip . ':' . $destination_port;
    
	my $source = $self->{server_hash}->{$source_ip_and_port};
	print "Got corresponding server:  " . Data::Dumper->Dump ([ $source ]) . "\n" if DEBUG_SIP_MESSAGES;
	my $source_hposition      = (ref $source eq 'Telephony::SipServer') ?
	                            $source->{hposition} :
				    0;

	my $destination = $self->{server_hash}->{$destination_ip_and_port};
	print "Got corresponding server:  " . Data::Dumper->Dump ([ $destination ]) . "\n" if DEBUG_SIP_MESSAGES;
	my $destination_hposition = (ref $destination eq 'Telephony::SipServer') ?    
	                            $destination->{hposition} :
				    0;    

	print "Drawing arrow for source $source_ip_and_port and destination $destination_ip_and_port...\n" if DEBUG_SIP_MESSAGES;

	my $x1 = $source_hposition;
	my $x2 = $destination_hposition;
	my $y1 = my $y2 = $self->{arrow_vposition};
	
	my $color_coding = &$_get_arrow_color ($sip_message->{reqres});
	print "Drawing $color_coding arrow from ($x1, $y1) to ($x2, $y2)\n" if DEBUG;
	$canvas->createLine ($x1,
			     $y1,
			     $x2,
			     $y2,
			     arrow  => 'last',
			     smooth => 1,
			     fill   => $color_coding,
			     tags => [ "message_arrow_$message_number" ]
			     );

	my $label = $canvas->createText ($x1 < $x2 ? $x1 : $x2,
					 $y1 - 12,
					 text    => "$message_number. $sip_message->{reqres}",
					 anchor => 'nw',
					 fill    => $color_coding,
					 font    => $settings{canvas_default_font},
					 tags    => [ "message_label_$message_number" ]
					 );
	$canvas->bind ($label,
		       '<Button-1>',
		       sub
		       {
			   print "Before call to \&\$draw_header_balloons, \$message_number is $message_number\n" if DEBUG;
			   &$_draw_header_balloons ($self,
						    $message_number,
						    $sip_message, #closure!
						    $x1 < $x2 ? $x1 : $x2,
						    $y1);
		       }
        );

        #Move down the screen...
        $self->{arrow_vposition} += $settings{space_between_arrows};
        $self->{arrow_number}++;
    };

    #Insert a number into a filename, so that the various pages written
    #by $self->_take_snapshot_page have unique names.
    my $_increment_filename =
    sub
    {
	my ($self) = @_;

	print "Incrementing $self->{filename} to " if DEBUG;
	
	print "(the number is $self->{file_number}; incrementing it to " if DEBUG;
	$self->{file_number}++;
	print "$self->{file_number})... " if DEBUG;
	#For Windows users' sake, put the number before the first dot,
	#if there is one.
	{   
	    my $filename    = $self->{filename};
	    my $file_number = $self->{file_number};
	    last if $filename =~ s|(\..*)|$file_number$1|;
	    $self->{filename} .= $self->{file_number};
	}
	print "$self->{filename}\n" if DEBUG;
    };

    my $_take_snapshot_page =
    sub
    {
	my ($self) = @_;
	my $canvas = $self->{canvas};
	#!my ($x1, $y1, $x2, $y2) = @{$self->{'x1', 'x2', 'y1', 'y2'}};
	my $x1 = $self->{x1};
	my $y1 = $self->{y1};
	my $x2 = $self->{x2};
	my $y2 = $self->{y2};

	print "Saving snapshot for coordinates ($x1, $y1), ($x2, $y2) in $self->{output_filename}\n" if DEBUG_SNAPSHOTS;
	my $width  = $x2 - $x1;
        my $height = $y2 - $y1;
        print "Width is $width; height is $height\n" if DEBUG_SNAPSHOTS == 2;

        my $snapshot_preferences = $self->{snapshot_preferences};
	print "Making postscript with " . Data::Dumper->Dump ([ $snapshot_preferences, '$snapshot_preferences' ]) if DEBUG_SNAPSHOTS;
        my $postscript = $canvas->postscript (x          => $x1,
                                              y          => $y1,
                                              width      => $width,
                                              height     => $height,
                                              colormode  => $snapshot_preferences->{colormode},
                                              rotate     => $snapshot_preferences->{rotate}
					      );

        print "Got postscript:\n$postscript" if DEBUG_POSTSCRIPT;
        my $output_filename = $self->{output_filename};
        if (! open DIAGRAM, ">$output_filename")
        {
            carp ("Could not open the Postscript output file $output_filename for writing:  $!");
            return;
        }
        print "Printing Postscript to $output_filename...\n" if DEBUG_SNAPSHOTS == 2;
        print DIAGRAM $postscript;
        if (! close DIAGRAM)
        {
            &show_error ("Could not close the Postscript output file $output_filename:  $!" );
            return;
        }
        print "Closed $output_filename.\n" if DEBUG_SNAPSHOTS == 2;
    };

    my $_do_snapshot =
    sub
    {
	my ($self) = @_;
	my $canvas = $self->{canvas};

	$canvas->createRectangle ($self->{x1},
				  $self->{y1},
				  $self->{x2},
				  $self->{y2},
				  outline => 'blue') if UEBER_DEBUG_SNAPSHOTS;
	&$_increment_filename ($self);
	&$_take_snapshot_page ($self);
    };

    my $_do_horizontal =
    sub
    {
	my ($self) = @_;

	if ($self->{x2} >= $self->{greatest_x})
	{
	    $self->{x2} = $self->{greatest_x};
	    &$_do_snapshot ($self);
	    return;
	}
	while (1) { &$_do_snapshot ($self); }
	continue
	{
	    $self->{x1} = $self->{x2};
	    $self->{x2} += $page_width;
	    if ($self->{x2} >= $self->{greatest_x})
	    {
		$self->{x2} = $self->{greatest_x};
		&$_do_snapshot ($self);
		return;
	    }
	}
    };

    my $_in_bbox =
    sub
    {
	my ($self, $arrow_id, $items) = @_;
	my @items = @$items;
	my $canvas = $self->{canvas};

	foreach my $item (@items)
	{
	    print "Looking in " . $canvas->gettags ($item) . "...\n" if DEBUG_SNAPSHOTS == 2;
	    return 1 if grep /$arrow_id/, $canvas->gettags ($item);
	}
	return 0;
    };

    #Push orphaned SIP messages onto the next page.  The idea
    #is to keep separate instances of a single request or response
    #together when they are propagating through a series of servers.
    #For instance, all the 200 messages in a response to a BYE should
    #appear on the same page, even if that means leaving some blank space
    #on the preceding page.
    my $_adjust_snapshot_boundaries =
    sub
    {
	my ($self) = @_;
	my $canvas = $self->{canvas};
	
	my $x1 = $self->{x1};
	my $y1 = $self->{y1};
	my $x2 = $self->{x2};
	my $y2 = $self->{y2};

	my @items = $canvas->find ('enclosed', $x1, $y1, $x2, $y2);

	print "The enclosed test gave coordinates ($items[0], $items[1]), ($items[3], $items[4])\n" if DEBUG_SNAPSHOTS;

	if (DEBUG_SNAPSHOTS == 2)
	{
	    print "Adjusting items:\n";
	    foreach my $item (@items)
	    {
		print "$item:  " . $canvas->gettags ($item) . "\n";
	    }
	    print "\n";
	}

	#The items are already ordered from first-drawn (i.e. lowest on the
	#canvas) to last-drawn (i.e. highest on the canvas).
 
	#If the last-drawn item is a label, it must be an orphan to a message
	#arrow on the following page.

	my @filtered_items;
	foreach my $item (@items)
	{
	    my $type = $canvas->type ($item);
	    print "$item is a $type.  " if DEBUG_SNAPSHOTS == 2;
	    if ($type ne 'text')
	    {
		#It's either an arrow or a bit of window dressing like a server
		#box's horizontal line.  Either way, it's guaranteed not to be an
		#orphan.  Include it.
		print "Keeping it...\n" if DEBUG_SNAPSHOTS == 2;
		push @filtered_items, $item;
	    }
	    else
	    {
		my $text = $canvas->itemcget ($item, '-text');
		print ":  '$text'.\n" if DEBUG_SNAPSHOTS == 2;
		#Keep server boxes and labels and the lines drawn under them
		if (grep /server|line/, $canvas->gettags ($item))
		{
		    push @filtered_items, $item;
		    print "It's a server glyph.  Keeping it.\n" if DEBUG_SNAPSHOTS == 2;
		    next;
		}
		$item =~ m|^(\d+)|;
		if (&$_in_bbox ($self, "message_arrow_$1", \@items))
		{
		    print "Keeping $item (a label with text $text)." if DEBUG_SNAPSHOTS == 2;
		    push @filtered_items, $item;
		}
		#Otherwise leave $item out of the new list, since its arrow is out.
		elsif (DEBUG_SNAPSHOTS == 2)
		{
		    print "Throwing out $item (a label with text $text):"
			. "\tIts corresponding message arrow was not included in this page.\n";
		}
	    }
	}

	#Find the type of SIP message label that belongs to the first
	#arrow on the next page (i.e. the first canvas item after the last
	#item on this page)
	my $last_item = $filtered_items[$#filtered_items];
	my $next_label = $canvas->find ('above', $last_item);
	until ($canvas->type ($next_label) eq 'text')
	{
	    $next_label = $canvas->find ('above', $next_label);
	    if (! defined $next_label)
	    {
		#An undefined label means we've reached the end of the output.
		@{$self->{'x1', 'y1', 'x2', 'y2'}} = $canvas->bbox (@items);
		last;
	    }
	    print "...and \$next_label is $next_label\n" if DEBUG_SNAPSHOTS == 2;
	}
	
	if (DEBUG_SNAPSHOTS == 2)
	{
	    my @tags = $canvas->gettags ($next_label);
	    print "The first label on the next page is "
		. Data::Dumper->Dump ([ $next_label ])
		. "\nIts tags are "
		. Data::Dumper->Dump ([ \@tags ]) if DEBUG_SNAPSHOTS == 2;
	}

	my $next_label_text = $canvas->itemcget ($next_label, '-text');
	print "\n\tIts text is $next_label_text\n" if DEBUG_SNAPSHOTS == 2;
	#Extract the SIP message type itself.
	my $next_SIP_message_type = '';
	if (defined $next_label_text)
	{
	    $next_label_text =~ m|\d+\.\s+(.*)|;
	    $next_SIP_message_type = $1;
	    print "Its message type is $next_SIP_message_type\n\n" if DEBUG_SNAPSHOTS == 2;
	}
	
	#Go backwards through the all the labels on the last page.
	for (my $i = $#filtered_items; $i > 0; $i--)
	{
	    my $label = $filtered_items[$i];
	    next unless $canvas->type ($label) eq 'text';
	    my $label_text = $canvas->itemcget ($label, '-text');
	    if (defined $label_text)
	    {
		print "Examining message '$label_text'...\n" if DEBUG_SNAPSHOTS == 2;
		$label_text =~ m|\d+\.\s+(.*)|;
		my $SIP_message_type = $1;
		if ($SIP_message_type eq $next_SIP_message_type)
		{
		    print "It's another $next_SIP_message_type.  Push it to the next page.\n" if DEBUG_SNAPSHOTS == 2;
		    #If it's the same kind of message, it belongs on the next
		    #page.  Remove both its label and its arrow from our list
		    #of items.
		    splice @filtered_items, $i, 2;
		}
		else
		{
		    print "It's a different type of message.\nLeave it where it is, and stop looking for orphans.\n\n" if DEBUG_SNAPSHOTS == 2;
		    last;
		}