Chapter 7: Graphical Examples with Perl/Tk- P3 Our destinations list is an almost exact copy of the list you'd see on the web page For ease in using, we placed "U.S.A." as the first item in the list, and we will select it as our default choice when we build the listbox: my $entry_f = $mw->Frame; $entry_f->pack(-expand => 'n', -fill => 'x'); $entry_f->Label(-text => "Airbill #: ")->pack(-side => 'left', -anchor => 'w', -expand => 'n', -fill => 'none'); my $airbill = ""; my $airbill_entry = $entry_f->Entry(-textvariable => \$airbill, -width => 10); $airbill_entry->pack(-side => 'left', -anchor => 'w', -expand => 'y', -fill => 'x'); The entry for the airbill requires a label so that the user knows what sort of input is expected The default for the $airbill variable is blank We save a reference to the entry widget, so that we can set the focus of the application to it right before we enter the MainLoop : $entry_f->Label(-text => "Date Shipped: ")->pack(side => 'left', -anchor => 'w', -expand => 'n', -fill => 'none'); my %months; my $i = 1; foreach (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)) { $months{$_} = $i++; } my $fulltime = localtime; my ($month, $day, $year) = $fulltime =~ /\w+\s(\w+)\s(\d+)\s : : \s (\d\d)$/; $month = $months{$month}; $month = "0$month" if (length($month) < 2); $day = "0$day" if (length($day) < 2); my $date = "$month$day$year"; $entry_f->Entry(-textvariable => \$date, -width => 6)->pack(-side => 'left', -anchor => 'w', -expand => 'n', -fill => 'none'); We are going to use a default of today for the date field The FedEx web page expects it in the form of "DayMonthYear", and digits with only one number require a leading zero The string returned from localtime( ) gives us the correct day, and we strip off the last two digits of the year For the month we need to translate it to a number value from 01 - 12 We this using a %months hash, where the keys are the string of the month, and the value the number of the month We add leading zeros to the day and month if necessary my $lb_f = $mw->Frame; $lb_f->pack(-anchor => 'n', -expand => 'n', -fill => 'x'); $lb_f->Label(-text => "Shipped To:")->pack(-side => 'left', -anchor => 'w'); We want a label to tell us what the listbox contains, so we create it first: my $scroll = $lb_f->Scrollbar; my $listbox = $lb_f->Listbox(-selectmode => 'single', -height => 1, -yscrollcommand => ['set', $scroll], -exportselection => 0); $scroll->configure(-command => ['yview', $listbox]); $scroll->pack(-side => 'right', -fill => 'y'); $listbox->pack(-side => 'left', -expand => 'yes', fill => 'both'); $listbox->insert('end', @destinations); $listbox->selection('set',0); Then we create the scrollbar and the listbox, and put our @destinations in the listbox Remember, we put the entry "U.S.A" first in our list, so when we select the 0th element of the listbox, we get that entry selected This is a pretty large list, and it takes quite a while to scroll down to Zimbabwe Although we didn't it for our example here, you could set up your listbox so that if you typed a letter, it would scroll to the first entry starting with that letter Or you could put an additional entry, and search for any word starting with those characters: my $response_f = $mw->Frame; $response_f->pack(-expand => 'y', -fill => 'both'); $response_f->Label(-text => "Response:")->pack(anchor => 'w', -side => 'left'); my $response_txt = ""; $response_f->Label(-justify => 'left', -borderwidth => 2, -relief => 'sunken', -textvariable => \$response_txt)>pack(-anchor => 'w', -side => 'left', -expand => 'y', -fill => 'x'); To show users what happened to their package (or any errors), we build a label that displays any text in the $response_txt variable To change the text, we simply reset $response_txt to another text string: my $bttn_f = $mw->Frame; $bttn_f->pack; $bttn_f->Button(-text => "Exit", -command => sub{exit}) ->pack(-side =>'right', -anchor => 'e'); my $loop_bttn = $bttn_f->Button(-text => "Loop", -command => \&loop_query); $loop_bttn->pack(-side => 'left', -anchor => 'w'); $bttn_f->Button(-text => "Query", -command => \&do_query)-> pack(-side => 'left', -anchor => 'w'); The buttons for our track program allow us to exit the program, start the query loop, or manually a query right now my $pkg_tracker = new FedEx $url, $email; my $loop_id; $airbill_entry->focus; MainLoop; One last thing before we start the MainLoop to handle the GUI interaction (Remember, this is different from our query loop.) We have to create a FedEx object and save a reference to it Now when we a query, we can utilize this package to the hard work for us: sub loop_query { my $bttn_text = $loop_bttn->cget(-text); if ($bttn_text =~ /^Loop/) { &do_query; $loop_bttn->configure(-text => "Stop"); $loop_id = $mw->repeat($query_interval * 60000, \&do_query); } else { $loop_bttn->configure(-text => "Loop"); $mw->after('cancel', $loop_id); } } The loop_query( ) subroutine gets called when the Loop button is pressed We query the web site with the information entered, then set up Tk to loop again in $query_interval minutes To let the user know that a loop has been started, we change the text on the button to say "Stop." Note that we check this text to determine whether we are starting or stopping a loop The $loop_id is a global outside of our sub because we need to remember it in order to cancel a loop For another example of this, look at our next example, webping sub do_query { $mw->configure(-cursor => 'watch'); $mw->idletasks; my $dest = $listbox->get($listbox>curselection); $pkg_tracker->check($airbill, $dest, $date); if ($pkg_tracker->retrieve_okay) { if ($pkg_tracker->delivered) { $response_txt = "Tracking number $airbill was delivered to: " $pkg_tracker->who_got_it; } else { $response_txt = "Package not yet delivered"; } } else { my $parsed = parse_html($pkg_tracker>error_info); my $converter = new HTML::FormatText; $response_txt = $converter->format($parsed); chomp($response_txt); } $response_txt = "\n[As of " localtime() "]"; $mw->configure(-cursor => 'top_left_arrow'); $mw->deiconify; $mw->bell; $mw->update; } The subroutine do_query( ) actually utilizes the FedEx package that we saw earlier in Chapter 6, and takes the information received and displays it to the user via our $response_txt We set the cursor to a watch to show the user we are actually doing something, and change it back to the default arrow when done $mw->deiconify will bring the window up if it was iconified during the wait, and the beep will tell the user that she needs to look at the window We also avoided doing any error checking here If we get some sort of error message back from the FedEx package, we simply display it, and keep going It's up to the user to check the response and make adjustments in the entered values, if there was an error The rest of the code is repeated from Chapter 6: ## Package FedEx Written by Clinton Wong package FedEx; use HTTP::Request; use HTTP::Response; use LWP::RobotUA; use HTTP::Status; sub new { my($class, $cgi_url, $email, $proxy) = @_; my $user_agent_name = 'ORA-Check-FedEx/1.0'; my $self = {}; bless $self, $class; $self->{'url'} = new URI::URL $cgi_url; $self->{'robot'} = new LWP::RobotUA $user_agent_name, $email; $self->{'robot'}->delay(0); requests by hand # we'll delay if ($proxy) { $self->{'robot'}->proxy('http', $proxy); } $self; } sub check { my ($self, $track_num, $country, $date) = @_; $self->{'url'}>query("trk_num=$track_num&dest_cntry=" "$country&ship_date=$date"); my $request = new HTTP::Request 'GET', $self>{'url'}; my $response = $self->{'robot'}>request($request); $self->{'status'} = $response->code(); if ($response->code == RC_OK) { if ($response->content =~ /Delivered To : (\w.*)/) { # package delivered $self->{'who_got_it'} = $1; $self->{'delivered'} = 1; } # Odd cases when package is delivered but "Delivered To" is blank # Check for delivery time instead elsif ($response->content =~ /Delivery Time : \w.*/) { # package delivered $self->{'who_got_it'} = 'left blank by FedEx computer'; $self->{'delivered'} = 1; } else { # package wasn't delivered $self->{'delivered'} = 0; # if there isn't a "Delivered To : " field, something's wrong # error messages seen between HTML comments if ($response->content !~ /Delivered To : /) { $self->{'status'} = RC_BAD_REQUEST; # get explanation from HTML response my $START = ''; my $END = ''; if ($response->content =~ /$START(.*?)$END/s) { $self->{'error_as_HTML'} = $1; } else { # couldn't get explanation, use generic one $self->{'error_as_HTML'} = 'Unexpected HTML response from FedEx'; } # couldn't get error explanation } } # unexpected reply # not delivered yet } # if HTTP response of RC_OK (200) else { $self->{'error_as_HTML'} = $response>error_as_HTML; } } sub retrieve_okay { my $self = shift; return if ($self->{'status'} != RC_OK); 1; } sub delivered { my $self = shift; $self->{'delivered'}; } sub who_got_it { my $self = shift; $self->{'who_got_it'}; } sub error_info { my $self = shift; $self->{'error_as_HTML'}; } The final program ends up looking like Figure 7-3 Figure 7-3 Package tracking client ... are going to use a default of today for the date field The FedEx web page expects it in the form of "DayMonthYear", and digits with only one number require a leading zero The string returned from... letter, it would scroll to the first entry starting with that letter Or you could put an additional entry, and search for any word starting with those characters: my $response_f = $mw->Frame;... $loop_id); } } The loop_query( ) subroutine gets called when the Loop button is pressed We query the web site with the information entered, then set up Tk to loop again in $query_interval minutes To let