Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

Perl/Tk Chatterbox Client

by Shendal (Hermit)
on Jul 13, 2000 at 00:33 UTC ( #22273=sourcecode: print w/ replies, xml ) Need Help??

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;
    }
}

Comment on Perl/Tk Chatterbox Client
Download Code
RE: Perl/Tk Chatterbox Client
by ZZamboni (Curate) on Jul 13, 2000 at 01:43 UTC
    If you cut-and-paste from this page, you can use the following to remove the continuation "+" signs and reconstruct the file correctly:
    perl -ne 'chomp; if (/^\+(.*)$/) { $last.=$1 } \ else { print "$last\n"; $last=$_ } \ END { print "$last\n" }' origfile.pl > destfile.pl

    --ZZamboni

      This is easier to type:

      perl -pe 'chomp;s/^\+//||s/^/\n/;END{print"\n"}' # Unix perl -pe "chomp;s/^\+//||s/^/\n/;END{print qq.\n.}" # Win32

      And you can drop the END{...} part if you just append an extra blank line to the input or don't mind the missing final newline on the output.

      isn't it easier to click on the "d/l code" to download the code????
      Chady | http://chady.net/
        Those comments were written waaaaaay before the "d/l code" feature existed... :-)

        --ZZamboni, aka Duke Dong

RE: Perl/Tk Chatterbox Client
by tiny (Beadle) on Jul 18, 2000 at 02:15 UTC
    Awesome script! A note for Win32 users: Make sure you have a C:\TEMP directory or you will run into some weird things.
RE: Perl/Tk Chatterbox Client
by young perlhopper (Scribe) on Jul 22, 2000 at 03:00 UTC
    Where do i find PerlMonksChat.pm? I searched cpan and perlmonks to no avail.

    Thanks,
    Mark

RE: Perl/Tk Chatterbox Client
by lolindrath (Scribe) on Aug 04, 2000 at 21:28 UTC
    Is there a workaround for us poor people with proxies? Is there anyway I can get this to connect to my proxy?

    --=Lolindrath=--

      First, set up your enviromental variables for your HTTP proxy. Then, backup Perlmonks.pm, open it, and move to line 63, which looks like this:

      $self->{ua}=new LWP::UserAgent;

      And add below it:

      $self->{ua}->env_proxy();

      Save it and run it.

      That will get you on as a Anonymous Monk, but I havn't sorted out why it fails with logging in. Ideas welcome! By the By, this is on a WinNT system.

      ----Asim, known to some as Woodrow.
        But what about proxies that require a username/pass combo?
        I've managed to set "HTTP_PROXY="http://bozo.the.com:83" in my .profile, but what about username and pass?

        What does this little button do . .<Click>; "USER HAS SIGNED OFF FOR THE DAY"
RE: Perl/Tk Chatterbox Client
by $code or die (Deacon) on Oct 28, 2000 at 19:57 UTC
    I had a problem using this script - it wouldn't let me log in because I have spaces in my username ('$code or die').

    I had to make a change to line 326 - in the runserver sub. It's looking for the following: /^LOGIN: (\S+) (\S+)$/ Which wouldn't work in my case because it will find: 'LOGIN: $code or die ****' so it thinks that 'or' is my password and there are things after it.

    I guess that most PerlMonks users have a one-word username, but I found that the following modification will work for me and anyone else:

    /^LOGIN: (.+) (\S+)$/ I hope that spaces aren't allowed in passwords too - otherwise you'll have to do this without a regex.

    Another way around this would be to change the line (1057) in the Ok_Click sub:
    &getFromServer("LOGIN $un $pw");
    to something like : &getFromServer("LOGIN $un-:-$pw");

    Then you could change the regex above to: /^LOGIN: (.+)-:-(.+)$/

    -:- is probably not a very good delimiter but it would probably work.

    Anyway - apart from that - monkchat is great - I love it!

    UPDATED: changed the regex strings from (.*) to (.+).
      Thanks for pointing this out. I have fixed the bug, and the fix will be included in the next released version (probably in the next few days).

      Cheers,
      Shendal
(crazyinsomniac) Re: Perl/Tk Chatterbox Client
by crazyinsomniac (Prior) on Jan 21, 2001 at 20:07 UTC
    Hi ya Shendal, y'all

    I needed to make the following 'small' changes to your LaunchBrowser subroutine.
    Here goes(my 100th post):

    eval ' use Win32::Process; my $cmdline = "command.com"; my $appname = "$ENV{WINBOOTDIR}/command.com"; if(Win32::IsWinNT()) { $cmdline = "cmd.exe"; $appname = "$ENV{SYSTEMROOT}/system32/cmd.exe"; } $cmdline .= " /c start $url"; Win32::Process::Create($process,$appname,$cmdline,0,DETACHED_P +ROCESS,".") || printError("Unable to launch browser: " . Win32::Forma +tMessage(Win32::GetLastError())); '; }

    "cRaZy is co01, but sometimes cRaZy is cRaZy".
                                                          - crazyinsomniac

