http://qs1969.pair.com?node_id=22273
Category: Chatterbox Clients
Author/Contact Info Shendal
Description: GUI Chatterbox client that works on NT and UNIX that makes use of Tk and zzamboni's PerlMonksChat module.

Notable features:
- Native look and feel on UNIX and NT
- GUI username/password changing
- Userlist and XP progress bar
- Text colorization
- Checkoff of private messages
- Separate server process to talk to website to alleviate gui locks
- Clickable links that will launch an external, user definable browser
- Double-clicking userlist will launch browser to user's perlmonks home node
- Colors are customizable and persistent
- Auto name completion -- just type part of a username that's currently lurking, and hit tab
- Msg button to message currently selected user
- Control-return to send message to currently selected user
- Resizable window
- Support for HREF & CODE tags
- Support for html characters
- Colorize user's name
- Bad commands can be suppressed by option (eliminating the /msh, if you want to)
- New: Uses browser that's already open if available

Users may note that this code started as a Win32::GUI program. I have sinced ported to Tk for portability and performance.

#!/usr/bin/perl -w -- # -*-Perl-*-
#
# monkchat
# Shendal, September 2000
#
# Thanks to ase for the original Tk port and color enhancements
# Special thanks to zzamboni who created PerlMonksChat.pm
# Very special thanks to vroom for creating PerlMonks.org
# Oh, and Larry Wall's okay in my book for making perl
#
# To-do:
#  - although we have a server process caching information for the
#    client, it still locks up occasionally when the client requests
#    data, and the website is taking a while to return. Probably
#    not going to be able to resolve this until perl on Win32 
#    supports alarm().
#  - closeDOSParent() doesn't work.
#
# Version history:
# 2.2.2 10/31/2002
#  - Halloween update! Fixed a few outstanding issues with GetOptions.
#    Thanks [converter].
#  - Some people are still getting bit by problems with the PerlMonks 
#    modules. The XML parsing in there is broken at worst, and fragile
+ 
#    at best.
#
# 2.2.1 9/22/00
#  - Colorizing system totally revamped - it wasn't reliable enough.
#  - On Win32, now uses the last browser window opened, if available. 
+This
#    also means that on Win32, the browser setting doesn't matter.
#
# 2.2 9/7/00
#  - Added support for <A HREF=foo>bar</A> tags in chatter
#  - Added support for CODE & /CODE tags in chatter
#  - Added support for /tell as an alias for /msg
#  - Using the msg button (or ctrl-enter) with the userlist will
#    now s/ /_/g so that usernames with spaces will work.
#  - printMessage now handles &lt;, &gt;, &#091;, and &#093; correctly
#    by translating them into <, >, [, and ], respectively.
#  - Will now colorize any place the username pops up, so it's easy to
+ 
#    scan the buffer for mentions of your name.
#  - fixed a problem with UNIX & cpan:// tags
#
# 2.1.2 9/5/00
#  - Window now resizable by request from zzamboni. Widgets now act 
#    as you would expect them to.
#
# 2.1.1 9/5/00
#  - Updated to work with PerlMonksChat2, if available. Essentially, t
+his just
#    tells the user whom he's logged in as (or suggests an upgrade).
#  - Fixed a bug where links of the form [foo|bar] or [id://123|bar] d
+idn't work.
#  - GetInfo button was outputting extraneous information
#
# 2.1 9/1/00
#  - windows now don't allow user to resize
#  - text input field larger
#  - updUserlist no longer clobbers selection
#  - added msg button
#  - ctrl-enter now sends message to selected user (clicks msg button)
#  - name completion partially implemented. Only works when the partia
+l
#    word is at the end of the entry.  This may be a feature?
#  - new options allows bad command or not, so it will automatically
#    block things like /msh or /ell, isuing a warning.  Default is to
#    allow these to be posted as normal text (the current behavior).
#
# 2.0.2 8/22/00
#  - now using Tk::ROText so that text in chatterbox window is selecta
+ble
#  - fixed a problem where links were not working
#  - pointing at a link now updates the status menu with the node name
#
# 2.0.1 7/13/00
#  - UNIX version now works!
#
# 2.0 7/12/00
#  - initial release
#  - majority of code base taken from the original client, which
#    was intended for use with Win32::GUI.  ase performed the original
#    port to Tk, and I have adapted some of his changes within.
#  - support for clicking on a user name to launch browser
#  - allows user to specify different colors -- saves information for
#    future sessions
#  - nodes mentioned in chat using the [node] syntax will launch a bro
+wser
#    with a single click.  Also supports [link|message] syntax by usin
+g
#    hidden text. Even supports id: and cpan: links!
#  - userlist launches browser to selected user's home node on double 
+click
#
# 0.9 to 1.0.1
#  - these versions were based on Win32::GUI.  I dumped it in favor of
#    the more portable, more extensible, more documented, more stable 
+Tk.
#    I don't plan on any updates to the old Win32::GUI version.
#
use strict; # Always!
use Getopt::Long;
use IPC::Open2;    # for server process
use Symbol;        # ditto
use PerlMonksChat; # access to perlmonks site

# for preference saving
use SDBM_File;
use Fcntl;

# GUI package
use Tk 8.0;
use Tk::LabEntry;
use Tk::FileSelect;
use Tk::ROText;

