Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

mchattk

by ase (Monk)
on Jun 22, 2000 at 16:10 UTC ( [id://19420]=sourcecode: print w/replies, xml ) Need Help??
Category: Chatterbox Clients
Author/Contact Info ase alevenson@uswest.net
Description: Tk Version of Shendal's Win32::GUI chatterbox client.
Added features:
  • Color options configurable and persistent between sessions via a tie'd SDBM_File
  • Should work on any platform with Tk 8.0 module
To do:
  • There is still the issue of the GUI blocking when accessing the network. Update: a new version (again based on Shendal's work (see reply below) is in the works... Check back soon.
  • Somehow the Tk status bar Shendal used to help aleviate the item above doesn't seem to work to well in the Tk version.. It doesn't seem to update properly
Notes:
  • Requires ZZamboni's PerlMonkChat module
  • Use/Abuse freely but, please let me know if you fix/add to it so I can use it too.
 
#!/usr/bin/perl -w # -*-Perl-*-
#
# NOTE: portions shamefully borrowed/mutilated from Shendal's monkchat
#       some of the comments are Shendal's.
#       My comments are denoted with (ase)
#
# (ase) mchattk
# Adapted from:
# 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
#
# (ase) And thanks to Shendal for the Win32:GUI code
#
# 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.
# (ase) Tk::Text widget doesn't have this problem fortunately :)
#
# To-do:
#  - while getting data from the website, the gui locks up
#    this is really annoying, but I can't figure out how 
#    to get around it.  I put a status bar there to help
#    let the user know what's going on, but it still locks.
# (ase) This is also a problem with this Tk version...
#
#  - chatterbox doesn't automatically scroll down when new
#    chatter is coming in.  I cannot find the method to 
#    move down on every insert.
# (ase) I've added the $Chatterbox->see('end') in &printMessage to fix
+ this.
#
#  - hitting return doesn't send message - I'm not sure
#    how to bind this
# (ase) In Tk one just uses $widget->bind("<Return>",\&sub_name)
#
#  - userlist should probably be double-clickable to get info
#    on selected user (by launching a browser?)
# (ase) not implemented in this tk version yet either
#
# Version history:
#
# 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 Tk 8.0;
use Tk::LabEntry;
use SDBM_File;
use PerlMonksChat;
use Fcntl;

# Version info
my $version     = '0.9.2';
my $status_idle = "mchattk version $version is idle";

# Polling itervals (in milliseconds)
# Set to zero to disable
my $interval_chat      = 15000;    # 15 secs
my $interval_xp        = 600000; # 10 mins
my $interval_userlist  = 60000;    # 1 mins

# Colors (ase) Note: I changed this to a hash for ease of tieing.
my %color;

tie(%color,'SDBM_File',"$ENV{HOME}/.mctk",O_RDWR|O_CREAT,0640);

my %default_color=(default=> 'black',
    private  => 'purple',
    username => 'blue',
    message  => 'green',
    error    => 'red',
    background => 'white', #chatwindow backround color
);

#set colors to default unless they have alreayd been set
for my $option (keys %default_color) {
    if ($color{$option} eq "") {
        $color{$option} = $default_color{$option}
    }
}

# 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);


# GUI Objects (Tk 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 ow
+n message
my($SayButton);            # send text button
my($Progress);            # progress bar intended to show xp & next le
+vel
my($XPLabel);            # displays XP information on the screen
my($Status);            # well, a status bar (ase) in this case a Tk c
+anvas object
my($userinfo_w);        # userinformation window
my($unField,$pwField,$confField);

# Status vars
my ($prect,$ptext); #XP canvas items

# here we go!
&initWindow;
&initChat;
MainLoop();

######################################################################
+##########
#
# initWindow
#
# Initialize the GUI window
#
sub initWindow {

  $Window = MainWindow->new(
                -title  => "Perlmonks Chat",
                -width  => 600,
                -height => 400,
                  );
  my $menubar = $Window->Menu;
  $Window->configure(-menu => $menubar);

  my $file_mb = $menubar->cascade(-label => '~File',-tearoff => 0);
  my $update_mb = $menubar->cascade(-label => '~Update',-tearoff => 0)
+;
  my $options_mb = $menubar->cascade(-label => '~Options',-tearoff => 
+0);

  $file_mb->command(-label         => 'Exit',
            -underline => 1,
            -command   => sub {exit(0)} );

  $update_mb->command(-label => 'Chatterbox',
              -underline => 0,
              -command => \&updChatterbox_Click);

  $update_mb->command(-label => 'XP',
              -underline => 0,
              -command => \&updXP_Click);

  $update_mb->command(-label => 'Userlist',
              -underline => 0,
              -command => \&updUserlist_Click);

  $update_mb->separator();

  $update_mb->command(-label => 'Username/passwd',
              -underline => 9,
              -command => \&updUsername_Click);

  $options_mb->command(-label=> 'Chat Background',
                       -underline => 0,
                       -command=> 
        sub { $Chatfield->configure(-bg=>$Window->
                chooseColor(-initialcolor=> $Chatfield->cget(-bg),
                            -title => "Background Color"))
            }
                      );

  $options_mb->command(-label=> 'Default text',
                       -underline => 0,
                       -command=> 
        sub { $Chatfield->tagConfigure('default',-foreground=>$Window-
+>
                chooseColor(-initialcolor=> $Chatfield->tagCget('defau
+lt',-foreground),
                            -title => "Default Text Color"));
            }
                      );

  $options_mb->command(-label=> 'Private text',
                       -underline => 0,
                       -command=> 
        sub { $Chatfield->tagConfigure('private',-foreground=>$Window-
+>
                chooseColor(-initialcolor=> $Chatfield->tagCget('priva
+te',-foreground),
                            -title => "Received Private /msg Text Colo
+r"));
            }
                      );

  $options_mb->command(-label=> 'Username text',
                       -underline => 0,
                       -command=> 
        sub { $Chatfield->tagConfigure('username',-foreground=>$Window
+->
                chooseColor(-initialcolor=> $Chatfield->tagCget('usern
+ame',-foreground),
                            -title => "Username Text Color"));
            }
                      );

  $options_mb->command(-label=> 'Message text',
                       -underline => 0,
                       -command=> 
        sub { $Chatfield->tagConfigure('message',-foreground=>$Window-
+>
                chooseColor(-initialcolor=> $Chatfield->tagCget('messa
+ge',-foreground),
                            -title => "Sent Private /msg Text Color"))
+;
            }
                      );

  $options_mb->command(-label=> 'Error text',
                       -underline => 0,
                       -command=> 
        sub { $Chatfield->tagConfigure('error',-foreground=>$Window->
                chooseColor(-initialcolor=> $Chatfield->tagCget('error
+',-foreground),
                            -title => "Error Text Color"));
            }
                      );

  $options_mb->separator();

  $options_mb->command(-label=> 'Save Settings',
                       -underline=> 0,
                       -command=>\&save_settings);

  $options_mb->command(-label=> 'Reset to defaults',
                       -underline=> 0,
                       -command=>\&reset_settings);

  my $uframe=$Window->Frame()->pack(-side=>'top');
  my $lframe=$uframe->Frame()->pack(-side=>'left');
  my $rframe=$uframe->Frame()->pack(-side=>'left',-anchor=>'n');
  my $dframe=$Window->Frame()->pack(-side=>'top');
  my $d2frame=$Window->Frame()->pack(-side=>'bottom');

  $Chatfield = $lframe->Scrolled("Text",
                    -width    => 50,
                    -height   => 20,
                    -bg => $color{'background'},
                 -wrap => 'word',
                    -state => 'disabled',
                 -scrollbars => 'osoe',
                   )->pack(-side=>'top');

  my $itfont = $Chatfield->fontCreate('fontitalic',
                                     -family => 'courier',
                                     -size=>'9',
                                     -slant=>'italic');
  #(ase) configure color tags
  foreach(keys %color) {
    $Chatfield->tagConfigure($_,-foreground=>$color{$_});
    }

  $Chatfield->tagConfigure('italic',-font=>'fontitalic');

  $UserlistLabel = $rframe->Label(
                     -text     => "Getting userlist...",
                     -relief   => "sunken",
                    )->pack(-side=>'top',-fill=>'x');

  $Userlist = $rframe->Scrolled("Listbox",
                  -width    => 10,
                  -height   => 12,
                  -scrollbars => 'osoe',
                  -selectmode => 'single',
                 )->pack(-side=>'top',-fill=>'x');

  $Inputfield = $dframe->Entry(
                      -width    => 50,
                     )->pack(-side=>'left',-fill=>'x',-pady=>4);

  $Inputfield->bind("<Return>", \&Say_Click);

  $SayButton = $dframe->Button(
                  -text     => "Say",
                  -command => \&Say_Click
                 )->pack(-side=>'left');

  $XPLabel = "Getting XP info...";

  $Status = $d2frame->Label(
                  -text  => $status_idle,
                  -relief   => 'sunken',
                 )->pack(-side=>'left',-fill=>'x');

  $Progress = $d2frame->Canvas(-height=>21,
                              -width=>251,
                              -relief=>'sunken',
                              -borderwidth=>2)->pack(-side=>'left');
  $prect = $Progress->createRectangle(0,0,250,20,-fill=> 'red',-outlin
+e=>'red');
  $ptext = $Progress->createText(125,10,-text=>$XPLabel);
}

######################################################################
+##########
#
# initChat
#
# Initialize the chat interface
#
sub initChat {
  $p = PerlMonksChat->new();
  $p->add_cookies;
  $p->login($user,$passwd) if $user;
  $Window->repeat($interval_chat,\&updChatterbox_Click)   if ($interva
+l_chat);
  $Window->repeat($interval_xp,\&updXP_Click)             if ($interva
+l_xp);
  $Window->repeat($interval_userlist,\&updUserlist_Click) if ($interva
+l_chat);
  &updChatterbox_Click;        # seed the chatterbox
  &updXP_Click;            # seed the XP info
  &updUserlist_Click;        # seed the Userlist area
}

######################################################################
+##########
#
# Say_Click
#
# What to do when the user clicks the say button
#
sub Say_Click {
  $Status->configure(-text=>"Sending data...");
  my($text) = $Inputfield->get();
  $Inputfield->delete(0,'end');
  if ($text =~ /^\s*\/msg\s+(\S+)\s*(.+)$/i) {
    $p->send($text);
    printMessage("Sent private msg to $1: $2");
  } elsif ($text =~ /^\/?(checkoff|co)\s+/ && (my @ids=($text=~/(\d+)/
+g))) {
    my(%msgs) = $p->personal_messages;
    $p->checkoff(map { (sort keys %msgs)[$_-1] } @ids);
    printMessage("* Checked off private msgs");
  } elsif ($text =~ /^\s*\/msgs\s*$/) {
    if (my %msgs=$p->personal_messages) {
      my($msg_num) = 1;
      foreach (sort keys %msgs) {
    printMessage("($msg_num) $msgs{$_}",'private');
    $msg_num++;
      }
    } else {
      printMessage("* No personal messages");
    }
  } else {
    $p->send($text);
    &updChatterbox_Click;
  }
  $Status->configure(-text=>$status_idle);
}

######################################################################
+##########
#
# Exit_Click
#
# What to do when the user clicks the exit menu option
#
sub Exit_Click { exit(0); }


######################################################################
+##########
#
# updChatterbox_Click;
#
# Checks for new chat messages
#
sub updChatterbox_Click {
  $Status->configure(-text=>"Checking for new chat messages...");
  my($msg_num) = 1;
  foreach ($p->getnewlines(1)) {
    if (s/^\(\d+\)/\($msg_num\)/) { 
      $msg_num++;
      printMessage("$_",'private');
    } elsif (s/^<(\S+)>//) {
      printuser($1);
      printMessage("$_",'default');
    } else {
      printMessage("$_",'italic');
    }
  }
  $Status->configure(-text=>$status_idle);
}

  sub printuser {
    my($user) = shift;
    printMessage('<','default',1);
    printMessage("$user",'username',1);
    printMessage('>','default',1);
  }

######################################################################
+##########
#
# updXP_Click
#
# Find user's current XP level and what the next level will be
#
sub updXP_Click {
  $Status->configure(-text=>"Checking for new XP information...");
  my(%xp)=$p->xp;
  if (%xp) {
    my($position) = int(( ($xp{xp}-$perlmonk_levels{$xp{level}}) /
              ($xp{xp} - $perlmonk_levels{$xp{level}} + $xp{xp2nextlev
+el}) ) * 100);
     $Progress->delete($prect);
     $prect=$Progress->createRectangle(0,0,$position*2.5-1,20,-fill=>'
+green',
         -outline=>'green');
    my($XPLabelStr) = "Level: $xp{level}, XP: $xp{xp}, "
      . "To next: $xp{xp2nextlevel} ($position%), Votes left: $xp{vote
+sleft}";
      $Progress->delete($ptext);
      $ptext=$Progress->createText(125,10,-text=>$XPLabelStr);
  } else {
      $Progress->delete($ptext);
      $ptext=$Progress->createText(125,10,-text=>"Could not get your X
+P info");
  }
  $Status->configure(-text=>$status_idle);
}

######################################################################
+##########
#
# updUserlist_Click
#
# Updates the userlist listbox
#
sub updUserlist_Click {
  $Status->configure(-text=>"Checking userlist...");
  $Userlist->delete(0,'end');
  my(%users)=$p->users;
  if (%users) {
    my $num_users = 0;
    foreach (sort keys(%users)) {
      $Userlist->insert('end',"$_"); $num_users++;
    }
    $UserlistLabel->configure(-text=>"# Users: $num_users");
  } else {
    printError("Ack!  Noone's logged in!");
    $UserlistLabel->configure(-text=>"# Users: zero!");
  }
  $Status->configure(-text=>$status_idle);
}

######################################################################
+##########
#
# updUsername_Click
#
# Updates the username/password cookie
#
sub updUsername_Click {
  $Status->configure(-text=>"Updating user information...");

   if (!$userinfo_w) {
     $userinfo_w = $Window->Toplevel(-takefocus=>1,
                                     -title  => "Update user info");
     $userinfo_w->withdraw();
     $userinfo_w->transient($Window);

     $unField = $userinfo_w->LabEntry(
                      -label => "Username:",
                      -width  => 25,
                      -labelPack => [-side => 'left' ]
                     )->pack;

     $pwField = $userinfo_w->LabEntry(
                      -label   => "Password:",
                      -width    => 25,
                      -show => '*',
                      -labelPack => [-side => 'left' ]
                     )->pack;

     $confField = $userinfo_w->LabEntry(
                        -label   => "Confirm:",
                        -width    => 25,
                        -show => '*',
                        -labelPack => [-side => 'left' ]
                       )->pack;

     $userinfo_w->Button(
                         -text     => "Cancel",
                         -command=>
             sub { $userinfo_w->grabRelease;
                   $userinfo_w->withdraw;
                 }
                            )->pack(-side =>'right',-padx=>5,-pady=>2)
+;

     $userinfo_w->Button (
                         -text     => "Ok",
                         -command=> \&Ok_Click
                        )->pack(-side => 'left',-padx=>5,-pady=>2);
   }

  $userinfo_w->Popup;
  $unField->focusForce;
  $userinfo_w->protocol('WM_DELETE_WINDOW',sub {;}); #handle window 'x
+' button
  $userinfo_w->grabGlobal;

  $Status->configure(-text=>$status_idle);
}

  sub Ok_Click { 
      my ($un,$pw,$co) = ($unField->Text,$pwField->Text,$confField->Te
+xt);
     unless ($un && $pw && $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 ch
+anged.");
       $userinfo_w->grabRelease;
        $userinfo_w->withdraw;
     } else {
       $p->login($un,$pw);
       $userinfo_w->grabRelease;
        $userinfo_w->withdraw;
     }
   }

######################################################################
+##########
#
# printMessage and printError
#
# Prints an error or message to the chatterbox
#
sub printMessage {
  my($msg) = shift;
  my($color) = shift || 'message';
  my($omit_return) = shift;
  $msg .= "\n" unless $omit_return;
  $Chatfield->configure(-state=>'normal');
  $Chatfield->insert('end',$msg,$color);
  $Chatfield->see('end');
  $Chatfield->configure(-state=>'disabled');
}
sub printError {
  my($error) = shift;
  printMessage("ERROR: $error",'error')
}

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

# reset color settings to default values
sub reset_settings {
  foreach(keys %default_color) {
    $Chatfield->tagConfigure($_,-foreground=>$color{$_}) unless $_ eq 
+'background';
    }
  $Chatfield->configure(-bg => $default_color{'background'});
  save_settings;
}
Replies are listed 'Best First'.
RE: mchattk
by Shendal (Hermit) on Jun 22, 2000 at 19:48 UTC
    Nice. I like it.

    You may want to get the latest version of my client. Version 1.0 alleviates the gui locking problem by launching a server process to connect to the server and cache information. Also, several other bugs/issues are resolved.

    Cheers!
    --shendal
[reply]
Re: mchattk
by Mago (Parson) on Jan 12, 2006 at 14:22 UTC
    Change for new hash in code:

    # 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  => 90,
                        5  => 150,
                        6  => 250,
                        7  => 400,
                        8  => 600,
                        9  => 900,
                        10 => 1300,
                        11 => 1800,
                        12 => 2400,
                        13 => 3000,
                        14 => 4000,
                        15 => 5400,
                        16 => 7000,
                        17 => 9000,
                        18 => 12000,
                        19 => 16000,
                        20 => 22000,
                        21 => 30000,
                        22 => 40000,
                        23 => 50000,
                        24 => 60000,
                        25 => 70000,
                        26 => 80000,
                        27 => 90000,
                        28 => 100000);

    [download]

    *<;o))


    Mago
    mago@rio.pm.org


[reply]
[d/l]

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: sourcecode [id://19420]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others exploiting the Monastery: (5)
As of 2024-10-03 15:03 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    The PerlMonks site front end has:





    Results (42 votes). Check out past polls.
    Notices?
    • erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.