Perl/TkでIP Messenger

まえからやろうと思っていたことだったのですが、ようやくふとしたきっかけで実装できました。

#!/usr/bin/perl
use Encode;
use encoding 'shift_jis';

use Ipmsg::Agent;
use Tk;


our $mw = MainWindow->new;


my $menu_bar = $mw->Frame()->pack('-side' => 'top',
   '-fill' => 'x');


my $menu_file = $menu_bar->Menubutton('-text' => 'File')->pack(
       '-side' => => 'left',
       -padx => 2);
$menu_file->command(-label => 'Quit',
    -command => \&logout);
my $font=['MS　ゴシック', 11, 'normal'];


our $sendText;
my $t = $mw->Scrolled('Text',-font => $font);
$t->pack(-expand => 1,
-fill => 'both');


our $sendIpBox = $mw->Entry(-width => 20,-font => $font);
$sendIpBox->pack(-expand => 1,
-fill => 'both');


our $sendBox = $mw->Scrolled('Text',-font => $font);
$sendBox->pack(-expand => 1,
-fill => 'both');


my $sendButton = $mw->Button(-text => '送信', -font => $font,
  -command => \&sendmsg);


$sendButton->pack(-expand => 1,
-fill => 'both');


$mw->after(600, \&ipMsgLoop);
tie(*STDOUT, 'Tk::Text', $t);


#Ipmsg::Agent->new->message( PeerAddr => '192.168.0.21', Ext => 'Hello World' )->sendmsg->sendcheckopt->queue;


#Ipmsg::Agent->new->send_queue();


# --------------------
# Constract Agent object


our $agent = Ipmsg::Agent->new(
Verbose => 1,
BindAddr => '192.168.0.2',
LocalPort => 2426,
User => "kjunichi",
Host => "cosmos",
Group => "Group",
NickName => "nampa2",
);
if( ! $agent ){ print "error\n"; exit; }


# --------------------
# Login


$agent->add_broadcast( PeerNet => '192.168.0.255', NetMask => '255.255.255.255', PeerPort => 2425 );
$agent->Login;
my $send = $agent->message( PeerAddr => '192.168.0.21',PeerPort => 2425, Ext => "Hello Universe!")->sendmsg->sendcheckopt->queue;


#$agent->send($send);


MainLoop();


# --------------------
# Main routine
sub ipMsgLoop {


    for my $i ( $agent->netif ){

my $recv = $agent->recv( NetIF => $i, FROMCHECK => 1 );
$agent->send_queue( NetIF => $i, );

next if ! $recv;

msg_process( $recv );

    }
    $mw->after(600, \&ipMsgLoop);
}


# --------------------
# Logout
sub logout {
    $agent->Logout;
    for my $i ( $agent->netif ){ while( $i->remainqueue ){ $i->send_queue; } }
    exit;
}
# --------------------
# Subroutine


sub msg_process
{
my ( $recv ) = shift;


if( $recv and $recv->sendmsg ){
    last if $recv->ext eq "quit";
    my $dialog = $mw->Dialog(
     -buttons => ['OK','返す'],
     -default_button => 'OK');
    my $recvBox = $dialog->Scrolled('Text',-font => $font);
    $recvBox->pack(-expand => 1,
-fill => 'both');
    tie(*TEXT, 'Tk::Text', $recvBox);
    print TEXT $recv->ext;
    my $answer = $dialog->Show;
    if($answer eq '返す') {
$sendBox->insert('end', $recv->ext);
    }
}


}
sub sendmsg {
    my $addr = $sendIpBox->get();
    my $message = $sendBox->get("1.0","end");
    print "$message\n";
    my $send = $agent->message( PeerAddr => $addr,
PeerPort => 2425,
Ext => encode('shift-jis',$message))->sendmsg->sendcheckopt->queue;
   
}