Web Client Programming with Perl: Chapter 7: Graphical Examples with Perl/Tk

Web Client Programming with Perl

Automating Tasks on the Web

By Clinton Wong
1st Edition March 1997

This book is out of print, but it has been made available online through the O'Reilly Open Books Project.

Chapter 7.
Graphical Examples with Perl/Tk

In this chapter:
A Brief Introduction to Tk
A Dictionary Client: xword
Check on Package Delivery: Track
Check if Servers Are up: webping

The Tk extension to Perl can be used to create a Graphical User Interface (GUI) to your Perl programs on UNIX. Why would you want to do this? Several reasons, such as ease of use, or to be able to display HTML nicely. Instead of just writing a "cool script," you could go as far as writing your own custom browser.

In this chapter, we show a few examples of Tk-based web clients, which go beyond the command-line interface that we've been using so far in this book:[1]

xword, a dictionary client

track, a graphical version of the FedEx example shown in Chapter 6.

webping, an at-a-glance display of the status of multiple web servers

One caveat about Tk, and it's a serious one. At this writing, the Tk module to Perl (also known as pTk) only runs on UNIX machines with the X Window System. While the Tk extension to the Tcl language has been successfully ported to Microsoft Windows, the Perl port is still pending, although it is rumored to be in the works.

Still, even with its limited availability, we think the ability to give your programs an easy-to-use graphical interface is important enough to devote a chapter to it. And who knows--by the time you're reading this, the pTk port to Windows might already be completed, and this whole paragraph may be moot.

A Brief Introduction to Tk

