Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
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 examining the Monastery: (10)
As of 2014-10-31 09:08 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (215 votes), past polls