cmd/show/db0sdx.pl

   1 #
   2 # Query the DB0SDX QSL server for a callsign
   3 #
   4 # Copyright (c) 2003 Dirk Koopman G1TLH
   5 # Modified Dec 9, 2004 for new website and xml schema by David Spoelstra N9KT
   6 # and tidied up by me (Dirk)
   7 #
   8 #
   9 #
  10
  11 my ($self, $line) = @_;
  12 my $call = $self->call;
  13 my @out;
  14
  15 $line = uc $line;
  16 return (1, $self->msg('e24')) unless $Internet::allow;
  17 return (1, "SHOW/DB0SDX <callsign>, e.g. SH/DB0SDX ea7wa") unless $line && is_callsign($line);
  18 my $target = $Internet::db0sdx_url || 'www.qslinfo.de';
  19 my $path = $Internet::db0sdx_path || '/qslinfo';
  20 my $suffix = $Internet::db0sdx_suffix || '.asmx';
  21 my $port = 80;
  22 my $cmdprompt = '/query->.*$/';
  23
  24 my($info, $t);
  25
  26 $t = new Net::Telnet;
  27
  28 dbg("db0sdx: contacting $target:$port") if isdbg('db0sdx');
  29 $info =  $t->open(Host    => $target,
  30                   Port    => $port,
  31                   Timeout => 15);
  32
  33 if (!$info) {
  34         push @out, $self->msg('e18', 'DB0SDX Database server');
  35 } else {
  36
  37         dbg("db0sdx: connected to $target:$port") if isdbg('db0sdx');
  38
  39         my $s = qq(<?xml version="1.0" encoding="utf-8"?>
  40 <soap:Envelope xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
  41   <soap:Body>
  42     <qslinfo xmlns="http://$target">
  43       <callsign>$line</callsign>
  44       <ClientInformation>DXSpider V$main::version B$main::build ($call\@$main::mycall)</ClientInformation>
  45     </qslinfo>
  46   </soap:Body>
  47 </soap:Envelope>
  48 );
  49
  50
  51         my $lth = length($s)+7;
  52
  53         dbg("db0sdx out: $s") if isdbg('db0sdx');
  54
  55         $t->print("POST $path$suffix HTTP/1.0");
  56         $t->print("Host: $target");
  57         $t->print("Content-Type: text/xml; charset=utf-8");
  58         $t->print("Content-Length: $lth");
  59         $t->print("Connection: Close");
  60         $t->print(qq{SOAPAction: "http://$target$path"});
  61         $t->print("");
  62         $t->put($s);
  63
  64         my $in;
  65
  66         while (my $result = eval { $t->getline(Timeout => 30) } || $@) {
  67                 if ($@) {
  68                         push @out, $self->msg('e18', 'DB0SDX Server');
  69                         last;
  70                 } else {
  71                         $in .= $result;
  72                 }
  73         }
  74
  75         dbg("db0sdx in: $in") if isdbg('db0sdx');
  76
  77         # Log the lookup
  78         Log('call', "$call: show/db0sdx $line");
  79         $t->close;
  80
  81         my ($info) = $in =~ m|<qslinfoResult>([^<]*)</qslinfoResult>|;
  82         my @in = split /[\r\n]/, $info if $info;
  83         if (@in && $in[0]) {
  84                 push @out, @in;
  85         } else {
  86                 ($info) = $in =~ m|<faultstring>([^<]*)</faultstring>|;
  87                 push @out, $info if $info;
  88                 push @out, $self->msg('e3', 'DB0SDX', $line) unless @out;
  89         }
  90 }
  91 return (1, @out);