File Coverage

blib/lib/Astro/SIMBAD/Client.pm
Criterion Covered Total %
statement 224 373 60.0
branch 79 220 35.9
condition 17 39 43.5
subroutine 39 54 72.2
pod 15 15 100.0
total 374 701 53.3


'.
line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Astro::SIMBAD::Client - Fetch astronomical data from SIMBAD 4.
4              
5             =head1 SYNOPSIS
6              
7             use Astro::SIMBAD::Client;
8             my $simbad = Astro::SIMBAD::Client->new ();
9             print $simbad->query (id => 'Arcturus');
10              
11             =head1 NOTICE
12              
13             As of release 0.027_01 the SOAP interface is deprecated. The University
14             of Strasbourg has announced at
15             L that this
16             interface will not be maintained after April 1 2014, and that
17             B.
18              
19             Because the SOAP interface is still sort of functional (except for
20             VO-format queries) as of June 4 2014, I have revised the transition plan
21             announced with the release of 0.027_01 on October 28 2014.
22              
23             What I have done as of version 0.031_01 is to add attribute
24             C. This was false by default. If this attribute is
25             true, the C method and friends, instead of issuing a SOAP
26             request to the SIMBAD server, will instead construct an equivalent
27             script query, and issue that. The deprecation warning will not be issued
28             if C is true, since the SOAP interface is not
29             being used.
30              
31             As of March 22 2021, SOAP queries started returning 404. Because of
32             this, I have made the default of C true. Well,
33             actually I have made it the Boolean inverse of environment variable
34             L. This is
35             mostly for my benefit, so I can see if SOAP has come back.
36              
37             If SOAP still has not come back after six months, SOAP queries will
38             become fatal, as will setting C to a false value.
39              
40             Eventually the SOAP code will be removed. In the meantime all tests are
41             skipped unless C is true, and are marked
42             TODO. Support of SOAP by this module will be on a best-effort basis;
43             that is, if I can make it work without a huge amount of work I will --
44             otherwise SOAP will become unsupported.
45              
46             =head1 DESCRIPTION
47              
48             This package implements several query interfaces to version 4 of the
49             SIMBAD on-line astronomical database, as documented at
50             L. B
51             with SIMBAD version 3.> Its primary purpose is to obtain SIMBAD data,
52             though some rudimentary parsing functionality also exists.
53              
54             There are three ways to access these data.
55              
56             - URL queries are essentially page scrapers, but their use is
57             documented, and output is available as HTML, text, or VOTable. URL
58             queries are implemented by the url_query() method.
59              
60             - Scripts may be submitted using the script() or script_file() methods.
61             The former takes as its argument the text of the script, the latter
62             takes a file name.
63              
64             - Queries may be made using the web services (SOAP) interface. The
65             query() method implements this, and queryObjectByBib,
66             queryObjectByCoord, and queryObjectById have been provided as
67             convenience methods. As of version 0.027_01, SOAP queries are
68             deprecated. See the L section above for the deprecation
69             schedule.
70              
71             Astro::SIMBAD::Client is object-oriented, with the object supplying not
72             only the URL scheme and SIMBAD server name, but the default format and
73             output type for URL and web service queries.
74              
75             A simple command line client application is also provided, as are
76             various examples in the F directory.
77              
78             =head2 Methods
79              
80             The following methods should be considered public:
81              
82             =over 4
83              
84             =cut
85              
86             package Astro::SIMBAD::Client;
87              
88             # We require Perl 5.008 because of MailTools, used by SOAP::Lite.
89             # Otherwise it would be 5.006 because of 'our'.
90              
91 5     5   1083 use 5.008;
  5         18  
92              
93 5     5   26 use strict;
  5         9  
  5         126  
94 5     5   25 use warnings;
  5         9  
  5         162  
95              
96 5     5   29 use Carp;
  5         11  
  5         498  
97 5     5   3725 use LWP::UserAgent;
  5         252571  
  5         203  
98 5     5   49 use LWP::Protocol;
  5         11  
  5         134  
99 5     5   3070 use HTTP::Request::Common qw{POST};
  5         12425  
  5         429  
100 5     5   43 use Scalar::Util 1.01 qw{looks_like_number};
  5         212  
  5         268  
101 5     5   37 use URI::Escape ();
  5         11  
  5         108  
102 5     5   2574 use XML::DoubleEncodedEntities;
  5         1982  
  5         269  
103             # use Astro::SIMBAD::Client::WSQueryInterfaceService;
104              
105 5     5   38 use constant ARRAY_REF => ref [];
  5         11  
  5         386  
106 5     5   32 use constant CODE_REF => ref sub {};
  5         9  
  5         580  
107              
108             my $have_time_hires;
109             BEGIN {
110 5     5   19 $have_time_hires = eval {
111 5         2818 require Time::HiRes;
112 5         7432 Time::HiRes->import (qw{time sleep});
113 5         984 1;
114             };
115              
116             *_escape_uri = URI::Escape->can( 'uri_escape_utf8' )
117             || URI::Escape->can( 'uri_escape' )
118 5   50     907 || sub { return $_[0] };
119             }
120              
121             our $VERSION = '0.045_01';
122              
123             our @CARP_NOT = qw{Astro::SIMBAD::Client::WSQueryInterfaceService};
124              
125             # TODO replace this with s///r if we ever get to the point where we
126             # require Perl 5.13.2 or greater.
127             sub _strip_returns {
128 10     10   31 my ( $data ) = @_;
129 10         91 $data =~ s/ \n //smxg;
130 10         874 return $data;
131             }
132              
133 5     5   45 use constant FORMAT_TXT_SIMPLE_BASIC => _strip_returns( <<'EOD' );
  5         12  
  5         14  
134             ---\n
135             name: %IDLIST(NAME|1)\n
136             type: %OTYPE\n
137             long: %OTYPELIST\n
138             ra: %COO(d;A)\n
139             dec: %COO(d;D)\n
140             plx: %PLX(V)\n
141             pmra: %PM(A)\n
142             pmdec: %PM(D)\n
143             radial: %RV(V)\n
144             redshift: %RV(Z)\n
145             spec: %SP(S)\n
146             bmag: %FLUXLIST(B)[%flux(F)]\n
147             vmag: %FLUXLIST(V)[%flux(F)]\n
148             ident: %IDLIST[%*,]
149             EOD
150              
151 5     5   38 use constant FORMAT_TXT_YAML_BASIC => _strip_returns( <<'EOD' );
  5         10  
  5         21  
