#!/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 ;
  }
}
[download]