Tk was originally developed by John Ousterhout as an extension to his Tcl language, for providing a graphical user interface for the X Window System. It was ported to Perl soon afterwards; Nick Ing-Simmons did most of the work to make it functional as a module with Perl. You can get Tk from any CPAN archive (http://www.perl.com/CPAN/).

The Tk extension provides an easy way to draw a window, put widgets into it (such as buttons, check boxes, entry fields, menus, etc.), and have them perform certain actions based on user input. A simple "Hello World" program would look like this:
1	#!/usr/bin/perl -w
2	use Tk;
3	my $mw = MainWindow->new;
4	$mw->Button(-text => "Hello World!", -command =>sub{exit})->pack;
5	MainLoop;
(The line numbers are not part of the actual code; they are just included for ease in reference.)

When you run it, it would look like Figure 7-1.

Figure 7-1. A simple Tk widget

Pushing the "Hello World" button will exit the program, and your window will then go away. Line 1 tells the shell to invoke Perl to interpret the rest of the file, and Line 2 then tells Perl that we need to use the Tk module. Line 3 tells the system that you want it to build you a generic, standard window. Line 4 creates a button, displays it (using the pack method), and gives the button something to do when pushed.

Line 5 tells the program to "go do it." MainLoop kicks off the event handler for the graphical interface. The most important concept to understand with Perl/Tk is that the program won't do a single thing until it hits the MainLoop statement. You won't see any graphical output at all until then. We prepare it by telling it what we want to draw, and what should happen when certain events happen, such as a mouse click on our button in our "Hello World" program. The more complex the things you want the GUI to do, the more complex the code looks for setting it up.

Since the purpose of this chapter is to show some examples using Tk and to interact with the WWW, we won't be going into much more detail about what Tk does and why. Some places you might look for help are the newsgroup comp.lang.perl.tk for Perk/Tk-specific questions, or the Perl/Tk FAQ at http://w4.lns.cornell.edu/~pvhp/ptk/ptkFAQ.html. Any search site will point you to at least 30 web sites as well. And of course the Tk source includes "pod" documentation: run pod2text on Tk.pm to get started.

Before we continue, there a few odd things you need to know about Perl/Tk:

=> is functionally the same as a comma (,). Using => makes it easier to detect "pairs" of items in a list.

Widgets are always built referencing another part of the GUI, if not the main window (in our examples, $mw), then another widget or frame. This builds the parent/child hierarchy and allows the packer to know what to pack where.

The pack( ) method essentially displays the widget on the screen, according to any parameters sent to it. Alternately, it could un-display it as well. If you don't pack( ) a widget, it won't show up.

Now on to some examples.

A Dictionary Client: xword

For our first example, we want to build a simple application that has only a few types of widgets in it. The xword program will prompt the user for a word, then use an online dictionary to define it, and return the formatted results.

When you need a quick word definition, instead of running a web browser (which can often have a lengthy startup time with all those fancy plug-ins), surfing to the site via a bookmark, and then entering the word to get your answer, you can use this simple program that will just prompt for the word and go look it up without all that extra hassle. Anyone familiar with the xwebster client for the X Window System will find xword to be vaguely familiar, but our version doesn't require a local licensed dictionary server; we use one already existing on the Web. Since the program is so simple, you can probably just iconify it, and then bring it back up whenever you're stumped for the spelling or meaning of another word.

So in designing our window, we want a place to enter the word, and a place to display the results. We also need to be able to exit the program (always a must). It seems pretty simple, until we remember that the definition information sent back to us is going to come back in HTML. I really don't want to have to visually dig through a bunch of HTML codes to find out the answer I'm looking for, so I want my program to handle that as well when it displays the answer. We have two options: ignore the HTML codes completely or find a simple way to parse them and make the output look a little nicer.

Luckily, the HTML module distributed with LWP will do most of the work for us. As described in Chapter 5, The LWP Library, the HTML package contains a function called parse_html(), which takes a string containing HTML as its argument, and returns a pointer to a data structure with all the HTML tags and text parsed out and remembered in order. Now we can use another function called traverse(), which operates on this data structure and lets us specify what function to call for each piece of information it contains.

Keeping all this in mind, let's look at our program:
#!/usr/bin/perl
 
use Tk;
require LWP::UserAgent;
use HTML::Parse;
We first use the #! notation to tell the kernel we'll be using Perl. We need the Tk package for the GUI interface, the LWP::UserAgent to connect to the web site, and HTML::Parse to help us parse the results:
%html_action =
  (
   "</TITLE>", \&end_title,
   "<H1>",     \&start_heading,
   "</h2>",    \&end_heading,
   "<H2>",     \&start_heading,
   "</H2>",    \&end_heading,
   "<H3>",     \&start_heading,
   "</H3>",    \&end_heading,
   "<H4>",     \&start_heading,
   "</H4>",    \&end_heading,
   "<H5>",     \&start_heading,
   "</H5>",    \&end_heading,
   "<H6>",     \&start_heading,
   "</H6>",    \&end_heading,
   "<P>",      \&paragraph,
   "<BR>",     \&line_break,
   "<HR>",     \&draw_line,
   "<A>",      \&flush_text,
   "</A>",     \&end_link,
   "</BODY>",  \&line_break,
  );
In order for us not to rethink the HTML each time, we build an associative array whose key is the HTML tag we want to take action on, and the value is a function reference. We'll cover what the functions take as arguments later on. Now, while we are traversing the document, we can ignore any tags that aren't in our array, and perform actions on ones that are:
$ua = new LWP::UserAgent;
$dictionary_url = "http://work.ucsd.edu:5141/cgi-bin/http_webster";
We need to set up a few basic globals, the UserAgent object being one of them. We'll use the dictionary server at UC San Diego as the default. While other dictionary servers would probably work, slight modifications to the code might be necessary. Now we can get on with building the actual interface:
$mw = MainWindow->new;
$mw->title("xword");
$mw->CmdLine;
So we create our window. $mw->CmdLine allows parsing of any -geometry or
-iconic command line arguments automatically:
$frame1 = $mw->Frame(-borderwidth => 2,
		     -relief => 'ridge');
$frame1->pack(-side => 'top',
	      -expand => 'n',
	      -fill => "x");
$frame2 = $mw->Frame;
$frame2->pack(-side => 'top', -expand => 'yes', -fill => 'both');
$frame3 = $mw->Frame;
$frame3->pack(-side => 'top', -expand => 'no', -fill => 'x');
We create three frames,[2] which essentially divide our window in thirds. The top frame, $frame1, will contain the place to type a word and the Lookup button. The middle frame, $frame2, will contain the text widget and its associated scrollbar. $frame3 will contain a text informational display and the exit button. $frame2 is the only one that will expand itself into any available space, making it the largest section of the window. Now, let's actually create the stuff to go in our empty frames:
$frame1->Label(-text => "Enter Word: ")->pack(-side => "left",
					      -anchor => "w");
$entry = $frame1->Entry(-textvariable => \$word,
			-width => 40);
$entry->pack(-side => "left",
	     -anchor => "w",
	     -fill => "x",
	     -expand => "y");
 
$bttn = $frame1->Button(-text => "Lookup",
			-command => sub { &do_search(); });
$bttn->pack(-side => "left",
	    -anchor => "w");
 
$entry->bind('<Return>', sub { &do_search(); } );
We create a Label so we know what to type in the entry area. We then create the Entry widget where the typing of the word will take place. We want lots of room to type, so we set it up with a default width of 40. Also note that we are storing anything that's been entered with the Entry widget in a global variable called $word.

The last item is our Lookup button. We configure it to call the function do_search when the button is clicked. One last refinement: we want to be able to just hit return after typing in our word, so we bind the key sequence Return to also call the do_search( ) function.[3]
$scroll = $frame2->Scrollbar;
$text = $frame2->Text(-yscrollcommand => ['set', $scroll],
		      -wrap => 'word',
		      -font => 'lucidasans-12',
		      -state => 'disabled');
$scroll->configure(-command => ['yview', $text]);
$scroll->pack(-side => 'right', -expand => 'no', -fill => 'y');
$text->pack(-side => 'left', -anchor => 'w',
	    -expand => 'yes', -fill => 'both');
Next we set up the middle area of our window to hold a text widget and a scrollbar. I'm making lucidasans-12[4] the default font for the text, but you can change this to any font you prefer. We also want our text to wrap around automatically at word boundaries (as opposed to character boundaries). Also note that we "disable" the text widget. This is done because the standard behavior of the text widget is to allow the user to type things into it. We want to use it for display purposes only, so we disable it. Most of the other stuff is setting the scrollbar to scroll up and down and assigning it to the text widget.
$frame3->Label(-textvariable => \$INFORMATION,
	       -justify => 'left')->pack(-side => 'left',
					 -expand => 'no',
					 -fill => 'x');
$frame3->Button(-text => "Exit",
	    -command => sub{exit} )->pack(-side => 'right',
				       -anchor => 'e');
The third portion of our window is just going to contain an information label, and the exit button. We don't have anything to save when we quit, so we just map it directly to sub{exit}.
$text->tag('configure', '</h2>', -font => 'lucidasans-bold-24');
$text->tag('configure', '</H2>', -font => 'lucidasans-bold-18');
$text->tag('configure', '</H3>', -font => 'lucidasans-bold-14');
$text->tag('configure', '</H4>', -font => 'lucidasans-bold-12');
$text->tag('configure', '</H5>', -font => 'lucidasans-bold-12');
$text->tag('configure', '</H6>', -font => 'lucidasans-bold-12');
Our window is basically set up--but our text widget isn't completely set up yet. We need to create some "tags" (identifiers that distinguish different portions of the text widget) to change the font when we find certain HTML tags. In this case, they are all HTML end tags for headers. We don't want to make this too complicated, so we won't handle many more complicated HTML tags. Note that our tag names are the same as the HTML tag names--this makes it easy to switch back and forth later on.
$entry->focus;
MainLoop;
Finally, we set our focus on the entry widget so we can start typing a word when the application comes up. Then we call MainLoop to start the event handler. The rest of the code gets called as certain events happen. (Remember how we told the Lookup button to call do_search( ) when pressed?) So let's look at the specifics of what happens in our window. Let's say we typed in the word "example" and hit Return. The global $word will contain the string "example", and the do_search( ) function will be called:
sub do_search {
    my ($url) = @_;
    
    return if ($word =~ /^\s*$/);
    
    $url = "$dictionary_url?$word" if (! defined $url);
The do_search( ) function will take an optional $url argument, to give it an alternative place to connect to. Otherwise it expects $word to contain something. We just hit Return from the entry widget, so $word contains the string "example", and $url is undefined. If we accidentally hit Return before typing anything, we don't want to search for a nonstring, so we return from the subroutine if that's the case:
    $INFORMATION = "Connect: $url";
 
    $text->configure(-cursor=> 'watch');
    $mw->idletasks;
We give the user some feedback by placing along the bottom of the application a "Connect..." string, and we also change the cursor to a watch. $mw->idletasks just tells the window to do anything it was waiting to do, so that we can actually see the watch and information string:
    my $request = new HTTP::Request('GET', $url);
    
    my $response = $ua->request($request);
    if ($response->is_error) {
    $INFORMATION = "ERROR: Could not retrieve $url";
    } elsif ($response->is_success) {
    my $html = parse_html($response->content);
 
    ## Clear out text item
    $text->configure(-state => "normal");
 
    $text->delete('1.0', 'end');
    $html->traverse(\&display_html);
    $text->configure(-state => "disabled");
    $html_text = "";
    $INFORMATION = "Done";
    }
    
    $text->configure(-cursor => 'top_left_arrow'); 
}
Next we try to connect to the $url. If we fail, the program should display a simple error message in the information area. If we succeed, then we want to get the actual document out and parse it. $html will contain the HTML tree object. We reconfigure the text object to "normal" so that we can place text in it,[5] delete anything that might have been there previously, and then call traverse for the HTML object (telling traverse to call display_html for each item). After the entire document has been traversed (we'll see what that does in a minute), we re-disable the text widget, and declare ourselves done for that particular word lookup.

Our function, display_html, gets called with three arguments: a $node pointer, a $startflag flag, and the $depth we are into the tree. We only care about the first two arguments, since they will help us decide what action to perform.
sub display_html {
    my ($node, $startflag, $depth) = @_;
    my ($tag, $type, $coderef);  ## This tag is the HTML tag...
    
    if (!ref $node) {
		$html_text .= $node;
   } else {
   if ($startflag) {
   $tag = $node->starttag;
} else {
	    	$tag = $node->endtag;
}
 
## Gets rid of any 'extra' stuff in the tag, and saves it
if ($tag =~ /^(<\w+)\s(.*)>/) {
	    	$tag = "$1>";
	    	$extra = $2;
}
	
if (exists $html_action{$tag}) {
$html_text =~ s/\s+/ /g;
	    	&{ $html_action{$tag} }($tag, $html_text);
	   	$html_text = "";
}
    }
    1;
}
That's the entire function, but it does quite a bit. The $node could either be an object or a simple text string. For the simple case, when it's just text, we append it to any prior text (remember, we could be ignoring HTML tags, along the way, that had text before them) and save it for future use. If $node is an object pointer, then we have to determine what kind it is, and decide if we care about the HTML tag it's telling us about.

HTML tags usually come in pairs, so $startflag tells us when we found the first of a pair. We want to know what that tag was, so we call the starttag method. Certain tags have other information associated with them (i.e., the <A> tag), and we want to save that for future use in $extra. Remember that we are trying to get just the plain simple tag to use in our lookup array.

We do a few more things to clean up, and then we can do our lookup. If we care about this $tag, then we compress all spaces in the current text string (makes the display a little bit nicer) and call the function specified in our lookup array, passing it $tag and $html_text. We left $extra as a global because most of our functions won't use it.

All that work was just to figure out what function to call. We could have done a big huge if..then..else statement instead of utilizing a lookup hash, but that would have been large and unwieldy, and would also have made it more difficult to add new tag handling functions. The following are those tag handling functions, and most of them are pretty short:
sub end_title {
    $mw->title("xword: ". $_[1]);
}
When we find the end title tag, we change our window title to reflect it (a lot like a standard web browser).
sub start_heading {
    &flush_text(@_);
    $text->insert('end', "\n\n");
}
When we start a heading, we need to delimit it from the prior text (which we insert into our text widget with the flush_text( ) function) with a few returns. Note that flush_text( ) takes the same arguments as any of our tag handlers. This allows us to specify it explicitly in the lookup hash if we want to:
sub end_heading {
    $text->insert('end', $_[1], $_[0]);
    $text->insert('end', "\n");
}
At the end of the heading, we insert the heading text and another return character. The third argument to the insert function is our actual HTML tag. (In this case it could be </h2> or </H2> and so on.) This tells the text widget to use that tag to format the text. For our headings, we set up that text tag to be a font-changing tag:
sub paragraph {
    &flush_text(@_);
    $text->insert('end', "\n\n");
}
A paragraph marker, <P>, just means insert a few returns. We also have to flush out any text prior to it:
sub line_break {
    &flush_text(@_);
    $text->insert('end', "\n");
}
Similar to <P>, the <BR> also just inserts a return:
sub draw_line {
    &flush_text(@_);
    $text->insert('end', "\n--------------------------------------\n");
}
The <HR> tag inserts a much nicer looking line in our normal web browser, but for our purposes, this set of dashes will accomplish pretty much the same thing:
sub flush_text {
    $text->insert('end', $_[1]);
}
This function just inserts the text it's handed, as is:
sub end_link {
	## Don't want to add links to mailto refs.
	if ($extra =~ /HREF\s*=\s*"(.+)"/ && $extra !~ /mailto/) {
	my $site = $1;
 
	## The tags must have unique names to allow for a different
	## binding to each one. (Otherwise we'd just be changing that same 
	## tag binding over and over again.)
	
	my $newtag = "LINK". $cnt++;
	
	$text->tag('configure', $newtag, -underline => 'true',
		   -foreground => 'blue');
	$text->tag('bind', $newtag, '<Enter>', 
		   sub { $text->configure(-cursor => 'hand2');
			 $INFORMATION = $site; });
	$text->tag('bind', $newtag, '<Leave>', 
		   sub { $text->configure(-cursor => 'top_left_arrow');
			 $INFORMATION = "";});
	
	$text->tag('bind', $newtag, '<ButtonPress>', 
		   sub { &do_search($site); });
	
	$text->insert('end', $_[1], $newtag);
    } else {
	&flush_text(@_);
    }
 
}
Our end_link( ) function is the most complicated, simply because we want to handle links. If you look at the output from our dictionary server on your normal web browser, you'll notice that almost every single piece of text it returns is a link to look up another word. I thought it would be easier to just click on those words and do the lookup than to type in the word again and possibly spell it wrong. We accomplish this by utilizing the text widget tags. If you want the specific word to do something different when you click on it, you have to create a new tag--so we are creating tags on-the-fly (unlike our heading tags, which remained the same no matter where they were in the document, or what text they surrounded).

We use a regexp to extract the URL from our $extra variable. We create a new name for our tag. (We never have to know what the name is again, so it's merely a place holder for the text widget.) We create our tag to change the text to be underlined and blue, much as a link would look in a full-blown web browser. We also bind that tag to change the cursor into a little hand when we enter the tag, and to change it back to the standard pointer when we leave that section of text. This gives the users some good feedback on the fact that they can do something with it. We also do one other simple thing: we display the URL in our information area so that users will know what will happen when they click.

The last bind we perform is one that tells the application to call our function, do_search( ), with the URL we extracted from the HTML tag. Then we insert the text for the link into the text widget, and associate it with the tag we just built.

Figure 7-2. xword window

There are a few other things that could be added to xword to make it even nicer. A Back button would be useful, so that after you looked up 10 or so words, you could click on Back to take you backwards through your selections. And how about a list of optional dictionary web servers, in case one is sometimes slow or doesn't respond? These will be left as exercises for the reader.

Some limitations of the HTML parsing: We don't worry about nested HTML tags at all, and we don't worry about fancy things like tables or graphics. Remember, we wanted to keep this simple.

Check on Package Delivery: Track

Web browsers are great at what they do, but what if we want to query the same page for the same information several times in a row? We could just leave our browser up, and keep hitting "reload" n times, but we'd have to remember to do it. A better way would be to write a small application that automatically does our query for us every few minutes.

For this example, we'll interact with the Federal Express tracking page. When you ship a package via FedEx, they keep track of it with a shipping number (also called an airbill number)--and they have been kind enough to make available via the Web a place for us to check up on our packages. If we look at their web page, they have a place to enter the airbill number, a place to select the destination country, and then a place to enter the date. In order to mimic their form, we'll want to have all of these elements in our application.

FedEx has a specific way they want you to specify the country (in all caps, and spelled a particular way), so we just looked at their document source for the list of countries. We will put them all in a listbox, to make it easier to select (instead of trying to guess at the spelling and/or punctuation). The tracking number is fairly easy--it's just a bunch of numbers--so a normal entry widget will do. For the date, another entry widget. Their setup is designed to tell us if we enter an invalid date, so we'll let them handle the error checking on that one.

Now that we know the inputs, we have to decide what to do with them. Basically we want our program to keep looping and re-querying the site. We really don't want our program to loop unless we tell it to, and we also want to be able to stop it from looping at any point. Here's how we accomplish this with Perl/Tk:
#!/usr/bin/perl -w
use strict;
 
use HTML::FormatText;
use HTML::Parse;
use Tk;
 
my $query_interval = 30; # in minutes
 
my $email = "<your email\@address here>";
my $url = "http://www.fedex.com/cgi-bin/track_it";
This is the basic beginning of a Perl/Tk script. We recognize that we want to utilize some of the HTML modules, and of course, the Tk module. We set up some basic globals in our program. The $query_interval is in minutes--you can change it to 60 minutes, or 15 minutes. Try not to query too often, though; the status of your package is not likely to change every five minutes. $email is your email address. You need to put a "\" in front of the @ sign, so that it won't be interpreted by Perl to be something it's not. This will inform the FedEx web site of who you are. Finally, the $url is the destination where we'll be sending our request.

For this program, we are setting the amount of time it waits between loops in a variable. In our next example, we'll show a way to allow the user to change it from the GUI.
my $mw = MainWindow->new;
$mw->title("Package Tracker");
$mw->CmdLine;
We created a window, gave it a title, and allowed the Tk portion to process any command-line options.
my @destinations = 
  ("U.S.A.", "ALBANIA", "ALGERIA", "AMERICAN SAMOA ", "ANDORRA", 
    "ANGOLA", "ANGUILLA", "ANTIGUA", "ARGENTINA",  "ARMENIA", "ARUBA", 
    "AUSTRALIA", "AUSTRIA", "AZERBAIJAN", "BAHAMAS", "BAHRAIN", 
    "BANGLADESH", "BARBADOS", "BELARUS", "BELGIUM", "BELIZE", "BENIN", 
    "BERMUDA", "BHUTAN", "BOLIVIA", "BOTSWANA", "BRAZIL", 
    "BRITISH VIRGIN IS.", "BRUNEI", "BULGARIA", "BURKINO FASO", 
    "BURUNDI", "CAMBODIA", "CAMEROON", "CANADA", "CAPE VERDE", 
    "CAYMAN ISLANDS", "CENTRAL AFRICAN REP.", "CHAD", "CHILE", 
    "CHINA", "COLOMBIA", "CONGO", "COOK ISLANDS", "COSTA RICA", 
    "COTE D'IVOIRE", "CROATIA", "CYPRUS", "CZECH REPUBLIC", "DENMARK", 
    "DJIBOUTI", "DOMINICA", "DOMINICAN REPUBLIC", "ECUADOR", "EGYPT", 
    "EL SALVADOR", "EQUATORIAL GUINEA", "ERITREA", "ESTONIA", 
    "ETHIOPIA", "FAEROE ISLANDS", "FIJI", "FINLAND", "FRANCE", 
    "FRENCH GUIANA", "FRENCH POLYNESIA", "GABON", "GAMBIA", 
    "GEORGIA, REPUBLIC OF", "GERMANY", "GHANA", "GIBRALTAR", "GREECE", 
    "GREENLAND", "GRENADA", "GUADELOUPE", "GUAM", "GUATEMALA", 
    "GUINEA", "GUINEA-BISSAU", "GUYANA", "HAITI", "HONDURAS", 
    "HONG KONG", "HUNGARY", "ICELAND", "INDIA", "INDONESIA", 
    "IRELAND", "ISRAEL", "ITALY", "JAMAICA", "JAPAN", "JORDAN", 
    "KAZAKHSTAN", "KENYA", "KUWAIT", "KYRGYZSTAN", "LATVIA", 
    "LEBANON", "LESOTHO", "LIBERIA", "LIECHTENSTEIN", "LITHUANIA", 
    "LUXEMBOURG", "MACAU", "MACEDONIA", "MADAGASCAR", "MALAWI", 
    "MALAYSIA", "MALDIVES", "MALI", "MALTA", "MARSHALL ISLANDS", 
    "MARTINIQUE", "MAURITANIA", "MAURITIUS", "MEXICO", "MICRONESIA", 
    "MOLDOVA", "MONACO", "MONGOLIA", "MONTSERRAT", "MOROCCO", 
    "MOZAMBIQUE", "NAMIBIA", "NEPAL", "NETHERLANDS", "NEW CALEDONIA", 
    "NEW ZEALAND", "NICARAGUA", "NIGER", "NIGERIA", 
    "NETHERLANDS ANTILLES", "NORWAY", "OMAN", "PAKISTAN", "PALAU", 
    "PANAMA", "PAPUA NEW GUINEA", "PARAGUAY", "PERU", "PHILIPPINES", 
    "POLAND", "PORTUGAL", "QATAR", "REUNION ISLAND", "ROMANIA", 
    "RUSSIA", "RWANDA", "SAIPAN", "SAN MARINO", "SAUDI ARABIA", 
    "SENEGAL", "SEYCHELLES", "SIERRA LEONE", "SINGAPORE", 
    "SLOVAK REPUBLIC", "SLOVENIA", "SOUTH AFRICA", "SOUTH KOREA", 
    "SPAIN", "SRI LANKA", "ST. KITTS & NEVIS", "ST. LUCIA", 
    "ST. VINCENT", "SUDAN", "SURINAME", "SWEDEN", "SWAZILAND", 
    "SWITZERLAND", "SYRIA", "TAIWAN", "TANZANIA", "THAILAND", "TOGO", 
    "TRINIDAD & TOBAGO", "TUNISIA", "TURKEY", 
    "TURKMENISTAN, REPUBLIC OF", "TURKS & CAICOS IS.", "U.A.E.", 
    "UGANDA", "UKRAINE", "UNITED KINGDOM", "URUGUAY", 
    "U.S. VIRGIN ISLANDS","UZBEKISTAN", "VANUATU", "VATICAN CITY", 
    "VENEZUELA", "VIETNAM", "WALLIS & FUTUNA ISLANDS", "YEMEN", 
    "ZAIRE", "ZAMBIA", "ZIMBABWE");
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 do 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 do 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 do 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 do a query, we can utilize this package to do 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);    # we'll delay requests by hand
 
  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 0 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

Check if Servers Are up: webping

For the last example, we'll build a GUI interface that will allow us to check and see if several web sites are running, at pre-specified intervals. Since this action is very similar to the UNIX ping command, we call it webping. This application would be useful to a web administrator who had to keep track of many different web sites, and wanted to know when one was down or not responding. We'll be utilizing the LWP::Simple module to actually ping each site.

The code to check a site's status is as follows, where $site is a string containing a standard URL (like http://www.ora.com):
$content = head($site);
if ($content) { 
  ## Site is UP.
} else {
  ## Site is DOWN.
}
While that's pretty simple, we have to have some way to set $site to a URL. It's not very efficient to have to type a new site on the command line each time we want to verify the status of a site. In order to make our GUI useful, we want to add some basic features to it.

A place to manually enter URLs would be nice, and a display of the sites we have checked and their status would be useful. Having the program automatically perform an update on each of the sites in the list every 30 minutes or so would be extremely useful. In that same vein, specifying the interval would also be easier than editing the source code any time we decide to change how often the ping happens. After we build a list of sites, it would be nice for the program to remember them, and bring them up automatically the next time we start the program.

Here's the final code, with most of the mentioned features represented:
#!/usr/bin/perl -w
#######################################################################
## Webping: A program that will detect and report whether a web site is up.
## usage: webping [ -a ] [ -i <minutes>] [ -f <filename> ] [-- [ -geometry...]]
##   -a : starts prog in "autoping" mode from beginning.
##   -i : Sets the autoping interval to <int>
##   -f : Uses <filename> instead of .webping_sites as site list
##   -- is necessary to separate webping's options from the Window
##   Manager options.  Allows us to utilize GetOptions instead of
##   parsing them manually (ick).
##   The standard wm specs are allowed after the --, -geometry and
##   -iconic being the most useful of them.
#######################################################################
 
use Tk;
use LWP::Simple;
use Getopt::Long;
The first section of the code says to use Tk, LWP::Simple, and Getopt::Long. We chose to utilize Getopt::Long so that we wouldn't have to parse any command-line options ourselves. As you can see from our usage statement, we've got quite a few to deal with. Automode is the term we use when the program loops and checks each web site every n minutes.
## DEFAULT values -- may be changed by specifing cmd line options.
my $site_file = "$ENV{HOME}/.webping_sites";
$ping_interval = 5;
$auto_mode = 0;
@intervals = (5, 10, 15, 20, 25, 30, 35);
 
sub numerically { $a <=> $b; }
sub antinumerically { $b <=> $a; }
		  
## Parse our specific command line options first
&GetOptions("i=i" => \$ping_interval,
  "f=s" => \$site_file,
	         "a" => \$auto_mode);
 
if (! grep /$ping_interval/, @intervals) {
    push (@intervals, $ping_interval);
}
These segments set up stuff the program should know about. There are default values for everything they might set on the command line. We've declared two sorting routines to be used later on. We get the options specified by the user (if any) to put the program in automode, add or set the interval, and determine which file to read our list of web sites from, if not the default file.

Next comes the meat of the GUI: setting up the window, widgets, and callbacks. webping does more complicated things than xword, so it will take quite a bit more effort to set it all up. No matter what it does, though, it all looks pretty much the same: creating buttons, assigning functions for them to call, and placing the widgets in a sensible order via pack. We won't go into too much detail about how this all happens, but here is the code:
my $mw = MainWindow->new;
$mw->title("Web Ping");
$mw->CmdLine;  ## parse -geometry and etc cmd line options.
 
$frame1 = $mw->Frame;
$frame1->pack(side => "bottom", -anchor => "n",
	      -expand => "n", -fill => "x");
 
## Create frame for buttons along the bottom of the window
my $button_f = $frame1->Frame(-borderwidth => 2,
			      -relief => "ridge");
$button_f->pack(-side => "top", -anchor => "n",
		-expand => "n",	-fill => "x");
 
$update_bttn = $button_f->Button(-text => "Update",
				 -state => 'disabled',
				 -command => sub { &end_automode;
						   &ping_site });
Notice that when we hit the Update button, we end the current automode (if we can). This is so that the program doesn't try to do two things at once.
$update_bttn->pack(-side => "left", -anchor => "w", -padx => 5);
 
$del_bttn = $button_f->Button(-text => "Delete",
			      -state => 'disabled',
			      -command => sub { &delete_site });
$del_bttn->pack(-side => "left",
		-anchor => 'w',
		-padx => 10);
 
$automode_bttn = $button_f->Button(-text => "Start Automode",
				   -command => \&do_automode);
$automode_bttn->pack(-side => 'left');
 
$button_f->Label(-text => "Interval: ")->pack(-side => "left");
 
## Create a psuedo pop-up menu using Menubutton
$interval_mb = $button_f->Menubutton(-indicatoron => 1,
			    -borderwidth => 2,
			    -relief => "raised");
$interval_mb->pack(-side => "left");
 
$interval_mb->configure(-menu => $interval_mb->Menu(-tearoff => 0),
	       -textvariable => \$ping_interval);
map { $interval_mb->radiobutton(-label => $_,
		       -variable => \$ping_interval,
		       -value => $_,
		       -indicatoron => 0) } sort numerically @intervals;
Using a menu button like this is often a good way to get a list of items into a very small space:
$button_f->Button(-text => "Exit",
		  -command => \&exit_program)->pack(-side => "right",
						    -anchor => "e");
 
my $entry_f = $mw->Frame;
$entry_f->pack(-side => 'top', -anchor => 'n', -fill => 'x');
 
$entry_f->Label(-text => "URL: ")->pack(-side => 'left',
					-anchor => 'w');
my $entry = $entry_f->Entry(-textvariable => \$url);
$entry->pack(-side => 'left', -anchor => 'w', -expand => 'y', 
     -fill => 'x');
 
 
$entry_f->Button(-text => "Ping",
	       -command => \&add_site)->pack(-side => 'left',
					     -anchor => 'e');
$entry->bind('<Return>', \&add_site);
 
my $list_f = $mw->Frame;
$list_f->pack(-side => 'top',
	      -anchor => 'n',
	      -expand => 'yes',
	      -fill => 'both');
$history_label = $list_f->Button(-text => "History:",
				 -borderwidth => 2,
				 -relief => "flat");
$history_label->pack(-side => 'top', -anchor => 'n', -fill => 'x');
 
my $scroll = $list_f->Scrollbar;
my $list = $list_f->Listbox(-selectmode => 'extended',
			    -yscrollcommand => ['set', $scroll]);
$scroll->configure(-command => ['yview', $list]);
$scroll->pack(-side => 'right', -fill => 'y');
$list->pack(-side => 'left', -expand => 'yes', -fill => 'both');
 
## Bind Listbox so that the "Update" button is enabled whenever a user
## has an item selected.
$list->bind('<Button-1>', sub { 
    my @selected = $list->curselection;
    if ($#selected >= 0) {
	$update_bttn->configure(-state => 'normal');
	$del_bttn->configure(-state => 'normal');
    } else {
	$update_bttn->configure(-state => 'disabled');
	$del_bttn->configure(-state => 'disabled');
    }
} );
 
if (open(FH, "$site_file")) {
    while (<FH>) {
	chomp;
	$url = $_;
	&add_site;
    }
    close FH;
}
$url = "";
Here is where we take advantage of a "remembering" file. When the program exits, we will save the current list of sites to this file. This way, when the program is started the next time, it looks exactly as it did the last time we ran it--except that the program will have updated the list of sites with the current status.
$entry->focus;
 
&do_automode if ($auto_mode);
 
MainLoop;
Off it goes! Now all that's left in our source code are the functions that we've bound to the buttons and various actions in the GUI. Remember, this is where the real work comes in; without these functions the GUI would just be a bunch of flashy buttons and lists.
sub exit_program {
    my @updated = $list->get(0, 'end');
    if (open FH, ">$site_file") {
    map { print FH "$_\n"; } @updated;
    close FH;
    }
    exit;
}
This is how we always save the current state of the site list. The only way to avoid running this function when exiting the application is to use the Window Manager's close/exit/destroy commands:
sub ping_site {
  ## get list of indexes in listbox of those selected.
  my $site = "";
  my ($content, @down);
  my @selected = $list->curselection;
  
  $mw->configure(-cursor => 'watch'); 
  $mw->idletasks;
 
  foreach $index (@selected) {
      my $site = $list->get($index);
      $site =~ s/\s.+$//;     ## Strip off last history record (if any)
      
      $content = head($site);
      if ($content) {
	  $site .= " is UP (" . localtime() .")";
      } else {
	  $site .= " is DOWN (" . localtime() .")";
	  push (@down, $site);
      }
      $list->delete($index);
      $list->insert($index, $site);
  }
  
  ## Since we've deleted and inserted into the box -- the sites prev
  ## selected now aren't. Luckily we know which ones those were.
  map { $list->selection('set', $_) } @selected;
  
  ## Set cursor back to the default value
  $mw->configure(-cursor => 'top_left_arrow'); 
  
  if ($#down >= 0) {
      $mw->deiconify;
      $mw->update;
      
      $old_color = $history_label->cget(-background);
      
      ## Do some stuff to make the user pay attention to us.
      $history_label->configure(-background => "red");
      $history_label->bell;
      $history_label->flash;       $history_label->flash;
      $history_label->configure(-background => $old_color);
  }
 
}
The function ping_site( ) is called when a new site is added to update its status. It is also called when in automode. It checks the sites selected in the listbox. ping_site( ) is where you could put in other things to happen when a site is down. For instance, mail the web administrator, page the administrator with a text message, or whatever you'd like!
sub add_site {
    return if ($url eq "");                ## Do nothing, empty string
    
    ## Validate $url contains correct information (ie a server name)
    $url = "http://$url" if ($url !~ /(\w+):\/\//);
    
    ## Insert new site name into list, and make sure we can see it.
    $list->insert('end', $url);
    $list->see('end');
    
    ## Select the item so that ping_site can do all the work
    $list->selection('clear', 0, 'end');
    $list->selection('set', $list->size - 1);  
    
    $url = "";   ## Clear out string for next site
 
    &ping_site;
}
We've set the default behavior of adding a site to automatically ping that site. You could comment out that line if you didn't want to wait for the ping to happen and you're adding a large number of sites. Remember, this would also affect what happened when the programs started up, since this function is called both at the beginning and during the manual adding of sites.
sub delete_site {
    my @selected = $list->curselection;
 
    ## Have to delete items out of list backwards so that indexes
    ## we just retrieved remain valid until we're done.
    map { $list->delete($_) } sort antinumerically @selected;
 
    $update_bttn->configure(-state => 'disabled');
    $del_bttn->configure(-state => 'disabled');
}
The function delete_site( ) will delete any selected items in the listbox. This allows us to remove ou-of-date sites from our list without having to edit the .webping_sites file manually.
sub do_automode {
    ## State if the $automode_bttn will tell us which way we are in.
    my $state = $automode_bttn->cget(-text);
 
    if ($state =~ /^Start/) {
	$automode_bttn->configure(-text => "End Automode");
 
	$mw->iconify if ($auto_mode);
	
	$interval_mb->configure(-state => 'disabled');
	
	## If the user started up from scratch -- then select all (doesn't
	## make sense to ping _nothing_.
	@selected = $list->curselection;
	$list->selection('set', 0, 'end') if ($#selected < 0);
	$id = $mw->repeat($ping_interval * 60000, \&ping_site);
    } else {
	&end_automode;
    }
}
## end of do_automode #################################################
When starting off in automode, do_automode( ) gets called. It verifies that the list has at least one site selected, and starts the timed loop. The Tk construct to do the "looping" is in the $mw->repeat( ) command. The function ping_site( ) will be called every $ping_interval minutes until end_autmode( ) is called.
sub end_automode {	
my $state = $automode_bttn->cget(-text);
   $interval_mb->configure(-state => 'normal');
   if ($state =~ /^End/) {
$automode_bttn->configure(-text => "Start Automode");
	   $mw->after('cancel', $id);
   }
}
And finally, webping looks like Figure 7-4.

Figure 7-4. webping client

1. I say "we," but I really mean "she"--this chapter was written by Nancy Walsh, who combined her knowledge of Tk with my knowledge of LWP.

2. Frames are just invisible containers for other widgets. They group things together so the window will look the way you want it to. You can make them visible by specifying -borderwidth and -relief options.

3. You'll note that it looks like a lot of extra effort to declare sub { do_search() }. Doing it this way prevents any parameters from being sent to our function when it is called.

4. To check to make sure you have this font family on your system, use xlsfonts. If you don't have it, just pick another font you do have.

5. One of the annoying things about a text widget is that when you disable it for the user, you also disable it for yourself. If you want to do anything to it other than destroy it, you need to configure it back to normal.

Back to: Chapter Index

Back to: Web Client Programming with Perl

Web Client Programming with Perl

Automating Tasks on the Web

Chapter 7. Graphical Examples with Perl/Tk

A Brief Introduction to Tk

A Dictionary Client: xword

Check on Package Delivery: Track

Check if Servers Are up: webping

Chapter 7.
Graphical Examples with Perl/Tk