Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
PerlMonks  

Perl/Tk GUI IRC Client

by #include (Curate)
on Jul 24, 2004 at 03:37 UTC ( #377068=sourcecode: print w/ replies, xml ) Need Help??

Category: Networking Code
Author/Contact Info Dan Hetrick
email: dhetrick@NOSPAMgmail.com

Description: A GUI IRC Client in less than 1200 lines of code (including whitespace, comments, and POD). Uses Perl/Tk, POE, POE::Component::IRC, and Getopt::Mixed. Heavily commented. Tested on Mandrake 10, Windows 98, Windows XP, Windows 2000, and Ubuntu Linux 6.06.


UPDATE: Added some more GUI settings, squashed a couple of bugs, and expanded what you can put in a config file.
UPDATE: Added a whole slew of new GUI settings, and fixed a bug in topic display.
UPDATE: Fixed a bug in topic retrieval (topics that contained a ':' were truncated).
UPDATE: Fixed a bug causing the client to error out on newer versions of Perl.
#!/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 b
+ackground>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 di
+splay).\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 Even
+t
        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 => 'gi
+f' );
    $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 li
+st
                    @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, A
+RG2 ];
    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, A
+RG2 ];
    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, A
+RG2 ];
    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' messa
+ge.
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, $isd
+st ) =
          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;
R0lGODdhIAAgAOdLAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA
+0NDQ4O
Dg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8fHy
+AgICEh
ISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDExMTIyMj
+MzMzQ0
NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkNDQ0REREVFRU
+ZGRkdH
R0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVVVVZWVldXV1hYWF
+lZWVpa
WltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdnZ2hoaGlpaWpqamtra2
+xsbG1t
bW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5eXp6ent7e3x8fH19fX5+fn
+9/f4CA
gIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouLi4yMjI2NjY6Ojo+Pj5CQkJGRkZ
+KSkpOT
k5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2dnZ6enp+fn6CgoKGhoaKioqOjo6SkpK
+Wlpaam
pqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+vr7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7
+i4uLm5
ubq6uru7u7y8vL29vb6+vr+/v8DAwMHBwcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKys
+vLy8zM
zM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d
+7e3t/f
3+Dg4OHh4eLi4uPj4+Tk5OXl5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8P
+Hx8fLy
8vPz8/T09PX19fb29vf39/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///ywAAAAAIAAgAAAI/g
+D/CRwo
0J2zUZa+8SPIsKHDge1qBUmx5saTV/4cflNTJtzDgeouUaEBxIoQICYCNfT2hYidHn9qTR
+rnEFgc
Gi1+4BihAQOIXwwnVaFC5AUoSHe84GsIBoiQMG9AXNgggUKObAOxqTBBgw6iVnOeONrH8N
+iMIlRI
5XHxwYMIF0VGbFp6DYeIGrHQJFmVLyNBdFWcOEG2LA+YGiCQxJlCIkMUde9o/FDxxEmKPA
+4Bndnz
CpsySIJK9TFUC1SbGhy+lJsyxcqRGS040CTobciYIXoUfUHzpMcVWtjWacoxYgIsRCBO3N
+gj5UQy
hqc2qRl0iccSLXnEoBIlbR+lP3Iw/nxh5qMFjSxCQLQiWC1II1LXyHEy08kVI2neyPE7dg
+TLBxuu
3HHDKEo0ocEyA83zhRCVhNKPP+rIwgkaiZjyBzHdPLMTB2h0wkcSlRhxgQbiDGTHD13ggQ
+Qx7twC
iBdr3FHHH3WA80YJGbSQBzFTtBHKDBcYoY5A+BBRCBdRWBCDHXMU4YQbdDDDxw+VRDHBCk
+YsAs0r
qNzBljIJBvGII0pcEIFPKKRAwharIDLDI2BM8AIJZSjDTR43oECJPgOlg4MpwYwBAgZUqF
+BCCiBs
gUkpU0QxggQfcHABHVtIUQIn8RDkzw26aKNEEDp808EINxiJhyAxTIABBRNQsAQd/kQsQk
+s+DRGi
RjoiqHHHP4lYQAEpeMxwAw1+UDICDRZk8s9SD80TCDgjGKHLP+BoQEEskpzQgQWj/MOEBh
+Vg9pFA
9wjDgg31CMQCCbKs48QGHvjxjxoTaKDHuAPRssElAwEBAzT/yEFCBzrUQ00IFTCCr0DRgG
+DOQHpx
8880UuxQwy/7TAHEJwv/U8sJ7gjEDyh/PPdPO60EIss/cNCQS8ejhFEiuc8MI5A/sgCBzj
++GIdNx
NUD0Q1A7kKzzDzFwvCPQKDM80/E/bzR0TCnzIMKnQPZQ0c3TgCzEXjxopEvQILs8zQdWA6
+GzxxJJ
XMOQM8ourI8ntxBkDA+sUIEFNSH3DMTOK0Pim00Yg9gzEDee4KONNshkKlA9tmDi10fOTN
+EFwB0j
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 c
+hannel at a time;  if the client uses the /join command to join anoth
+er 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<SETT
+ING=VALUE>, one setting per line.  Avaliable settings are B<server>, 
+B<port>, B<nick>, B<channel>, B<text> (same as the -T option), B<user
+list> (the same as the -U option), B<height> (the same as the -H opti
+on), 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, t
+he default port of 6667 is used.  The client will automatically conne
+ct 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 w
+hen 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 'bla
+ck'.

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 o
+f 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 i
+t
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 opti
+on)
any later version.

This program is distributed in the hope that it will be useful, but WI
+THOUT
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 alon
+g with
this program; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA


Comment on Perl/Tk GUI IRC Client
Download Code
Re: Perl/Tk GUI IRC Client
by buetow (Beadle) on Apr 12, 2007 at 18:47 UTC
    Hello! Very nice work! But i ve a question. Is it normal that this client consumes 99% of my CPU resources? (1Ghz Pentium 3 box). It seems to depend on the combination POE::Component::IRC & Tk. Running POE::Component::IRC together with Tk is causing this. Using POE::Component::IRC without Tk or using Tk without POE::Component::IRC within the same application does not need as much resources. I think this is strange.
    Paul Buetow - http://www.buetow.org

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://377068]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (3)
As of 2015-07-05 09:35 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (61 votes), past polls