Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!/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; } }

In reply to Perl/Tk Chatterbox Client by Shendal

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others drinking their drinks and smoking their pipes about the Monastery: (10)
    As of 2014-07-31 09:08 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      My favorite superfluous repetitious redundant duplicative phrase is:









      Results (248 votes), past polls