Imagine you need to integrate with an application that uses SOAP and the SOAP methods return things like available fields and their properties and lists of options etc. Something like this interface for posting job adverts on a site. So you need to fetch the data and display it in an easier to read format, with the option lists in whatever format your application requires, ...

This is what I just whipped up. Note especially how XML::Rules let me neatly extract just the data I need in the format that makes them easy to display.

use strict;
use warnings; no warnings 'uninitialized';
use LWP::Simple qw(get);
use CGI::Deurl qw(as q); use vars qw(%q);
use CGI::Enurl qw(enurl);
use XML::Rules;
use Data::Dumper;
use File::Basename;
use HTML::Entities;
use Interpolation '"' 
  => sub { '"' . HTML::Entities::encode($_[0], '^\r\n\t !\#\$%\(-;=?-~
+')};

print "HTTP/1.0 200 OK\n" if($ENV{'PerlXS'} eq 'PerlIS');
print "Content-type: text/html\n\n";

my $script = basename($0);

my $site;
if ($q{site} eq '' or $q{UploaderID} eq '' or $q{Password} eq '' or $q
+{back} eq 'yes') {
  print <<"*END*";
<html><head><title>Madgex info</title>
</head>
<body>
 <h1>Select the site</h1>
 <form method="get">
   <select name="site">
*END*
  foreach ( qw(
    grocerjobs.webservice.madgexjb.com
    bighospitality.webservice.madgexjb.com
    foodmanjobs.webservice.madgexjb.com
    grocerjobs.webservice.madgexjbtest.com
    bighospitality.webservice.madgexjbtest.com
    foodmanjobs.webservice.madgexjbtest.com
  )) {
    if ($q{site} eq $_) {
      print "<option selected>$_</option>";
    } else {
      print "<option>$_</option>";
    }
  }
  print <<"*END*";
   </select><br/>
   Uploader ID: <input type="text" name="UploaderID" value=$"{$q{Uploa
+derID}}"><br/>
   Password: <input type="text" name="Password" value=$"{$q{Password}}
+"><br/>
   <input type="submit"><br/>
 </form>
 <small>All fields are required!</small>
</body>
</html>
*END*
    exit;
} else {
    $site = $q{site};
}

print <<"*END*";
<html><head><title>Madgex info</title>
<style>
td { padding: 2px;}
th { padding: 2px;}
h2 { margin-bottom: 3px;}
p { margin-top: 3px;}
</style>
</head>
<body>
*END*


my $uploaderID = $q{UploaderID};
my $password = $q{Password};

my $xml = get(
 "http://$site/jobposting.asmx/Logon?"
  . enurl({sUploaderID => $uploaderID, sPassword => $password})
);

if (! $xml) {
  print <<"*END*";
<h1 style="color: Red;">Invalid Uploader ID or Password for site $site
+</h1>

<p>Go <a href="$script?back=yes&$ENV{QUERY_STRING}">back</a></p>
</body>
</html>
*END*
  exit;
}

my $token = eval {XML::Rules->new(
  rules => {string => 'content'}, stripspaces => 7
)->parse($xml)->{string}};
#print "token=" . $token . "\n";

if (! $token) {
  my $err = $@;
  $xml = HTML::Entities::encode( $xml, '^\r\n\t !\#\$%\(-;=?-~');
  $xml =~ s{^( +)}{ '&nbsp;' x length($1) }gme;
  $xml =~ s/\n/<br\/>\n/sg;

  print <<"*END*";
<h1 style="color: Red;">Invalid login response</h1>
<p>
$xml
</p>

<p style="color: Red;">Error: $err</p>

<p>Go <a href="$script?back=yes&$ENV{QUERY_STRING}">back</a></p>
</body>
</html>
*END*
  exit;
}


$xml = get(
 "http://$site/jobposting.asmx/GetApplicationMethodTypes?"
  . enurl({uiSecurityToken => $token})
);

my $ApplicationMethods = XML::Rules->new(
  rules => {string => 'content array', ArrayOfString => sub {return $_
+[1]->{string}}},
  stripspaces => 7
)->parse($xml);

