Beefy Boxes and Bandwidth Generously Provided by pair Networks Cowboy Neal with Hat
P is for Practical
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!/usr/local/perl/bin/perl -- # -*-Perl-*- # NOTE: I always use -w, but I'm not here because there's a bug # in Win32::GUI which constantly spits out warnings. It's # annoying, so I'm not using -w. Get over it. # # monkchat # Shendal, June 2000 # # 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 # # Notes: # - When I output to the chatterbox window, the script needs # to append the output to the end of the buffer. Currently, # Win32::GUI doesn't have a nice way to do this. Instead, # I have to select the end of the buffer and then do a # ReplaceSel. It's kludgy, but it works. # # To-do: # - userlist could be double-clickable to get info # on selected user (by launching a browser?) # # Version history: # 1.0 6/21/00 # - Added File->About to show version information # - Chatterbox now automatically scrolls on every insert! *phew* # 0.9.4 6/20/00 # - Hitting return now sends whatever is in the input box. I simply # changed the Win32::Window to Win32::DialogBox and it worked. # Go figure. # - Tabbing around the userinfo/password box now works as well. # 0.9.3 6/20/00 # - Spawn new process to alleviate gui locking during updates # 0.9.2 6/16/00 # - XP progress bar is more accurate: now reports % of way # from current level to next # 0.9.1 6/16/00 # - fixed private message formatting # - text now inserted at bottom of buffer # - added /checkoff, /co for checking off private messages # - added /msgs to re-print unchecked private messages # - sent private messages now appear in chatterbox buffer # - added color # 0.9 6/15/00 # - initial release # use strict; use Getopt::Long; use Win32::GUI; use IPC::Open2; use Symbol; use PerlMonksChat; # Process command-line options use vars '$opt_server'; # launch in server mode use vars '$opt_close'; # close dos parent window use vars '$opt_debug'; # debug &GetOptions("server","close","debug") or die "Bad options!"; # Since we're communicating line by line, we want everything unbuffere +d select STDERR; $|=1; select STDOUT; $|=1; # Version info my($version) = '1.0'; my($status_idle) = "monkchat version $version is idle"; # Polling itervals (in millisecs) # set to 0 to disable my($interval_chat) = 15000; # 15 secs my($interval_xp) = 30000; # 30 secs my($interval_userlist) = 30000; # 30 secs # refreshes all caches at the expense of occasional gui locks # not really needed, unless you REALLY want to be up to date my($interval_caches) = 0; # Colors my($text_default) = 0x010101; # black my($text_private) = 0x880088; # purple my($text_username) = 0xFF0000; # blue my($text_message) = 0x888800; # aqua my($text_error) = 0x0000FF; # red # 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 # user information my($user,$passwd); # 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($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); # userinformation window my($menu); # Globally declare menu since it affects some user # Thanks to httptech for this one if ($opt_server) { # launch as server process &runServer; } else { # launch as client process # Hide the DOS window that created me, if you want to # Warning: This can create a 'zombie' process &closeDOSParent if ($opt_close); &initWindow; &initServer; &initChat; Win32::GUI::Dialog(); } ###################################################################### +########## # # initServer # # Initialize the server process # sub initServer { $Status->Text("Initializing server process..."); my($flags) = '-s'; $flags .= ' -d' if ($opt_debug); $serverProcess = open2($fromServer,$toServer,"$^X","$0","$flags"); while (<$fromServer>) { if (/server started/) { printMessage("Server process started successfully ($serverProc +ess)."); last; } else { printMessage("Failed to start server process."); } } select $toServer; $|=1; select STDOUT; $Status->Text("$status_idle"); } ###################################################################### +########## # # initChat # # Initialize the chat process # sub initChat { $Status->Text("Initializing client..."); $Window->AddTimer("updChatterbox",$interval_chat) if ($interval_ +chat); $Window->AddTimer("updXP",$interval_xp) if ($interval_ +xp); $Window->AddTimer("updUserlist",$interval_userlist) if ($interval_ +userlist); $Window->AddTimer("refreshCaches",$interval_caches) if ($interval_ +caches); &updChatterbox_Click; # seed the chatterbox &updXP_Click; # seed the XP info &updUserlist_Click; # seed the Userlist area $Status->Text("$status_idle"); } ###################################################################### +########## # # runServer # # Run as server # sub runServer { select STDERR; $|=1; select STDOUT; $|=1; # server-only objects my(@chat_cache,%xp_cache,%userlist_cache,@msgs_cache); # caches # init perlmonks chat object $p = PerlMonksChat->new(); $p->add_cookies; $p->login($user,$passwd) if $user; # Seed caches &refreshCaches; # print advisory information so the gui can continue loading print "server started\n"; while (<STDIN>) { s/\r*\n//g; print STDERR "SERVER: received \"$_\"\n" if ($opt_debug); if (/chat/) { foreach (@chat_cache) { print "$_\n"; } print "MeSsAgE_eNd\n"; @chat_cache = (); # flush cache } elsif (/xp/) { foreach ('level','xp','xp2nextlevel','votesleft') { print "$xp +_cache{$_}\n"; } print "MeSsAgE_eNd\n"; } elsif (/userlist/) { foreach (sort keys(%userlist_cache)) { print "$_\n"; } print "MeSsAgE_eNd\n"; } elsif (/msgs/) { my(%msgs) = $p->personal_messages; foreach (sort keys(%msgs)) { print "$msgs{$_}\n"; } print "MeSsAgE_eNd\n"; } elsif (/^upd/) { &updChatCache if (/updChatCache/); &updXPCache if (/updXPCache/); &updUserlistCache if (/updUserlistCache/); } elsif (/^refreshCaches/) { &refreshCaches; } elsif (s/^SEND://) { s/\r*\n//g; 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); } else { print STDERR "Un-oh -- shouldn't ever get here: $_\n"; } } print STDERR "server exited abnormally\n"; sub updChatCache { foreach ($p->getnewlines(1)) { push @chat_c +ache, $_; } } sub updXPCache { %xp_cache = $p->xp; } sub updUserlistCache { %userlist_cache = $p->users; } sub refreshCaches { &updChatCache; &updXPCache; &updUserlistCache; } } ###################################################################### +########## # # 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 { $menu = Win32::GUI::MakeMenu ( "&File" => "File", "> &About" => "About", "> E&xit" => "Exit", "&Update" => "Update", "> Force update on &chatterbox" => "updChatterbox", "> Force update on &XP" => "updXP", "> Force update on &userlist" => "updUserlist", "> -" => 0, "> Change username and password" => "updUsername", ); $Window = new Win32::GUI::DialogBox( -title => "Perlmonks Chat", -left => 100, -top => 100, -width => 600, -height => 400, -name => "Window", -style => WS_MINIMIZEBOX | WS_CAPTION | WS_SYSMENU, -menu => $menu, ); $Chatfield = $Window->AddRichEdit( -name => "Chatfield", -left => 5, -top => 5, -text => "", -width => $Window->ScaleWidth-105, -height => $Window->ScaleHeight-70, -readonly => 1, -style => WS_CHILD | WS_VISIBLE | ES_AUTOVSCROLL | WS_VSCROLL | ES_LEFT | ES_MULTILINE | ES_READONLY, -exstyle => WS_EX_CLIENTEDGE, ); $Userlist = $Window->AddListbox( -name => "Userlist", -text => "Userlist", -left => $Window->ScaleWidth-100, -top => 5, -width => 95, -height => $Window->ScaleHeight-65, -multisel => 0, -sort => 1, ); $UserlistLabel = $Window->AddLabel( -text => "Getting userlist...", -sunken => 1, -name => "UserlistLabel", -left => $Window->ScaleWidth-100, -top => $Window->ScaleHeight-86, -width => 95, -height => 21, ); $Inputfield = $Window->AddTextfield( -name => "input", -left => 5, -top => $Window->ScaleHeight-60, -text => "", -width => $Window->ScaleWidth-50, -height => 22, -foreground => [0,0,0], -background => [255,255,255], -tabstop => 1, ); $Inputfield->SetFocus; $SayButton = $Window->AddButton( -name => "Say", -left => $Window->ScaleWidth-40, -top => $Window->ScaleHeight-60, -width => 35, -height => 22, -text => "Say", -tabstop => 1, -default => 1, -ok => 1, ); $Progress = $Window->AddProgressBar( -name => "Progress", -left => $Window->ScaleWidth/2, -top => $Window->ScaleHeight-34, -width => ($Window->ScaleWidth/2)-5, -height => 10, -smooth => 1, ); $XPLabel = $Window->AddLabel( -text => "Getting XP info...", -sunken => 1, -name => "XPLabel", -left => $Window->ScaleWidth/2, -top => $Window->ScaleHeight-22, -width => ($Window->ScaleWidth/2)-5, -height => 20, ); $Status = $Window->AddLabel( -name => "Status", -text => "$status_idle", -sunken => 1, -left => 5, -top => $Window->ScaleHeight-22, -width => ($Window->ScaleWidth/2)-10, -height => 20, ); $Window->Show(); } ###################################################################### +########## # # 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; } ###################################################################### +########## # # Timers # # Checks for new message or updates info on timers # sub updChatterbox_Timer { &updChatterbox_Click; print $toServer "updCh +atCache\n"; } sub updXP_Timer { &updXP_Click; print $toServer "updXP +Cache\n"; } sub updUserlist_Timer { &updUserlist_Click; print $toServer "updUs +erlistCache\n"; } sub refreshCaches_Timer { print $toServer "refreshCaches\n"; } ###################################################################### +########## # # Say_Click # # What to do when the user clicks the say button # sub Say_Click { $Status->Text("Sending data..."); my($text) = $Inputfield->Text(); $Inputfield->Text(""); $text =~ s/\r*\n//g; if ($text =~ /^\s*\/msg\s+(\S+)\s*(.+)$/i) { print $toServer "SEND:$text\n"; printMessage("Sent private msg to $1: $2"); } elsif ($text =~ /^\/?(checkoff|co)\s+/ && (my @ids=($text=~/(\d+ +)/g))) { my($list) = join ',',@ids; print $toServer "CO:" . join ',',@ids . "\n"; printMessage("* Checked off private msgs"); } elsif ($text =~ /^\s*\/msgs\s*$/) { my(@msgs) = &getFromServer('msgs'); printMessage("* No personal messages") unless @msgs; my($msg_num) = 1; foreach (@msgs) { printMessage("($msg_num) $_",$text_private); $msg_num++; } } else { print $toServer "SEND:$text\n"; } $Status->Text("$status_idle"); } ###################################################################### +########## # # Exit_Click # # What to do when the user clicks the exit menu option # sub Exit_Click { if (kill('KILL',$serverProcess)) { print "Successfully shutdown server.\n"; } else { print "An error occurred shutting down server ($serverProcess).\n" +; } exit(0); } ###################################################################### +########## # # About_Click # # What to do when the user clicks the about menu option # sub About_Click { my($gui_ver) = $Window->Version(); printMessage("monkchat version $version"); printMessage("Win32::GUI version $gui_ver"); printMessage("by Shendal, copyleft 2000"); } ###################################################################### +########## # # updChatterbox_Click; # # Checks for new chat messages # sub updChatterbox_Click { $Status->Text("Checking for new chat messages..."); my($msg_num) = 1; foreach (&getFromServer('chat')) { $Chatfield->Select(999999,999999); # See note above on this kludge if (s/^\(\d+\)/\($msg_num\)/) { $msg_num++; printMessage("$_",$text_private); } elsif (s/^<(\S+)>//) { printuser($1); printMessage("$_",$text_default); } else { printMessage("$_",$text_default); } } $Status->Text("$status_idle"); sub printuser { my($user) = shift; printMessage('<',$text_default,1); printMessage("$user",$text_username,1); printMessage('>',$text_default,1); } } ###################################################################### +########## # # updXP_Click # # Find user's current XP level and what the next level will be # sub updXP_Click { $Status->Text("Checking for new XP information..."); my($level,$xp,$xp2next,$votesleft) = &getFromServer('xp'); if ($level =~ /^\s*$/) { $XPLabel->Text("Error accessing your XP node"); } else { my($position) = int(( ($xp-$perlmonk_levels{$level}) / ($xp-$perlmonk_levels{$level}+$xp2next)) * 100) ; $Window->Progress->SetPos($position); my($XPLabelStr) = "Level: $level, XP: $xp, " . "To next: $xp2next ($position%), Votes left: $votesleft"; $XPLabel->Text("$XPLabelStr"); } $Status->Text("$status_idle"); } ###################################################################### +########## # # updUserlist_Click # # Updates the userlist listbox # sub updUserlist_Click { $Status->Text("Checking userlist..."); $Userlist->Clear; my($num_users) = 0; foreach (&getFromServer('userlist')) { $Userlist->AddString("$_"); $num_users++; } $UserlistLabel->Text("# Users: $num_users"); printError("Ack! Noone's logged in!") unless $num_users; $Status->Text("$status_idle"); } ###################################################################### +########## # # updUsername_Click # # Updates the username/password cookie # sub updUsername_Click { $Status->Text("Updating user information..."); my($unField,$pwField,$confField); if (!$userinfo_w) { $userinfo_w = new Win32::GUI::DialogBox( -title => "Update user info", -left => 200, -top => 200, -width => 250, -height => 150, -name => "userinfo_w", -style => WS_CAPTION, ); $unField = $userinfo_w->AddTextfield( -name => "username", -prompt => "Username:", -left => 5, -top => 5, -height => 22, -width => 150, -tabstop=> 1, ); $pwField = $userinfo_w->AddTextfield( -name => "password", -prompt => "Password:", -left => 5, -top => 32, -height => 22, -width => 150, -password => 1, -tabstop=> 1, ); $confField = $userinfo_w->AddTextfield( -name => "confirm", -prompt => "Confirm:", -left => 5, -top => 56, -height => 22, -width => 150, -password => 1, -tabstop=> 1, ); my($cancelButton) = $userinfo_w->AddButton ( -name => "Cancel", -text => "Cancel", -left => 5, -top => 83, -height => 30, -width => ($userinfo_w->ScaleWidth/2)-5, -tabstop=> 1, ); my($okButton) = $userinfo_w->AddButton ( -name => "Ok", -text => "Ok", -left => ($userinfo_w->ScaleWidth/2)+5, -top => 83, -height => 30, -width => ($userinfo_w->ScaleWidth/2)-5, -tabstop=> 1, ); $unField->SetFocus; } $userinfo_w->Show(); $Status->Text("$status_idle"); sub userinfo_w_Terminate { return -1; } sub Cancel_Click { $userinfo_w->Hide; } sub Ok_Click { unless ($unField->Text && $pwField->Text && $confField->Text) { printError("All fields required. Nothing changed."); $userinfo_w->Hide; return; } if ($pwField->Text ne $confField->Text) { printError("Password and confirmation did not match. Nothing c +hanged."); $userinfo_w->Hide; } else { print $toServer 'LOGIN ' . $unField->Text . ' ' . $pwField->Te +xt . "\n"; printMessage("Logged in as " . $unField->Text); $userinfo_w->Hide; } } } ###################################################################### +########## # # Userlist_DblClick # # What to do when a user double-clicks someone in the user list # sub Userlist_DblClick { printMessage("Detected double click in userlist!"); my($selected) = $Userlist->GetString($Userlist->SelectedItem); if ($selected) { printMessage("Launch browser to look at user $selected."); } } ###################################################################### +########## # # printMessage and printError # # Prints an error or message to the chatterbox # sub printMessage { my($msg) = shift; my($color) = shift || $text_message; my($omit_return) = shift; $msg .= "\n" unless $omit_return; $Chatfield->SetFocus(); $Chatfield->Select(999999,999999); # See hack message above setColor($color); $Chatfield->ReplaceSel("$msg",1); setColor($text_default); $Inputfield->SetFocus(); } sub printError { my($error) = shift; printMessage("ERROR: $error","$text_error") } ###################################################################### +########## # # setColor # # sets text color for chatterbox # sub setColor { my($color) = shift; $Chatfield->SetCharFormat(-color => "$color"); } ###################################################################### +########## # # closeDOSParent # # Closes the dos prompt that created this process # sub closeDOSParent { my($DOShwnd, $DOShinstance) = Win32::GUI::GetPerlWindow(); # either close it or hide it, but it's gonna be around when you qu +it this # program! Win32::GUI::CloseWindow($DOShwnd); Win32::GUI::Hide($DOShwnd); }

In reply to Win32::GUI 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 examining the Monastery: (16)
    As of 2014-04-24 11:47 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      April first is:







      Results (565 votes), past polls