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