print "<h2>Application Methods</h2>\n<p>";
print join( "<br/>\n", @$ApplicationMethods);
print "</p>\n\n";

$xml = get(
 "http://$site/jobposting.asmx/GetAvailableRecruiters?"
  . enurl({uiSecurityToken => $token})
);
my $Recruiters = XML::Rules->new(
  rules => {
    'Name,ID' => 'content', 
    WSRecruiter => 'no content array', 
    ArrayOfWSRecruiter => sub {return $_[1]->{WSRecruiter}}},  
  stripspaces => 7
)->parse($xml);

print <<"*END*";
<h2>Recruiters</h2>
<table border="1">
<tr><th>ID</th><th>Name</th></tr>
*END*
foreach (@$Recruiters) {
    print "<tr><td>$_->{ID}</td><td>$_->{Name}</td></tr>\n";
}
print "</table>\n\n";

$xml = get(
 "http://$site/jobposting.asmx/GetJobProperties?"
  . enurl({uiSecurityToken => $token})
);
my $JobProperties = XML::Rules->new(
  rules => {
    '_default' => 'content',
    Mandatory => sub { return Mandatory => ($_[1]->{_content} eq 'true
+' ? 'mandatory' : 'optional')},
    WSJobProperty => 'no content array', 
    ArrayOfWSJobProperty => sub {return $_[1]->{WSJobProperty}}
  }, 
  stripspaces => 7
)->parse($xml);

print <<"*END*";
<h2>Job Properties</h2>
<table border="1">
<tr><th>Name</th><th>Length</th><th>Description</th><th> </th></tr>
*END*
foreach (@$JobProperties) {
  print "<tr><td><b>$_->{Name}</b></td><td>$_->{MaxLen}</td><td>$_->{D
+esc}</td><td>$_->{Mandatory}</td></tr>\n";
}
print "</table>\n\n";

$xml = get(
 "http://$site/jobposting.asmx/GetActiveUpsellPackages?"
  . enurl({uiSecurityToken => $token})
);
my $Upsells = XML::Rules->new(
  rules => {'_default' => 'content', WSUpsell => 'no content array', A
+rrayOfWSUpsell => sub {return $_[1]->{WSUpsell}}},
  stripspaces => 7
)->parse($xml);

print <<"*END*";
<h2>Upsells</h2>
<table border="1">
<tr><th>ID</th><th>Name</th></tr>
*END*
foreach (@$Upsells) {
  print "<tr><td>$_->{ID}</td><td>$_->{Name}</td></tr>\n";
}
print "</table>\n\n";


$xml = get(
 "http://$site/jobposting.asmx/GetCategories?"
  . enurl({uiSecurityToken => $token})
);
#print $xml;
#exit;
my $Categories = XML::Rules->new(
  rules => {
    '_default' => 'content',
    Mandatory => sub { return Mandatory => ($_[1]->{_content} eq 'true
+' ? 'mandatory' : 'optional')},
    MultiSelect => sub { return MultiSelect => ($_[1]->{_content} eq '
+true' ? 'multiple' : 'single')},
    WSCategory => 'no content array', 
    ArrayOfWSCategory => sub {return $_[1]->{WSCategory}}
  },
  stripspaces => 7
)->parse($xml);

#print Dumper($Categories);

print <<"*END*";
<h2>Categories</h2>
<table border="1">
<tr><th>ID</th><th>Name</th><th>Select</th><th>Req?</th><th>Options</t
+h></tr>
*END*

my $catParser = XML::Rules->new(
  rules => {
    '_default' => 'content',
    WSTerm => sub {'@list' => qq{$_[1]->{ID},"$_[1]->{Name}"}},
    ArrayOfWSTerm => sub {return $_[1]->{list}},
  }, 
  stripspaces => 7
);

foreach my $Category (@$Categories) {
  $xml = get(
    "http://$site/jobposting.asmx/GetCategoryTerms?"
    . enurl({uiSecurityToken => $token, sCategoryID => $Category->{ID}
+})
  );
  my $Terms = $catParser->parse($xml);
  if ($Terms and @$Terms) {
    $Terms = join( "<br/>\n", @$Terms)
  } else {
    $Terms = '';
  }

  print "<tr><td><b>$Category->{ID}</b></td><td><b>$Category->{Name}</
+b></td>
<td>$Category->{MultiSelect}</td><td>$Category->{Mandatory}</td>
<td>$Terms</td></tr>\n";
}

print <<"*END*";
</table>
<p>Go <a href="$script?back=yes&$ENV{QUERY_STRING}">back</a></p>
</body>
</html>
*END*

$xml = get( "http://$site/jobposting.asmx/Logoff?" . enurl({uiSecurity
+Token => $token}) );

[download]

Sorry I can't give you a working username and password so this is what the result looks like:

Application Methods

AutoForwardedApplications
ResponseManagement
ExternalRedirect
OfflineApplications

Recruiters

IDName
303908Madgex

Job Properties

NameLengthDescription
JobTitle255Mandatory string(255). Title of the job.mandatory
JobDescription-1Mandatory string. Description of the job.mandatory
ShortJobDescription255Optional string(255). Short job descriptionoptional
JobRef50Optional string(50). Recruiter's job reference stringoptional
JobPostCode50Optional string(50). Post code location of the job, which must be either a full, valid UK postcode or outcode only - used for radial searchingoptional
LocationDescription30Optional string (30). Location description shown on job detailsoptional
SalaryDescription30Mandatory string(30). Salary description shown on job detailsmandatory
ContactTitle50Optional string(50). Recruiter contact detailsoptional
ContactFirstName50Optional string(50). Recruiter contact detailsoptional
ContactLastName50Optional string(50). Recruiter contact detailsoptional
Telephone50Optional string(50). Recruiter contact detailsoptional
Fax50Optional string(50). Recruiter contact detailsoptional
Address150Optional string(50). Recruiter contact address detailsoptional
Address250Optional string(50). Recruiter contact address detailsoptional
Address350Optional string(50). Recruiter contact address detailsoptional
CityTown50Optional string(50). Recruiter contact address detailsoptional
County50Optional string(50). Recruiter contact address detailsoptional
PostCode50Optional string(50). Recruiter contact address detailsoptional
Country50Optional string(50). Recruiter contact address detailsoptional

Upsells

IDName
2Featured Job
5Premium Job

Categories

IDNameSelectReq?Options
104Job Functionsinglemandatory104001,"Buying"
104002,"Category Management"
104003,"Customer Service"
104004,"Finance"
104005,"Human Resources"
104006,"Marketing"
104007,"Merchandising"
104008,"National Account Management"
104009,"Retail Management"
104010,"Sales"
104011,"Student"
104012,"Other Job Sector"
103Salarymultipleoptional103001,"£10,000 or below"
103002,"£10,001 - £15,000"
103003,"£15,001 - £20,000"
103004,"£20,001 - £25,000"
103005,"£25,001 - £30,000"
103006,"£30,001 - £40,000"
103007,"£40,001 - £50,000"
103008,"£50,001 - £60,000"
103009,"£60,001 - £80,000"
103010,"£80,001 - £100,000"
103011,"Over £100,000"
103012,"Commission only"
106Locationmultiplemandatory106001,"East Anglia"
106002,"East Midlands"
106003,"London"
106004,"North East"
106005,"North West"
106006,"Northern Ireland"
106007,"Scotland"
106008,"South East"
106009,"South West"
106010,"Wales"
106011,"West Midlands"
106012,"Yorkshire/Humberside"
106013,"EU"
106014,"Outside EU"
105Business Sectorsingleoptional105001,"Retail"
105002,"Manufacturing"
105003,"Wholesalers"
105004,"Recruitment"
105005,"Other"
102Hourssinglemandatory102001,"Full Time"
102002,"Part Time"
101Contractsinglemandatory101001,"Permanent"
101002,"Interim"

Jenda
Enoch was right!
Enjoy the last years of Rome.

Back to Cool Uses for Perl