Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
#!/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

In reply to Perl/Tk GUI IRC Client by #include

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chilling in the Monastery: (3)
As of 2022-10-04 07:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My preferred way to holiday/vacation is:











    Results (16 votes). Check out past polls.

    Notices?