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