sourcecode
#include
<code>
#!/usr/bin/perl
#
# pic.pl
#
# A GUI Perl IRC Client
#
# AUTHOR: Dan Hetrick
# LICENSE: GPL
# VERSION: alpha-0.4
# REQUIREMENTS: Perl, POE, POE::Component::IRC, Perl/Tk, Getopt::Mixed
#
use warnings;
use strict;
use Tk;
use POE;
use POE::Component::IRC;
use Getopt::Mixed "nextOption";
# ====================
# Application Settings
# ====================
my $APPNAME = 'pic';
my $VERSION = 'alpha-0.3';
# ====================
# Default IRC Settings
# ====================
my $SERVER = '';
my $PORT = 6667;
my $NICK = $ENV{USER};
my $CHANNEL = '#pic';
# =================
# Internal Settings
# =================
my $CONFIG_FILE = '';
my $CONNECTED = 0;
my $TOPIC = 'No topic.';
my $CHANNEL_DISPLAY = 'No channel.';
my $TIMESTAMP = 0;
my $LOGGING = 0;
my @USERS;
my $KERNEL;
my $option;
my $value;
# ========================
# GUI Widgets and Settings
# ========================
my $ENTRY;
my $TEXT_BOX;
my $USERLIST;
my $BACKGROUND = 'white';
my $FOREGROUND = 'black';
my $SIMPLE_MODE = 0;
my $TBOX_WIDTH = 80;
my $UBOX_WIDTH = 20;
my $BOX_HEIGHT = 20;
# =======
# History
# =======
my $MAX_HISTORY = 4;
my $HISTORY_POINTER = 0;
my $INTERNAL_POINTER = 0;
my @HISTORY = ( '' x ( $MAX_HISTORY + 1 ) );
# ===========
# MAIN SCRIPT
# ===========
# Process commandline arguments
Getopt::Mixed::init(
'h help>h v version>v s=s server>s p=s port>p n=s nick>n c=s channel>c C=s config>C T=i text>T U=i userlist>U H=i height>H S simple>S B=s background>B F=s foreground>F t timestamp>t l log>l'
);
while ( ( $option, $value ) = nextOption() ) {
if ( $option =~ /h/ ) {
print "$APPNAME $VERSION\n";
print "Usage: $0 OPTIONS\n";
print "Options:\n";
print "-h,--help Display this text.\n";
print "-v,--version Display version and exit.\n";
print "-C,--config FILE Load settings from config file.\n";
print "-t,--timestamp Turn on timestamping.\n";
print "-l,--log Turn on logging.\n";
print "IRC Options:\n";
print "-s,--server HOST Sets the IRC server.\n";
print "-p,--port PORT Sets the server port.\n";
print "-n,--nick NICK Sets the user nick.\n";
print "-c,--channel CHANNEL Sets the starting channel.\n";
print "GUI Options:\n";
print
"-T,--text NUMBER Sets the width of the main textbox (80).\n";
print
"-U,--userlist NUMBER Sets the width of the userlist display (20).\n";
print
"-H,--height NUMBER Sets the height of the main display (20).\n";
print
"-S,--simple Turns on simple mode (no topic/channel name display).\n";
print "-B,--background COLOR Sets the background color (white).\n";
print "-F,--foreground COLOR Sets the foreground color (black).\n";
exit;
}
if ( $option =~ /v/ ) { print "$VERSION\n"; exit; }
if ( $option =~ /s/ ) { $SERVER = $value; }
if ( $option =~ /p/ ) { $PORT = $value; }
if ( $option =~ /n/ ) { $NICK = $value; }
if ( $option =~ /c/ ) { $CHANNEL = $value; }
if ( $option =~ /C/ ) { $CONFIG_FILE = $value; }
if ( $option =~ /T/ ) { $TBOX_WIDTH = $value; }
if ( $option =~ /U/ ) { $UBOX_WIDTH = $value; }
if ( $option =~ /H/ ) { $BOX_HEIGHT = $value; }
if ( $option =~ /S/ ) { $SIMPLE_MODE = 1; }
if ( $option =~ /B/ ) { $BACKGROUND = $value; }
if ( $option =~ /F/ ) { $FOREGROUND = $value; }
if ( $option =~ /t/ ) { $TIMESTAMP = 1; }
if ( $option =~ /l/ ) { $LOGGING = 1; }
}
Getopt::Mixed::cleanup();
# Load config file if one's been passed to us
# on the commandline
if ( $CONFIG_FILE ne '' ) {
load_config($CONFIG_FILE);
}
# Create the IRC Session
POE::Component::IRC->new("irc_client");
# Create the GUI session, and set up events
POE::Session->create(
inline_states => {
_start => \&start_gui, # GUI Creation
irc_001 => \&on_connect, # Connection Event
irc_public => \&on_public, # Public Message Event
irc_msg => \&on_private, # Private Message Event
irc_352 => \&on_who, # WHO Data Event
irc_315 => \&end_who, # End WHO Data Event
irc_join => \&on_join, # Join Event
irc_part => \&on_part, # Part Event
irc_disconnected => \&on_disconnect, # Disconnect Event
irc_notice => \&on_notice, # Notice Event
irc_ctcp_action => \&on_action, # CTCP Action Event
irc_kick => \&on_kick, # Kick Event
irc_433 => \&on_nick_taken, # Nick Taken Event
irc_332 => \&on_topic, # Topic Event
irc_331 => \&no_topic, # No Topic Event
irc_nick => \&on_nick, # Nick Event
irc_mode => \&on_mode, # Mode Event
}
);
# Run
$poe_kernel->run();
exit 0;
# ===============
# END MAIN SCRIPT
# ===============
# ===
# GUI
# ===
# =========
# start_gui
# =========
# Creates the Tk GUI and connects to the IRC
# server if the program's been passed the
# appropriate commandline arguments
sub start_gui {
my ( $kernel, $session, $heap ) = @_[ KERNEL, SESSION, HEAP ];
# Set the application icon
my $icon =
$poe_main_window->Photo( 'image', -data => icon(), format => 'gif' );
$poe_main_window->iconimage($icon);
# Set the window title
$poe_main_window->title("Not connected.");
# Turn off resizing
$poe_main_window->resizable( 0, 0 );
if ( $SIMPLE_MODE == 0 ) {
# Channel/Topic Display
my $status_frame = $poe_main_window->Frame()->pack(
-expand => 1,
-fill => 'x'
);
my $topic_frame = $status_frame->Frame()->pack(
-expand => 1,
-fill => 'x',
- side => 'left'
);
my $topic_label = $topic_frame->Label(
-textvariable => \$TOPIC,
-relief => 'sunken',
-width => $TBOX_WIDTH + 3,
'-background' => $BACKGROUND,
'-foreground' => $FOREGROUND
)->pack( -side => 'left' );
my $channel_frame = $status_frame->Frame()->pack(
-expand => 1,
-fill => 'x',
-side => 'right'
);
my $channel_label = $channel_frame->Label(
-textvariable => \$CHANNEL_DISPLAY,
'-width' => $UBOX_WIDTH + 3,
-relief => 'sunken',
'-background' => $BACKGROUND,
'-foreground' => $FOREGROUND
)->pack( -side => 'right' );
}
# Main Display
my $main_frame = $poe_main_window->Frame()->pack(
-fill => 'both',
-expand => 1,
-fill => 'x'
);
$TEXT_BOX = $main_frame->Scrolled(
'Text',
'-scrollbars' => 'e',
'-width' => $TBOX_WIDTH,
'-height' => $BOX_HEIGHT,
'-background' => $BACKGROUND,
'-foreground' => $FOREGROUND
)->pack( -fill => 'both', -expand => 1, -side => 'left' );
# Userlist
$USERLIST = $main_frame->Scrolled(
'Listbox',
'-scrollbars' => 'e',
'-width' => $UBOX_WIDTH,
'-height' => $BOX_HEIGHT,
'-background' => $BACKGROUND,
'-foreground' => $FOREGROUND
)->pack( -fill => 'both', -expand => 1, -side => 'right' );
# Text Entry
my $entry_frame = $poe_main_window->Frame()->pack( -fill => 'x' );
$ENTRY = $entry_frame->Entry()->pack(
-side => 'right',
-fill => 'both',
-expand => 1
);
# Set up GUI Events
$ENTRY->bind( '<Key-Return>', \&send_text );
$ENTRY->bind( '<Key-Up>', \&backinHistory );
$ENTRY->bind( '<Key-Down>', \&upinHistory );
# Center the window
$poe_main_window->withdraw;
$poe_main_window->Popup;
$KERNEL = $kernel;
display_text( Startup(), 0 );
# Register the IRC session events
$kernel->post( irc_client => register => "all" );
# Connect to IRC if we've been passed the -s argument
if ( ( $SERVER ne '' ) && ( $PORT ne '' ) ) {
$KERNEL->post(
irc_client => connect => {
Nick => $NICK,
Username => "pic-$NICK",
Ircname => "$APPNAME $VERSION",
Server => $SERVER,
Port => $PORT,
}
);
$poe_main_window->title('Connecting...');
display_text( "*** Connecting to $SERVER:$PORT...", 1 );
}
}
# =======
# END GUI
# =======
# ==========
# GUI EVENTS
# ==========
# =========
# send_text
# =========
# This sub is bound to the ENTRY widget on the GUI;
# it handles command parsing and message sending.
sub send_text {
my $text = $ENTRY->get();
$ENTRY->delete( '0', 'end' );
# Parse commands
if ( index( $text, '/' ) == 0 ) { # Commands start with /
# /server <host> <port>
if ( index( $text, '/server' ) == 0 ) {
my @ln = split( ' ', $text );
if ( $#ln == 2 ) {
$SERVER = $ln[1];
$PORT = $ln[2];
if ( $CONNECTED == 1 ) {
$KERNEL->post( irc_client => quit => 'QUIT' );
$USERLIST->delete( '0', 'end' ); # Clear the list
@USERS = ();
sleep(1);
}
$KERNEL->post(
irc_client => connect => {
Nick => $NICK,
Username => "pic-$NICK",
Ircname => "$APPNAME $VERSION",
Server => $SERVER,
Port => $PORT,
}
);
$poe_main_window->title('Connecting...');
display_text( "*** Connecting to $SERVER:$PORT...", 1 );
}
else {
display_text( "*** Usage: /server <host> <port>", 0 );
}
}
# /nick <nickname>
if ( index( $text, '/nick' ) == 0 ) {
my @n = split( ' ', $text );
if ( $#n == 1 ) {
$NICK = $n[1];
if ( $CONNECTED == 1 ) {
doUserlist();
$KERNEL->post( irc_client => nick => $NICK );
$poe_main_window->title("$NICK - $SERVER:$PORT");
}
}
else {
display_text( "*** Usage: /nick <nickname>", 0 );
}
}
# /help
if ( index( $text, '/help' ) == 0 ) {
display_text( Help(), 0 );
}
# /exit
if ( index( $text, '/exit' ) == 0 ) {
exit;
}
# /quit <msg>
if ( index( $text, '/quit' ) == 0 ) {
if ( $CONNECTED == 0 ) {
display_text( "*** Not connected.", 0 );
return;
}
if ( length($text) > 6 ) {
my $msg = substr( $text, 6 );
$KERNEL->post( irc_client => quit => $msg );
}
else {
$KERNEL->post( irc_client => quit => 'QUIT' );
}
}
# /join <channel>
if ( index( $text, '/join' ) == 0 ) {
if ( $CONNECTED == 0 ) {
display_text( "*** Not connected.", 0 );
return;
}
if ( length($text) > 6 ) {
my $newchan = substr( $text, 6 );
$KERNEL->post( irc_client => part => $CHANNEL );
$CHANNEL = $newchan;
doUserlist();
display_text( "*** Joining $CHANNEL...", 1 );
$KERNEL->post( irc_client => join => $CHANNEL );
$KERNEL->post( irc_client => topic => $CHANNEL );
$poe_main_window->title("$NICK - $SERVER:$PORT");
$CHANNEL_DISPLAY = "$CHANNEL";
}
else {
display_text( "*** Usage: /join <channel>", 0 );
}
}
# /msg <target> <msg>
if ( index( $text, '/msg' ) == 0 ) {
if ( $CONNECTED == 0 ) {
display_text( "*** Not connected.", 0 );
return;
}
my @ln = split( ' ', $text );
if ( $#ln >= 2 ) {
my $target = $ln[1];
my $msg =
substr( $text, length( $ln[0] ) + length( $ln[1] ) + 2 );
$KERNEL->post( irc_client => privmsg => $target, $msg );
display_text( "<$NICK> $target: $msg", 1 );
}
else {
display_text( "*** Usage: /msg <channel|nick> <msg>", 0 );
}
}
# /notice <target> <msg>
if ( index( $text, '/notice' ) == 0 ) {
if ( $CONNECTED == 0 ) {
display_text( "*** Not connected.", 0 );
return;
}
my @ln = split( ' ', $text );
if ( $#ln >= 2 ) {
my $target = $ln[1];
my $msg =
substr( $text, length( $ln[0] ) + length( $ln[1] ) + 2 );
$KERNEL->post( irc_client => notice => $target, $msg );
display_text( "*$NICK* $target: $msg", 1 );
}
else {
display_text( "*** Usage: /notice <channel|nick> <msg>", 0 );
}
}
# /me <desrciption>
if ( index( $text, '/me' ) == 0 ) {
if ( $CONNECTED == 0 ) {
display_text( "*** Not connected.", 0 );
return;
}
my @ln = split( ' ', $text );
if ( $#ln >= 1 ) {
my $msg = substr( $text, length( $ln[0] ) + 1 );
$KERNEL->post( irc_client => ctcp => $CHANNEL, "action:$msg" );
display_text( "> $NICK $msg", 1 );
}
else {
display_text( "*** Usage: /me <description>", 0 );
}
}
}
else {
if ( $CONNECTED == 0 ) {
display_text( "*** Not connected.", 0 );
return;
}
$KERNEL->post( irc_client => privmsg => $CHANNEL, $text );
display_text( "<$NICK> $text", 1 );
}
addHistory($text);
}
# =============
# backinHistory
# =============
# Moves 'backward' in the history and displays
# the stored command
sub backinHistory {
$ENTRY->delete( '0', 'end' );
$ENTRY->insert( 'end', upHistory() );
}
# ===========
# upinHistory
# ===========
# Moves 'forward' in the history and displays
# the stored command
sub upinHistory {
$ENTRY->delete( '0', 'end' );
$ENTRY->insert( 'end', downHistory() );
}
# ==============
# END GUI EVENTS
# ==============
# ==========
# IRC EVENTS
# ==========
# ==========
# on_connect
# ==========
# Triggered when the client first connects to an
# IRC server.
sub on_connect {
$CONNECTED = 1;
$CHANNEL_DISPLAY = "$CHANNEL";
display_text( "*** Connected to $SERVER:$PORT!", 1 );
$poe_main_window->title("$NICK - $SERVER:$PORT");
display_text( "*** Joining $CHANNEL...", 1 );
doUserlist();
$_[KERNEL]->post( irc_client => join => $CHANNEL );
$_[KERNEL]->post( irc_client => topic => $CHANNEL );
}
# =========
# on_public
# =========
# Triggered whenever the client receives a 'public' message.
sub on_public {
my ( $kernel, $who, $where, $MESSAGE ) = @_[ KERNEL, ARG0, ARG1, ARG2 ];
my $eNICK = ( split /!/, $who )[0];
my $eHOSTMASK = ( split /!/, $who )[1];
my $eCHANNEL = $where->[0];
display_text( "<$eNICK> $MESSAGE", 1 );
}
# ==========
# on_private
# ==========
# Triggered whenever the client receives a 'private' message.
sub on_private {
my ( $kernel, $who, $where, $MESSAGE ) = @_[ KERNEL, ARG0, ARG1, ARG2 ];
my $eNICK = ( split /!/, $who )[0];
my $eHOSTMASK = ( split /!/, $who )[1];
my $eCHANNEL = $where->[0];
display_text( ">$eNICK< $MESSAGE", 1 );
}
# =======
# on_join
# =======
# Triggered whenever someone joins the client's IRC channel.
sub on_join {
my ( $kernel, $nd, $eCHANNEL ) = @_[ KERNEL, ARG0, ARG1 ];
my $eNICK = ( split /!/, $nd )[0];
doUserlist();
display_text( "*** $eNICK joined $eCHANNEL.", 1 );
}
# =======
# on_part
# =======
# Triggered whenever someone parts the client's IRC channel.
sub on_part {
my ( $kernel, $nd, $eCHANNEL ) = @_[ KERNEL, ARG0, ARG1 ];
my $eNICK = ( split /!/, $nd )[0];
my $eHOSTMASK = ( split /!/, $nd )[1];
doUserlist();
display_text( "*** $eNICK left $eCHANNEL.", 1 );
}
# ======
# on_who
# ======
# Triggered whenever 'who' data is received by the client.
# Builds the userlist for display.
sub on_who {
my ( $kernel, $serv, $data ) = @_[ KERNEL, ARG0, ARG1 ];
my $nick = ( split / /, $data )[4];
my $code = ( split / /, $data )[5];
if ( $code =~ /\@/ ) { $nick = '@' . $nick; }
if ( $code =~ /\+/ ) { $nick = '+' . $nick; }
push( @USERS, $nick );
}
# =======
# end_who
# =======
# Triggered when the server sends an 'end of who data' message.
# Takes the data built by on_who() and displays it.
sub end_who {
my ( $kernel, $serv ) = @_[ KERNEL, ARG0 ];
@USERS = sortNicks(@USERS);
$USERLIST->delete( '0', 'end' ); # Clear the list
foreach my $u (@USERS) {
$USERLIST->insert( 'end', $u );
}
}
# =============
# on_disconnect
# =============
# Triggered when the client disconnects from the server.
sub on_disconnect {
my ( $kernel, $serv ) = @_[ KERNEL, ARG0 ];
$CONNECTED = 0;
$USERLIST->delete( '0', 'end' ); # Clear the list
@USERS = ();
display_text( "*** Disconnected.", 1 );
}
# =========
# on_notice
# =========
# Triggered whenever the server sends the client a notice.
sub on_notice {
my ( $kernel, $who, $where, $MESSAGE ) = @_[ KERNEL, ARG0, ARG1, ARG2 ];
my $eNICK = ( split /!/, $who )[0];
my $eHOSTMASK = ( split /!/, $who )[1];
my $eCHANNEL = $where->[0];
display_text( "*$eNICK* $MESSAGE", 1 );
}
# =========
# on_action
# =========
# Triggered whenever the server sends the client a CTCP 'action' message.
sub on_action {
my ( $kernel, $who, $where, $msg ) = @_[ KERNEL, ARG0, ARG1, ARG2 ];
my $nick = ( split /!/, $who )[0];
my $hostmask = ( split /!/, $who )[1];
my $channel = $where->[0];
display_text( "> $nick $msg", 1 );
}
# =======
# on_kick
# =======
# Triggered whenever someone is kicked from the channel.
sub on_kick {
my ( $kernel, $who, $where, $target, $reason ) =
@_[ KERNEL, ARG0, ARG1, ARG2, ARG3 ];
my $nick = ( split /!/, $who )[0];
my $hostmask = ( split /!/, $who )[1];
my $channel = $where;
doUserlist();
display_text( "*** $nick kicked $target from $where ($reason)", 1 );
}
# =============
# on_nick_taken
# =============
# Triggered whenever the client's nick is already in use.
# A random number is added to the client's nick.
sub on_nick_taken {
my ($kernel) = $_[KERNEL];
$NICK = $NICK . $$ % 1000;
$kernel->post( irc_client => nick => $NICK );
doUserlist();
}
# ========
# on_topic
# ========
# Triggered whenever the client gets channel topic data.
sub on_topic {
my ( $kernel, $serv, $data ) = @_[ KERNEL, ARG0, ARG1 ];
my $stuff = ( split /:/, $data )[0];
$TOPIC = substr( $data, length($stuff) + 1 );
trim_topic();
}
# ========
# no_topic
# ========
# Triggered whenever the client receives blank topic data.
sub no_topic {
my ( $kernel, $serv, $data ) = @_[ KERNEL, ARG0, ARG1 ];
$TOPIC = 'No topic.';
}
# =======
# on_nick
# =======
# Triggered whenever someone in the same channel as the client
# changes their nick.
sub on_nick {
my ( $kernel, $who, $newnick ) = @_[ KERNEL, ARG0, ARG1 ];
my $nick = ( split /!/, $who )[0];
my $hostmask = ( split /!/, $who )[1];
display_text( "*** $nick is now known as $newnick", 1 );
doUserlist();
}
# =======
# on_mode
# =======
# Triggered whenever a mode change is made, applying
# to the client or the client's channel.
sub on_mode {
my ( $kernel, $who, $target, $mode, $arg ) =
@_[ KERNEL, ARG0, ARG1, ARG2, ARG3 ];
my $nick = ( split /!/, $who )[0];
my $hostmask = ( split /!/, $who )[1];
if ( ( $mode =~ /o/ ) || ( $mode =~ /v/ ) ) {
doUserlist();
}
if ($arg) {
display_text( "*** $nick sets mode $mode $arg", 1 );
}
else {
display_text( "*** $nick sets mode $mode", 1 );
}
}
# ==============
# END IRC Events
# ==============
# ===================
# SUPPORT SUBROUTINES
# ===================
# ============
# display_text
# ============
# Arguments: Scalar, Integer
# Returns: Nothing
# Description: Displays text and/or logs it
sub display_text {
my ( $data, $dotimestamp ) = @_;
if ( $dotimestamp == 0 ) {
$TEXT_BOX->insert( 'end', "$data\n" );
$TEXT_BOX->see('end');
return;
}
if ( $TIMESTAMP == 1 ) {
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
localtime(time);
$TEXT_BOX->insert( 'end', "[$hour:$min:$sec] $data\n" );
$TEXT_BOX->see('end');
if ( $LOGGING == 1 ) {
open( LOG, ">>$SERVER.$PORT.$CHANNEL.log" )
or die "Error writing to log.";
print LOG "[$hour:$min:$sec] $data\n";
close LOG;
}
}
else {
$TEXT_BOX->insert( 'end', "$data\n" );
$TEXT_BOX->see('end');
if ( $LOGGING == 1 ) {
open( LOG, ">>$SERVER.$PORT.$CHANNEL.log" )
or die "Error writing to log.";
print LOG "$data\n";
close LOG;
}
}
}
# ==========
# trim_topic
# ==========
# Arguments: None
# Returns: Nothing
# Description: Trims the topic if it's too long
sub trim_topic {
if ( length($TOPIC) >= $TBOX_WIDTH ) {
my $NEW_TOPIC = substr( $TOPIC, 0, ( $TBOX_WIDTH - 3 ) );
$TOPIC = "$NEW_TOPIC...";
}
}
# ==========
# doUserList
# ==========
# Arguments: None
# Returns: Nothing
# Description: Clears out the local userlist and
# requests fresh user data from the
# server.
sub doUserlist {
@USERS = ();
$KERNEL->post( irc_client => who => $CHANNEL );
}
# =========
# sortNicks
# =========
# Arguments: List
# Returns: List
# Description: Sorts an array containing user
# data for display. Ops come first,
# voiced users second, and normal users
# third.
sub sortNicks {
my (@nicks) = @_;
my @ops = ();
my @voiced = ();
my @normal = ();
my @list = ();
foreach my $n (@nicks) {
if ( $n =~ /\@/ ) { push( @ops, $n ); next; }
if ( $n =~ /\+/ ) { push( @voiced, $n ); next; }
push( @normal, $n );
}
push( @list, sort( keys %{ { map { $_, 1 } @ops } } ) );
push( @list, sort( keys %{ { map { $_, 1 } @voiced } } ) );
push( @list, sort( keys %{ { map { $_, 1 } @normal } } ) );
return @list;
}
# =======
# Startup
# =======
# Arguments: None
# Returns: Scalar
# Description: Text to be displayed at client start up.
sub Startup {
my $START = <<"EOS";
$APPNAME $VERSION
Use the /server command to connect to IRC.
Use the /help command to get a list of commands.
EOS
return $START;
}
# ====
# Help
# ====
# Arguments: None
# Returns: Scalar
# Description: Text to be displayed when using the
# /help command.
sub Help {
my $HELP = <<'EOH';
/quit <message>
Disconnects from the IRC server.
The quit message is optional.
/join <channel>
Parts the current channel, and joins a new channel.
/msg <nick|channel> <message>
Sends a private message to a nick or channel.
/notice <nick|channel> <message>
Sends a notice to a nick or channel.
/me <message>
Sends a CTCP action message to the current channel.
/server <host> <port>
Connects to an IRC server.
/nick <nickname>
Changes your nick.
/exit
Exits the program.
EOH
return $HELP;
}
# ====
# icon
# ====
# Arguments: None
# Returns: GIF Image
# Description: Returns a BASE-64 encoded GIF image
# for use as the application icon.
sub icon {
my $binary_data = <<EOD;
R0lGODdhIAAgAOdLAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA0NDQ4O
Dg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8fHyAgICEh
ISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDExMTIyMjMzMzQ0
NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkNDQ0REREVFRUZGRkdH
R0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVVVVZWVldXV1hYWFlZWVpa
WltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdnZ2hoaGlpaWpqamtra2xsbG1t
bW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5eXp6ent7e3x8fH19fX5+fn9/f4CA
gIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouLi4yMjI2NjY6Ojo+Pj5CQkJGRkZKSkpOT
k5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2dnZ6enp+fn6CgoKGhoaKioqOjo6SkpKWlpaam
pqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+vr7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5
ubq6uru7u7y8vL29vb6+vr+/v8DAwMHBwcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zM
zM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d7e3t/f
3+Dg4OHh4eLi4uPj4+Tk5OXl5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8PHx8fLy
8vPz8/T09PX19fb29vf39/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///ywAAAAAIAAgAAAI/gD/CRwo
0J2zUZa+8SPIsKHDge1qBUmx5saTV/4cflNTJtzDgeouUaEBxIoQICYCNfT2hYidHn9qTRrnEFgc
Gi1+4BihAQOIXwwnVaFC5AUoSHe84GsIBoiQMG9AXNgggUKObAOxqTBBgw6iVnOeONrH8NiMIlRI
5XHxwYMIF0VGbFp6DYeIGrHQJFmVLyNBdFWcOEG2LA+YGiCQxJlCIkMUde9o/FDxxEmKPA4Bndnz
CpsySIJK9TFUC1SbGhy+lJsyxcqRGS040CTobciYIXoUfUHzpMcVWtjWacoxYgIsRCBO3Ngj5UQy
hqc2qRl0iccSLXnEoBIlbR+lP3Iw/nxh5qMFjSxCQLQiWC1II1LXyHEy08kVI2neyPE7dgTLBxuu
3HHDKEo0ocEyA83zhRCVhNKPP+rIwgkaiZjyBzHdPLMTB2h0wkcSlRhxgQbiDGTHD13ggQQx7twC
iBdr3FHHH3WA80YJGbSQBzFTtBHKDBcYoY5A+BBRCBdRWBCDHXMU4YQbdDDDxw+VRDHBCkYsAs0r
qNzBljIJBvGII0pcEIFPKKRAwharIDLDI2BM8AIJZSjDTR43oECJPgOlg4MpwYwBAgZUqFBCCiBs
gUkpU0QxggQfcHABHVtIUQIn8RDkzw26aKNEEDp808EINxiJhyAxTIABBRNQsAQd/kQsQks+DRGi
RjoiqHHHP4lYQAEpeMxwAw1+UDICDRZk8s9SD80TCDgjGKHLP+BoQEEskpzQgQWj/MOEBhVg9pFA
9wjDgg31CMQCCbKs48QGHvjxjxoTaKDHuAPRssElAwEBAzT/yEFCBzrUQ00IFTCCr0DRgGDOQHpx
8880UuxQwy/7TAHEJwv/U8sJ7gjEDyh/PPdPO60EIss/cNCQS8ejhFEiuc8MI5A/sgCBzj+GIdNx
NUD0Q1A7kKzzDzFwvCPQKDM80/E/bzR0TCnzIMKnQPZQ0c3TgCzEXjxopEvQILs8zQdWA6GzxxJJ
XMOQM8ourI8ntxBkDA+sUIEFNSH3DMTOK0Pim00Yg9gzEDee4KONNshkKlA9tmDi10fOTNEFwB0j
4gkYdT/dMTTi/GJ4QwEBADs=
EOD
return ($binary_data);
}
# ==========
# addHistory
# ==========
# Argument: Scalar
# Returns: Nothing
# Description: Adds commands to the history.
sub addHistory {
my ($data) = @_;
$HISTORY[$INTERNAL_POINTER] = $data;
$INTERNAL_POINTER++;
if ( $INTERNAL_POINTER >= $MAX_HISTORY ) { $INTERNAL_POINTER = 0; }
}
# =========
# upHistory
# =========
# Argument: None
# Returns: Scalar
# Description: Moves 'forward' in the history
# and returns a stored commandline
sub upHistory {
my $cmd = $HISTORY[$HISTORY_POINTER];
$HISTORY_POINTER++;
if ( $HISTORY_POINTER >= $MAX_HISTORY ) { $HISTORY_POINTER = 0; }
return $cmd;
}
# ===========
# downHistory
# ===========
# Argument: None
# Returns: Scalar
# Description: Moves 'backward' in the history
# and returns a stored commandline
sub downHistory {
my $cmd = $HISTORY[$HISTORY_POINTER];
$HISTORY_POINTER--;
if ( $HISTORY_POINTER < 0 ) { $HISTORY_POINTER = $MAX_HISTORY; }
return $cmd;
}
# ===========
# load_config
# ===========
# Arguments: Filename
# Returns: Nothing
# Description: Loads settings from a text file.
sub load_config {
my ($file) = @_;
if ( ( -e $file ) && ( -f $file ) ) {
open( FILE, "<$file" ) or die "Error loading config file.";
foreach my $line (<FILE>) {
chomp $line;
if ( index( $line, '#' ) == 0 ) { next; }
my @l = split( '=', $line );
if ( $#l != 1 ) { next; }
if ( $l[0] =~ /server/i ) { $SERVER = $l[1]; }
if ( $l[0] =~ /port/i ) { $PORT = $l[1]; }
if ( $l[0] =~ /nick/i ) { $NICK = $l[1]; }
if ( $l[0] =~ /channel/i ) { $CHANNEL = $l[1]; }
if ( $l[0] =~ /text/i ) { $TBOX_WIDTH = $l[1]; }
if ( $l[0] =~ /userlist/i ) { $UBOX_WIDTH = $l[1]; }
if ( $l[0] =~ /height/i ) { $BOX_HEIGHT = $l[1]; }
if ( $l[0] =~ /simple/i ) { $SIMPLE_MODE = $l[1]; }
if ( $l[0] =~ /background/i ) { $BACKGROUND = $l[1]; }
if ( $l[0] =~ /foreground/i ) { $FOREGROUND = $l[1]; }
if ( $l[0] =~ /timestamp/i ) { $TIMESTAMP = $l[1]; }
if ( $l[0] =~ /log/i ) { $LOGGING = $l[1]; }
}
}
}
# =======================
# END SUPPORT SUBROUTINES
# =======================
# =================
# POD DOCUMENTATION
# =================
=head1 NAME
pic - Perl IRC Client
=head1 VERSION
alpha-0.2
=head1 DESCRIPTION
A GUI IRC Client written in Perl, using Perl/Tk for the GUI, and POE::Component::IRC for the networking. The client can only chat in one channel at a time; if the client uses the /join command to join another channel, the channel it is currently in will be parted.
=head1 USAGE
C<$ perl pic.pl [ OPTIONS ]>
Options:
B<-v,--version>
Print version and exit.
B<-h,--help>
Print help text.
B<-C,--config FILE>
Loads settings from a text file. Settings are in the format of I<SETTING=VALUE>, one setting per line. Avaliable settings are B<server>, B<port>, B<nick>, B<channel>, B<text> (same as the -T option), B<userlist> (the same as the -U option), B<height> (the same as the -H option), B<simple> (set it to '1' to turn simple mode on), B<background> (the same as the -B option), B<foreground> (the same as the -F option), B<timestamp> (set it to '1' to turn timestamping on), and B<log> (set it to '1' to turn logging on).
Here's an example config file, containing all the default settings:
C<server=irc.gamesurge.net>
C<port=6667>
C<nick=PerlIRCClient>
C<channel=#shogomad>
C<text=80>
C<userlist=20>
C<height=20>
C<simple=0>
C<background=white>
C<foreground=black>
C<timestamp=0>
C<logging=0>
B<-s,--server HOST>
Sets the server to connect to. If the B<-p> option isn't also used, the default port of 6667 is used. The client will automatically connect to IRC on startup.
B<-p,--port NUMBER>
Sets the connection port. Use with the B<-s> option if the server you want to connect to uses a port other than 6667.
B<-n,--nick NICKNAME>
Sets the default nick.
B<-c,--channel CHANNEL>
Sets the default channel. This channel will be joined automatically when the client connects to IRC.
B<-T,--text NUNBER>
Sets the width of the main textbox display. The default is '80'.
B<-U,--userlist NUNBER>
Sets the width of the user list listbox display. The default is '20'.
B<-H,--height NUNBER>
Sets the height of the main textbox and the user list. The default is '20'.
B<-S,--simple>
Turns on 'simple mode', which turns off topic and channel name display.
B<-B,--background COLOR>
Sets the textbox/listbox background color. Default is 'white'.
B<-F,--foreground COLOR>
Sets the textbox/listbox foreground (text) color. The default is 'black'.
B<-t,--timestamp>
Turns on timestamping.
B<-l,--log>
Turns on logging. A file is created in the current working directory named I<SERVER.PORT.CHANNEL-NAME.log>.
=head1 COMMANDS
To get a list of avaliable commands, use B</help>.
=head1 CHANGELOG
B<alpha-0.4>
* Fixed a bug causing the the program to error out on newer versions of Perl.
B<alpha-0.3>
* Refined the text display.
* Added a timestamp option.
* Added a logging option.
* Added more options to the configuration files.
B<alpha-0.2>
* Fixed a topic diplay bug
(topics that contained a ':' were truncated).
* Limited the length of topic text.
* Added some GUI commandlist configuration options.
B<alpha-0.1>
* Initial release.
=head1 LICENSE
(c) Copyright Dan Hetrick 2004
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2 of the License, or (at your option)
any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
</code>
A GUI IRC Client in less than 1200 lines of code (including whitespace, comments, and POD). Uses Perl/Tk, <a href="http://poe.perl.org/">POE</a>, <a href="http://search.cpan.org/author/FIMM/POE-Component-IRC-2.9/IRC.pm">POE::Component::IRC</a>, and <a href="http://search.cpan.org/author/CJM/Getopt-Mixed-1.008/lib/Getopt/Mixed.pm">Getopt::Mixed</a>. <i>Heavily</i> commented. Tested on Mandrake 10, Windows 98, Windows XP, Windows 2000, and Ubuntu Linux 6.06.<br><br><br>
<b><i>UPDATE:</i></b> Added some more GUI settings, squashed a couple of bugs, and expanded what you can put in a config file.<br>
<b><i>UPDATE:</i></b> Added a whole slew of new GUI settings, and fixed a bug in topic display.<br>
<b><i>UPDATE:</b></i> Fixed a bug in topic retrieval (topics that contained a ':' were truncated).<br>
<b><i>UPDATE:</b></i> Fixed a bug causing the client to error out on newer versions of Perl.<br>
Networking Code
Dan Hetrick<br>email: dhetrick@NOSPAMgmail.com<br><br>