use Tk; use IO::Select; use POSIX; use IO::Socket; use Socket; use Fcntl; use Tie::RefHash; my $VERSION = "0.1.1"; my ($user, $pass, $auto, $realname, $email, $quote); my $configfile_name = '.perlchatrc'; $| = 1; retrieve_config(); create_gui(); #--------------------------------------------------------------------- sub create_gui { # Preconditions: none # Postconditions: creates the top level window, its frames, the # buddy list, and the bindings on actions to # objects in this window. $top = MainWindow->new(); $top->title ("Perl Chat $VERSION"); # Create Menu Bar $menu_bar = $top->Frame()->pack('-side' => 'top', '-fill' => 'x'); # File Menu Button $menu_file = $menu_bar->Menubutton('-text' => 'File', '-relief' => 'raised', '-borderwidth' => 2, )->pack('-side' => 'left', '-padx' => 2 ); # Edit Menu Button $menu_edit = $menu_bar->Menubutton('-text' => 'Edit', '-relief' => 'raised', '-borderwidth' => 2, )->pack('-side' => 'left', '-padx' => 2 ); # About Menu Button $menu_about = $menu_bar->Menubutton('-text' => 'About', '-relief' => 'raised', '-borderwidth' => 2, )->pack('-side' => 'right', '-padx' => 2 ); $menu_about->command('-label' => 'About', '-accelerator' => ' ', '-underline' => 0, '-command' => \&popup_about); $menu_about->command('-label' => 'License', '-accelerator' => ' ', '-underline' => 0, '-command' => \&popup_license); $menu_edit->command('-label' => 'Options', '-accelerator' => ' ', '-underline' => 1, '-command' => \&options); $menu_edit->command('-label' => 'Clear Messages', '-accelerator' => ' ', '-underline' => 1, '-command' => sub { $status->delete('0.0', +'end') }); $menu_edit->command('-label' => 'Update Info', '-accelerator' => ' ', '-underline' => 1, '-command' => \&update_info); $menu_file->command('-label' => 'Connect', '-accelerator' => ' ', '-underline' => 0, '-command' => sub { connect_server($host,$p +ort) }); $menu_file->command('-label' => 'Login', '-accelerator' => ' ', '-underline' => 1, '-command' => \&login); $menu_file->command('-label' => 'Register', '-accelerator' => '', '-underline' => 0, '-command' => \®ister); $menu_file->command('-label' => 'List Users', '-accelerator' => '', '-underline' => 1, '-command' => \&update_buddy_list); $menu_file->command('-label' => 'Global Message', '-accelerator' => '', '-underline' => 0, '-command' => \&msg_all_buddy); $menu_file->command('-label' => 'Log Off', '-accelerator' => '', '-underline' => 5, '-command' => \&logoff); $menu_file->command('-label' => 'Get Buddy Info.', '-accelerator' => '', '-underline' => 1, '-command' => \&get_user_info); $menu_file->command('-label' => 'Quit', '-accelerator' => '', '-underline' => 0, '-command' => sub { quit(); exit(1) } ); $bottom_frame = $top->Frame()->pack(-side => 'bottom', -fill => 'x', -expand => 'x'); $left_frame = $bottom_frame->Frame()->pack(-side => 'left', -fill => 'y', -expand => 'y'); $right_frame = $bottom_frame->Frame()->pack(-side => 'right', -fill => 'y', -expand => 'y'); # Sample radio buttons/checkboxes/separators #$match_type = "regexp"; $case_type = 1; ####################################################### #$menu_file->separator(); ## Regexp match #$menu_file->radiobutton('-label' => 'Regexp match', # '-value' => 'regexp', # '-variable' => \$match_type); ## Exact match #$menu_file->radiobutton('-label' => 'Exact match', # '-value' => 'exact', # '-variable' => \$match_type); ####################################################### #$menu_file->separator(); ## Ignore case #$menu_file->checkbutton('-label' => 'Ignore case?', # '-variable' => \$case_type); #----------------------- Set up status widgit ------------------------ +------- $left_frame->Label(text => "Perl Chat Client v$VERSION") ->pack(-side => 'top', -anchor => 'nw'); $status = $left_frame->Text (-width => 40, -height => 30, -wrap => 'word')->pack(); $status->tagConfigure(section, -font => '-adobe-helvetica-bold-r-normal--14-140-75-75-p-82-iso8 +859-1'); $status->bind('<Double-1>', \&pick_word); $left_frame->Label(-text => 'Global Message:')->pack(-side => 'left +'); $gm_quick = $left_frame->Entry (-width => 26)->pack(-side => 'left' +); $gm_quick->bind('<KeyPress-Return>', sub { send_msg_all($gm_quick->get +()); $gm_quick->delete(0,'end'); }); # ------------------------ Set up Buddy list ------------------------- +------- $right_frame->Label(text => 'Buddies') ->pack(-side => 'top', -anchor => 'ne'); $buddy_list = $right_frame->Listbox(width => 10, height => 25)->pack(); $buddy_list->bind('<Double-1>', \&msg_buddy); process_config(); MainLoop(); } #--------------------------------------------------------------------- +------- sub process_config { print "Processing Config File...\n"; if ($auto =~ /^y/i) { # auto connect, logon, update info connect_server($host, $port); send_login($user, $pass); # send_update(); } } # -------------------------------------------------------------------- +------- sub save_options { my ($h, $po, $u, $pa, $a, $r, $e, $q) = @_; print "Saving configuration...\n"; open(CONF, ">$configfile_name") || die "Cannot save new conf fil +e $!\n"; print CONF "# This is the Perl Chat Client config file.\n"; print CONF "# You may edit this file with a text editor or\n"; print CONF "# from the edit menu within Perl Chat itself.\n\n"; print CONF "HOST=$h\n"; print CONF "PORT=$po\n"; print CONF "USER=$u\n"; print CONF "PASS=$pa\n"; print CONF "AUTO=$a\n\n"; print CONF "# User Information to be updated upon login\n\n"; print CONF "REALNAME=$r\n"; print CONF "EMAIL=$e\n"; print CONF "QUOTE=$q\n"; close (CONF) || die "Cannot close saved config file $!\n"; } # -------------------------------------------------------------------- +------- sub options { print "Perl Chat Options.\n"; my ($options_window) = $top->Toplevel; $options_window->title ("Perl Chat Options"); my $bottom_frame = $options_window->Frame()->pack(-side => 'bottom' +, -fill => 'x', -expand => 'x'); my $left_frame = $options_window->Frame()->pack(-side => 'left', -fill => 'x', -expand => 'x'); my $right_frame = $options_window->Frame()->pack(-side => 'right', -fill => 'x', -expand => 'x'); my($host_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Host', )->pack(); my($host_entry) = $right_frame->Entry (-width => 40)->pack();; my($port_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Port', )->pack(); my($port_entry) = $right_frame->Entry (-width => 40)->pack(); my($user_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Username', )->pack(); my($user_entry) = $right_frame->Entry (-width => 40)->pack(); my($pass_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Password', )->pack(); my($pass_entry) = $right_frame->Entry (-width => 40, -show => '*')->pack(); my($auto_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Auto Login', )->pack(); my($auto_entry) = $right_frame->Entry (-width => 40)->pack(); my($realname_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Real Name', )->pack(); my($realname_entry) = $right_frame->Entry (-width => 40)->pack(); my($email_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Email', )->pack(); my($email_entry) = $right_frame->Entry (-width => 40)->pack(); my($quote_label) = $left_frame->Label ( -anchor => 'w', -justify => 'left', -text => 'Quote', )->pack(); my($quote_entry) = $right_frame->Entry (-width => 40)->pack(); $host_entry->insert (0,"$host"); $port_entry->insert (0,"$port"); $user_entry->insert (0,"$user"); $pass_entry->insert (0,"$pass"); $auto_entry->insert (0,"$auto"); $realname_entry->insert (0,"$realname"); $email_entry->insert (0,"$email"); $quote_entry->insert (0,"$quote"); $bottom_frame->Button(-text => 'Save', -command => sub { save_options($host_entry->get(), $port_entry->get(), $user_entry->get(), $pass_entry->get(), $auto_entry->get(), $realname_entry->get(), $email_entry->get(), $quote_entry->get()); $host = $host_entry->get(); $port = $port_entry->get(); $user = $user_entry->get(); $pass = $pass_entry->get(); $auto = $auto_entry->get(); $realname = $realname_entry->get(); $email = $email_entry->get(); $quote = $quote_entry->get(); destroy $options_window; } )->pack(-side => 'left'); $bottom_frame->Button(-text => 'Cancel', -command => sub{destroy $options_window} )->pack(-side => 'right'); } # -------------------------------------------------------------------- +------- sub get_user_info { # Preconditions: should be connected to a server, and logged into the +server # Postconditions: creates a window, prompts user for a buddy, # calls send_query with this info (buddy) # my ($get_info_window, $get_buddy); print "Getting info to query buddy.\n"; if(defined $conn) { print "Connection Checked: Proceeding with message!\n"; $get_info_window = $top->Toplevel; $get_info_window->title ("Query Buddy"); $get_info_window->Label(-text => "Enter Buddy:")->pack(); $get_buddy = $get_info_window->Entry (-width => 20)->pack(); $get_buddy->bind('<KeyPress-Return>',sub { send_query($get_buddy->get()); destroy $get_info_window; }); $get_info_window->Button(-text => 'OK', -command => sub { send_query($get_buddy->get()); destroy $get_info_window; } )->pack(-side => 'left'); $get_info_window->Button(-text => 'Cancel', -command => sub{destroy $get_info_window} )->pack(-side => 'left'); } else { print "No connection established!\n"; popup_err(91); } } # -------------------------------------------------------------------- +------- sub msg_all_buddy { # Preconditions: should be connected to a server, and logged into the +server # Postconditions: creates a window, prompts user for msg, calls send_m +sg_all # with this info (message) # my ($msg_all_window, $get_msg); print "Getting message to send to $buddy\n"; if(defined $conn) { print "Connection Checked: Proceeding with message!\n"; $msg_all_window = $top->Toplevel; $msg_all_window->title ("Global Message"); $msg_all_window->Label(-text => "Enter Message:")->pack(); $get_msg = $msg_all_window->Entry (-width => 40)->pack(); $get_msg->bind('<KeyPress-Return>',sub { send_msg_all($get_msg->get()); destroy $msg_all_window; }); $msg_all_window->Button(-text => 'OK', -command => sub { send_msg_all($get_msg->get()); destroy $msg_all_window; } )->pack(-side => 'left'); $msg_all_window->Button(-text => 'Cancel', -command => sub{destroy $msg_all_window} )->pack(-side => 'left'); } else { print "No connection established!\n"; popup_err(91); } } # -------------------------------------------------------------------- +------- sub msg_buddy { # Preconditions: should be connected to server, and logged on to serve +r # Postconditions: creates a window and gets info from user and calls s +end_msg # with the info obtained (recipient and message) # my $buddy = $buddy_list->get('active'); my ($msg_bud_window, $get_msg, $get_rcpt); return if(!$buddy); print "Getting message to send to $buddy\n"; if(defined $conn) { print "Connection Checked: Proceeding with message!\n"; $msg_bud_window = $top->Toplevel; $msg_bud_window->title ("Message Buddy"); $msg_bud_window->Label(-text => "To User:")->pack(); $get_rcpt = $msg_bud_window->Entry (-width => 15)->pack(); $get_rcpt->insert (0,"$buddy"); $msg_bud_window->Label(-text => "Enter Message:")->pack(); $get_msg = $msg_bud_window->Entry (-width => 40)->pack(); $get_msg->bind('<KeyPress-Return>', sub { send_msg($buddy, $get_msg +->get()); destroy $msg_bud_window; }); $msg_bud_window->Button(-text => 'OK', -command => sub { send_msg($buddy, $get_msg->g +et()); destroy $msg_bud_window; } )->pack(-side => 'left'); $msg_bud_window->Button(-text => 'Cancel', -command => sub{destroy $msg_bud_window} )->pack(-side => 'left'); } else { print "No connection established!\n"; popup_err(91); } # THis is how to delete a buddy from the list # $buddy_list->delete('active'); # delete an actively selected budd +y } # -------------------------------------------------------------------- +------- sub connect_server { # Preconditions: gui should be created, this should be called from # Connect under the File menu button. # Postconditions: connects to server then spawns another thread # this new thread processes responses from the server. + my ($host, $port) = @_; # # connect socket -> set up select -> loop # if($conn_stat ne 'connected') { print "Connecting to Server $host:$port...\n"; $conn = IO::Socket::INET->new(PeerAddr => $host, PeerPort => $port, Proto => 'tcp') or popup_err(4); ### %inbuffer = (); %outbuffer = (); %ready = (); tie %ready, 'Tie::RefHash'; nonblock($conn); $select = IO::Select->new($conn); ### $menu_file->repeat(5000, sub { wait_for_msgs() }); $conn_stat = 'connected'; } if (!defined $conn) { print "Unhandled error, make a popup. Could not connect to serv +er.\n"; } } #--------------------------------------------------------------------- +------- sub login { # TODO: create frames and make everything line up correctly. # Preconditions: should be connected to the server # Postconditions: will log client into server with input provided my ($login_window, $get_user, $get_pass); if(defined $conn) { print "Connection Checked: Proceeding with Login!\n"; $login_window = $top->Toplevel; $login_window->title ("Login Procedure"); $login_window->Label(-text => 'Enter Your Login Information:')-> +pack; $login_window->Label(-text => "Username:")->pack(); $get_user = $login_window->Entry (-width => 15)->pack(); $login_window->Label(-text => "Password:")->pack(); $get_pass = $login_window->Entry (-width => 15, -show => '*')->pack(); $get_pass->bind('<KeyPress-Return>', sub { send_login($get_user->get(), $get_pass->get() +); destroy $login_window; }); $login_window->Button(-text => 'OK', -command => sub { send_login($get_user->get(), $get_pass->ge +t()); destroy $login_window; } )->pack(-side => 'left'); $login_window->Button(-text => 'Cancel', -command => sub{destroy $login_window} )->pack(-side => 'left'); } else { print "No connection established!\n"; popup_err(91); } } # -------------------------------------------------------------------- +------- sub register { # Preconditions: none # Postconditions: draws a window and prompts the user for input. # also calls calls the sub send_reg upon users action my $reg_window; if(defined $conn) { print "Connection Checked: Proceeding with Reg.!\n"; $reg_window = $top->Toplevel; $reg_window->title ("Registration Procedure"); $reg_window->Label(-text => 'Enter Your Desired Information:')-> +pack; $reg_window->Label(-text => "Username:")->pack(); $get_new_user = $reg_window->Entry (-width => 15)->pack(); $reg_window->Label(-text => "Password:")->pack(); $get_new_pass1 = $reg_window->Entry (-width => 15, -show => '*')->pack(); $reg_window->Label(-text => "Re-Enter Password:")->pack(); $get_new_pass2 = $reg_window->Entry (-width => 15, -show => '*')->pack(); $get_new_pass1->bind('<KeyPress-Return>', sub { send_reg($get_new_user->get(), $get_new_pass1->get(), $get_new_pass2->get()); destroy $reg_window; }); $get_new_pass2->bind('<KeyPress-Return>', sub { send_reg($get_new_user->get(), $get_new_pass1->get(), $get_new_pass2->get()); destroy $reg_window; }); $reg_window->Button(-text => 'OK', -command => sub { send_reg($get_new_user->get(), $get_new_pass1->get(), $get_new_pass2->get()); destroy $reg_window } )->pack(-side => 'left'); $reg_window->Button(-text => 'Cancel', -command => sub{destroy $reg_window} )->pack(-side => 'left'); } else { print "No connection established!\n"; popup_err(91); } } #--------------------------------------------------------------------- +------- sub send_msg_all { # Preconditions: should have gotten input from user in msg_all_buddy() +; before # this sub is called. # Postconditions: sends a message to the server to send a message to # every user my ($msg) = @_; if(defined $conn) { # prints it to console print "Global Message:\n"; print "Contents: $msg\n"; # Send a the Message to server print $conn "7\:\:$user\:\:$pass\:\:$msg\n"; } else { print "No connection established!\n"; popup_err(91); } } #--------------------------------------------------------------------- +------- sub send_msg { # Preconditions: should have gotten input from user in msg_buddy(); be +fore # this sub is called. # Postconditions: sends a message to the server to send a message to # another user my ($rcpt, $msg) = @_; if(defined $conn) { # prints it to console print "Recipient: $rcpt\n"; print "Message: $msg\n"; # Print message to localhost $status->insert('end',"[$user]->[$rcpt]: $msg\n"); # Send a Private Message print $conn "6\:\:$user\:\:$pass\:\:$rcpt\:\:$msg\n"; } else { print "No connection established!\n"; popup_err(91); } } # -------------------------------------------------------------------- +------- sub send_login { # Preconditions: should have gotten input from user in login(); before # this sub is called. # Postconditions: sends a message to the server to log in my ($u, $p) = @_; if(defined $conn) { if(length($u) > 0 && length($p) > 0) { # prints it to console print "Username: $u\n"; print "Password: ********\n"; print $conn "1\:\:$u\:\:$p\n"; $user = $u; # damn these globals, i dont like them!!!! $pass = $p; update_info(); } else { popup_err(3); } } else { print "No connection established!\n"; popup_err(91); } } #--------------------------------------------------------------------- +----- sub send_query { my ($buddy) = @_; if(length($buddy) < 1) { popup_err(81); } elsif (defined $conn) { if (defined $user) { # send query to server print $conn "8\:\:$user\:\:$pass\:\:$buddy\n"; } else { popup_err(82); } } else { print "No connection established!\n"; popup_err(91); } } #--------------------------------------------------------------------- +----- sub send_reg { # Preconditions: should have gotten input from user from the ENTRY box +'s # in register(); # Postconditions: sends a message to the server to register the user my ($u, $p1, $p2) = @_; if (length($u) < 1) { popup_err(25); } elsif (length($p1) < 1 || length($p2) < 1) { popup_err(26); } else { if ($p1 eq $p2) { if(defined $conn) { print "Username: $u\n"; print "Password: ********\n"; print $conn "2\:\:$u\:\:$p1\n"; } else { print "No connection established!\n"; popup_err(91); } } else { popup_err(24); } } } #--------------------------------------------------------------------- +----- sub logoff { # Preconditions: should be logged onto server # Postconditions: sends a message to the server to log user out if(defined $conn) { print "Logging out of Server\n"; print "Username: $user\n"; print "Password: ********\n"; print $conn "4\:\:$user\:\:$pass\n"; } else { print "No connection established!\n"; popup_err(91); } } #--------------------------------------------------------------------- +----- sub update_buddy_list { # Preconditions: none # Postconditions: sends a message to update the buddy list if(defined $conn) { print $conn "5\:\:$user\:\:$pass\n"; } else { print "No connection established!\n"; popup_err(91); } } #--------------------------------------------------------------------- +----- sub process_query { my ($msg) = @_; my @chopped_msg = split(/::/, $msg); my $query_window; my $query_msg; $query_window = $top->Toplevel; $query_window->title ("Query Results"); $query_window->Label(-text => "User $chopped_msg[3]'s Info Listed B +elow")->pack; $query_msg = $query_window->Text (-width => 60, -height => 12, -wrap => 'word')->pack(); $query_msg->insert('end',"Real Name: $chopped_msg[4]\n"); $query_msg->insert('end',"Email: $chopped_msg[5]\n"); $query_msg->insert('end',"Quote: $chopped_msg[6]\n"); $query_msg->insert('end',"IP: $chopped_msg[7]\n"); $query_msg->insert('end',"Logged In: $chopped_msg[8]\n"); $query_msg->insert('end',"Status: $chopped_msg[9]\n"); $query_msg->insert('end',"Connected: $chopped_msg[10]\n"); $query_window->Button(-text => 'OK', -command => sub { destroy $query_window } )->pack(); } #--------------------------------------------------------------------- +----- sub wait_for_msgs { # Preconditions: Must be connected to the Server. # Postconditions: Process incoming messages from the Server. my ($list_size, $msg); # my $exit_cond = 1; # %inbuffer = (); # %outbuffer = (); # %ready = (); # tie %ready, 'Tie::RefHash'; # nonblock($conn); # $select = IO::Select->new($conn); my $server; my $rv; my $data; # check for new information on the connections we have # anything to read or accept? foreach $server ($select->can_read(1)) { # read data $data = ''; $menu_file->update; $rv = $server->recv($data, POSIX::BUFSIZ, 0); unless (defined($rv) && length $data) { # This would be the end of file, so close the client delete $inbuffer{$server}; delete $outbuffer{$server}; delete $ready{$server}; $select->remove($server); close $server; next; } $inbuffer{$server} .= $data; # test whether the data in the buffer or the data we # just read means there is a complete request waiting # to be fulfilled. If there is, set $ready{$client} # to the requests waiting to be fulfilled. while ($inbuffer{$server} =~ s/(.*\n)//) { $menu_file->update; push( @{$ready{$server}}, $1 ); } } # Any complete requests to process? foreach $server (keys %ready) { $menu_file->update; handle($server); } # This is commented out since we dont care about sending, only receivi +ng!!! # # buffers to flush, AKA write to socket! # foreach $server ($select->can_write(1)) { # # Skip this client if we have nothing to say # next unless exists $outbuffer{$server}; # # $rv = $server->send($outbuffer{$server}, 0); # unless (defined $rv) { # # Whine, but move on. # warn "I was told I could write, but I can't.\n"; # next; # } # # if ($rv == length $outbuffer{$server} || # $! == POSIX::EWOULDBLOCK) { # # is executing htis block every time! :( # substr($outbuffer{$server}, 0, $rv) = ''; # delete $outbuffer{$server} unless length $outbuffer{$ser +ver}; # } else { # # Couldn't write all the data, and it wasn't because # # it would have blocked. Shutdown and move on. # delete $inbuffer{$server}; # delete $outbuffer{$server}; # delete $ready{$server}; # # $select->remove($server); # close($server); # next; # } # } # # Out of band data? # foreach $server ($select->has_exception(0)) { # arg is timeou +t # # Deal with out-of-band data here, if you want to. # print "ERROR DEBUG ME!\n"; # } $top->update; } #--------------------------------------------------------------------- +------ # handle($socket) deals with all pending requests for $client sub handle { # requests are in $ready{$server} # send output to $outbuffer{$server} my $server = shift; my $request; foreach $request (@{$ready{$server}}) { # $request is the text of the request # put text of reply into $outbuffer{$client} chomp $request; print "Incoming message received: $request\n"; process_incoming($server, $request); } delete $ready{$server}; } # -------------------------------------------------------------------- +---- # nonblock($socket) puts socket into nonblocking mode sub nonblock { my $socket = shift; my $flags; $flags = fcntl($socket, F_GETFL, 0) or die "Can't get flags for socket: $!\n"; fcntl($socket, F_SETFL, $flags | O_NONBLOCK) or die "Can't make socket nonblocking: $!\n"; } # -------------------------------------------------------------------- +---- sub process_incoming { my ($server, $msg) = @_; my @logged_users; my @rcvd_msg = split(/::/, $msg); $menu_file->update; if ($rcvd_msg[1] eq "1") { # Login responses # 12 = already logged on # 03 = logged in if($rcvd_msg[2] eq "03") { print "Successfully Logged in!\n"; } elsif ($rcvd_msg[2] eq "12") { popup_err(2); } else { # Create pop-up for error! print "Error Logging in ", $msg, "\n"; popup_err(1); } $menu_file->update; } elsif ($rcvd_msg[1] eq "2") { # register response if ($rcvd_msg[2] eq "06") { print "New user successfully registered!\n"; popup_err(27); } elsif ($rcvd_msg[2] eq "02") { print "$msg\n"; popup_err(22); } else { print "$msg\n"; popup_err(21); } $menu_file->update; } elsif ($rcvd_msg[1] eq "3") { # quit response print "$msg\n"; $exit_cond = 0; $menu_file->update; } elsif ($rcvd_msg[1] eq "4") { # log out response # 14 = user logged off # 13 = user not logged in to begin with print "$msg\n"; if($rcvd_msg[2] == 13) { popup_err(41); # not logged in } else { # clear the buddy list $list_size = $buddy_list->size; $list_size = $list_size - 1; $buddy_list->delete(0,$list_size); } $menu_file->update; } elsif ($rcvd_msg[1] eq "5") { # delete existing list of users $list_size = $buddy_list->size; if($list_size > 0) { $buddy_list->delete(0,$list_size); } # get users list response # if server response for proto 5 is 17 then Draw in $buddy_li +st if ($rcvd_msg[2] == 17) { @logged_users = split (/ /, $rcvd_msg[3]); foreach (@logged_users) { $buddy_list->insert('end', "$_"); } } elsif ($rcvd_msg[2] eq 18) { # generate error for login print "Please Log in to server first!\n"; print "$msg\n"; popup_err(51); } else { print "Unknown error updating buddy list:\n"; print "$msg\n"; popup_err(52); } $menu_file->update; } elsif ($rcvd_msg[1] eq "6") { # receive user message # 13 - user not logged in # 23 - buddy (target) not logged in print "$msg\n"; rcv_msg($rcvd_msg[3], $rcvd_msg[4]); } elsif ($rcvd_msg[1] eq "7") { # receive global message print "$msg\n"; rcv_msg_all($rcvd_msg[3], $rcvd_msg[4]); } elsif ($rcvd_msg[1] eq "8") { if ($rcvd_msg[2] == 23) { popup_err(81); } elsif ($rcvd_msg[2] eq "13") { popup_err(82); } else { # receive query information print "$msg\n"; process_query($msg); } $menu_file->update; } else { print "Unrecognized response: $msg\n"; popup_err(92); exit(0); } if($err) { print "ERROR: $err\n"; } } #------------------------------------------------------------------ sub quit { # Preconditions: none # Postconditions: this thread exits if(defined $conn) { # send quit command print $conn "3\:\:$user\:\:$pass\n"; } else { exit; } } #------------------------------------------------------------------ sub rcv_msg { my ($from, $msg) = @_; print "Received message from $from\n"; if(defined $conn) { print "Already Connected: Proceeding with message!\n"; $status->insert('end',"[$from]: $msg\n"); } else { print "No connection established!\n"; popup_err(91); } } #------------------------------------------------------------------ sub rcv_msg_all { my ($from, $msg) = @_; print "Received Global message:\n"; if(defined $conn) { print "Already Connected: Proceeding with message!\n"; $status->insert('end',"$from: $msg\n"); } else { print "No connection established!\n"; popup_err(91); } } #------------------------------------------------------------------ sub popup_about { my $about_text = "Perl Chat version $VERSION\n". "Copyright (C) 2000 Torrance Jones\n". "Distributed under the GNU GPL\n". "For more information about this program ". "its developers or its license visit\n". "http://perlchat.sourceforge.net or email\n". "torrancejones\@users.sourceforge.net\n"; my $about_window = $top->Toplevel; $about_window->title ("About"); my $topframe = $about_window->Frame(-background => 'White')->pack(' +-side' => 'top', ' +-fill' => 'x'); my $bottomframe = $about_window->Frame(-background => 'White')->pac +k('-side' => 'bottom', + '-fill' => 'x'); $topframe->Photo('logo', -file => "perlchat.gif"); $topframe->Label('-image' => 'logo')->pack(-side => 'left'); my $about_msg = $bottomframe->Text (-width => 40, -height => 10, -wrap => 'word')->pack(); $about_msg->insert('end',"$about_text"); $bottomframe->Button(-text => 'OK', -command => sub { destroy $about_window } )->pack(); } #------------------------------------------------------------------ sub popup_license { my $license_window; my $license_msg; $license_window = MainWindow->new(); $license_window->title ("License"); $license_window->Label(-text => "Perl Chat License")->pack; my $top_frame = $license_window->Frame()->pack('-side' => 'top', '-fill' => 'x', -expand => 'x'); my $bottom_frame = $license_window->Frame()->pack(-side => 'bottom' +, -fill => 'x', -expand => 'x'); $license_msg = $top_frame->Text (-width => 50, -height => 15, -wrap => 'word')->pack(side => 'le +ft', padx => 10) +; $license_msg->insert('end',"This program is distributed under the t +erms ". "of the GNU General Public License. This program is distributed +in the ". "hope that it will be useful but WITHOUT ANY WARRANTY without eve +n the ". "implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +". "PURPOSE. See the GNU General Public License for more details.\ +n\n". "You should have received a copy of the GNU General Public Licens +e along ". "with this program; if not, write to the Free Software Foundation +, ". "Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA or v +isit ". "http://www.fsf.org/copyleft/gpl.html\nFor more information about + this ". "program its developers or its license visit\n". "http://perlchat.sourceforge.net\nor email ". "torrancejones\@users.sourceforge.net\n"); $scroll = $top_frame->Scrollbar(orient => 'vertical', width => 10, command => ['yview', $license_msg] )->pack(side => 'left', fill => 'y', padx => 0); $license_msg->configure(yscrollcommand => ['set', $scroll]); $bottom_frame->Button(-text => 'OK', -command => sub { destroy $license_window } )->pack(); } #------------------------------------------------------------------ sub popup_err { # Preconditions: none # Postconditions: a popup is drawn according to the error code # received my ($error_code) = @_; my $popup_win; my $error_msg; my $error_title; print"Error Code: $error_code\n"; if($error_code eq 1) { $error_msg = "Not Connected!"; $error_title = "Login Error:"; } elsif($error_code eq 2) { $error_msg = "Already Logged on with This User Name!"; $error_title = "Logon Error:"; } elsif($error_code eq 3) { $error_msg = "Username or Password to short!"; $error_title = "Logon Error:"; } elsif($error_code eq 4) { $error_msg = "Cannot Create Socket!"; $error_title = "Socket Error:"; } elsif($error_code eq 21) { $error_msg = "Error Registering User!"; $error_title = "Registration Error:"; } elsif($error_code eq 22) { $error_msg = "Error user Already Exists!"; $error_title = "Registration Error:"; } elsif($error_code eq 24) { $error_msg = "Passwords entered do not match!"; $error_title = "Registration Error:"; } elsif($error_code eq 25) { $error_msg = "Please Enter a Username!"; $error_title = "Registration Error:"; } elsif($error_code eq 26) { $error_msg = "Please Enter a valid Password!"; $error_title = "Registration Error:"; } elsif($error_code eq 27) { $error_msg = "User Successfully Added!"; $error_title = "Registration Message:"; } elsif($error_code eq 41) { $error_msg = "Already Logged Out!"; $error_title = "Logout Error:"; } elsif($error_code eq 51) { $error_msg = "Please Log into the Server First!"; $error_title = "Update Error:"; } elsif($error_code eq 52) { $error_msg = "Unkown Update Error!"; $error_title = "Unknown Update Error:"; } elsif($error_code eq 81) { $error_msg = "Target Not Logged In!"; $error_title = "Query Error:"; } elsif($error_code eq 82) { $error_msg = "Please Log In First!"; $error_title = "Query Error:"; } elsif($error_code eq 91) { $error_msg = "No Connection Established!"; $error_title = "Connection Error:"; } elsif($error_code eq 92) { $error_msg = "Unrecognized Response!"; $error_title = "Unrecognized Server Response:"; } else { $error_msg = "Unknown Error!"; $error_title = "Unkown Error:"; } $popup_win = $top->Toplevel; $popup_win->title ("$error_title"); $popup_win->Label(-text => "$error_msg")->pack; $popup_win->Button(-text => 'OK', -command => sub {destroy $popup_win})->pack(); } #------------------------------------------------------------------ sub retrieve_config { # Preconditions: the config file must follow the proper format, # Postconditions: global variables are set... ick globals yucky! # print "Retreiving Config File...\n"; if(-e $configfile_name) { # config file exists if (-r $configfile_name) { # config file is readable open (CONF, "$configfile_name") || die "Cannot open config fi +le $!\n"; while (<CONF>) { chomp ($_); if($_ =~ /^HOST/i) { $_ =~ s/HOST=//; $host = $_; } elsif ($_ =~ /^PORT/i) { $_ =~ s/PORT=//; $port = $_; } elsif ($_ =~ /^USER/i) { $_ =~ s/USER=//; $user = $_; } elsif ($_ =~ /^PASS/i) { $_ =~ s/PASS=//; $pass = $_; } elsif ($_ =~ /^AUTO/i) { $_ =~ s/AUTO=//; $auto = $_; } elsif ($_ =~ /^REALNAME/i) { $_ =~ s/REALNAME=//; $realname = $_; } elsif ($_ =~ /^EMAIL/i) { $_ =~ s/EMAIL=//; $email = $_; } elsif ($_ =~ /^QUOTE/i) { $_ =~ s/QUOTE=//; $quote = $_; } } close (CONF) || die "Cannot close config file $!\n"; } } else { # create default config file open(CONF, ">$configfile_name") || die "Cannot create new conf f +ile $!\n"; print "No config file exists, so lets create one!\n"; print CONF "# This is the Perl Chat Client config file.\n"; print CONF "# You may edit this file with a text editor or\n"; print CONF "# from the edit menu within Perl Chat itself.\n\n"; print CONF "HOST=localhost\n"; print CONF "PORT=6666\n"; print CONF "USER=enter_your_own_username\n"; print CONF "PASS=enter_your_own_password\n"; print CONF "AUTO=no\n\n"; print CONF "# User Information to be updated upon login\n\n"; print CONF "REALNAME=Torrance Jones\n"; print CONF "EMAIL=torrancejones\@users.sourceforge.net\n"; print CONF "QUOTE=Nothing entered yet.\n"; close (CONF) || die "Cannot close config file $!\n"; # if this new file is readable... if (-r $configfile_name) { open (CONF, "$configfile_name") || die "Cannot open config fi +le $!\n"; while (<CONF>) { chomp ($_); if($_ =~ /^HOST/i) { $_ =~ s/HOST=//; $host = $_; } elsif ($_ =~ /^PORT/i) { $_ =~ s/PORT=//; $port = $_; } elsif ($_ =~ /^USER/i) { $_ =~ s/USER=//; $user = $_; } elsif ($_ =~ /^PASS/i) { $_ =~ s/PASS=//; $pass = $_; } elsif ($_ =~ /^AUTO/i) { $_ =~ s/AUTO=//; $auto = $_; } elsif ($_ =~ /^REALNAME/i) { $_ =~ s/REALNAME=//; $realname = $_; } elsif ($_ =~ /^EMAIL/i) { $_ =~ s/EMAIL=//; $email = $_; } elsif ($_ =~ /^QUOTE/i) { $_ =~ s/QUOTE=//; $quote = $_; } } close (CONF) || die "Cannot close config file $!\n"; } } } #--------------------------------------------------------------------- +-------- sub update_info { # Preconditions: should have gottent the correct values of $realname # $email and $quote. # Postconditions: sends a message to the server to request info update print $conn "9\:\:$user\:\:$pass\:\:$realname\:\:$email\:\:$quote\n +"; }
In reply to Re^2: Simple error
by Jshelton31
in thread Simple error
by Anonymous Monk
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |