#!/usr/local/bin/perl -w
#
# winp.pl - packet building and encoding example using Packet.pm and Tk.pm
#
# $Id: winp.pl,v 1.1 2002/05/14 07:12:51 tcaine Exp $
#

use strict;
use Packet::TCP;
use Packet::UDP;
use Packet::IP;
use Packet::ICMP;
use Packet::Ethernet;
use Tk;

my @PROTOCOL  = qw( TCP UDP IP ICMP Ethernet );
my $TITLE_FONT = "-adobe-helvetica-bold-r-*-*-48-*-*-*-*-*-*-*";
my $BODY_FONT  = "-adobe-helvetica-plain-r-*-*-12-*-*-*-*-*-*-*";
my $FG = "black";
my $mw = new MainWindow;  #  main window
my $pcw;                  #  packet configuration window

#  pop-up a warning dialog box upon any warnings encountered (perl cookbook example)
BEGIN {
    $SIG{__WARN__} = sub {
        require Tk::DialogBox;
        my $warning = shift;
        my $dialog = $mw->DialogBox(-title => "Warning", -buttons => ["Ok"]);
        $dialog->add("Label", -text => $warning)->pack;
        $dialog->Show;
    };
}

$mw->bind("<q>" => sub { exit } );

$mw->Label(
    -text => "Packet Builder!",
    -font => $TITLE_FONT,
    -fg   => $FG,
)->pack();

$mw->Label(
    -text => "Select the protocols needed to build your packet:",
    -font => $BODY_FONT,
    -fg   => $FG,
)->pack(-anchor => 'w', -side => 'top');


#  the "l" frame hold the protocol building controller.
#  the controller consists of a listbox with available protocols,
#  4 arrow buttons (^<>v), and a listbox to hold the protocols
#  needed for the packet encoding.
my $l = $mw->Frame();

my $box_src = $l->Listbox(
    -relief  => 'sunken',
    -width   => 25,
    -height  => 7,
    -setgrid => 1,
    -fg  => $FG,
);
$box_src->insert('end', $_) for @PROTOCOL;
$box_src->selectionSet(0);
$box_src->pack(-side => 'left', -anchor => 'n');

my $c = $l->Frame();
$c->Button(-text => "^", -command => \&up   )->pack(-anchor => 'n');
$c->Button(-text => "<", -command => \&left )->pack(-anchor => 'n');
$c->Button(-text => ">", -command => \&right)->pack(-anchor => 'n');
$c->Button(-text => "v", -command => \&down )->pack(-anchor => 'n');
$c->pack(-side => 'left', -anchor => 'n', -padx => 5);

my $box_dst = $l->Listbox(
    -relief  => 'sunken',
    -width   => 25,
    -height  => 7,
    -setgrid => 1,
    -fg  => $FG,
)->pack(-side => 'left', -anchor => 'n');

$l->pack(-padx => 5, -side => 'top');

$mw->Button(-text => "NEXT >", -command => \&configure)->pack(-side => 'right', -padx => 10, -pady => 10);
$mw->Button(-text => "RESET",  -command => \&reset)->pack(-side => 'right', -padx => 10, -pady => 10);

MainLoop;

exit;


#  Button event handlers
sub up { 
    my $index = $box_dst->curselection();
    if(defined $index) {
        my $element  = $box_dst->get($index);
        my $position = ($index == 0) ? 0 : $index - 1;
        $box_dst->delete($index);
        $box_dst->insert($position, $element);
        $box_dst->selectionSet($position);
    }
    else {
        my $index = $box_src->curselection();
        return unless defined $index;
        my $position = ($index == 0) ? 0 : $index - 1;
        $box_src->selectionClear($index);
        $box_src->selectionSet($position);
    }
}

sub right { 
    my $index = $box_src->curselection();
    if (defined $index) {
        $box_dst->insert('end', $PROTOCOL[$index]);
        my $size = $box_src->size() - 1;
        my $position = ($index == $size) ? $size : $index + 1;
        $box_src->selectionClear($index);
        $box_src->selectionSet($position);
    }
}

sub left { 
    my $index = $box_dst->curselection(); 
    if (defined $index) {
        $box_dst->delete($index);
        my $size = $box_dst->size() - 1;
        my $position = ($index <= $size) ? $index : $size;
        $box_dst->selectionClear($index);
        $box_dst->selectionSet($position);
    }
}

sub down {
    my $index = $box_dst->curselection();
    if(defined $index) {
        my $size = $box_dst->size() - 1;
        my $element = $box_dst->get($index);
        my $position = ($index == $size) ? $size : $index + 1;
        $box_dst->delete($index);
        $box_dst->insert($position, $element);
        $box_dst->selectionSet($position);
    }
    else {
        my $index = $box_src->curselection();
        return unless defined $index;
        my $size = $box_src->size() - 1;
        my $position = ($index == $size) ? $size : $index + 1;
        $box_src->selectionClear($index);
        $box_src->selectionSet($position);
    }
}

sub reset {
    my $index = $box_src->curselection();
    $box_dst->delete(0, $box_dst->size - 1);
    $box_src->selectionClear($index) if defined $index;
    $box_src->selectionSet(0);
}


#  Top Level Configuration Window
sub configure {
    return if Exists($pcw);
    $pcw = $mw->Toplevel();
    $pcw->title('Configure Packet');

    #  which protocols where selected?
    my @elem = $box_dst->get(0, $box_dst->size - 1);

    no strict "refs";
    my ($last_data, $o) = ('');
    foreach my $proto (@elem) {
        $o = "Packet::${proto}"->new(data => "$last_data");
        $last_data = $o->encode();
    }

    my $pkt  = $o->encode();
    my $dump = $o->hexdump($pkt);

    $pcw->Label(-text => "$dump\n")->pack(-side => 'top', -anchor => 'w');
    $pcw->Button(-text => "Close", -command => \&close_top)->pack();
    $pcw->Button(
        -text => "Close", 
        -command => 
            sub {
                return unless Exists($pcw);
                $pcw->withdraw;
                $pcw->destroy;
            },
    )->pack();
}


__END__

=pod

=head1 NAME

winp - Windowed Protocol Builder

=head1 SYNOPSIS

perl winp.pl

=head1 AUTHOR

Todd Caine    <todd_caine@hotmail.com>

=head1 SEE ALSO

L<Packet.pm>

=cut