File Coverage

blib/lib/WWW/Dict/Leo/Org.pm
Criterion Covered Total %
statement 27 157 17.2
branch 0 44 0.0
condition 0 6 0.0
subroutine 9 17 52.9
pod 4 8 50.0
total 40 232 17.2


line stmt bran cond sub pod time code
1             #
2             # Copyleft (l) 2000-2017 Thomas v.D. .
3             #
4             # leo may be
5             # used and distributed under the terms of the GNU General Public License.
6             # All other brand and product names are trademarks, registered trademarks
7             # or service marks of their respective holders.
8              
9             package WWW::Dict::Leo::Org;
10             $WWW::Dict::Leo::Org::VERSION = "2.01";
11              
12 1     1   52186 use strict;
  1         2  
  1         29  
13 1     1   5 use warnings;
  1         2  
  1         30  
14 1     1   300 use English '-no_match_vars';
  1         3018  
  1         7  
15 1     1   736 use Carp::Heavy;
  1         146  
  1         30  
16 1     1   5 use Carp;
  1         1  
  1         55  
17 1     1   688 use IO::Socket::SSL;
  1         72227  
  1         8  
18 1     1   474 use MIME::Base64;
  1         556  
  1         71  
19 1     1   501 use XML::Simple;
  1         6980  
  1         6  
20 1     1   432 use Encode;
  1         7136  
  1         1375  
