<![CDATA[
#!/usr/bin/perl
## 'Shebangs' must be on the first line.
## On *nix use, e.g. #!/usr/bin/perl
## On Windows with Cygwin, use, e.g. #!c:/cygwin/bin/perl
=pod Notes and ToDo
Con-way XML Sample Code for Image Retrieval Interface
required software: Expat (http://sourceforge.net/projects/expat/)
To execute this as CGI in a browser, you must configure your webserver accordingly.
For example, if you are using Apache, your httpd.conf file would have something
like this:
## Add +ExecCGI to the default directory
<Directory />
Options FollowSymLinks +ExecCGI
AllowOverride None
</Directory>
## Add the handler to execute CGI scripts
AddHandler cgi-script .cgi .pl
## Create an alias and directory to point to where you have your perl scripts
## With this, you would then use the URL http://WEBROOT/perl/myScript.pl
Alias /perl "C:/workspace/eclipse/DEV_PERL"
<Directory "C:/workspace/eclipse/DEV_PERL">
Options Indexes MultiViews ExecCGI
AllowOverride None
Order allow,deny
Allow from all
</Directory>
## TODO:
* replace the USERNAME and PASSWORD String values below
with your Con-way username and password
* replace PRONUMBER strings below with your own 9-digit PRO Numbers
* update $imageDir with the location to which you want to write
* the image files on your webserver
* update $imageUrl with the URL to access the files
Send questions to Con-way XML Support at web.support@Con-way.com
=cut
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use HTTP::Request::Common;
use LWP::UserAgent;
use Crypt::SSLEay;
use URI::Escape;
use XML::Parser;
use XML::SimpleObject;
use MIME::Base64;
use Date::Format;
=pod
Documentation for XML::SimpleObject here:
http://aspn.activestate.com/ASPN/CodeDoc/XML-SimpleObject/SimpleObject.html
=cut
## Replace USERNAME and PASSWORD strings with your Con-way username and password
my $username = 'USERNAME';
my $password = 'PASSWORD';
my $title = 'Image Retrieval';
my $requestType = 'ImageRequest';
my $responseType = 'ImageResponse';
my $conwayUrl = 'https://www.Con-way.com/';
my $servletUri = 'webapp/imaging_app/XmlImageRetrieverServlet';
my $postUrl = $conwayUrl.$servletUri;
## TODO update $imageDir with the location to which you want to write
## the image files on your webserver
## update $imageUrl with the URL to access the files
## on Windows, like this:
my $imageDir = "C:\\Program Files\\Apache Group\\Apache2\\htdocs\\conwayImages\\";
## on OS X, like this:
# my $imageDir = "/Library/WebServer/Documents/conwayImages/";
my $imageUrl = "http://localhost/conwayImages/";
=pod XML Data setup
In actual use, you would probably populate the parameters
from data submitted via an on-line form or database.
For this sample we will just hard code some dummy data.
=cut
print header; ## Start the HTML page
my @getValues = split(/&/,$ENV{QUERY_STRING});
my %myInput = ();
foreach my $i (@getValues) {
my($label, $data) = split(/=/, $i);
$myInput{"$label"} = $data;
}
## If you don't pass data in as a GET variables, hard code them here:
## Build the XML Request --
# replace PRONUMBER with your own 9-digit PRO Number
if (! defined $myInput{'pro'} ) {
$myInput{'pro'} = 'PRONUMBER';
}
if (! defined $myInput{'type'} ) {
$myInput{'type'} = 'BL'; ## Type may be BL, DR, LOA, WI
}
if (! defined $myInput{'format'} ) {
$myInput{'format'} = 'jpeg'; ## Format may be pdf, jpeg, png, tiff
}
my $xmlRequest = "
<ImageRequest>
<ImageKey>
<PRONumber>$myInput{'pro'}</PRONumber>
<ImageType>$myInput{'type'}</ImageType>
<ImageFormat>$myInput{'format'}</ImageFormat>
</ImageKey>
</ImageRequest>";
## URL Encode the XML String
$xmlRequest = uri_escape($xmlRequest);
## Set up the HTTP request
my $req = HTTP::Request->new(POST => $postUrl);
$req->authorization_basic($username, $password);
$req->content_type('application/x-www-form-urlencoded');
$req->content("$requestType=$xmlRequest");
my $userAgent = LWP::UserAgent->new;
my $resp = $userAgent->request($req);
## Abort now with error message if not successful
if (!$resp->is_success) {
print $resp->error_as_HTML;
exit;
}
## Parse the XML response
my $parser = XML::Parser->new(ErrorContext => 2, Style => "Tree");
my $respObj = XML::SimpleObject->new( $parser->parse($resp->content) );
my $rootEl = $respObj->child($responseType);
## Output HTML
print "
<html>
<head>
<title>Sample Perl for Con-way XML $title></title>
<script language=\"Javascript\" type=\"text/javascript\">
<!--
function erase(object) {
object.value=\"\";
}
// -->
</script>
</head>
<body text=\"RoyalBlue\">
<center>
<B><font face=\"arial\" size=+1><I>Sample Perl Con-way XML $title</I></font></B>
</center>
<br>";
## check for general error (usually XML input) at child element of root
my $err = $rootEl->child("Error");
if ($err) {
print "XML Input Error: " . $err->value;
parseElement($rootEl);
print end_html;
exit;
}
## Now get the array of Image elements
my @images = $rootEl->children("Image");
## Process the array of Image(s), first checking for any error elements
my $errMessage = "";
foreach my $image (@images) {
## check for Errors
foreach my $error ($image->children("Error")) {
if ($error) {
$errMessage .= $error->value . "\n";
}
}
}
## If any errors found, display message and exit.
if ($errMessage) {
print $errMessage;
print end_html;
exit;
}
## Set up HTML form
print "\n<form action=\"$ENV{'SCRIPT_NAME'}\" method=\"GET\">
<table border=\"0\" cellspacing=\"0\" cellpadding=\"0\">
";
while ((my $key, my $value) = each(%myInput)) {
if ($key ne 'Submit') {
# print "$key = $value<br>";
print '<tr><td><b>' . uc($key) . ': </b></td>'
.' <td><input type="text" name="'. $key .'" value="' . $value .'"'
.'onFocus="erase(this);" onClick="erase(this);"></td></tr>';
}
}
print "
<tr><td> </td><td> </td></tr>
<tr>
<td> </td>
<td><input type=\"submit\" name=\"Submit\" value=\"Process $title\"></td>
</tr>
</table>
</form>
<hr>
";
## Get unique number from Datetime
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
my $uniqueString = sprintf "%02d%02d%02d_%02d%02d%02d",$year-100,$mon+1,$mday,$hour,$min,$sec;
## Process the array of Images, and output optionally to HTML page
foreach my $image (@images) {
my $pro = $image->child("PRONumber")->value;
my $type = $image->child("ImageType")->value;
my $format = $image->child("ImageFormat")->value;
my @encodedPages = $image->children("ImageData");
my $pageString = ""; ## page number for filename
my $pages = @encodedPages;
for(my $i = 0; $i < $pages; $i++) {
my $decodedPage = MIME::Base64::decode($encodedPages[$i]->value);
if ($pages > 1) {
$pageString = $i+1;
if (length($pageString) < 2) {
$pageString = '0'.$pageString;
}
$pageString = '_'.$pageString;
}
my $imageLabel = "$type image for PRO number $pro - $pageString";
my $fileName = $type.'-'.$pro.'-'.$uniqueString.$pageString.'.'.$format;
my $filePath = $imageDir.$fileName;
my $fileUrl = $imageUrl.$fileName;
open(FH, "> $filePath") or die "Cannot open $filePath for writing: $!";
## print 'Writing '.$imageLabel."\n";
print FH $decodedPage;
close(FH) or die "FH didn't close: $!";
print "<a href =\"$fileUrl\"><img src=\"$fileUrl\" border=\"0\" "
."alt=\"$imageLabel\" title =\"$imageLabel\"></a><br><br>";
}
}
print end_html;
=item
This subroutine accesses and prints the XML tree for the element argument,
printing element names, attibutes and text values, but not in any order.
It processess recursively, so as to print the entire tree for the given element.
=cut
sub parseElement {
my $parseEl = $_[0];
print "Parsing element <", $parseEl->name, ">:\n";
printElementAttributes($parseEl);
printElementValue($parseEl);
foreach my $element ($parseEl->children()) {
print "<", $element->name, "> element - \n";
printElementAttributes($element);
printElementValue($element);
if ($element->children()) {
print " Beginning children of <",$element->name,">: \n\n";
parseElement($element);
print " End of children for <", $element->name, ">\n";
}
print "\n";
}
}
sub printElementAttributes {
my $element = $_[0];
if ($element->attributes()) {
my %attributes = $element->attributes();
print "\t", "Attributes: ";
foreach my $key (keys %attributes) {
my $value = $attributes{$key};
print $key."=\"".$value ."\" ";
}
print "\n";
}
}
sub printElementValue {
if ($_[0]->value) {
print "\t", "Value: ", $_[0]->value, "\n";
}
}
]]>