See also http://www.nule.org/?tale=6 to download the latest and archival versions.
#! /usr/bin/perl -w
####################################################################
# ccb.pl - a Chatterbox client written in Perl Curses #
####################################################################
# Abstract: ccb is a simple curses interface to the chatterbox #
# : feature of the PerlMonks.org website. #
# : Some functionality is missing, but it is designed to #
# : to meet some very specific goals - and should be easy #
# : to enhance. #
# #
# Thanks : Go to Shendal for his Perk/Tk client, #
# : Zzamboni for the PerlMonks modules and the sample code #
# : Vroom for creating PerlMonks.org #
# : ybiC for saying "A curses CB client would be mondo++!" #
# : and merlyn, for not turning me into a frog #
# : Lots of other people that deserve mention #
# #
# History : 20011004 - mbl - Initial version. #
# : 20011006 - mbl - Some primitive functionality is here. #
# : 20011007 - mbl - Created the chat buffer object. #
# : - I guess I pretty much made the whole #
# : - thing work - all options and stuff. #
# : 20011008 - mbl - Fixed a little big in the log buffer #
# : - and some other screen bugs. #
# : 20011015 - mbl - Removed some of the lag by correcting #
# : - the timing and help in a window. #
# : 20011016 - mbl - Forking code added. #
# : 20011018 - mbl - More things to make the behavior #
# : - match the CB spec. #
# : 20011021 - mbl - Added support for ignore/unignore #
# : 20011022 - mbl - Adjusted IPC timing to reduce errors. #
# : 20011024 - mbl - Added support for timestamps. #
# : 20011025 - mbl - Added confirm odd message dialog. #
# : 20011026 - mbl - Added support to save message buffer. #
# : 20011027 - mbl - Fixed a bug when the child lags. #
# : - Some private message handling. #
# : 20011104 - mbl - Some more tweaks to IPC. #
# #
# To-do : More fun stuff, like colors. #
# : Get personal messages checkoff to work. #
# : Improvements to the IPC performance might be possible. #
# : I *still* like the idea of a PM minibrowser... #
####################################################################
# Boring, pointless crap: #
# This is free software that may be distributed under the same #
# license as Perl itself. This software comes with no warranty. #
# #
# I suppose that it's Copyright (C) 2001 M. Litherland #
# #
# Get the latest version from http://www.nule.org/ which is also #
# where the author can be reached. #
####################################################################
my $VERSION = "1.0pre2a";
# change your @INC if you have weird module locations.
use lib "/home/litherm/lib/perl5/site_perl/5.6.1/PerlMonksChat2";
use strict;
use Curses;
use Curses::Widgets;
use IO::Handle qw(autoflush);
use Socket;
use Text::Wrap;
# PM Modules
use PerlMonks::Chat;
use PerlMonks::Users;
# Record separator for IPC
use constant RSEPARATOR => "MiKeIsDaUbErCoDeR"; #:)
#############
# Variables #
#############
# Widgets
my ($main, $input, $display, $dialog);
# Variables for dealing with curses widgets
my ($text, $test);
# Handles for our PM objects
my ($chat, $monks, $buffer, $pid);
# More variables
my ($username, $password);
###########################
# Initialize chat package #
###########################
# I'm a newbie when it comes to OO Perl too - be gentle...
{ package Chat;
# Object constructor
sub new
{
my $self = {};
shift; # Package name
# Counter for updating the buffer
$self->{COUNTER} = time();
$self->{MCOUNTER} = 20; # Max time
# Flag for time stamps
$self->{TIMESTAMP} = 1; # 0 is off
# Variables for working with the buffer
$self->{POSITION} = 0;
$self->{LENGTH} = 500;
$self->{BUFFER} = []; # Message buffer
bless($self);
return $self;
}
# Provide a method for changing the buffer size
sub length
{
my $self = shift;
if (@_)
{
$self->{LENGTH} = shift;
}
return $self->{LENGTH};
}
# Provide a method for toggling the time stamp
sub show_time
{
my $self = shift;
if (@_)
{
$self->{TIMESTAMP} = shift;
}
return $self->{TIMESTAMP};
}
# A simple counter to set the chat request interval.
# Passing a value instead sets the Max Counter interval,
# returns the time remaining (0 if done);
sub counter
{
my $self = shift;
my $delta;
if (@_)
{
$self->{MCOUNTER} = shift;
}
$delta = ($self->{COUNTER} + $self->{MCOUNTER}) - time();
if ($delta <= 0)
{
$self->{COUNTER} = time();
return 0;
}
else
{
return $delta;
}
}
# Add lines into the scrollback buffer
sub addlines
{
my $self = shift;
my $line;
if (@_)
{
foreach $line (@_)
{
# Attempt to remove empty lines.
next if ($line =~ /^\s*$/);
# Add the line in the next available position
# in the buffer
$self->{BUFFER}[$self->{POSITION}] = $line;
# If we are at the last available position in
# the buffer, reset and start over.
if ($self->{POSITION} >= $self->{LENGTH})
{
$self->{POSITION} = 0;
}
else
{
$self->{POSITION}++;
}
}
}
}
# Return an array with the number of lines requested.
sub getlines
{
my $self = shift;
my ($rows, $i, $position);
my (@return);
if (@_)
{
$rows = shift;
# POSITION is one past the current line (ahem, bug? :-)
$position = $self->{POSITION} - $rows - 1;
$position += $self->{LENGTH} if ($position < 0);
for ($i = 0; $i < $rows; $i++)
{
# Set the position ahead, but rewind if hit the
# end.
$position++;
$position = 0 if ($position >= $self->{LENGTH});
# When first initialized Much of the buffer may
# be empty.
if (defined($self->{BUFFER}[$position]))
{
push @return, $self->{BUFFER}[$position];
}
else
{
push @return, "";
}
}
}
return @return;
}
} # Back to the main package
################
# Main Routine #
################
# Create a new main window
$main = new Curses;
# Configure some options
noecho(); # Disable echoing from the console.
$main->keypad(1); # Map special keys.
halfdelay(10); # This works like Poll when a function is passed
# to a widget. Redraws the chat window every 2
# seconds, and gets new messages per /freq
$main->erase();
select_colour($main, 'black');
$main->attrset(0);
&header();
# Prompt for username and pass
($text, $test) = input_box(
'title' => "Logon",
'prompt' => "Enter your PM username",
'border' => "white",
'cursor_disable' => 1,
'function' => \&header
);
if (($test == 1) && ($text ne ""))
{
$username = $text;
}
else
{
&handle_error("Username required and not provided");
}
($text, $test) = input_box(
'title' => "Logon",
'prompt' => "Enter your PM password",
'border' => "white",
'cursor_disable' => 1,
'password' => 1,
'function' => \&header
);
if (($test == 1) && ($text ne ""))
{
$password = $text;
}
else
{
&handle_error("Password required and not provided");
}
# Get rid of the login boxes while we wait
$main->erase();
$main->addstr(0, 1, "Attempting to log in, please wait...");
$main->refresh();
# Log in (all your password are belong to us)
$chat = PerlMonks::Chat->new();
$chat->add_cookies;
$chat->login($username, $password)
or &handle_error("Could not login: $!");
$monks = PerlMonks::Users->new();
$monks->add_cookies;
# Produce a child to handle the transactions.
$main->addstr(1, 1, "Starting child process...");
$main->refresh();
# Create a socketpair
socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
or &handle_error("Socket could not be created.");
CHILD->autoflush(1);
PARENT->autoflush(1);
# Fork here
if ($pid = fork())
{
close PARENT;
# Create a chat buffer
$buffer = new Chat;
print CHILD $buffer->counter . "\n";
}
else
{
close CHILD;
&child();
exit 0;
}
# Clear the screen
$main->erase();
$main->refresh();
# From now on the &message subroutine and the chat $buffer handle
# all screen draws.
$buffer->addlines("{CCB} - Curses Chatterbox client, Type '/help' for
+available commands.");
# Main loop
while (1)
{
($test, $text) = txt_field(
'window' => $main,
'regex' => "\n",
'xpos' => 0,
'ypos' => $LINES - 3,
'lines' => 1,
'cols' => $COLS - 2,
'border' => "white",
'cursor_disable' => 1,
'function' => \&messages
);
chomp $text;
# Begin processing the message entered
if ($text =~ /^\/help/i)
{
&help_popup($buffer);
}
elsif ($text =~ /^\/who/i)
{
&list_users($buffer);
}
elsif ($text =~ /^\/xp/i)
{
&show_xp($buffer);
}
elsif ($text =~ /^\/log/i)
{
&show_log($buffer, "SHOW");
}
elsif ($text =~ /^\/save/i)
{
&show_log($buffer, "SAVE");
}
elsif ($text =~ /^\/msgs/i)
{
&show_msgs($buffer);
}
#elsif ($text =~ /^\/(?:checkoff|co)\s+/i)
#{
# Don't quite have this figured out...
#}
elsif ($text =~ /^\/freq\s*(\d*)/i)
{
# This is used to set an alarm and shouldn't be
# too small.
my $min = 5;
if ($1 > $min)
{
$buffer->counter($1);
$buffer->addlines("{CCB} - Interval set to $1");
}
else
{
$buffer->addlines("{CCB} - Interval must be greater than $
+min");
}
}
elsif ($text =~ /^\/time/i)
{
if ($buffer->show_time)
{
$buffer->show_time(0);
$buffer->addlines("{CCB} - Time stamps disabled");
}
else
{
$buffer->show_time(1);
$buffer->addlines("{CCB} - Time stamps enabled");
}
}
elsif ($text =~ /^\/(?:msg|tell)\s+(\S+)\s+(.+)$/i)
{
# A private message is being sent
$chat->send($text);
$buffer->addlines(split "\n", wrap("", "\t", "{CCB} - private
+message sent to $1: $2"));
}
elsif ($text =~ /^\/(ignore|unignore)\s+(\S+)/i)
{
my $action = lc($1);
my $user = $2;
$action =~ s/.$/ing/;
# A private message is being sent
$chat->send($text);
$buffer->addlines(split "\n", wrap("", "\t", "{CCB} - $action
+user $user"));
}
elsif ($text =~ /^\/me\s*/i)
{
# /me emotes.
$chat->send($text);
}
elsif ($text =~ /^\/quit/i)
{
# Ask the child to exit then quit.
$main->erase();
$main->addstr(0, 1, "Ending child process...");
$main->refresh();
# Code to exit.
print CHILD "-1\n";
waitpid($pid, 0);
exit 0;
}
elsif (($text =~ /^\s{0,1}\//) || ($text =~ /^.{0,2]msg/i))
{
# All valid forms of commands are accounted for,
# here we can handle near misses.
($text, $test) = input_box(
'title' => "Vague response",
'prompt' => "Please confirm, cancel or change your message
+:",
'border' => "white",
'content' => "$text",
'cursor_disable' => 1
);
if (($test == 1) && ($text ne ""))
{
# Text was confirmed to send.
$chat->send($text);
}
else
{
$buffer->addlines("{CCB} - message not sent");
}
}
else
{
# Try to send whatever message was entered.
if ($text ne "")
{
$chat->send($text);
}
}
}
END
{
# Ask Curses to exit cleanly.
endwin();
}
exit 0;
###############
# Subroutines #
###############
sub header
{
# Display a nice header whilst we perform various tasks
$main->standout();
$main->addstr(0, 1, "{CCB} - Curses ChatterBox Client by {NULE} v.
+ $VERSION");
$main->standend();
$main->refresh();
}
sub child
{
my ($request, $text);
# Listen for a timing value from the parent.
# Request the resource from
while (1)
{
chomp($request = <PARENT>);
if ($request == -1)
{
# We have been asked to exit
return 1;
}
else
{
# The parent is expecting a response
# in this many seconds or we will
# send a lag error message
eval
{
local $SIG{ALRM} = sub { die "ALARM\n" };
alarm ($request - 1);
$text = join "\n", $chat->getnewlines(1);
alarm 0;
};
if ($@)
{
# Timeouts are different from other problems
print PARENT "{CCB} - ERROR with child: $@" unless $@
+eq "ALARM\n";
# Request timed out
print PARENT "{CCB} - Lag problem, try setting /freq h
+igher..."
. RSEPARATOR;
}
else
{
print PARENT "$text" . RSEPARATOR;
}
}
}
}
sub messages
{
# Note that our handles are global here because Curses::Widgets
# doesn't seem amenable to passing arguments ($buffer, $main)
my ($chat, @chat, @prechat, $line, $length);
my $i = 0;
if ($buffer->counter == 0)
{
local $/ = RSEPARATOR;
eval
{
local $SIG{ALRM} = sub { die "ALARM\n" };
alarm 2;
chomp ($chat = <CHILD>);
alarm 0;
};
if ($@)
{
$buffer->addlines("{CCB} - ERROR with parent: $@") unless
+$@ eq "ALARM\n";
$buffer->addlines("{CCB} - May have lost sync with child.
+(1)");
}
eval
{
local $SIG{ALRM} = sub { die "ALARM\n" };
alarm 2;
print CHILD $buffer->counter . "\n";
alarm 0;
};
if ($@)
{
$buffer->addlines("{CCB} - ERROR with parent: $@") unless
+$@ eq "ALARM\n";
$buffer->addlines("{CCB} - May have lost sync with child.
+(2)");
}
@chat = map { "$_\n" } split "\n", $chat;
$Text::Wrap::columns = $COLS - 2;
foreach $line (@chat)
{
if ($buffer->show_time)
{
$line = &time_stamp . " $line";
}
$buffer->addlines(split "\n", wrap("", "\t", $line));
}
}
@chat = $buffer->getlines($LINES - 3);
# Start drawing from the bottom of the screen
$i = $LINES - 4;
foreach $line (reverse @chat)
{
# Not the best way to do this, but length()
# doesn't handle tabs correctly. # TODO? #
$line =~ s/^\t/ /;
$length = $COLS - length($line) - 2;
$line = " ".$line." "x$length;
$main->addstr($i, 0, "$line");
$i--;
last if $i < 0;
}
$main->refresh();
return 1;
}
sub help_popup
{
# Display a window with help information in it.
my $buffer = shift;
my ($line, $help);
my @help = (
"Curses ChatterBox Client v. $VERSION",
" ",
"Commands available:",
"- /help - displays this message",
"- /who - shows the monks logged on",
"- /xp - shows some quick information about you",
"- /log - show the chat log",
"- /freq <#> - sets the refresh interval to # seconds",
"- /time - toggles time stamps on messages",
"- /save - dump buffer to a save file",
"- /quit - exits the Chatterbox client",
"Supported Chatterbox Commands",
"- /me ... - emote a message.",
"- /msg <user> ... - send a message to <user>.",
"- /tell <user> ... - same thing.",
"- /msgs - show all private messages.",
#"- /co ###<,###...> - check off private messages.",
#"- /checkoff ### - same thing.",
"- /ignore <user> - Ignore <user>.",
"- /unignore <user> - Unignore <user>.",
"To-do:",
"- Colors",
"- I keep having imaginings of building a mini-browser in...",
" if winamp can do it, so can I!",
"- Tell me what features you would like!"
);
foreach $line (@help)
{
chomp $line;
if ($line ne "")
{
$help .= "$line\n";
}
}
txt_field(
'window' => $main,
'title' => "{CCB} Help - PGUP and PGDOWN to scroll, ENTER to e
+xit.",
'regex' => "\n",
'xpos' => 0,
'ypos' => 0,
'lines' => $LINES - 2,
'cols' => $COLS - 2,
'border' => "white",
'edit' => 0,
'cursor_disable' => 1,
'content' => $help
);
# Clear the screen before returning.
$main->erase();
$main->refresh();
}
sub list_users
{
my $buffer = shift;
my (%users, $users);
%users = $monks->users;
if (%users)
{
$Text::Wrap::columns = $COLS - 2;
$users = "{CCB} - " . (scalar(keys(%users)) + 1);
$users .= " users logged in: " . join " ",sort keys(%users);
$buffer->addlines(split "\n", wrap("", "\t", $users));
}
else
{
$buffer->addlines("No users logged in (oddly enough)");
}
}
sub show_msgs
{
# Retrieve and display all personal messages
my $buffer = shift;
my (%msgs, $msg);
%msgs = $chat->personal_messages;
if (%msgs)
{
$Text::Wrap::columns = $COLS - 2;
foreach $msg (sort keys(%msgs))
{
$buffer->addlines(split "\n", wrap("", "\t", "($msg) $msgs
+{$msg}"));
}
}
else
{
$buffer->addlines("Could not get personal messages");
}
}
sub show_xp
{
# Print a display of current XP information
my $buffer = shift;
my (%xp, $xp);
%xp = $monks->xp;
if (%xp)
{
$Text::Wrap::columns = $COLS - 2;
$xp = "{CCB} - User: $xp{user}, Level: $xp{level}, XP: $xp{xp
+}, ";
$xp .= "Votes: $xp{votesleft}, Next level in: $xp{xp2nextlevel
+} XP";
$buffer->addlines(split "\n", wrap("", "\t", $xp));
}
else
{
$buffer->addlines("Could not get XP information");
}
}
sub show_log
{
my ($buffer, $mode) = @_;
my (@chat, $line, $chat, $length, $filename);
# If mode is SAVE then prompt for a file name
if ($mode eq "SAVE")
{
my ($text, $test) = input_box(
'title' => "Save log",
'prompt' => "Please enter a path and filename to save your
+ message:",
'border' => "white",
'edit' => 0,
'cursor_disable' => 1
);
if (($test == 1) && ($text ne ""))
{
$filename = $text;
}
else
{
$buffer->addlines("{CCB} - log not saved.");
return 0;
}
}
$length = $buffer->length;
# Retrieve all the lines.
@chat = $buffer->getlines($length);
$chat = "";
foreach $line (@chat)
{
chomp $line;
if ($line ne "")
{
$chat .= "$line\n";
}
}
if ($mode eq "SAVE")
{
open (FILEHANDLE, ">$filename");
print FILEHANDLE $chat;
close FILEHANDLE;
$buffer->addlines("{CCB} - log saved as $filename");
}
else
{
txt_field(
'window' => $main,
'title' => "{CCB} Chat log - PGUP and PGDOWN to scroll, EN
+TER to exit (max $length lines).",
'regex' => "\n",
'xpos' => 0,
'ypos' => 0,
'lines' => $LINES - 2,
'cols' => $COLS - 2,
'border' => "white",
'cursor_disable' => 1,
'content' => $chat
);
}
# Clear the screen before returning.
$main->erase();
$main->refresh();
}
sub time_stamp
{
# Produce a time stamp
my ($sec, $min, $hour) = localtime;
$sec = "0".$sec if $sec < 10;
$min = "0".$min if $min < 10;
$hour = "0".$hour if $hour < 10;
return ("$hour:$min:$sec")
}
sub handle_error
{
my $message = shift;
msg_box(
'message' => "$message",
'title' => "Error"
);
die "$message\n";
}
|