The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

package cmt::echohh; 

use strict; 
use vars qw/@ISA @EXPORT/; 
use Exporter; 
use HTTP::Response;
use LWP::UserAgent; 
use XML::Simple;

sub xsmerge; 
sub verbose; 

# args: 
#   method  => $string 'GET' or 'POST'
#   form    => \%hash { $name => $value }
#   headers => \%hash { $name => $value }
#   content => $string
#
# returns:
#   $string:    error text
#   \%hash:     info in sections
sub echohh {
    my ($url, %args) = @_; 
    
    verbose "retr from $url"; 
    
    my $method  = $args{'method'} || 'GET'; 
    my $formref = $args{'form'} || {}; 
    
    my $_headers= $args{'headers'} || {};
    my %headers = %$_headers;
    
    # Not used.
    my $content = $args{'content'} || ''; 
    
    my $agent   = LWP::UserAgent->new(); 
    my $response;
    
    if ($method eq 'GET') {
        $response = $agent->get($url, %headers);
    } elsif ($method eq 'POST') {
        $response = $agent->post($url, $formref, %headers);
    } else {
        die "Invalid method: $method, neither GET nor POST. "; 
    }
    
    if ($response->is_error) {
        verbose "error: " . $response->status_line; 
        return $response->status_line;
    }
    
    my $title   = $response->title || "Unknown"; 
    $content    = $response->content; 
    my $headers = $response->headers;
    
    my %HEADERS = %$headers;
    
    my $ref     = XMLin($content); 
    
    my $ENV     = xsmerge($ref->{env});
    my $SERVER  = xsmerge($ref->{server});
    my $REQUEST = xsmerge($ref->{request});
    my $SESSION = xsmerge($ref->{session});
    my $USER    = xsmerge($ref->{user});
    
    my %ALL = (
        'title'     => $title, 
        'headers'   => \%HEADERS, 
        'env'       => $ENV, 
        'server'    => $SERVER, 
        'request'   => $REQUEST, 
        'session'   => $SESSION, 
        'user'      => $USER, 
        ); 
    return \%ALL; 
}


our @ECHOHH_URLS    = (
    'http://localhost/service/echohh.php', 
    # 'http://lenik.vicp.net:700/~dansei/service/echohh.php', 
    'http://xjl.sourceforge.net/service/echohh.php', 
    'http://www.zjjxfp.com/service/echohh.php', 
    'http://www.pfpf.net/service/echohh.php', 
    );

sub echohh_addservice {
    my $url = shift;
    unshift @ECHOHH_URLS, $url; 
}

sub echohh_get {
    my $name = shift || 'REMOTE_ADDR'; 
    my $section = shift || 'server'; 
    
    # copy urls, for random scan
    my @urls = @ECHOHH_URLS; 
    
    # TODO - add random pick algor.
    for my $url (@urls) {
        my $all = echohh($url);
        if (ref $all) {
            my $sect = $all->{$section};
            return $sect->{$name};
        }
    }
    return undef;
}

sub echohh_env      { return echohh_get(shift, 'env'); }
sub echohh_server   { return echohh_get(shift, 'server'); }
sub echohh_request  { return echohh_get(shift, 'request'); }
sub echohh_session  { return echohh_get(shift, 'session'); }
sub echohh_user     { return echohh_get(shift, 'user'); }


sub verbose {
    # print "[echohh] @_\n";
}

sub xsmerge {
    my $items = shift; 
    my %hash = ();
    if ($items->{item}) {
        $items = $items->{item};
        for my $k (keys %$items) {
            my $v = $items->{$k}->{content};
            $hash{$k} = $v;
        }
    }
    return \%hash;
}


@ISA = qw(Exporter); 
@EXPORT = qw(
	echohh
	echohh_addservice
	echohh_get
	echohh_env
	echohh_server
	echohh_request
	echohh_session
	echohh_user
	); 

1;