21              
22             sub debug;
23              
24             sub new {
25 0     0 0   my ($class, %param) = @_;
26 0   0       my $type = ref( $class ) || $class;
27              
28 0           my %settings = (
29             "-Host" => "dict.leo.org",
30             "-Port" => 443,
31             "-UserAgent" => "Mozilla/5.0 (Windows NT 6.3; rv:36.0) Gecko/20100101 Firefox/36.0",
32             "-Proxy" => "",
33             "-ProxyUser" => "",
34             "-ProxyPass" => "",
35             "-Debug" => 0,
36             "-Language" => "en", # en2de, de2fr, fr2de, de2es, es2de
37             "data" => {}, # the results
38             "section" => [],
39             "title" => "",
40             "segments" => [],
41             "Maxsize" => 0,
42             "Linecount" => 0,
43             );
44              
45 0           foreach my $key (keys %param) {
46 0           $settings{$key} = $param{$key}; # override defaults
47             }
48              
49 0           my $self = \%settings;
50 0           bless $self, $type;
51              
52 0           return $self;
53             }
54              
55             sub translate {
56 0     0 1   my($this, $term) = @_;
57              
58 0 0         if (! $term) {
59 0           croak "No term to translate given!";
60             }
61              
62 0           my $linecount = 0;
63 0           my $maxsize = 0;
64 0           my @match = ();
65              
66             #
67             # form var transitions for searchLoc(=translation direction) and lp(=language)
68 0           my %lang = ( speak => "ende" );
69              
70 0           my @langs = qw(en es ru pt fr pl ch it);
71 0 0         if ($this->{"-Language"}) {
72             # en | fr | ru2en | de2pl etc
73             # de2, 2de, de are not part of lang spec
74 0 0         if (! grep { $this->{"-Language"} =~ /$_/ } @langs) {
  0            
75 0           croak "Unsupported language: " . $this->{"-Language"};
76             }
77 0           my $spec = $this->{"-Language"};
78 0           my $l;
79 0 0         if ($spec =~ /(..)2de/) {
    0          
80 0           $l = $1;
81 0           $this->{"-Language"} = -1;
82 0           $lang{speak} = "${l}de";
83             }
84             elsif ($spec =~ /de2(..)/) {
85 0           $l = $1;
86 0           $this->{"-Language"} = 1;
87 0           $lang{speak} = "${l}de";
88             }
89             else {
90 0           $lang{speak} = $this->{"-Language"} . 'de';
91 0           $this->{"-Language"} = 0;
92             }
93             }
94              
95             # add language
96 0           my @form;
97 0           push @form, "lp=$lang{speak}";
98              
99             #
100             # process whitespaces
101             #
102 0           my $query = $term;
103 0           $query =~ s/\s\s*/ /g;
104 0           $query =~ s/\s/\+/g;
105 0           push @form, "search=$query";
106              
107             #
108             # make the query cgi'ish
109             #
110 0           my $form = join "&", @form;
111              
112             # store for result caching
113 0           $this->{Form} = $form;
114              
115             #
116             # check for proxy settings and use it if exists
117             # otherwise use direct connection
118             #
119 0           my ($url, $site);
120 0           my $ip = $this->{"-Host"};
121 0           my $port = $this->{"-Port"};
122 0           my $proxy_user = $this->{"-ProxyUser"};
123 0           my $proxy_pass = $this->{"-ProxyPass"};
124              
125 0 0         if ($this->{"-Proxy"}) {
126 0           my $proxy = $this->{"-Proxy"};
127 0           $proxy =~ s/^http:\/\///i;
128 0 0         if ($proxy =~ /^(.+):(.+)\@(.*)$/) {
129             # proxy user account
130 0           $proxy_user = $1;
131 0           $proxy_pass = $2;
132 0           $proxy = $3;
133 0           $this->debug( "proxy_user: $proxy_user");
134             }
135 0           my($host, $pport) = split /:/, $proxy;
136 0 0         if ($pport) {
137 0           $url = "http://$ip:$port/dictQuery/m-vocab/$lang{speak}/query.xml";
138 0           $port = $pport;
139             }
140             else {
141 0           $port = 80;
142             }
143 0           $ip = $host;
144 0           $this->debug( "connecting to proxy:", $ip, $port);
145             }
146             else {
147 0           $this->debug( "connecting to site:", $ip, "port", $port);
148 0           $url = "/dictQuery/m-vocab/$lang{speak}/query.xml";
149             }
150              
151 0 0         my $conn = new IO::Socket::SSL(
152             #Proto => "tcp",
153             PeerAddr => $ip,
154             PeerPort => $port,
155             SSL_verify_mode => SSL_VERIFY_NONE
156             ) or die "Unable to connect to $ip:$port: $!\n";
157 0           $conn->autoflush(1);
158              
159 0           $this->debug( "GET $url?$form HTTP/1.0");
160 0           print $conn "GET $url?$form HTTP/1.0\r\n";
161              
162             # be nice, simulate Konqueror.
163 0           print $conn
164             qq($this->{"-UserAgent"}
165             Host: $this->{"-Host"}:$this->{"-Port"}
166             Accept: text/*;q=1.0, image/png;q=1.0, image/jpeg;q=1.0, image/gif;q=1.0, image/*;q=0.8, */*;q=0.5
167             Accept-Charset: iso-8859-1;q=1.0, *;q=0.9, utf-8;q=0.8
168             Accept-Language: en_US, en\r\n);
169              
170 0 0 0       if ($this->{"-Proxy"} and $proxy_user) {
171             # authenticate
172             # construct the auth header
173 0           my $coded = encode_base64("$proxy_user:$proxy_pass");
174 0           $this->debug( "Proxy-Authorization: Basic $coded");
175 0           print $conn "Proxy-Authorization: Basic $coded\r\n";
176             }
177              
178             # finish the request
179 0           print $conn "\r\n";
180              
181             #
182             # parse dict.leo.org output
183             #
184 0           $site = "";
185 0           my $got_headers = 0;
186 0           while (<$conn>) {
187 0 0         if ($got_headers) {
    0          
    0          
188 0           $site .= $_;
189             }
190             elsif (/^\r?$/) {
191 0           $got_headers = 1;
192             }
193             elsif ($_ !~ /HTTP\/1\.(0|1) 200 OK/i) {
194 0 0         if (/HTTP\/1\.(0|1) (\d+) /i) {
195             # got HTTP error
196 0           my $err = $2;
197 0 0         if ($err == 407) {
198 0           croak "proxy auth required or access denied!\n";
199 0           close $conn;
200 0           return ();
201             }
202             else {
203 0           croak "got HTTP error $err!\n";
204 0           close $conn;
205 0           return ();
206             }
207             }
208             }
209             }
210              
211 0 0         close $conn or die "Connection failed: $!\n";
212 0           $this->debug( "connection: done");
213              
214 0           $this->{Linecount} = 0;
215 0           $this->{Maxsize} = 0;
216              
217             # parse the XML
218 0           my $xml = new XML::Simple;
219 0           my $data = $xml->XMLin($site,
220             ForceArray => [ 'section', 'entry' ],
221             ForceContent => 1,
222             KeyAttr => { side => 'lang' }
223             );
224              
225 0           my (@matches, $from_lang, $to_lang);
226 0           $from_lang = substr $lang{speak}, 0, 2;
227 0           $to_lang = substr $lang{speak}, 2, 2;
228              
229 0           foreach my $section (@{$data->{sectionlist}->{section}}) {
  0            
230 0           my @entries;
231 0           foreach my $entry (@{$section->{entry}}) {
  0            
232              
233 0           my $left = $this->parse_word($entry->{side}->{$from_lang}->{words}->{word});
234 0           my $right = $this->parse_word($entry->{side}->{$to_lang}->{words}->{word});
235              
236 0           push @entries, { left => $left, right => $right };
237 0 0         if ($this->{Maxsize} < length($left)) {
238 0           $this->{Maxsize} = length($left);
239             }
240 0           $this->{Linecount}++;
241             }
242             push @matches, {
243 0           title => encode('UTF-8', $section->{sctTitle}),
244             data => \@entries
245             };
246             }
247              
248 0           return @matches;
249             }
250              
251             # parse all the s and build a string
252             sub parse_word {
253 0     0 0   my ($this, $word) = @_;
254 0 0         if (ref $word eq "HASH") {
    0          
255 0 0         if ($word->{content}) {
    0          
256 0           return encode('UTF-8', $word->{content});
257             }
258             elsif ($word->{cc}) {
259             # chinese simplified, traditional and pinyin
260             return encode('UTF-8', $word->{cc}->{cs}->{content} . "[" .
261             $word->{cc}->{ct}->{content} . "] " .
262 0           $word->{cc}->{pa}->{content});
263             }
264             }
265             elsif (ref $word eq "ARRAY") {
266             # FIXME: include alternatives, if any
267 0           return encode('UTF-8', @{$word}[-1]->{content});
  0            
268             }
269             else {
270 0           return encode('UTF-8', $word);
271             }
272             }
273              
274             sub grapheme_length {
275 0     0 0   my($this, $str) = @_;
276 0           my $count = 0;
277 0           while ($str =~ /\X/g) { $count++ };
  0            
278 0           return $count;
279             }
280              
281             sub maxsize {
282 0     0 1   my($this) = @_;
283 0           return $this->{Maxsize};
284             }
285              
286             sub lines {
287 0     0 1   my($this) = @_;
288 0           return $this->{Linecount};
289             }
290              
291             sub form {
292 0     0 1   my($this) = @_;
293 0           return $this->{Form};
294             }
295              
296             sub debug {
297 0     0 0   my($this, @msg) = @_;
298 0 0         if ($this->{"-Debug"}) {
299 0           print STDERR "%DEBUG: " . join(" ", @msg) . "\n";
300             }
301             }
302              
303              
304             1;
305              
306             =encoding ISO8859-1
307              
308             =head1 NAME
309              
310             WWW::Dict::Leo::Org - Interface module to dictionary dict.leo.org
311              
312             =head1 SYNOPSIS
313              
314             use WWW::Dict::Leo::Org;
315             my $leo = new WWW::Dict::Leo::Org();
316             my @matches = $leo->translate($term);
317              
318             =head1 DESCRIPTION
319              
320             B is a module which connects to the website
321             B and translates the given term. It returns an array
322             of hashes. Each hash contains a left side and a right side of the
323             result entry.
324              
325             =head1 OPTIONS
326              
327             B has several parameters, which can be supplied as a hash.
328              
329             All parameters are optional.
330              
331             =over
332              
333             =item I<-Host>
334              
335             The hostname of the dict website to use. For the moment only dict.leo.org
336             is supported, which is also the default - therefore changing the
337             hostname would not make much sense.
338              
339             =item I<-Port>
340              
341             The tcp port to use for connecting, the default is 80, you shouldn't
342             change it.
343              
344             =item I<-UserAgent>
345              
346             The user-agent to send to dict.leo.org site. Currently this is the
347             default:
348              
349             Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8.1.9) Gecko/20071025 Firefox/2.0.0.9
350              
351             =item I<-Proxy>
352              
353             Fully qualified proxy server. Specify as you would do in the well
354             known environment variable B, example:
355              
356             -Proxy => "http://192.168.1.1:3128"
357              
358             =item I<-ProxyUser> I<-ProxyPass>
359              
360             If your proxy requires authentication, use these parameters
361             to specify the credentials.
362              
363             =item I<-Debug>
364              
365             If enabled (set to 1), prints a lot of debug information to
366             stderr, normally only required for developers or to
367             report bugs (see below).
368              
369             =back
370              
371             Parameters to control behavior of dict.leo.org:
372              
373             =over
374              
375             =item I<-Language>
376              
377             Translation direction. Please note that dict.leo.org always translates
378             either to or from german.
379              
380             The following languages are supported: english, polish, spanish, portuguese
381             russian and chinese.
382              
383             You can specify only the country code, or append B in order to
384             force translation to german, or preprend B in order to translate
385             to the other language.
386              
387             Valid examples:
388              
389             ru to or from russian
390             de2pl to polish
391             es2de spanish to german
392              
393             Valid country codes:
394              
395             en english
396             es spanish
397             fr french
398             ru russian
399             pt portuguese
400             pl polish
401             ch chinese
402              
403             Default: B.
404              
405             =back
406              
407             =head1 METHODS
408              
409             =head2 translate($term)
410              
411             Use this method after initialization to connect to dict.leo.org
412             and translate the given term. It returns an array of hashes containing
413             the actual results.
414              
415             use WWW::Dict::Leo::Org;
416             use Data::Dumper;
417             my $leo = new WWW::Dict::Leo::Org();
418             my @matches = $leo->translate("test");
419             print Dumper(\@matches);
420              
421             which prints:
422              
423             $VAR1 = [
424             {
425             'data' => [
426             {
427             'left' => 'check',
428             'right' => 'der Test'
429             },
430             {
431             'left' => 'quiz (Amer.)',
432             'right' => 'der Test    [Schule]'
433             ],
434             'title' => 'Unmittelbare Treffer'
435             },
436             {
437             'data' => [
438             {
439             'left' => 'to fail a test',
440             'right' => 'einen Test nicht bestehen'
441             },
442             {
443             'left' => 'to test',
444             'right' => 'Tests macheneinen Test machen'
445             }
446             ],
447             'title' => 'Verben und Verbzusammensetzungen'
448             },
449             'data' => [
450             {
451             'left' => 'testing  adj.',
452             'right' => 'im Test'
453             }
454             ],
455             'title' => 'Wendungen und Ausdrücke'
456             }
457             ];
458              
459              
460             You might take a look at the B script how to process
461             this data.
462              
463             =head2 maxsize()
464              
465             Returns the size of the largest returned term (left side).
466              
467             =head2 lines()
468              
469             Returns the number of translation results.
470              
471             =head2 form()
472              
473             Returns the submitted form uri.
474              
475             =head1 SEE ALSO
476              
477             L
478              
479             =head1 COPYRIGHT
480              
481             WWW::Dict::Leo::Org - Copyright (c) 2007-2017 by Thomas v.D.
482              
483             L -
484             Copyright (c) 1995-2016 LEO Dictionary Team.
485              
486             =head1 AUTHOR
487              
488             Thomas v.D.
489              
490             =head1 HOW TO REPORT BUGS
491              
492             Use L to report bugs, select the queue for B.
493              
494             Please don't forget to add debugging output!
495              
496             =head1 VERSION
497              
498             2.01
499              
500             =cut