152             ---\n
153             name: '%IDLIST(NAME|1)'\n
154             type: '%OTYPE'\n
155             long: '%OTYPELIST'\n
156             ra: %COO(d;A)\n
157             dec: %COO(d;D)\n
158             plx: %PLX(V)\n
159             pm:\n
160             - %PM(A)\n
161             - %PM(D)\n
162             radial: %RV(V)\n
163             redshift: %RV(Z)\n
164             spec: %SP(S)\n
165             bmag: %FLUXLIST(B)[%flux(F)]\n
166             vmag: %FLUXLIST(V)[%flux(F)]\n
167             ident:\n%IDLIST[ - '%*'\n]
168             EOD
169              
170             # Documentation errors/omissions:
171             # %PLX:
172             # P = something. Yields '2' for Arcturus
173             # %SP: is really %sptype
174             # B = bibcode? Yields '~' for Arcturus
175             # N = don't know -- yields 'S' for Arcturus
176             # Q = quality? Yields 'C' for Arcturus
177             # S = spectral type
178              
179 5         26894 use constant FORMAT_VO_BASIC => join ',', qw{
180             id(NAME|1) otype ra(d) dec(d) plx_value pmra pmdec rv_value z_value
181 5     5   36 sp_type flux(B) flux(V)};
  5         9  