# Process command-line options
my($orig_params) = join ' ',@ARGV;
use vars '$opt_server'; # launch in server mode
use vars '$opt_close';  # close dos parent window
use vars '$opt_debug';  # debug
&GetOptions("server" => \$opt_server,
        "close"  => \$opt_close,
        "debug"  => \$opt_debug) or die "Bad options!";

# Since we're communicating line by line, we want everything unbuffere
+d
select STDERR; $|++;
select STDOUT; $|++;

# Version info
my($version)     = '2.2.1';
my($status_idle) = "monkchat version $version is idle";

# Polling itervals (in millisecs) - set to 0 to disable
my(%interval) = (chat     => 10000,    # 10 secs
         xp       => 30000,    # 30 secs
         userlist => 30000);  # 30 secs
my($pid); # process id of server

# perlmonk levels
# the xp xml ticker doesn't return this, so we'll have to hard code it
my(%perlmonk_levels) = (1  => 0,
            2  => 20,
            3  => 50,
            4  => 100,
            5  => 200,
            6  => 500,
            7  => 1000,
            8  => 1600,
            9  => 2300,
            10 => 3000);

# This is the beast that drives everything
my($p); # perlmonkschat object

# Server Objects
my($serverProcess); # server process object
my($toServer)   = gensym(); # send data glob to server
my($fromServer) = gensym(); # read data glob from server

# GUI Objects
my($Window);        # The over-all window object
my($Chatfield);     # object that displays all the chat text
my($Userlist);      # userlist listbox
my($UserlistLabel); # displays number of users logged in
my($Inputfield);    # object that allows the user to type their own me
+ssage
my($SayButton);     # send text button
my($MsgButton);     # send private message button
my($getInfoButton); # get username information button
my($Progress);      # progress bar intended to show xp & next level
my($XPLabel);       # displays XP information on the screen
my($Status);        # well, a status bar
my($userinfo_w);    # user information window
my($choosebrowser_w); # browser information window
my($msg_num) = 0;   # number of private messages
my($menu);          # Globally declare menu since it affects some user
+s
                    # Thanks to httptech for this one
my($prect,$ptext);  # for XP canvas
my($unField);       # username field
my($pwField);       # password field
my($browserfield);  # browser field
my($confField);     # confirmation field
my($browser) = '';  # full path to browser to launch for user informat
+ion
my($loggedInUser);  # name of user currently logged in

# URL to use for links into perlmonks & cpan
my($perlmonksURL)      = 'http://www.perlmonks.org/index.pl?node=';
my($perlmonksURL_id)   = 'http://www.perlmonks.org/index.pl?node_id=';
my($perlmonksURL_cpan) = 'http://search.cpan.org/search?mode=module&qu
+ery=';

# OS specific stuff
my(%options) = ();
if ($^O =~ /MSWin32/i) {
    require 5.005;
    $ENV{HOME} = "c:/TEMP" unless ($ENV{HOME});
} else {
    require 5.004_04;
}

# options hash
tie(%options,'SDBM_File',"$ENV{HOME}/.monkchat",O_RDWR|O_CREAT,0640);
my %default_options=(default    => 'black',
             private    => 'purple',
             username   => 'blue',
             message    => 'green',
             error      => 'red',
             link       => 'brown',
             background => 'white',
             self       => 'orange',
             badcmds    => 1,
             browser    => undef,
             );

#set options to default unless they have alreayd been set
foreach (keys %default_options) {
    unless (defined $_ && defined $options{$_} ) {
    $options{$_} = $default_options{$_};
    }
}

if ($opt_server) {
    # launch as server process
    &runServer;
} else {
    # launch as client process
    &closeDOSParent if ($opt_close);
    &initWindow;
    &initServer;
    &initChat;
    MainLoop();
}

######################################################################
+##########
#
# initServer
#
# Initialize the server process
#
sub initServer {
    &Status('Initializing server process...');
    my @flags = ('--server', $opt_debug ? '--debug' : () );
    $serverProcess = open2($fromServer, $toServer, $^X, $0, @flags);
    while (<$fromServer>) {
    chomp;
    if (/server started - logged in as \b(\w.+\w)\b/) {
        $loggedInUser = $1;
        printMessage("Server process started successfully ($serverProc
+ess).");
        printMessage("\nLogged in as $loggedInUser.");
        last;
    } elsif (/server started/) {
        printMessage("Server process started successfully ($serverProc
+ess).");
        printMessage("\nPlease upgrade your version of PerlMonksChat")
+;
        last;
    } else {
        printError("Failed to start server process.");
    }
    }
    select $toServer; $|++;
    select STDOUT;
    &Status($status_idle);
}

######################################################################
+##########
#
# initChat
#
# Initialize the chat process
#
sub initChat {
    &Status('Initializing client...');
    $Window->repeat($interval{'chat'},\&updChatterbox)   if ($interval
+{'chat'});
    $Window->repeat($interval{'xp'},\&updXP)             if ($interval
+{'xp'});
    $Window->repeat($interval{'userlist'},\&updUserlist) if ($interval
+{'userlist'});
    &updChatterbox; # seed the chatterbox
    &updXP;         # seed the XP info
    &updUserlist;   # seed the Userlist area
    &Status($status_idle);
}