(yakko: ctrl-u addition) Re: Perl/Tk Chatterbox Client
by yakko (Friar) on Jan 22, 2001 at 01:34 UTC
    Great client!

    Here's some small bits to add if you like using ^U to get rid of the text in the input widget...

    Around line 541, you originally have:

    $Inputfield->bind("<Return>", \&Say_Click); $Inputfield->bind("<Control-Return>", \&Msg_Click); $Inputfield->bind("<Tab>", \&completeName);
    insert the ^U binding after the statements above:
    $Inputfield->bind("<Control-u>", \&clearentrybox);
    and around line 682, between the end of the Msg_Click sub and the beginning of the completeName sub, I put my ^U subroutine:
    ###################################################################### +########## # # clearentrybox # # clears the entry box on ^U # sub clearentrybox { $Inputfield->delete(0,'end'); }
    So far, so good here on my system... a perusal of Tk::Text didn't reveal conflicts with normal keys...

    (Update: Added context to make locating the spots to put the code a tad easier)

    --
    Me spell chucker work grate. Need grandma chicken.

Re: Perl/Tk Chatterbox Client
by chipmunk (Parson) on Feb 01, 2001 at 03:42 UTC
    This change allows monkchat.pl to use the appropriate URL for links like [/index.pl?node_id=43546|chipmunk]. (Inspired by epoptai. ;)

    Replace the definition of the perlmonks URLs with these lines:

    # URL to use for links into perlmonks & cpan my($perlmonksURL_base) = 'http://www.perlmonks.org/'; my($perlmonksURL_node) = '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=';
    And update the code for the launchBrowser sub with these lines:
    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; + } elsif ($node =~ s/^\/+//) { $url = $perlmonksURL_base . $nod +e; } else { $url = $perlmonksURL_node . $nod +e; }
(yakko: URL handler tweaks) Re: Perl/Tk Chatterbox Client
by yakko (Friar) on Feb 04, 2001 at 04:16 UTC
    (Update(1): added handling for "+", and Mandrake info)

    After a week in the cooker and a couple of revisions, I think I've got a fix for URL passing... at least for me, when I click on a URL, it may not make it to netscape (shell munged it), or netscape won't like it (has commas in it)... so, here's the stuff:

    Near the top, right after the comments, you have the usual use stuff. Insert:

    use URI::Escape; # escape funky chars out of URLs
    I inserted this around line 90, after use PerlMonksChat;

    Next, you'll want to go down to the LaunchBrowser sub, where you have at about line 773:

    ... else { $url = $perlmonksURL . $nod +e; } if ($^O =~ /MSWin32/i) { ...
    In between these two lines, I've inserted the magic code to take care of all my weird URL woes[1]:
    # escape URL to keep netscape and/or the shell from choking # " " is also unsafe (causes "Doc contains no data" $url=~s/+/%2B/g; # real "+" is preserved $url=~s/\s/+/g; # get rid of whitespace, not just " " $url=uri_escape($url,"\',");
    Now, for Unix folks, there's now a duplicate line in the eval block that handled whitespace:
    ... eval ' my($pid) = fork; $url =~ s/\s/+/g; if ($pid == 0) { ...
    Get rid of the $url =~ ... line (line 791 in my original), and you'll be set.

    Tested for a week on Unix; some testing by dystrophy on win32. It's taken every URL that folks in the CB and I myself have thrown at it. Let me know if something goes weird.

    [1] Alternatively, you may want to toy with the following instead of s///, but I haven't tested this:

    $url=uri_escape($url," \',+");
    Also, for you Mandrake users, the "netscape" wrapper really mangles URLs with "-" in them. If you find this happening to you, and you haven't got it fixed, I have some diffs for the shell script that have helped me. Just /msg me to let me know you're interested.

    --
    Me spell chucker work grate. Need grandma chicken.

Re: Perl/Tk Chatterbox Client
by chipmunk (Parson) on May 08, 2001 at 22:46 UTC
    Update to accept the new google:// links, in addition to the cpan:// links:

    Replace the section for the perlmonks URLs with this code:

    # URL to use for links into perlmonks, cpan, and google my($perlmonksURL_base) = 'http://www.perlmonks.org/'; my($perlmonksURL_node) = '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='; my($perlmonksURL_google) = 'http://www.google.com/search?q=';
    And update part of the launchBrowser sub with this code (also fixed those escaped slashes...):
    printMessage("\n*Launching browser for node $node..."); if ($node =~ s,^id://,,) { $url = $perlmonksURL_id . $n +ode; } elsif ($node =~ s,^node_id=,,) { $url = $perlmonksURL_id . $n +ode; } elsif ($node =~ s,^cpan://,,) { $url = $perlmonksURL_cpan . $n +ode; } elsif ($node =~ s,^google://,,) { $url = $perlmonksURL_google . $n +ode; } elsif ($node =~ m,^http:,) { $url = $node; + } elsif ($node =~ s,^/+,,) { $url = $perlmonksURL_base . $n +ode; } else { $url = $perlmonksURL_node . $n +ode; }
      I did
      elsif ($node =~ s/^google:\/\///) { $node =~ s/\s/%20/g; $url = $perlmonksURL_google . $node;
      to take care of the spaces. Still won't get too funky ...

      HTH
      --
      idnopheq
      Apply yourself to new problems without preparation, develop confidence in your ability to to meet situations as they arrise.

Re: Perl/Tk Chatterbox Client (id:// resolving)
by yakko (Friar) on Jun 14, 2001 at 20:54 UTC
    Here's an update to [id://] resolution in the Tk client.

    The client as posted at the head returns

        resolved name of id:// link
    for each id:// link. This is not always wanted, as sometimes you'll be greeted with a Search page instead of the node in question when you click on such a link. Turns out that PerlMonks::Chat can be told to do the right thing!

    At lines 280, 298, and 315 of the original code, we have:

        foreach ($p->getnewlines(1)) { push @chat_cache, $_; }

    For each of these instances, change it to be:     foreach ($p->getnewlines(1,1)) { push @chat_cache, $_; }
    This will tell PerlMonks::Chat to render id:// links as [id://xxxxxx|resolved name]

    Here's the diff against the code at the head of this thread. Patches a file called "chatterbox" in the current dir, so hack as needed. :o)

    --
    Me spell chucker work grate. Knead grandma chicken.

Re: Perl/Tk Chatterbox Client - fix for WinNT
by kevin_i_orourke (Friar) on Oct 04, 2001 at 15:30 UTC

    Update: the cookie file is '.pm-cookie' NOT '.pm-cookies', thanks to Asim for making me test my own instructions.

    I only seemed to be able to log in as Anonymous Monk through our local firewall/proxy. It turns out that the '.pm-cookie' file which is used to store login information wasn't being created.

    All you need to do is find the directory where your '.perlmonks' directory lives (%HOME%?) and create an empty '.pm-cookie' file. Then run 'getchat.pl' (comes with PerlMonks module) as 'getchat.pl -l <username>', this will log you in properly and sort out the cookies.

    Update: the directories should be something like this:

    • %HOME%/
      • .perlmonks/
      • .pm-cookie
      • (other stuff...)

    /msg me if you need any more information...

    Kevin O'Rourke

Does anybody else have this problem?
by snafu (Chaplain) on Jun 13, 2002 at 19:42 UTC
    Try running the script in debug mode using -d for the switch and you get the following error:

    [jconner@kwan ~/bin/pl]$ ./latest_chat.pl -d Initializing Tk window... Unknown option: s -d Bad options! at ./latest_chat.pl line 106. CLIENT: requesting chat Broken Pipe [jconner@kwan ~/bin/pl]$ ./latest_chat.pl --debug Initializing Tk window... Unknown option: s -d Bad options! at ./latest_chat.pl line 106. CLIENT: requesting chat Broken Pipe
    The reason I am attempting to debug this is because I get logged in just fine but the client doesn't detect any users online. Therefore, I see no chatter going on. Quite frustrating. If I can debug it I am hoping I can learn what it's attempting to do that is failing. Shoot, might just be a firewall. I doubt it though since my regular browser can connect, see, and interact with pm just fine. Thanks! TIA

    _ _ _ _ _ _ _ _ _ _
    - Jim
    Insert clever comment here...

Re: Perl/Tk Chatterbox Client
by converter (Priest) on Oct 31, 2002 at 11:23 UTC

    These patches fix the Perl/Tk chatterbox client (or so it would seem).

    Please test and let me know if there are any problems.

    • Fixed Getopt::Long exception when monkchat is run with the '--debug' or '-d' option:
      Unknown option: s -d Bad options! at ./latest_chat.pl line 106.
      Call to open2() passed command line arguments as list, appending the '-s' and optional '-d' switches as a single string ("-s -d"). When open2() is called with a list of command line args, the shell's word splitting doesn't take place, so "-s -d" is parsed as option switch '-s' with value '-d'.
    • Fixed XML parsing patterns in both Chat.pm and monkchat to accomodate recent changes to the chatterbox XML ticker output.
    • Made a few changes to style to make some of the code easier to read. This is probably an evil thing to do, my apologies.
    • Localized $_ in a few places where it looked like it needed to be done.
    • Fixed pet peeve: "Noone" is not a word. :)

    conv

    NOTE: link removed until I can find time to grab the patches and put them on a different server.
      In case some poor soul wants to test the patched listed in OP, note that "dalnet-perl.org", as of Mar 19 2006, goes to "Porn Guide".

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://22273]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (5)
As of 2015-07-05 18:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (67 votes), past polls