#!/usr/bin/perl use strict ; use warnings ; use constant DEBUG => 1 ; use threads ; use threads::shared ; use Tk ; use AppConfig qw(:expand :argcount) ; use HTTP::Daemon ; use HTTP::Status ; use LWP::UserAgent ; use CGI ; $| = 1 if DEBUG ; # Define configuration variables my $conf = AppConfig->new({CASE => 1, GLOBAL => { ARGCOUNT => ARGCOUNT_ONE }}) ;$conf->define('peerhost', { DEFAULT => 'localhost' }) ; $conf->define('peerport', { DEFAULT => 1080 }) ; $conf->define('localport', { DEFAULT => 1080 }) ; $conf->define('mynick', { DEFAULT => $ENV{USER} || $ENV{USERNAME} || "Mr.X" }) ; # Parse command line arguments $conf->args() ; my $peerhost = $conf->get("peerhost") ; my $peerport = $conf->get("peerport") ; my $localport = $conf->get("localport") ; my $nick = $conf->get("mynick") ; # Create a daemon to run in a thread my $httpd = HTTP::Daemon->new(LocalPort => $localport, ReuseAddr => 1) ; die "Cannot create an HTTP daemon" unless defined $httpd ; # Create an user agent to send messages my $ua = LWP::UserAgent->new ; die "Cannot create an User Agent" unless defined $ua ; # Configure application window my $mw = MainWindow->new ; $mw->title("ChatBG - $nick chatting with $peerhost:$peerport") ; my $etext = "" ; my $tbox = $mw->Scrolled("Text", -width => 80, -height => 10,) ; my $ebox = $mw->Entry(-width => 70, -textvariable => \$etext) ; my $bsend = $mw->Button(-text => 'Send', -command => \&send_text) ; $tbox->insert('end',"Listening on port $localport\n") ; $tbox->configure(-state => 'disabled') ; $tbox->pack(-side => 'top', -expand => 1, -fill => 'x') ; $ebox->pack(-side => 'left', -expand => 1) ; $bsend->pack(-side => 'right', -expand => 1, -fill => 'x') ; my $httpdt = threads->new(\&httpd) ; $httpdt->detach ; MainLoop ; sub send_text { unless (length $etext > 0) { print STDERR "Empty text, won't send\n" ; return ; } $ua->post("http://$peerhost:$peerport/message", { nick => $nick, message => $etext }) ; $etext = "" ; } sub httpd { LISTEN: { my $client = $httpd->accept ; redo LISTEN unless defined $client ; my $request = $client->get_request ; unless ($request->method eq 'POST' and $request->url->path eq '/message') { $client->send_error(RC_FORBIDDEN) ; $client->close ; redo LISTEN ; } my $q = CGI->new($request->content) ; my ($nick,$message) = map $q->param($_),qw(nick message) ; print STDERR "Resetting text box state\n" if DEBUG ; $tbox->configure(-state => 'normal') ; $tbox->insert('end',qq($nick says: $message\n)) ; print STDERR "Disabling text box\n" if DEBUG ; $tbox->configure(-state => 'disabled') ; $client->send_status_line ; $client->close ; redo LISTEN ; } }