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