######################################################################
+##########
#
# runServer
#
# Run as server
#
sub runServer {
    # server-only objects
    my(@chat_cache,%xp_cache,%userlist_cache,@msgs_cache); # caches

    local $_;

    # init perlmonks chat object
    $p = PerlMonksChat->new();
    $p->add_cookies;

    # Seed caches
    foreach ($p->getnewlines(1)) { push @chat_cache, $_; }
    %xp_cache       = $p->xp;
    %userlist_cache = $p->users;

    # print advisory information so the gui can continue loading
    if ($xp_cache{'user'}) {
    print "server started - logged in as $xp_cache{user}\n";
    } else {
    print "server started\n";
    }

    while (<STDIN>) {
    s/\r?\n//g;
    print STDERR "SERVER: received \"$_\"\n" if ($opt_debug);
    if (/^chat$/) {
        foreach (@chat_cache) { next unless /\S/; print "$_\n"; }
        print "MeSsAgE_eNd\n";
        @chat_cache = (); # flush cache
        foreach ($p->getnewlines(1)) { push @chat_cache, $_; }
    } elsif (/^xp$/) {
        if (defined $xp_cache{'level'}) {
        foreach ('level','xp','xp2nextlevel','votesleft') { print "$xp
+_cache{$_}\n"; }
        }
        print "MeSsAgE_eNd\n";
        %xp_cache       = $p->xp;
    } elsif (/^userlist$/) {
        foreach (sort { lc($a) cmp lc($b) } keys(%userlist_cache)) { p
+rint "$_\n"; }
        print "MeSsAgE_eNd\n";
        %userlist_cache = $p->users;
    } elsif (/^msgs$/) {
        my(%msgs) = $p->personal_messages;
        foreach (sort keys(%msgs)) { print "$msgs{$_}\n"; }
        print "MeSsAgE_eNd\n";
    } elsif (/^upd\S+$/) {
        if (/updChatCache/) {
        foreach ($p->getnewlines(1)) { push @chat_cache, $_; }
        }
        %xp_cache       = $p->xp    if (/updXPCache/);
        %userlist_cache = $p->users if (/updUserlistCache/);
    } elsif (s/^SEND://) {
        print STDERR "SERVER: Sending \"$_\"\n" if ($opt_debug);
        $p->send("$_");
    } elsif (/^CO:(.+)$/) {
        my(@ids) = split /,/,$1;
        my(%msgs) = $p->personal_messages;
        $p->checkoff(map { (sort keys %msgs)[$_-1] } @ids);
    } elsif (/^LOGIN (\S+) (\S+)$/) {
        $p->login($1,$2);
        print "Logged in as " . $p->current_user . "\n";
        print "MeSsAgE_eNd\n";
    } else {
        print STDERR "Un-oh -- shouldn't ever get here: $_\n";
    }
    }
    print STDERR "server exited abnormally\n";
}

######################################################################
+##########
#
# getFromServer
#
# Interface for client to get information from server
#
sub getFromServer {
    my($what) = shift;
    my(@result) = ();
    print STDERR "CLIENT: requesting $what\n" if ($opt_debug);
    print $toServer "$what\n";
    while (<$fromServer>) {
    last if (/MeSsAgE_eNd/);
    s/\r?\n//g;
    push @result, $_;
    }
    print STDERR "CLIENT: received @result\n" if ($opt_debug);
    return @result;
}

######################################################################
+##########
#
# initWindow
#
# Initialize the GUI window
#
sub initWindow {
    print STDERR "Initializing Tk window...\n" if ($opt_debug);
    $Window = MainWindow->new(-title  => "Perlmonks Chat");
    my($menu) = $Window->Menu;
    $Window->configure (-menu => $menu);

    # build menubar
    my($file_menu)    = $menu->cascade(-label   => '~File',
                       -tearoff => 0);
    my($update_menu)  = $menu->cascade(-label   => '~Update',
                       -tearoff => 0);
    my($options_menu) = $menu->cascade(-label   => '~Options',
                       -tearoff => 0);
    # file menu
    $file_menu->command(-label     => 'About',
            -underline => 1,
            -command   => \&About,
            );
    $file_menu->command(-label     => 'Exit',
            -underline => 1,
            -command   => \&Exit,
            );
    # update menu
    $update_menu->command(-label     => 'Chatterbox',
              -underline => 0,
              -command   => \&updChatterbox,
              );
    $update_menu->command(-label     => 'XP',
              -underline => 0,
              -command   => \&updXP,
              );
    $update_menu->command(-label     => 'Userlist',
              -underline => 0,
              -command   => \&updUserlist,
              );
    $update_menu->separator();
    $update_menu->command(-label     => 'Username and Password',
              -underline => 0,
              -command   => \&updUsername,
              );

    # options menu
    $options_menu->command(-label     => 'Chat Background',
               -underline => 0,
               -command   => sub { $Chatfield->configure
                           (-bg=>$Window->chooseColor
                            (-initialcolor=>$Chatfield->cget
                             (-bg),
                             -title => "Background Color"))
                           }
               );
    $options_menu->command(-label     => 'Default text',
               -underline => 0,
               -command   => sub { $Chatfield->tagConfigure
                           ('default',-foreground=>$Window->chooseColo
+r
                            (-initialcolor=>$Chatfield->tagCget
                             ('default',-foreground),
                             -title => "Default Text Color"));
                       }
               );
    $options_menu->command(-label     => 'Private text',
               -underline => 0,
               -command   => sub { $Chatfield->tagConfigure
                           ('private',-foreground=>$Window->chooseColo
+r
                            (-initialcolor=>$Chatfield->tagCget
                             ('private',-foreground),
                             -title => "Received Private /msg Text Col
+or"));
                       }
               );
    $options_menu->command(-label     => 'Username text',
               -underline => 0,
               -command   => sub { $Chatfield->tagConfigure
                           ('username',-foreground=>$Window->chooseCol
+or
                            (-initialcolor=>$Chatfield->tagCget
                             ('username',-foreground),
                             -title => "Username Text Color"));
                       }
               );
    $options_menu->command(-label     => 'Message text',
               -underline => 0,
               -command   => sub { $Chatfield->tagConfigure
                        ('message',-foreground=>$Window->chooseColor
                         (-initialcolor=>$Chatfield->tagCget
                          ('message',-foreground),
                          -title => "Sent Private /msg Text Color"));
                    }
               );
    $options_menu->command(-label     => 'Error text',
               -underline => 0,
               -command   => sub { $Chatfield->tagConfigure
                           ('error',-foreground=>$Window->chooseColor
                            (-initialcolor=>$Chatfield->tagCget
                             ('error',-foreground),
                             -title => "Error Text Color"));
                       }
               );
    $options_menu->command(-label     => 'Link text',
               -underline => 0,
               -command   => sub { $Chatfield->tagConfigure
                           ('link',-foreground=>$Window->chooseColor
                            (-initialcolor=>$Chatfield->tagCget
                             ('link',-foreground),
                             -title => "Link Text Color"));
                    }
               );
    $options_menu->command(-label     => 'My nickname text',
               -underline => 0,
               -command   => sub { $Chatfield->tagConfigure
                           ('self',-foreground=>$Window->chooseColor
                            (-initialcolor=>$Chatfield->tagCget
                             ('self',-foreground),
                             -title => "My Nickname Color"));
                    }
               );
    $options_menu->separator();
    $options_menu->command(-label     => 'Save color settings',
               -underline => 0,
               -command   => \&save_settings);
    $options_menu->command(-label     => 'Reset to default colors',
               -underline => 0,
               -command   => \&reset_settings);
    $options_menu->separator();
    $options_menu->checkbutton(-label       => 'Allow bad commands',
                   -onvalue     => 1,
                   -offvalue    => 0,
                   -indicatoron => 1,
                   -underline   => 0,
                   -variable    => \$options{badcmds});
    $options_menu->command(-label     => 'Choose browser',
               -underline => 7,
               -command   => \&chooseBrowser);
    
    # create window frames
    my($uframe) =$Window->Frame()->pack(-side   => 'top',
                    -fill   => 'both',
                    -expand => 1
                    );
    my($lframe) =$uframe->Frame()->pack(-side   => 'left',
                    -fill   => 'both',
                    -expand => 1);
    my($rframe) =$uframe->Frame()->pack(-side   => 'right',
                    -fill   => 'y');
    my($dframe) =$Window->Frame()->pack(-side   =>'top',
                    -fill   => 'x');

    # chatfield
    $Chatfield = $lframe->Scrolled("ROText",
                   -width  => 20,
                   -height => 2,
                   -bg     => $options{'background'},
                   -wrap   => 'word',
                   -relief => 'sunken',
                   -scrollbars => 'osoe',
                   )->pack(-side   => 'top',
                       -fill   => 'both',
                       -expand => 1);

    # userlist            
    $Userlist = $rframe->Scrolled("Listbox",
                  -width      => 12,
                  -scrollbars => 'osoe',
                  -selectmode => 'single',
                  )->pack(-side   =>'top',
                      -fill   => 'y',
                      -expand => 1,
                      -padx   => 2);
    $UserlistLabel = $rframe->Label(-text     => "Getting userlist..."
+,
                    -relief   => "sunken",
                    )->pack(-side=>'top',-fill=>'x',-padx=>2,-pady=>2)
+;
    $Userlist->bind("<Double-Button-1>",\&getInfo);
    $Userlist->bind("<Return>",\&getInfo);
    
    # input field
    $Inputfield = $lframe->Entry()->pack(-side   => 'left',
                     -fill   => 'x',
                     -expand => 1,
                     -pady   => 2);
    $Inputfield->bind("<Return>", \&Say_Click);
    $Inputfield->bind("<Control-Return>", \&Msg_Click);
    $Inputfield->bind("<Tab>", \&completeName);

    # say button
    $SayButton = $lframe->Button(-text     => "Say",
                 -command  => \&Say_Click,
                 -height   => 1,
                 -takefocus=> 0,
                 )->pack(-side=>'left',-padx=>2,-pady=>2);
    # msg button
    $MsgButton = $lframe->Button(-text     => "Msg",
                 -command  => \&Msg_Click,
                 -height   => 1,
                 -takefocus=> 0,
                 )->pack(-side=>'left',-padx=>2,-pady=>2);
    # getInfo button
    $getInfoButton = $lframe->Button(-text     => "Get Info",
                     -command  => \&getInfo,
                     -height   => 1,
                     -takefocus=> 0,
                     )->pack(-side=>'left',-padx=>2,-pady=>2);

    # status label
    $Status = $dframe->Label(-text   => $status_idle,
                 -relief => 'sunken',
                 -width  => 40,
                 )->pack(-side   => 'left',
                     -fill   => 'x',
                     -expand => 1);
    
    # XP status bar
    $Progress = $dframe->Canvas(-height      => 16,
                -width       => 301,
                -relief      => 'sunken',
                -borderwidth => 2,
                -takefocus   => 0
                )->pack(-side => 'left',
                    -padx => 2);
    $prect = $Progress->createRectangle(0,0,300,16,-fill=>'red',-outli
+ne=>'red');
    $ptext = $Progress->createText(150,10,-text=>'Getting XP info...')
+;

    # link text & cursor changes
    foreach (keys %options) {
    next if /(browser|badcmds)/;
    $Chatfield->tagConfigure($_,-foreground=>$options{$_});
    }
    $Chatfield->tagConfigure('italic',-font=>'fontitalic');
    $Chatfield->tagConfigure('hidden_link',-state=>'hidden');
    $Chatfield->tagBind('link',"<Button-1>",sub { &LaunchBrowser(&getL
+ink); });
    $Chatfield->tagBind('link',"<Enter>",sub {
    &Status('Node: ' . &getLink);
    $Chatfield->configure(-cursor=>'hand1'); });
    $Chatfield->tagBind('link',"<Leave>",sub { 
    &Status($status_idle);
    $Chatfield->configure(-cursor=>'arrow'); });
    $Chatfield->tagBind('username',"<Button-1>",sub { &LaunchBrowser(&
+getLink); });
    $Chatfield->tagBind('username',"<Enter>",sub {
    &Status('Node: ' . &getLink);
    $Chatfield->configure(-cursor=>'hand1'); });
    $Chatfield->tagBind('username',"<Leave>",sub {
    &Status($status_idle);
    $Chatfield->configure(-cursor=>'arrow'); });

    # Set initial focus
    $Inputfield->focus;
}

######################################################################
+##########
#
# Window_Terminate
#
# What to do when the user closes the window
#
sub Window_Terminate { 
    if (kill('KILL',$serverProcess)) {
    print "Successfully shutdown server.\n";
    } else {
    print "An error occurred shutting down server ($serverProcess).\n"
+;
    }
    return -1;
}

######################################################################
+##########
#
# Say_Click
#
# What to do when the user clicks the say button
#
sub Say_Click {
    &Status('Communicating with website...');
    my($text) = $Inputfield->get();
    $Inputfield->delete(0,'end');
    $text =~ s/\r*\n//g;
    if ($text =~ /^\s*\/(msg|tell)\s+(\S+)\s*(.+)$/i) {
    print $toServer "SEND:$text\n";
    printMessage("\nSent private msg to $2: $3");
    } elsif ($text =~ /^\/?(checkoff|co)\s+/ && (my @ids=($text=~/(\d+
+)/g))) {
    $msg_num = $msg_num - scalar(@ids);
    my($list) = join ',',@ids;
    print $toServer "CO:$list\n";
    printMessage("\n* Checked off private msgs");
    } elsif ($text =~ /^\s*\/msgs\s*$/) {
    $msg_num = 0;
    my(@msgs) = &getFromServer('msgs');
    printMessage("\n* No personal messages") unless @msgs;
    foreach (@msgs) { &printChat("$_"); }
    } elsif ($text =~ /^\/me /) {
    print $toServer "SEND:$text\n";
    } elsif ($text =~ /^\// && ! $options{badcmds}) {
    printError("\nBad command: $text");
    } else {
    print $toServer "SEND:$text\n";
    }
    &Status($status_idle);
}

######################################################################
+##########
#
# Msg_Click
#
# What to do when the user clicks the msg button
#
sub Msg_Click {
    &Status('Sending data...');
    my($index) = $Userlist->curselection;
    if ($index eq "") {
    printError("No user selected");
    } else {
    my($username) = $Userlist->get($index);
    my($text) = $Inputfield->get();
    if ($text) {
        $Inputfield->delete(0,'end');
        $text =~ s/\r*\n//g;
        printMessage("\nSent private msg to $username: $text");
        $username =~ s/ /_/g; # must sub _ for spaces
        $text = '/msg ' . $username . " $text";
        print $toServer "SEND:$text\n";
    }
    }
    &Status($status_idle);
}

######################################################################
+##########
#
# completeName
#
# completes the word where the current insertion point is by looking t
+hrough
# the userlist
#
sub completeName {
    my($text) = $Inputfield->get();
    return unless ($text);
    if ($text =~ /(\[*)\b(\w+)$/) {
    my($brace,$word) = ($1,$2);
    foreach ($Userlist->get(0,'end')) {
        if (s/^$word//i) {
        $_ .= ']' if ($brace);
        $Inputfield->insert('end',$_);
        last;
        }
    }
    }
    $Inputfield->break;
}

######################################################################
+##########
#
# getInfo
#
# Get information on selected user
#
sub getInfo {
    my($index) = $Userlist->curselection;
    if ($index eq "") {
    printError("No user selected");
    } else {
    my($username) = $Userlist->get($index);
    &LaunchBrowser("$username");
    }
}

######################################################################
+##########
#
# getLink
#
# Return the node name which is currently being pointed at by the curs
+or
#
sub getLink {
    my($text) = shift;
    my(%ranges) = ($text->tagRanges('link'),$text->tagRanges('username
+'));
    my($current_row,$current_col) = $text->index('current') =~ /^(\d+)
+\.(\d+)$/;
    foreach (keys %ranges) {
    my($start_row,$start_col) = /^(\d+)\.(\d+)$/;
    my($end_row,$end_col)     = $ranges{$_} =~ /^(\d+)\.(\d+)$/;
    if (&isBetween($current_row,$start_row,$end_row) &&
        &isBetween($current_col,$start_col,$end_col)) {
        my($value) = $text->get("$start_row.$start_col","$end_row.$end
+_col");
        my(%hidden_link_ranges) = $text->tagRanges('hidden_link');
        foreach (keys %hidden_link_ranges) {
        if ($hidden_link_ranges{$_} eq "$start_row.$start_col") {
            $value = $text->get($_,$hidden_link_ranges{$_});
        }
        }
        return $value;
    }
    }
}
sub isBetween {
    my($val,$a,$b) = @_;
    return 1 if (($val >= $a) && ($val <= $b));
}

######################################################################
+##########
#
# LaunchBrowser
#
# Launch a browser to look at a particular node on perlmonks
#
sub LaunchBrowser {
    unless ($^O =~ /MSWin32/i || defined $options{'browser'}) {
    printError("No browser defined");
    printError("Use Options->Choose browser menu to define one.");
    return -1;
    }
    my($node) = @_;
    my($url);
    my($browser) = $options{'browser'};
    printMessage("\n*Launching browser for node $node...");
    if    ($node =~ s/^id:\/\///)   { $url = $perlmonksURL_id   . $nod
+e; }
    elsif ($node =~ s/^node_id=//)  { $url = $perlmonksURL_id   . $nod
+e; }
    elsif ($node =~ s/^cpan:\/\///) { $url = $perlmonksURL_cpan . $nod
+e; }
    elsif ($node =~ /^http:/)       { $url = $node;                   
+   }
    else                            { $url = $perlmonksURL      . $nod
+e; }
    if ($^O =~ /MSWin32/i) {
    my($process);
    $browser =~ s/\\/\\\\/g;
    $browser =~ s/\"//g;
    $browser =~ /\\(\S+)$/;
    my($pgm) = $1;
    eval '
        use Win32::Process;
        Win32::Process::Create($process,
                                   "$ENV{SYSTEMROOT}\\\\system32\\\\cm
+d.exe",
                                   "cmd.exe /c start $url",
                                   0,DETACHED_PROCESS,".") ||
          printError("Unable to launch browser: " . Win32::FormatMessa
+ge(Win32::GetLastError()));
    ';
    } else {
    eval '
        my($pid) = fork;
            $url =~ s/\s/+/g;
        if ($pid == 0) {
        exec "$browser \'$url\'";
        }';
    }
}

######################################################################
+##########
#
# Exit
#
# What to do when the user clicks the exit menu option
#
sub Exit {
    &Status("Killing server process ($serverProcess)...");
    if (kill('KILL',$serverProcess)) {
    print "Successfully shutdown server.\n";
    } else {
    print "An error occurred shutting down server ($serverProcess).\n"
+;
    }
    exit(0);
}

######################################################################
+##########
#
# About
#
# What to do when the user clicks the about menu option
#
sub About {
    my($perl_ver) = $];
    $perl_ver =~ s/^(\d+)\.0+(\d+)$/$1.$2/;
    my($tk_ver) = $Tk::VERSION;
    $tk_ver =~ s/^(\d)(\d+)\.\S+$/$1.$2/;
    my($browser_short) = $options{'browser'};
    $browser_short =~ s/\\+/\\/g;
    printMessage("\nmonkchat version $version");
    printMessage("\nPerl version $perl_ver");
    printMessage("\nTk version $tk_ver");
    printMessage("\nBrowser: $browser_short") if ($browser_short);
    printMessage("\nby ");
    printMessage('Shendal','link');
    printMessage(", copyleft 2000");
}

######################################################################
+##########
#
# updChatterbox
#
# Checks for new chat messages
#
sub updChatterbox {
    &Status('Checking for new chat messages...');
    foreach (&getFromServer('chat')) { &printChat("$_"); }
    &Status($status_idle);
}

######################################################################
+##########
#
# printChat
#
# Print to chatterbox with proper format and colors
#
sub printChat {
    local($_) = shift;
    chomp;
    return unless ($_);
    my($color) = shift || 'default';
    my($ret)   = shift;
    $ret = 1 unless (defined $ret);
    LINE: {
    # special case for needed a return: and all is quiet
    if (/^and all is quiet\.\.\.$/) {
        printMessage('and all is quiet...','default',1);
        last LINE;
    }
    # private messages
    if (s/^\(\d+\) \* (.+) says // || s/^\* (.+) says //) {
        printMessage("*** (" . ++$msg_num . ") ",'private',1);
        printMessage("$1",'username');
        printMessage(' says ','private');
        $ret = 0;
        redo LINE;
    }
    # usernames
    if ($ret && s/^<(.+?)>//) {
        printMessage('<', 'default',1);
        printMessage("$1",'username');
        printMessage('>', 'default');
        $ret = 0;
        redo LINE;
    }
    # CODE blah /CODE
    if (s/^(.*?)\<CODE\>(.*?)<\/CODE>//i) {
        my($text,$code) = ($1,$2);
        printChat("$text",$color,$ret);
        printMessage("$code",'code');
        $ret = 0;
        redo LINE;
    }
    # [blah]
    if (s/^([^\[]*?)\[(.+?)\]//) {
        my($text,$link) = ($1,$2);
        printChat("$text",$color,$ret);
        if ($link =~ s/^(.+)\|(.+)$/$2/) { printMessage("$1",'hidden_l
+ink'); }
        printMessage("$link",'link');
        $ret = 0;
        redo LINE;
    }
    # <A HREF=foo>bar</A>
    if (s/^(.*?)<A\s+HREF=(\S+)>(.+)<\/A>//i) {
        my($text,$link,$linktext) = ($1,$2,$3);
        printChat("$text",$color,$ret);
        $link =~ s/[\"\']//g;
        printMessage("$link",'hidden_link');
        printMessage("$linktext",'link');
        $ret = 0;
        redo LINE;
    }
    # colorize logged in user's name
    if (defined $loggedInUser && s/^(.*?)$loggedInUser//i) {
        printChat("$1",$color,$ret) if ($1);
        printMessage("$loggedInUser",'self',$ret);
        $ret = 0;
        redo LINE;
    }
    # everything else just print
    printMessage("$_",$color,$ret);
    }
}

######################################################################
+##########
#
# updXP
#
# Find user's current XP level and what the next level will be
#
sub updXP {
    &Status('Checking for new XP information...');
    my($level,$xp,$xp2next,$votesleft) = &getFromServer('xp');
    if (!defined $level || $level =~ /^\s*$/) {
    $Progress->delete($ptext);
    $ptext=$Progress->createText(150,10,-text=>"Unable to obtain your 
+XP info");
    } else {
    my($position) = int(( ($xp-$perlmonk_levels{$level}) /
                  ($xp-$perlmonk_levels{$level}+$xp2next)) * 100) ;
    $Progress->delete($prect);
    $prect=$Progress->createRectangle(0,0,$position*3-1,20,
                      -fill    => 'green',
                      -outline => 'green');
    my($XPLabelStr) = "Level: $level, XP: $xp, "
        . "To next: $xp2next ($position%), Votes left: $votesleft";
    $Progress->delete($ptext);
    $ptext=$Progress->createText(150,10,-text=>$XPLabelStr);
    }
    &Status($status_idle);
}

######################################################################
+##########
#
# updUserlist
#
# Updates the userlist listbox
#
sub updUserlist {
    &Status('Checking userlist...');
    my($oldindex) = $Userlist->curselection || "";
    if ($oldindex ne "") { $oldindex = $Userlist->get($oldindex); }
    $Userlist->delete(0,'end');
    my($num_users) = 0;
    foreach (&getFromServer('userlist')) {
    $Userlist->insert('end',"$_");
    $num_users++;
    if (defined $oldindex && $_ eq $oldindex) { $Userlist->selectionSe
+t('end'); }
    }
    $UserlistLabel->configure(-text => "# Users: $num_users");
    printError("Ack!  No one's logged in!") unless $num_users;
    &Status($status_idle);
}

######################################################################
+##########
#
# updUsername
#
# Updates the username/password cookie
#
sub updUsername {

    &Status("Updating user information...");

    if (!$userinfo_w) {
    $userinfo_w = $Window->Toplevel(-takefocus=>1,
                    -title  => "Update user info");
    # don't allow any resizing of the window
    $userinfo_w->bind('<Configure>' => sub {
        my($xe) = $userinfo_w->XEvent;
        $userinfo_w->maxsize($xe->w, $xe->h);
        $userinfo_w->minsize($xe->w, $xe->h);
    });
    $userinfo_w->withdraw();
    $userinfo_w->transient($Window);

    # setup frames
    my $frame1 =$userinfo_w->Frame()->pack(-side=>'top');
    my $frame2 =$userinfo_w->Frame()->pack(-side=>'top');
    my $frame3 =$userinfo_w->Frame()->pack(-side=>'top');
    my $frame4 =$userinfo_w->Frame()->pack(-side=>'bottom');

    $frame1->Label(
               -text   => 'Username:',
               -width  => 20,
               )->pack(-side=>'left',-fill=>'x');
    $unField = $frame1->LabEntry(
                     -width  => 25,
                     )->pack;
    $frame2->Label(
               -text   => 'Password:',
               -width  => 20,
               )->pack(-side=>'left',-fill=>'x');    
    $pwField = $frame2->LabEntry(
                      -width    => 25,
                      -show => '*',
                     )->pack;
    $frame3->Label(
               -text   => 'Confirm:',
               -width  => 20,
               )->pack(-side=>'left',-fill=>'x');
    $confField = $frame3->LabEntry(
                        -width    => 25,
                        -show => '*',
                       )->pack;
    
    $frame4->Button (
             -text     => "Ok",
             -command=> \&Ok_Click
             )->pack(-side => 'right',-padx=>5,-pady=>2);
    $frame4->Button(
                -text     => "Cancel",
                -command=> sub { $userinfo_w->grabRelease;
                         $userinfo_w->withdraw;
                     }
                )->pack(-side =>'right',-padx=>5,-pady=>2);
    }
    
    $userinfo_w->Popup;
    $unField->focus;
    $userinfo_w->protocol('WM_DELETE_WINDOW',sub {;}); #handle window 
+'x' button
    $userinfo_w->grabGlobal;
    
    &Status($status_idle);
}

sub Ok_Click { 
    my ($un,$pw,$co) = ($unField->get,$pwField->get,$confField->get);
    unless (defined $un && defined $pw && defined $co) {
    printError("All fields required. Nothing changed.");
    $userinfo_w->grabRelease;
    $userinfo_w->withdraw;
    return;
    }
    if ($pw ne $co) {
    printError("Password and confirmation did not match. Nothing chang
+ed.");
    $userinfo_w->grabRelease;
    $userinfo_w->withdraw;
    } else {
    local($_) = &getFromServer("LOGIN $un $pw");
    if (/^Logged in as (.+)$/) {
        printMessage("\nLogged in as $1");
    } else {
        printError("\nLogin failed.");
    }
    $userinfo_w->grabRelease;
    $userinfo_w->withdraw;
     }
}

######################################################################
+##########
#
# chooseBrowser
#
# Prompts the user to select the browser executable
#
sub chooseBrowser {
    &Status("Updating browser information...");
    if (!$choosebrowser_w) {
    $choosebrowser_w = $Window->Toplevel(-takefocus=>1,
                         -title  => "Choose browser executable");
    $choosebrowser_w->withdraw();
    $choosebrowser_w->transient($Window);

    $browserfield = $choosebrowser_w->LabEntry(
                      -label => "Executable:",
                      -width  => 40,
                      -labelPack => [-side => 'left' ]
                     )->pack;
    $choosebrowser_w->Button(
                -text     => "Browse",
                -command=> sub { my($fsref) = $choosebrowser_w->FileSe
+lect;
                         my($file)  = $fsref->Show;
                         $browserfield->configure(-textvariable=>\$fil
+e);
                     }
                )->pack(-side =>'left',-padx=>5,-pady=>2);
    $choosebrowser_w->Button (
                 -text     => "Ok",
                 -command=> \&chooseBrowser_ok
                 )->pack(-side => 'right',-padx=>5,-pady=>2);
    $choosebrowser_w->Button(
                -text     => "Cancel",
                -command=> sub { $choosebrowser_w->grabRelease;
                         $choosebrowser_w->withdraw;
                     }
                )->pack(-side =>'right',-padx=>5,-pady=>2);
    }
    
    $browserfield->configure(-textvariable=>\$options{'browser'}) if (
+defined $options{'browser'});
    $choosebrowser_w->Popup;
    $browserfield->focus;
    $choosebrowser_w->protocol('WM_DELETE_WINDOW',sub {;}); #handle wi
+ndow 'x' button
    $choosebrowser_w->grabGlobal;
    
    &Status("$status_idle");
}

sub chooseBrowser_ok { 
    my($potential_browser) = $browserfield->get;
    $potential_browser =~ s/\//\\/g if ($^O =~ /Win32/i);
    unless ($potential_browser) {
    printError("No browser specified.  Nothing changed.");
    $choosebrowser_w->grabRelease;
    $choosebrowser_w->withdraw;
    return;
    }
    if (! -e "$potential_browser") {
    printError("Could not locate browser executable.");
    } else {
    $options{'browser'} = $potential_browser;
     }
    $choosebrowser_w->grabRelease;
    $choosebrowser_w->withdraw;
}

######################################################################
+##########
#
# printMessage and printError
#
# Prints an error or message to the chatterbox
#
sub printMessage {
    local($_)  = shift;
    my($color) = shift || 'message';
    my($ret)   = shift || 0;

    # translate escape sequences
    s/\&lt\;/</g;     # <
    s/\&gt\;/>/g;     # >
    s/\&\#091\;/\[/g; # [
    s/\&\#093\;/\]/g; # ]

    # print initial return if requested
    $Chatfield->insert('end',"\n",$color) if ($ret);

    # print rest of message
    $Chatfield->insert('end',$_,$color);
    $Chatfield->see('end');
}
sub printError {
    my($error) = shift;
    $error =~ s/\r*\n//g;
    printMessage("ERROR: $error",'error',1);
}

######################################################################
+##########
#
# status
#
# change status line to say something else
#
sub Status {
    my($msg) = shift;
    $Status->configure(-text => $msg);
    $Status->update;
}

######################################################################
+##########
#
# save_settings
#
# save color settings
#
sub save_settings {
    for my $option (keys %options) {
    next if $option =~ /browser/;
    $options{$option}=$Chatfield->tagCget($option,-foreground) unless 
+$option eq 'background';
    }
    $options{'background'}=$Chatfield->cget(-bg);
}

######################################################################
+##########
#
# reset_settings
#
# reset color settings
#
sub reset_settings {
    foreach(keys %default_options) {
    $Chatfield->tagConfigure($_,-foreground=>$options{$_}) unless $_ e
+q 'background';
    }
    $Chatfield->configure(-bg => $default_options{'background'});
    save_settings;
}

######################################################################
+##########
#
# closeDOSParent
#
# Closes the dos prompt that created this process
#
sub closeDOSParent {
    # This just simply doesn't work.  I'm not sure why.
    return;
    return if ($opt_debug); # debugging info goes to STDOUT!
    if ($^O =~ /MSWin32/i) {
    my($process);
    my($program) = $^X;
    $orig_params =~ s/\-c\S*\b//g;
    my($pgm) = "perl $0 $orig_params";
    eval '
        use Win32::Process;
      Win32::Process::Create($process,"$program","$pgm",0,DETACHED_PRO
+CESS,".") ||
          die Win32::FormatMessage(Win32::GetLastError()) . "\n";
    ';
    exit;
    }
}