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 sub on_disc
  12 {
  13         my $conn = shift;
  14         my $dxchan = shift;
  15         my @out;
  16
  17         $conn->{sdxin} .= $conn->{msg}; # because there will be stuff left in the rx buffer because it isn't \n terminated
  18         dbg("db0sdx in: $conn->{sdxin}") if isdbg('db0sdx');
  19
  20         my ($info) = $conn->{sdxin} =~ m|<qslinfoResult>([^<]*)</qslinfoResult>|;
  21         dbg("info: $info");
  22         my $prefix = $conn->{prefix} || '';
  23
  24         my @in = split /[\r\n]/, $info if $info;
  25         if (@in && $in[0]) {
  26                 dbg("in qsl");
  27                 push @out, map {"$prefix$_"} @in;
  28         } else {
  29                 dbg("in fault");
  30                 ($info) = $conn->{sdxin} =~ m|<faultstring>([^<]*)</faultstring>|;
  31                 push @out, "$prefix$info" if $info;
  32                 push @out, $dxchan->msg('e3', 'DB0SDX', $conn->{sdxline}) unless @out;
  33         }
  34         $dxchan->send(@out);
  35 }
  36
  37 sub process
  38 {
  39         my $conn = shift;
  40         my $msg = shift;
  41
  42         $conn->{sdxin} .= "$msg\n";
  43
  44         dbg("db0sdx in: $conn->{sdxin}") if isdbg('db0sdx');
  45 }
  46
  47 sub handle
  48 {
  49         my ($self, $line) = @_;
  50         my $call = $self->call;
  51         my @out;
  52
  53         $line = uc $line;
  54         return (1, $self->msg('e24')) unless $Internet::allow;
  55         return (1, "SHOW/DB0SDX <callsign>, e.g. SH/DB0SDX ea7wa") unless $line && is_callsign($line);
  56         my $target = $Internet::db0sdx_url || 'www.qslinfo.de';
  57         my $path = $Internet::db0sdx_path || '/qslinfo';
  58         my $suffix = $Internet::db0sdx_suffix || '.asmx';
  59         my $port = 80;
  60
  61         dbg("db0sdx: contacting $target:$port") if isdbg('db0sdx');
  62
  63         my $s = qq(<?xml version="1.0" encoding="utf-8"?>
  64 <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/">
  65   <soap:Body>
  66     <qslinfo xmlns="http://$target">
  67       <callsign>$line</callsign>
  68       <ClientInformation>DXSpider V$main::version B$main::build ($call\@$main::mycall)</ClientInformation>
  69     </qslinfo>
  70   </soap:Body>
  71 </soap:Envelope>);
  72         my $lth = length($s)+1;
  73
  74         Log('call', "$call: show/db0sdx $line");
  75         my $conn = AsyncMsg->post($self, $target, $port, "$path$suffix", prefix => 'sdx> ', filter => \&process,
  76                                                          'Content-Type' => 'text/xml; charset=utf-8',
  77                                                          'Content-Length' => $lth,
  78                                                           Connection => 'Close',
  79                                                           SOAPAction => qq{"http://$target$path"},
  80                                                           data => $s,
  81                                                           on_disc => \&on_disc);
  82
  83         if ($conn) {
  84                 $conn->{sdxcall} = $line;
  85                 push @out, $self->msg('m21', "show/db0sdx");
  86         } else {
  87                 push @out, $self->msg('e18', 'DB0SDX Database server');
  88         }
  89
  90         return (1, @out);
  91 }