]> scm.dxcluster.org Git - spider.git/blob - cmd/show/db0sdx.pl
Add clear/cmd_cache command to git
[spider.git] / 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);