182             # Note that idlist was documented at one point as being the
183             # VOTable equivalent of %IDLIST. But it is no longer documented,
184             # and never returned anything but '?IDLIST
185              
186             my %static = (
187             autoload => 1,
188             debug => 0,
189             delay => 3,
190             emulate_soap_queries => ! $ENV{ASTRO_SIMBAD_CLIENT_USE_SOAP},
191             format => {
192             txt => FORMAT_TXT_YAML_BASIC,
193             vo => FORMAT_VO_BASIC,
194             script => '',
195             },
196             parser => {
197             txt => '',
198             vo => '',
199             script => '',
200             },
201             post => 1,
202             # lc(...) per https://tools.ietf.org/html/rfc3986#section-3.1
203             scheme => lc( $ENV{ASTRO_SIMBAD_CLIENT_SCHEME} || 'http' ),
204             ## server => 'simbad.u-strasbg.fr',
205             server => $ENV{ASTRO_SIMBAD_CLIENT_SERVER} || 'simbad.u-strasbg.fr',
206             type => 'txt',
207             url_args => {},
208             verbatim => 0,
209             );
210              
211             if ( my $msg = _is_scheme_valid(
212             $static{scheme},
213             q,
214             ) ) {
215             carp $msg;
216             $static{scheme} = 'http';
217             }
218              
219             =item $simbad = Astro::SIMBAD::Client->new ();
220              
221             This method instantiates an Astro::SIMBAD::Client object. Any arguments will be
222             passed to the set() method once the object is instantiated.
223              
224             =cut
225              
226             # The set() method does the unpacking. CAVEAT: do _NOT_ modify the
227             # contents of @_, as this will be seen by the caller. Modifying @_
228             # itself is fine.
229             sub new { ## no critic (RequireArgUnpacking)
230 3     3 1 605 my $class = shift;
231 3 50       14 $class = ref $class if ref $class;
232 3         12 my $self = bless {}, $class;
233 3         51 $self->set (%static, @_);
234 3         17 return $self;
235             }
236              
237             =item $string = $simbad->agent ();
238              
239             This method retrieves the user agent string used to identify this
240             package in queries to SIMBAD. This string will be the default string for
241             LWP::UserAgent, with this package name and version number appended in
242             parentheses. This method is exposed for the curious.
243              
244             =cut
245              
246             {
247             my $agent_string;
248             sub agent {
249 9   66 9 1 70 return ($agent_string ||= join (' ', LWP::UserAgent->_agent,
250             __PACKAGE__ . '/' . $VERSION));
251             }
252             }
253              
254             =item @attribs = $simbad->attributes ();
255              
256             This method retrieves the names of all public attributes, in
257             alphabetical order. It can be called as a static method, or
258             even as a subroutine.
259              
260             =cut
261              
262             sub attributes {
263 0 0   0 1 0 return wantarray ? sort keys %static : [sort keys %static]
264             }
265              
266             =item $value = $simbad->get ($attrib);
267              
268             This method retrieves the current value of the named
269             L. It can be called as a static method to
270             retrieve the default value.
271              
272             =cut
273              
274             sub get {
275 69     69 1 489 my $self = shift;
276 0         0 croak "Error - First argument must be an @{[__PACKAGE__]} object"
277 69 50       147 unless eval {$self->isa(__PACKAGE__)};
  69         421  
278 69 100       282 $self = \%static unless ref $self;
279 69         161 my $name = shift;
280             croak "Error - Attribute '$name' is unknown"
281 69 50       247 unless exists $static{$name};
282 69         432 return $self->{$name};
283             }
284              
285             =item $result = Parse_TXT_Simple ($data);
286              
287             This subroutine (B method) parses the given text data under the
288             assumption that it was generated using FORMAT_TXT_SIMPLE_BASIC or
289             something similar. The data is expected to be formatted as follows:
290              
291             A line consisting of exactly '---' separates objects.
292              
293             Data appear on lines that look like
294              
295             name: data
296              
297             and are parsed into a hash keyed by the given name. If the line ends
298             with a comma, it is assumed to contain multiple items, and the data
299             portion of the line is split on the commas; the resultant hash value
300             is a list reference.
301              
302             The user would normally not call this directly, but specify it as the
303             parser for 'txt'-type queries:
304              
305             $simbad->set (parser => {txt => 'Parse_TXT_Simple'});
306              
307             =cut
308              
309             sub Parse_TXT_Simple {
310 6     6 1 18 my $text = shift;
311 6         19 my $obj = {};
312 6         18 my @data;
313 6         231 foreach (split '\s*\n', $text) {
314 90 50       194 next unless $_;
315 90 100       212 if (m/^-+$/) {
316 6         29 $obj = {};
317 6         19 push @data, $obj;
318             } else {
319 84         321 my ($name, $val) = split ':\s*', $_;
320 84 100       382 $val =~ s/,$// and $val = [split ',', $val];
321 84         282 $obj->{$name} = $val;
322             }
323             }
324 6         34 return @data;
325             }
326              
327             =item $result = Parse_VO_Table ($data);
328              
329             This subroutine (B method) parses the given VOTable data,
330             returning a list of anonymous hashes describing the data. The $data
331             value is split on '
332             VOTables back (rather than a parse error) if that is what the input
333             contains.
334              
335             This is B a full-grown VOTable parser capable of handling
336             the full spec (see L).
337             It is oriented toward returning ETABLEDATAE contents, and the
338             metadata that can reasonably be associated with those contents.
339              
340             B that as of version 0.026_01, the requisite modules
341             to support VO format are B required. If you need VO format you will
342             need to install L or L
343              
344             The return is a list of anonymous hashes, one per ETABLEE. Each
345             hash contains two keys:
346              
347             {data} is the data contained in the table, and
348             {meta} is the metadata for the table.
349              
350             The {meta} element for the table is a reference to a list of data
351             gathered from the ETABLEE tag. Element zero is the tag name
352             ('TABLE'), and element 1 is a reference to a hash containing the
353             attributes of the ETABLEE tag. Subsequent elements if any
354             represent metadata tags in the order encountered in the parse.
355              
356             The {data} contains an anonymous list, each element of which is a row of
357             data from the ETABLEDATAE element of the ETABLEE, in the
358             order encountered by the parse. Each row is a reference to a list of
359             anonymous hashes, which represent the individual data of the row, in the
360             order encountered by the parse. The data hashes contain two keys:
361              
362             {value} is the value of the datum with undef for '~', and
363             {meta} is a reference to the metadata for the datum.
364              
365             The {meta} element for a datum is a reference to the metadata tag that
366             describes that datum. This will be an anonymous list, of which element 0
367             is the tag ('FIELD'), element 1 is a reference to a hash containing that
368             tag's attributes, and subsequent elements will be the contents of the
369             tag (typically including a reference to the list representing the
370             EDESCRIPTIONE tag for that FIELD).
371              
372             All values are returned as provided by the XML parser; no further
373             decoding is done. Specifically, the datatype and arraysize attributes
374             are ignored.
375              
376             This parser is based on XML::Parser.
377              
378             The user would normally not call this directly, but specify it as the
379             parser for 'vo'-type queries:
380              
381             $simbad->set (parser => {vo => 'Parse_VO_Table'});
382              
383             =cut
384              
385             { # Begin local symbol block.
386              
387             my $xml_parser;
388              
389             # TODO get rid of XML::Parser::Lite when you get rid of SOAP
390             foreach (qw{XML::Parser XML::Parser::Lite}) {
391             eval { _load_module( $_ ); 1 } or next;
392             $xml_parser = $_;
393             last;
394             }
395              
396             sub Parse_VO_Table {
397 0     0 1 0 my $data = shift;
398              
399 0 0       0 defined $xml_parser
400             or croak 'Error - No XML parser available. Need XML::Parser or XML::Parser::Lite';
401              
402 0         0 my $root;
403             my @tree;
404 0         0 my @table;
405 0         0 my @to_strip;
406              
407             # Arguments:
408             # Init ($class)
409             # Start ($class, $tag, $attr => $value ...)
410             # Char ($class, $text)
411             # End ($class, $tag)
412             # Final ($class)
413              
414             my $psr = $xml_parser->new (
415             Handlers => {
416             Init => sub {
417 0     0   0 $root = [];
418 0         0 @tree = ($root);
419 0         0 @table = ();
420             },
421             Start => sub {
422 0     0   0 shift;
423 0         0 my $tag = shift;
424 0         0 my $item = [$tag, {@_}];
425 0         0 push @{$tree[-1]}, $item;
  0         0  
426 0         0 push @tree, $item;
427             },
428             Char => sub {
429 0     0   0 push @{$tree[-1]}, $_[1];
  0         0  
430             },
431             End => sub {
432 0     0   0 my $tag = $_[1];
433 0 0       0 die < 1;
434             Error - Unmatched end tag
435             eod
436 0 0       0 die <
437             Error - End tag does not match start tag <$tree[-1][0]>
438             eod
439              
440             # From here to the end of the subroutine is devoted to detecting
441             # the
tag and extracting the data of the table into what 442             # is hopefully a more usable format. Any relationship of tables 443             # to resources is lost. 444               445 0         0 my $element = pop @tree; 446 0 0       0 if ($element->[0] eq 'TABLE') { 447 0         0 my (@meta, @data, @descr); 448 0         0 foreach (@$element) { 449 0 0       0 next unless ARRAY_REF eq ref $_; 450 0 0       0 if ($_->[0] eq 'FIELD') {     0           451 0         0 push @meta, $_; 452 0         0 push @descr, $_; 453             } elsif ($_->[0] eq 'DATA') { 454 0         0 foreach (@$_) { 455 0 0       0 next unless ARRAY_REF eq ref $_; 456 0 0       0 next unless $_->[0] eq 'TABLEDATA'; 457 0         0 foreach (@$_) { 458 0 0       0 next unless ARRAY_REF eq ref $_; 459 0 0       0 next unless $_->[0] eq 'TR'; 460 0         0 my @row; 461 0         0 foreach (@$_) { 462 0 0       0 next unless ARRAY_REF eq ref $_; 463 0 0       0 next unless $_->[0] eq 'TD'; 464 0         0 my @inf = grep {!ref $_} @$_;   0         0   465 0         0 shift @inf; 466 0         0 push @row, join ' ', @inf; 467             } 468 0         0 push @data, \@row; 469             } 470             } 471             } else { 472 0         0 push @descr, $_; 473             } 474             } 475 0         0 foreach (@data) { 476 0         0 my $inx = 0; 477 0         0 @$_ = map { { 478 0 0 0     0 value => (defined $_ && $_ eq '~') 479             ? undef : $_, 480             meta => $meta[$inx++], 481             } } @$_; 482             } 483 0         0 push @to_strip, @descr; 484 0         0 push @table, { 485             data => \@data, 486             meta => [$element->[0], 487             $element->[1], @descr], 488             }; 489             } 490             }, 491             Final => sub { 492 0 0   0   0 die < 1; 493             Error - Missing end tags. 494             eod 495               496             ## _strip_empty ($root); 497             ## @$root; 498             # If the previous two lines were uncommented and the following two 499             # commented, the parser would return the parse tree for the 500             # VOTable. 501 0         0 _strip_empty (\@to_strip); 502 0         0 @table; 503             }, 504 0         0 }); 505 0 0       0 return map {$_ ? $psr->parse ($_) : ()} split '(?=<\?xml)', $data   0         0   506             } 507               508             } # End of local symbol block. 509               510             # _strip_empty (\@tree) 511             # 512             # splices out anything in the tree that is not a reference and 513             # does not match m/\S/. 514               515             sub _strip_empty { 516 0     0   0 my $ref = shift; 517 0         0 my $inx = @$ref; 518 0         0 while (--$inx >= 0) { 519 0         0 my $val = $ref->[$inx]; 520 0         0 my $typ = ref $val; 521 0 0       0 if ( ARRAY_REF eq $typ ) {     0           522 0         0 _strip_empty ($val); 523             } elsif (!$typ) { 524 0 0       0 splice @$ref, $inx, 1 unless $val =~ m/\S/ms; 525             } 526             } 527 0         0 return; 528             } 529               530             =item $result = $simbad->query ($query => @args); 531               532             This method is B, and will cease to work in April 2014. 533             Please choose a method that does not use SOAP. See the L 534             above for details. 535               536             This method issues a web services (SOAP) query to the SIMBAD database. 537             The $query specifies a SIMBAD query method, and the @args are the 538             arguments for that method. Valid $query values and the corresponding 539             SIMBAD methods and arguments are: 540               541             bib => queryObjectByBib ($bibcode, $format, $type) 542             coo => queryObjectByCoord ($coord, $radius, $format, $type) 543             id => queryObjectById ($id, $format, $type) 544               545             where: 546               547             $bibcode is a SIMBAD bibliographic code 548             $coord is a set of coordinates 549             $radius is an angular radius around the coordinates 550             $type is the type of data to be returned 551             $format is a format appropriate to the data type. 552               553             The $type defaults to the value of the L attribute, and 554             the $format defaults to the value of the L attribute 555             for the given $type. 556               557             The return value depends on a number of factors: 558               559             If the query found nothing, you get undef in scalar context, and an 560             empty list in list context. 561               562             If a L is defined for the given type, the returned 563             data will be fed to the parser, and the output of the parser will be 564             returned. This is assumed to be a list, so a reference to the list 565             will be used in scalar context. Parser exceptions are not trapped, 566             so the caller will need to be prepared to deal with malformed data. 567               568             Otherwise, the result of the query is returned as-is. 569               570             B that this functionality makes use of the 571             L module. As of version 0.026_01 of 572             C, L is not a prerequisite 573             of this module. If you wish to use the C method, you will have 574             to install L separately. This can be done after 575             C is installed. 576               577             =cut 578               579             { # Begin local symbol block 580               581             my %query_args = ( 582             id => { 583             type => 2, 584             format => 1, 585             method => 'queryObjectById', 586             }, 587             bib => { 588             type => 2, 589             format => 1, 590             method => 'queryObjectByBib', 591             }, 592             coo => { 593             type => 3, 594             format => 2, 595             method => 'queryObjectByCoord', 596             }, 597             ); 598               599             my %transform = ( 600             txt => sub { 601             local $_ = $_[0]; 602             s/\n//gm; 603             return $_ 604             }, 605             vo => sub { 606             local $_ = ref $_[0] ? join (',', @{$_[0]}) : $_[0]; 607             if ( defined $_ ) { 608             s/\s+/,/gms; 609             s/^,+//; 610             s/,+$//; 611             s/,+/,/g; 612             } 613             return $_ 614             }, 615             ); 616               617             my %make_script = ( 618             txt => sub { 619             my ( $self, $query, @args ) = @_; 620             return <<"EOD"; 621             format object "@{[ $transform{txt}->( $self->get( 'format' )->{txt} ) ]}" 622             query $query @args 623             EOD 624             }, 625             vo => sub { 626             my ( $self, $query, @args ) = @_; 627             return <<"EOD"; 628             votable myvo { 629             @{[ $transform{vo}->( $self->get( 'format' )->{vo} ) ]} 630             } 631             votable open myvo 632             query $query @args 633             votable close myvo 634             EOD 635             }, 636             ); 637               638             sub query { 639 2     2 1 8 my ( $self, $query, @args ) = @_; 640 2 50       7 if ( $self->get( 'emulate_soap_queries' ) ) { 641 2         8 my $type = $self->get( 'type' ); 642             my $code = $make_script{$type} || sub { 643 0     0   0 my ( undef, $query, @args ) = @_; # Invocant unused 644 0         0 return "query $query @args\n"; 645 2   50     12 }; 646 2         10 return $self->_script( 647             parser => $type, 648             script => $code->( $self, $query, @args ), 649             verbatim => 0, 650             ); 651             } 652 0         0 $self->_deprecation_notice( method => 'query', 'a non-SOAP method' ); 653 0 0       0 eval { _load_module( 'SOAP::Lite' ); 1 }   0         0     0         0   654             or croak 'Error - query() requires SOAP::Lite'; 655 0 0       0 eval { _load_module(   0         0   656 0         0 'Astro::SIMBAD::Client::WSQueryInterfaceService' ); 1 } 657             or croak "Programming Error - Can not load Astro::SIMBAD::Client::WSQueryInterfaceService: $@"; 658             croak "Error - Illegal query type '$query'" 659 0 0       0 unless $query_args{$query}; 660 0         0 my $method = $query_args{$query}{method}; 661 0 0       0 croak "Programming error - Illegal query $query method $method" 662             unless Astro::SIMBAD::Client::WSQueryInterfaceService->can ($method); 663 0         0 my $debug = $self->get ('debug'); 664 0         0 my $parser; 665 0 0       0 if (defined (my $type = $query_args{$query}{type})) { 666 0   0     0 $args[$type] ||= $self->get ('type'); 667 0 0       0 if (defined (my $format = $query_args{$query}{format})) { 668 0   0     0 $args[$format] ||= $self->get ('format')->{$args[$type]}; 669             $args[$format] = $transform{$args[$type]}->($args[$format]) 670 0 0       0 if $transform{$args[$type]}; 671 0 0       0 warn "$args[$type] format: $args[$format]\n" if $debug; 672 0 0       0 $args[$format] = undef unless $args[$format]; 673             } 674 0         0 $parser = $self->_get_parser ($args[$type]); 675             } 676 0 0       0 SOAP::Lite->import (+trace => $debug ? 'all' : '-all'); 677 0         0 $self->_delay (); 678             ## $debug and SOAP::Trace->import ('all'); 679 0         0 my $resp = Astro::SIMBAD::Client::WSQueryInterfaceService->$method( 680             $self, @args); 681 0 0       0 return unless defined $resp; 682 0         0 $resp = XML::DoubleEncodedEntities::decode ($resp); 683 0 0       0 return wantarray ? ($parser->($resp)) : [$parser->($resp)]     0           684             if $parser; 685 0         0 return $resp; 686             } 687               688             } # End local symbol block. 689               690             =item $value = $simbad->queryObjectByBib ($bibcode, $format, $type); 691               692             This method is B, and will cease to work on December 31 693             2018. Please choose a method that does not use SOAP. See the 694             L above for details. 695               696             This method is just a convenience wrapper for 697               698             $value = $simbad->query (bib => $bibcode, $format, $type); 699               700             See the query() documentation for more information. 701               702             =cut 703               704             sub queryObjectByBib { 705 0     0 1 0 my $self = shift; 706 0         0 return $self->query (bib => @_); 707             } 708               709             =item $value = $simbad->queryObjectByCoord ($coord, $radius, $format, $type); 710               711             This method is B, and will cease to work on December 31 712             2018. Please choose a method that does not use SOAP. See the 713             L above for details. 714               715             This method is just a convenience wrapper for 716               717             $value = $simbad->query (coo => $coord, $radius, $format, $type); 718               719             See the query() documentation for more information. 720               721             =cut 722               723             sub queryObjectByCoord { 724 0     0 1 0 my $self = shift; 725 0         0 return $self->query (coo => @_); 726             } 727               728             =item $value = $simbad->queryObjectById ($id, $format, $type); 729               730             This method is B, and will cease to work on December 31 731             2018. Please choose a method that does not use SOAP. See the 732             L above for details. 733               734             This method is just a convenience wrapper for 735               736             $value = $simbad->query (id => $id, $format, $type); 737               738             See the query() documentation for more information. 739               740             =cut 741               742             sub queryObjectById { 743 0     0 1 0 my $self = shift; 744 0         0 return $self->query (id => @_); 745             } 746               747             =item $release = $simbad->release (); 748               749             This method returns the current SIMBAD4 release, as scraped from the 750             top-level web page. This will look something like 'SIMBAD4 1.045 - 751             27-Jul-2007' 752               753             If called in list context, it returns ($major, $minor, $point, $patch, 754             $date). The returned information corresponding to the scalar example 755             above is: 756               757             $major => 4 758             $minor => 1 759             $point => 45 760             $patch => '' 761             $date => '27-Jul-2007' 762               763             The $patch will usually be empty, but occasionally you get something 764             like release '1.019a', in which case $patch would be 'a'. 765               766             Please note that this method is B based on a published interface, 767             but is simply a web page scraper, and subject to all the problems such 768             software is heir to. What the algorithm attempts to do is to find (and 769             parse, if called in list context) the contents of the next EtdE 770             after 'Release:' (case-insensitive). 771               772             =cut 773               774             sub release { 775 3     3 1 12 my $self = shift; 776 3         17 my $rslt = $self->_retrieve( 'simbad/' ); 777 3 50       167 my ($rls) = $rslt->content =~ 778             m{Release:.*?.*?(.*?)}sxi 779             or croak "Error - Release information not found"; 780 3         601 $rls =~ s{<.*?>}{}g; 781 3         20 $rls =~ s/^\s+//; 782 3         24 $rls =~ s/\s+$//; 783 3 100       98 wantarray or return $rls; 784 1         6 $rls =~ s/\s+-\s+/ /; 785 1 50       11 my ($major, $minor, $date) = split '\s+', $rls 786             or croak "Error - Release '$rls' is ill-formed"; 787 1         5 $major =~s/^\D+//; 788 1         3 $major += 0; 789 1         6 ($minor, my $point) = split '\.', $minor, 2; 790 1         3 $minor += 0; 791 1 50       7 ($point, my $patch) = $point =~ m/^(\d+)(.*)/ 792             or croak "Error - Release '$rls' is ill-formed: bad point"; 793 1 50       5 defined $patch or $patch = ''; 794 1         4 $point += 0; 795 1         24 return ($major, $minor, $point, $patch, $date); 796             } 797               798             =item $value = $simbad->script ($script); 799               800             This method submits the given script to SIMBAD4. The $script variable 801             contains the text if the script; if you want to submit a script file 802             by name, use the script_file() method. 803               804             If the L attribute is false, the front matter of the 805             result (up to and including the '::data:::::' line) is stripped. If 806             there is no '::data:::::' line, the entire script output is raised as an 807             exception. 808               809             If a 'script' L was specified, the output of the script 810             (after stripping front matter if that was specified) is passed to it. 811             The parser is presumed to return a list, so if script() was called in 812             scalar context you get a reference to that list back. 813               814             If no 'script' L is specified, the output of the script 815             (after stripping front matter if that was specified) is simply returned 816             to the caller. 817               818             =cut 819               820             sub script { 821 2     2 1 11 my ( $self, $script ) = @_; 822 2         10 return $self->_script( 823             parser => 'script', 824             script => $script, 825             verbatim => $self->get( 'verbatim' ), 826             ); 827             } 828               829             { 830             my %dflt = ( 831             parser => sub { return 'script' }, 832             script => sub { 833             confess 'Programming error - script argument required'; 834             }, 835             verbatim => sub { 836             my ( $self ) = @_; 837             return $self->get( 'verbatim' ); 838             }, 839             ); 840               841             sub _script { 842 4     4   27 my ( $self, %arg ) = @_; 843               844 4         19 foreach my $key ( keys %dflt ) { 845             defined $arg{$key} 846 12 50       34 or $arg{$key} = $dflt{$key}->( $self ); 847             } 848               849 4         15 my $debug = $self->get( 'debug' ); 850               851 4 50       16 $debug 852             and warn "Debug - script\n$arg{script} "; 853               854             my $resp = $self->_retrieve( 'simbad/sim-script', { 855             submit => 'submit+script', 856             script => $arg{script}, 857             }, 858 4         31 ); 859               860 4 50       186 my $rslt = $resp->content 861             or return; 862               863 4 50       211 unless ( $arg{verbatim} ) { 864 4 50       105 $rslt =~ s/.*?::data:+\s*//sm or croak $rslt; 865             } 866               867             $debug 868 4 50       21 and warn "Debug - result:\n$rslt "; 869               870 4         30 $rslt = XML::DoubleEncodedEntities::decode( $rslt ); 871 4 50       507 if ( my $parser = $self->_get_parser( $arg{parser} ) ) { 872 4 50       19 $debug 873             and warn "Debug - Parser $arg{parser}"; 874             ## $rslt =~ s/.*?::data:+.?$//sm or croak $rslt; 875 4         24 my @rslt = $parser->($rslt); 876             $debug 877 4 50       16 and eval { ## no critic (RequireCheckingReturnValueOfEval) 878 0         0 require YAML; 879 0         0 warn "Debug - Parsed to:\n", YAML::Dump( \@rslt ), ' '; 880             }; 881 4 50       89 return wantarray ? @rslt : \@rslt; 882             } else { 883 0 0       0 $debug 884             and warn "Debug - No parser for $arg{parser}"; 885 0         0 return $rslt; 886             } 887             } 888             } 889               890             =item $value = $simbad->script_file ($filename); 891               892             This method submits the given script file to SIMBAD, returning the 893             result of the script. Unlike script(), the argument is the name of the 894             file containing the script, not the text of the script. However, if a 895             parser for 'script' has been specified, it will be applied to the 896             output. 897               898             =cut 899               900             sub script_file { 901 2     2 1 7 my ( $self, $file ) = @_; 902               903 2         10 my $url = $self->__build_url( 'simbad/sim-script' ); 904 2         27 my $rqst = POST $url, 905             Content_Type => 'form-data', 906             Content => [ 907             submit => 'submit file', 908             scriptFile => [$file, undef], 909             # May need to specify Content_Type => application/octet-stream. 910             ]; 911 2         20865 my $resp = $self->_retrieve( $rqst ); 912               913 2 50       84 my $rslt = $resp->content or return; 914 2 50       58 unless ($self->get ('verbatim')) { 915 2 50       53 $rslt =~ s/.*?::data:+\s*//sm or croak $rslt; 916             } 917 2 50       15 if (my $parser = $self->_get_parser ('script')) { 918             ## $rslt =~ s/.*?::data:+.?$//sm or croak $rslt; 919             ## $rslt =~ s/\s+//sm; 920 2         9 my @rslt = $parser->($rslt); 921 2 50       42 return wantarray ? @rslt : \@rslt; 922             } else { 923 0         0 return $rslt; 924             } 925               926             } 927               928             =item $simbad->set ($name => $value ...); 929               930             This method sets the value of the given L. More 931             than one name/value pair may be specified. If called as a static method, 932             it sets the default value of the attribute. 933               934             =cut 935               936             { # Begin local symbol block. 937               938             my $ckpn = sub { 939             (looks_like_number ($_[2]) && $_[2] >= 0) 940             or croak "Attribute '$_[1]' must be a non-negative number"; 941             +$_[2]; 942             }; 943               944             my %mutator = ( 945             format => \&_set_hash, 946             parser => \&_set_hash, 947             scheme => \&_set_scheme, 948             url_args => \&_set_hash, 949             ); 950               951             my %transform = ( 952             delay => ($have_time_hires ? 953             $ckpn : 954             sub {+sprintf '%d', $ckpn->(@_) + .5}), 955             format => sub { 956             ## my ( $self, $name, $val, $key ) = @_; 957             my ( $self, undef, $val ) = @_; # Name and key unused 958             if ($val !~ m/\W/ && (my $code = eval { 959             $self->_get_coderef ($val)})) { 960             $val = $code->(); 961             } 962             $val; 963             }, 964             parser => sub { 965             ## my ( $self, $name, $val, $key ) = @_; 966             my ( $self, undef, $val ) = @_; # Name and key unused 967             if (!ref $val) { 968             unless ($val =~ m/::/) { 969             my $pkg = $self->_parse_subroutine_name ($val); 970             $val = $pkg . '::' . $val; 971             } 972             $self->_get_coderef ($val); # Just to see if we can. 973             } elsif ( CODE_REF ne ref $val ) { 974             croak "Error - $_[1] value must be scalar or code reference"; 975             } 976             $val; 977             }, 978             ); 979               980             foreach my $key (keys %static) { 981             $transform{$key} ||= sub {$_[2]}; 982             $mutator{$key} ||= sub { 983             my $hash = ref $_[0] ? $_[0] : \%static; 984             $hash->{$_[1]} = $transform{$_[1]}->(@_) 985             }; 986             } 987               988             sub set { 989 15     15 1 60 my ($self, @args) = @_; 990 0         0 croak "Error - First argument must be an @{[__PACKAGE__]} object" 991 15 50       33 unless eval {$self->isa(__PACKAGE__)};   15         90   992 15         55 while (@args) { 993 48         110 my $name = shift @args; 994             croak "Error - Attribute '$name' is unknown" 995 48 50       131 unless exists $mutator{$name}; 996 48         134 $mutator{$name}->($self, $name, shift @args); 997             } 998 14         40 return $self; 999             } 1000               1001             sub _set_hash { 1002 13     13   32 my ($self, $name, $value) = @_; 1003 13 50       38 my $hash = ref $self ? $self : \%static; 1004 13 100       42 unless (ref $value) { 1005 4 50       32 $value = {$value =~ m/=/ ? 1006             split ('=', $value, 2) : ($value => undef)}; 1007             } 1008 13 50       42 $hash->{$name} = {} if $value->{clear}; 1009 13         26 delete $value->{clear}; 1010 13         51 foreach my $key (keys %$value) { 1011 22         44 my $val = $value->{$key}; 1012 22 50       68 if (!defined $val) {     100           1013 0         0 delete $hash->{$name}{$key}; 1014             } elsif ($val) { 1015             $hash->{$name}{$key} = 1016 10         40 $transform{$name}->($self, $name, $value->{$key}, $key); 1017             } else { 1018 12         36 $hash->{$name}{$key} = ''; 1019             } 1020             } 1021 13         44 return; 1022             } 1023               1024             sub _set_scheme { 1025 6     6   21 my ( $self, $name, $value ) = @_; 1026 6 100       26 if ( my $msg = _is_scheme_valid( $value ) ) { 1027 1         255 croak $msg; 1028             } 1029 5 50       85 my $hash = ref $self ? $self : \%static; 1030 5         17 $hash->{$name} = lc $value; 1031 5         20 return; 1032             } 1033               1034             } # End local symbol block. 1035               1036             =item $value = $simbad->url_query ($type => ...) 1037               1038             This method performs a query by URL, returning the results. The type 1039             is one of: 1040               1041             id = query by identifier, 1042             coo = query by coordinates, 1043             ref = query by references, 1044             sam = query by criteria. 1045               1046             The arguments depend on on the type, and are documented at 1047             L. They are 1048             specified as name => value. For example: 1049               1050             $simbad->url_query (id => 1051             Ident => 'Arcturus', 1052             NbIdent => 1 1053             ); 1054               1055             Note that in an id query you must specify 'Ident' explicitly. This is 1056             true in general, because it is not always possible to derive the first 1057             argument name from the query type, and consistency was chosen over 1058             brevity. 1059               1060             The output.format argument can be defaulted based on the object's type 1061             setting as follows: 1062               1063             txt becomes 'ASCII', 1064             vo becomes 'VOTable'. 1065               1066             Any other value is passed verbatim. 1067               1068             If the query succeeds, the results will be passed to the appropriate 1069             parser if any. The reverse of the above translation is done to determine 1070             the appropriate parser, so the 'vo' parser (if any) is called if 1071             output.format is 'VOTable', and the 'txt' parser (if any) is called if 1072             output.format is 'ASCII'. If output.format is 'HTML', you will need to 1073             explicitly set up a parser for that. 1074               1075             The type of HTTP interaction depends on the setting of the L 1076             attribute: if true a POST is done; otherwise all arguments are tacked 1077             onto the end of the URL and a GET is done. 1078               1079             =cut 1080               1081             { # Begin local symbol block. 1082               1083             my %type_map = ( # Map SOAP type parameter to URL output.format. 1084             txt => 'ASCII', 1085             vo => 'VOTable', 1086             ); 1087             my %type_unmap = reverse %type_map; 1088               1089             # Perl::Critic objects to the use of @_ (rather than values 1090             # unpacked from it) but the parity check lets me give a less 1091             # unfriendly error message. CAVEAT: do NOT modify the contents 1092             # of @_, since this will be seen by the caller. Modifying @_ 1093             # itself is fine. 1094             sub url_query { ## no critic (RequireArgUnpacking) 1095 0 0   0 1 0 @_ % 2 and croak < 1096             Error - url_query needs an even number of arguments after the query 1097             type. 1098             eod 1099 0         0 my ($self, $query, %args) = @_; 1100             ### my $debug = $self->get ('debug'); 1101 0         0 my $dflt = $self->get ('url_args'); 1102 0         0 foreach my $key (keys %$dflt) { 1103 0 0       0 exists ($args{$key}) or $args{$key} = $dflt->{$key}; 1104             } 1105 0 0       0 unless ($args{'output.format'}) { 1106 0         0 my $type = $self->get ('type'); 1107 0   0     0 $args{'output.format'} = $type_map{$type} || $type; 1108             } 1109 0         0 my $resp = $self->_retrieve( "simbad/sim-$query", \%args ); 1110               1111 0         0 $resp = XML::DoubleEncodedEntities::decode ($resp->content); 1112               1113 0         0 my $parser; 1114 0 0       0 if (my $type = $type_unmap{$args{'output.format'}}) { 1115 0         0 $parser = $self->_get_parser ($type); 1116 0 0       0 return wantarray ? ($parser->($resp)) : [$parser->($resp)]     0           1117             if $parser; 1118             } 1119               1120 0         0 return $resp; 1121             } 1122               1123             } # End local symbol block. 1124               1125             ######################################################################## 1126             # 1127             # Utility routines 1128             # 1129               1130             # __build_url 1131             # 1132             # Builds a URL based on the currently-set scheme and server, and 1133             # the fragment provided as an argument. If the fragment is an 1134             # HTTP::Request object it is simply returned. 1135               1136             sub __build_url { 1137 17     17   13149 my ( $self, $fragment ) = @_; 1138 17 100       81 defined $fragment 1139             or $fragment = ''; 1140 17 100       39 eval { $fragment->isa( 'HTTP::Request' ) }   17         192   1141             and return $fragment; 1142 15         62 $fragment =~ s< \A / ><>smx; # Defensive programming 1143 15         58 return sprintf '%s://%s/%s', $self->get( 'scheme' ), 1144             $self->get( 'server' ), $fragment; 1145             } 1146               1147             # _callers_caller(); 1148             # 1149             # Returns the name of the subroutine that called the caller. 1150             # Results undefined if not called from a subroutine nested at 1151             # least two deep. 1152               1153             sub _callers_caller { 1154 0     0   0 my $inx = 1; 1155 0         0 my $caller; 1156 0         0 foreach ( 1 .. 2 ) { 1157 0         0 do { 1158 0         0 $caller = ( caller $inx++ )[3] 1159             } while '(eval)' eq $caller; 1160             } 1161 0         0 return $caller; 1162             } 1163               1164             # $self->_delay 1165             # 1166             # Delays the desired amount of time before issuing the next 1167             # query. 1168               1169             { 1170             my %last; 1171             sub _delay { 1172 9     9   53 my $self = shift; 1173 9   100     64 my $last = $last{$self->{server}} ||= 0; 1174 9 100       107 if ((my $delay = $last + $self->{delay} - time) > 0) { 1175 6         16855856 sleep ($delay); 1176             } 1177 9         277 return ($last{$self->{server}} = time); 1178             } 1179             } 1180               1181             # $self->_deprecation_notice( $type, $name ); 1182             # 1183             # This method centralizes deprecation. Type is 'attribute' or 1184             # 'method'. Deprecation is driven of the %deprecate hash. Values 1185             # are: 1186             # false - no warning 1187             # 1 - warn on first use 1188             # 2 - warn on each use 1189             # 3 - die on each use. 1190             # 1191             # $self->_deprecation_in_progress( $type, $name ) 1192             # 1193             # This method returns true if the deprecation is in progress. In 1194             # practice this means the %deprecate value is defined. 1195             # This is currently unused and commented out 1196               1197             { 1198               1199             my %deprecate = ( 1200             method => { 1201             query => 2, 1202             }, 1203             ); 1204               1205             sub _deprecation_notice { 1206 0     0   0 my ( undef, $type, $name, $repl ) = @_; # Invocant unused 1207 0 0       0 $deprecate{$type} or return; 1208 0 0       0 $deprecate{$type}{$name} or return; 1209             my $msg = sprintf 'The %s %s is %s', $name, $type, 1210 0 0       0 $deprecate{$type}{$name} > 2 ? 'removed' : 'deprecated'; 1211 0 0       0 defined $repl 1212             and $msg .= "; use $repl instead"; 1213 0 0       0 $deprecate{$type}{$name} >= 3 1214             and croak( $msg ); 1215 0 0       0 warnings::enabled( 'deprecated' ) 1216             and carp( $msg ); 1217             $deprecate{$type}{$name} == 1 1218 0 0       0 and $deprecate{$type}{$name} = 0; 1219 0         0 return; 1220             } 1221               1222             =begin comment 1223               1224             sub _deprecation_in_progress { 1225             my ( undef, $type, $name ) = @_; # Invocant unused 1226             $deprecate{$type} or return; 1227             return defined $deprecate{$type}{$name}; 1228             } 1229               1230             =end comment 1231               1232             =cut 1233               1234             } 1235               1236             # $ref = $self->_get_coderef ($string) 1237             # 1238             # Translates the given string into a code reference, loading 1239             # modules if needed. If the string is not a fully-qualified 1240             # subroutine name, it is assumed to be in the namespace of 1241             # the first caller not in this namespace. Failed loads are 1242             # cached so that they will not be tried again. 1243               1244             { 1245               1246             sub _get_coderef { 1247 10     10   26 my $self = shift; 1248 10         24 my $parser = shift; 1249 10 50 33     76 if ($parser && !ref $parser) { 1250 10         46 my ($pkg, $code) = 1251             $self->_parse_subroutine_name ($parser); 1252 10 50 33     121 unless (($parser = $pkg->can ($code)) || !$self->get ('autoload')) { 1253 0         0 _load_module ($pkg); 1254 0         0 $parser = $pkg->can ($code); 1255             } 1256 10 50       35 $parser or croak "Error - ${pkg}::$code undefined"; 1257             } 1258 10         46 return $parser; 1259             } 1260               1261             } 1262               1263             # $parser = $self->_get_parser ($type) 1264               1265             # returns the code reference to the parser for the given type of 1266             # data, or false if none. An exception is thrown if the value 1267             # is a string which does not specify a defined subroutine. 1268               1269             sub _get_parser { 1270 6     6   29 my ($self, $type) = @_; 1271 6         33 return $self->_get_coderef ($self->get ('parser')->{$type}); 1272             } 1273               1274             # Return false if the argument is a URI scheme we know how to deal with; 1275             # otherwise return an error message. The optional second argument is a 1276             # template for the message, with a single '%s' that gets the actual 1277             # value of the scheme. 1278               1279             { 1280             my %supported; 1281               1282             BEGIN { 1283 5     5   34 %supported = map { $_ => 1 } qw{ http https };   10         4921   1284             } 1285               1286             sub _is_scheme_valid { 1287 12     12   39 my ( $scheme, $msg ) = @_; 1288 12   100     49 $scheme = lc( $scheme || '' ); 1289 12   100     63 $msg ||= q; 1290 12 100       49 $supported{$scheme} 1291             or return sprintf $msg, $scheme; 1292 11 100       57 LWP::Protocol::implementor( $scheme ) 1293             and return; 1294 1         321 $msg .= "; have you installed LWP::Protocol::$scheme?"; 1295 1         52 return sprintf $msg, $scheme; 1296             } 1297             } 1298               1299             # $rslt = _load_module($name) 1300             # 1301             # This subroutine loads the named module using 'require'. It 1302             # croaks if the load fails, or returns the result of the 1303             # 'require' if it succeeds. Results are cached, so subsequent 1304             # calls simply do what the first one did. 1305               1306             { # Local symbol block. Oh, for 5.10 and state variables. 1307             my %error; 1308             my %rslt; 1309             sub _load_module { 1310 10     10   31 my ($module) = @_; 1311 10 50       42 exists $error{$module} and croak $error{$module}; 1312 10 50       28 exists $rslt{$module} and return $rslt{$module}; 1313 10         720 $rslt{$module} = eval "require $module"; 1314 10 50       1756 $@ and croak ($error{$module} = $@); 1315 0         0 return $rslt{$module}; 1316             } 1317             } # End local symbol block. 1318               1319             # $ua = _get_user_agent (); 1320             # 1321             # This subroutine returns an LWP::UserAgent object with its agent 1322             # string set to the default, with our class name and version 1323             # appended in parentheses. 1324               1325             sub _get_user_agent { 1326 9     9   95 my $ua = LWP::UserAgent->new ( 1327             ); 1328             ## $ua->agent ($ua->_agent . ' (' . __PACKAGE__ . ' ' . $VERSION . 1329             ## ')'); 1330 9         6439 $ua->agent (&agent); 1331 9         787 return $ua; 1332             } 1333               1334             # ($package, $subroutine) = $self->_parse_subroutine_name ($name); 1335             # 1336             # This method parses the given name, and returns the package name 1337             # in which the subroutine is defined and the subroutine name. If 1338             # the $name is a bare subroutine name, the package is the calling 1339             # package unless that package contains no such subroutine but 1340             # $self->can($name) is true, in which case the package is 1341             # ref($self). 1342             # 1343             # If called in scalar context, the package is returned. 1344               1345             sub _parse_subroutine_name { 1346 13     13   39 my ($self, $parser) = @_; 1347 13         53 my @parts = split '::', $parser; 1348 13         34 my $code = pop @parts; 1349 13         43 my $pkg = join '::', @parts; 1350 13 100       44 unless ($pkg) { 1351 4         14 my %tried = (__PACKAGE__, 1); 1352 4         10 my $inx = 1; 1353 4         40 while ($pkg = (caller ($inx++))[0]) { 1354 30 100       123 next if $tried{$pkg}; 1355 12         23 $tried{$pkg} = 1; 1356 12 50       118 last if $pkg->can ($code); 1357             } 1358 4 50 33     39 $pkg = ref $self if !$pkg && $self->can ($code); 1359 4 50       12 defined $pkg or croak < 1360             Error - '$parser' yields undefined package name. 1361             eod 1362 4         18 @parts = split '::', $pkg; 1363             } 1364 13 100       81 return wantarray ? ($pkg, $code) : $pkg; 1365             } 1366               1367             # my $resp = $self->_retrieve( $fragment, \%args ); 1368             # 1369             # Build a URL from the contents of the 'scheme' and 'server' 1370             # attributes, and the given fragment, and retrieve the data from 1371             # that URL. The \%args argument is optional. 1372             # 1373             # The return is an HTTP::Response object. If the response is 1374             # indicates that the request is unsuccessful we croak with the URL 1375             # (if that can be retrieved) and the status line. 1376             # 1377             # The details depend on the arguments and the state of the 1378             # invocant as follows: 1379             # 1380             # If $url is an HTTP::Request object, it is executed and the 1381             # response returned. Otherwise 1382             # 1383             # If \%args is present and not empty, and the 'post' attribute is 1384             # true, an HTTP post() request is done to the URL, sending the 1385             # data. Otherwise 1386             # 1387             # If there are arguments they are appended to the URL, and an HTTP 1388             # get() is done to the URL. 1389               1390             sub _retrieve { 1391 9     9   42 my ($self, $fragment, $args) = @_; 1392 9         46 my $url = $self->__build_url( $fragment ); 1393 9   100     63 $args ||= {}; 1394 9         34 my $debug = $self->get ('debug'); 1395 9         49 my $ua = _get_user_agent (); 1396 9         64 $self->_delay (); 1397 9         31 my $resp; 1398 9 100 66     44 if (eval {$url->isa('HTTP::Request')}) {   9 100       307   1399 2 50       19 $debug 1400             and print 'Debug ', _callers_caller(), 'executing ', 1401             $url->as_string, "\n"; 1402 2         25 $resp = $ua->request ($url); 1403             } elsif ($self->get ('post') && %$args) { 1404 4 50       22 if ($debug) { 1405 0         0 print 'Debug ', _callers_caller(), " posting to $url\n"; 1406 0         0 foreach my $key (sort keys %$args) { 1407 0         0 print " $key => $args->{$key}\n"; 1408             } 1409             } 1410 4         58 $resp = $ua->post ($url, $args); 1411             } else { 1412 3         10 my $join = '?'; 1413 3         27 foreach my $key (sort keys %$args) { 1414             $url .= $join . _escape_uri( $key ) . '=' . _escape_uri ( 1415 0         0 $args->{$key} ); 1416 0         0 $join = '&'; 1417             } 1418             $debug 1419 3 50       12 and print 'Debug ', _callers_caller(), " getting from $url\n"; 1420 3         25 $resp = $ua->get( $url ); 1421             } 1422 9 50       1671236 $debug 1423             and print 'Debug - request: ', $resp->request()->as_string(), "\n"; 1424               1425 9 50       67 $resp->is_success() 1426             and return $resp; 1427               1428 0 0         my $rq = $resp->request() 1429             or croak $resp->status_line(); 1430 0           my $u = $rq->uri(); 1431 0           croak "$u: ", $resp->status_line(); 1432             } 1433               1434             1; 1435               1436             __END__