xml_post.pl

#!/usr/bin/perl

# This program was written for the purpose of testing an XML RPC system.
# Copyright 2010 Barry County Services Company
# LICENSE: GPL -- http://www.gnu.org/licenses/gpl-3.0.txt

use common::sense;
use CGI;
use CGI::Carp qw(fatalsToBrowser);
use LWP::UserAgent;
use HTTP::Request::Common;

my $cgi = CGI->new;

my @cookies;

    push @cookies,
         map {$cgi->cookie(-expire=>'+1y', -name=>$_->[0], -value=>$_->[1])}
        grep { $_->[1] }
         map {[$_, $cgi->param($_)]}
            qw(url encoding content-type)
                if $cgi->param("send");

print $cgi->header(-cookie=>\@cookies);

print $cgi->h3("request");
print $cgi->start_form;
print $cgi->start_table;
print $cgi->Tr($cgi->td(["URL:",          $cgi->textfield({name=>"url",          value=>$cgi->cookie('url')})]));
print $cgi->Tr($cgi->td(["encoding:",     $cgi->textfield({name=>"encoding",     value=>$cgi->cookie('encoding')||"UTF-8"})]));
print $cgi->Tr($cgi->td(["content-type:", $cgi->textfield({name=>"content-type", value=>$cgi->cookie("content-type")||"application/xml"})]));
print $cgi->Tr($cgi->td({colspan=>2}, $cgi->textarea({name=>"xml", cols=>65, rows=>7})));
print $cgi->Tr($cgi->td({colspan=>2}, $cgi->submit("send"), $cgi->submit("show_req")));
print $cgi->end_table;
print $cgi->end_form;

if( ($cgi->param("send") or $cgi->param("show_req")) and (my $url = $cgi->param("url"))) {
    my $ua        = LWP::UserAgent->new(agent => 'BCSC XML CNP');
    my $encoding  = $cgi->param("encoding");
    my $content   = "<?xml version='1.0' encoding='$encoding'?>\n\n" . ($cgi->param("xml")||"<pfft/>");
    my $request   = POST($url, content_type=>($cgi->param("content_type")||"text/xml"), content=>$content);
    my $response  = $ua->request($request);

    print $cgi->style(qq(
        p.fail { color: red }
        p.res  { font-family: monospace; }
    ));

    if( $cgi->param("show_req") ) {
        print $cgi->h1("response");
        print $cgi->p({class=>"res"}, $cgi->pre($cgi->escapeHTML($request->as_string)));

    } else {
        print $cgi->h1("response");
        print $cgi->p({class=>"fail"}, $response->error_as_HTML) unless $response->is_success;
        print $cgi->p({class=>"res"}, $cgi->pre($cgi->escapeHTML($response->as_string)));
    }
}