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'     => \&register);

   $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
+";   

}
[download]