File Coverage

blib/lib/WWW/Metaweb.pm
Criterion Covered Total %
statement 99 287 34.4
branch 17 100 17.0
condition 6 61 9.8
subroutine 20 38 52.6
pod 28 28 100.0
total 170 514 33.0


line stmt bran cond sub pod time code
1             package WWW::Metaweb;
2              
3 5     5   147732 use 5.008006;
  5         139  
  5         216  
4 5     5   29 use strict;
  5         11  
  5         163  
5 5     5   25 use warnings;
  5         16  
  5         421  
6              
7 5     5   7145 use JSON::XS;
  5         69588  
  5         561  
8 5     5   10576 use LWP::UserAgent;
  5         357528  
  5         183  
9 5     5   60 use URI::Escape;
  5         11  
  5         429  
10 5     5   27 use HTTP::Request;
  5         11  
  5         116  
11 5     5   30 use Carp;
  5         7  
  5         289  
12              
13             # debugging
14 5     5   8438 use Data::Dumper;
  5         55847  
  5         28510  
15              
16             our $VERSION = '0.02';
17             our $errstr = '';
18              
19             =head1 NAME
20              
21             WWW::Metaweb - An interface to the Metaweb database via MQL
22              
23             =head1 SYNOPSIS
24              
25             use strict;
26             use WWW::Metaweb;
27              
28             my $mh = WWW::Metaweb->connect( username => $u,
29             password => $p,
30             server => 'www.freebase.com',
31             auth_uri => '/api/account/login',
32             read_uri => '/api/service/mqlread',
33             write_uri => '/api/service/mqlwrite',
34             trans_uri => '/api/trans',
35             pretty_json => 1 );
36              
37             my $query = {
38             '/type/object/creator' => undef,
39             cover_appearances => [{
40             type => '/comic_books/comic_book_issue',
41             name => undef,
42             part_of_series => undef
43             }],
44             created_by => [],
45             id => undef,
46             name => 'Nico Minoru',
47             type => '/comic_books/comic_book_character'
48             };
49              
50             The easy way:
51              
52             my $result = $mh->read($query, 'json');
53             print $result;
54              
55             The complicated way:
56              
57             $mh->add_query('read', $query);
58             $mh->send_envelope('read')
59             or die $WWW::Metaweb::errstr;
60              
61             my $result = $mh->result('read', 'json');
62             print $result . "\n";
63              
64             =head1 ABSTRACT
65              
66             WWW::Metaweb provides an interface to a Metaweb database through it's HTTP API and MQL.
67              
68             =head1 DESCRIPTION
69              
70             WWW::Metaweb provides an interface to a Metaweb database instance. The best example currently is Freebase (www.freebase.com). Queries to a Metaweb are made through HTTP requests to the Metaweb API.
71              
72             Qeueries are written in the Metaweb Query Language (MQL), using Javascript Object Notation (JSON). WWW::Metaweb allows you to write the actual JSON string yourself or provide a Perl array ref / hash ref structure to be converted to JSON.
73              
74             =head1 METHODS
75              
76             =head2 Class methods
77              
78             =over
79              
80             =item B<< $version = WWW::Metaweb->version >>
81              
82             Returns the version of WWW::Metaweb being used.
83              
84             =back
85              
86             =cut
87              
88             sub version {
89 1     1 1 993 return $WWW::Metaweb::VERSION;
90             } # ->version
91              
92             =head2 Constructors
93              
94             =over
95              
96             =item B<< $mh = WWW::Metaweb->connect( [option_key => 'option_value' ...] ) >>
97              
98             Returns a new WWW::Metaweb instance, a number of different attributes can be sethere (see below).
99              
100             If a C and C are supplied then C will attempt to authenticate before returning. If this authentication fails then C will be returned.
101              
102             =over
103              
104             =item B<< Metaweb parameters >>
105              
106             =over
107              
108             =item B<< auth_uri >>
109              
110             The URI used to authenticate for this Metaweb (eg. /api/account/login).
111              
112             =item B<< read_uri >>
113              
114             The URI used to submit a read MQL query to this Metaweb (eg. /api/service/mqlread).
115              
116             =item B<< write_uri >>
117              
118             The URI used to submit a write MQL query to this Metaweb (eg. /api/service/mqlwrite).
119              
120             =item B<< trans_uri >>
121              
122             The URI used to access the translation service for this Metaweb (eg. /api/trans). Please note this this URI does not include the actual C, at this time these are C, C and C.
123              
124             =back
125              
126             =item B<< JSON parameters >>
127              
128             =over
129              
130             =item B<< pretty_json >>
131              
132             Determines whether the response to a JSON query is formatted nicely. This is just passed along to the JSON object as Cnew->pretty($mh->{pretty})>.
133              
134             =item B<< json_preprocessor >>
135              
136             Can provide a reference to a sub-routine that pre-processes JSON queries, the sub-routine should expect one argument - the JSON query as a string and return the processed JSON query as a scalar.
137              
138             =back
139              
140             =back
141              
142             =cut
143              
144             sub connect {
145 3     3 1 80 my $invocant = shift;
146 3   33     28 my $class = ref($invocant) || $invocant;
147 3         8 my ($username, $password);
148              
149              
150 3         27 my $options = { @_ };
151 3 50 0     18 $username = $options->{username} || '' if exists $options->{username};
152 3 50 0     22 $password = $options->{password} || '' if exists $options->{password};
153 3         11 delete $options->{username};
154 3         10 delete $options->{password};
155              
156 3         230 my $self = {
157             auth_uri => undef,
158             read_uri => undef,
159             write_uri => undef,
160             trans_uri => undef,
161             read_envelope => { },
162             write_envelope => { },
163             result_envelope => { },
164             json_preprocessor => undef,
165             pretty_json => 0,
166             query_counter => 0,
167             debug => 0
168             };
169            
170 3         13 bless $self, $class;
171            
172 3         21 $self->server($options->{server}); # Sets the server.
173 3         10 delete $options->{server};
174             # Sets the option attributes from $options into $self.
175 3         16 foreach my $key (keys %$options) {
176 8 50       23 if (exists $self->{$key}) {
177 8         23 $self->{$key} = $options->{$key};
178             }
179             else {
180 0         0 carp "Unknown option '$key' used in connect().";
181             }
182             }
183              
184             # A little bit of vanity here (the agent).
185 3         48 $self->useragent(LWP::UserAgent->new( agent => 'Metaweb/'.$WWW::Metaweb::VERSION,
186             timeout => 10)
187             );
188              
189             # Attempt to authenticate if $username and $password are defined.
190             # As far as Freebase goes this is a required step right now.
191 3 50 33     23 if (defined $username && defined $password) {
192 0 0       0 $self = undef unless ($self->authenticate($username, $password));
193             }
194              
195 3         22 return $self;
196             } # ->connect
197              
198             =back
199              
200             =head2 Authentication
201              
202             =over
203              
204             =item B<< $mh->authenticate($username, $password) >>
205              
206             Authenticates to the auth_uri using the supplied username and password. If the authentication is successful then the cookie is retained for future queries.
207              
208             In the future this method may give the option to accept a cookie instead of username and password.
209              
210             =cut
211              
212             sub authenticate {
213 0     0 1 0 my $self = shift;
214 0         0 my ($username, $password) = @_;
215 0         0 my ($response, $raw_header, $credentials, @cookies);
216 0         0 my $login_url = $self->server.$self->{auth_uri};
217              
218              
219 0         0 $response = $self->useragent->post($login_url, { username => $username,
220             password => $password
221             });
222             # This would indicate some form of network problem (such as the server
223             # being down).
224 0 0       0 unless ($response->is_success) {
225 0         0 $WWW::Metaweb::errstr = 'Authentication HTTP request failed: ' . $response->status_line;
226 0         0 return undef;
227             }
228              
229 0 0       0 unless ($raw_header = $response->header('Set_Cookie')) {
230             # Authentication failed.
231 0         0 my $jsonxs = JSON::XS->new->utf8;
232 0         0 my $reply = $jsonxs->decode($response->content);
233 0         0 $WWW::Metaweb::errstr = "Login failed: [status: $reply->{status}, code: $reply->{code}]";
234            
235 0         0 return undef;
236             }
237 0         0 @cookies = split /,\s+/, $raw_header;
238 0         0 $credentials = '';
239 0         0 my $crumb_count = 0;
240 0         0 foreach my $cookie (@cookies) {
241 0         0 my @crumbs = split ';', $cookie;
242 0         0 $credentials .= ';';
243 0         0 $credentials .= $crumbs[0];
244             }
245              
246 0         0 $self->useragent->default_header('Cookie' => $credentials);
247 0         0 $self->{authenticated} = 1;
248              
249 0         0 return 1;
250             } # ->authenticate
251              
252             =back
253              
254             =head2 Easy Querying
255              
256             =over
257              
258             =item B<< @results = $mh->read($read_query [, $read_query2 ...] [, $format]) >> or B<< $result = $mh->read($read_query [, $format]) >>
259              
260             The easy way to perform a read query.
261              
262             Accepts one or more queries which are bundled up in one envelope and sent to the read service. The response is an array containing the results in the same order as the queries were given in.
263              
264             If only one query is given and assigned to a scaler then the single query will be returned as a scaler instead of in an array.
265              
266             =cut
267              
268             sub read {
269 1     1 1 9 my $self = shift;
270 1         37 my @read_queries = @_;
271 1         2 my ($i, $format);
272              
273 1         6 $self->clear_read_queries;
274            
275             # Add each query to the envelope and replace it's place in the array
276             # with the query name asigned to it.
277 1         5 for ($i = 0; $i < @read_queries; $i++) {
278 1 50 33     12 if ($read_queries[$i] eq 'perl' || $read_queries[$i] eq 'json') {
279 0         0 $format = $read_queries[$i];
280 0         0 delete $read_queries[$i];
281             }
282             else {
283 1         3 my $read_query = $read_queries[$i];
284 1         3 $read_queries[$i] = "query$i";
285              
286 1         5 $self->add_read_query($read_queries[$i] => $read_query);
287             #carp 'WWW::Metaweb - Bad format in read() - ($format = \'' . $read_queries[$i] . '\')';
288             #delete $read_queries[$i];
289             }
290             }
291              
292             # We're helpless if this fails, return undef and trust the errstr has
293             # been set further down.
294 0 0       0 return undef unless (defined $self->send_read_envelope);
295              
296             # Replace the query names in our array with the result of the query.
297 0         0 map { $_ = $self->result($_, $format); } @read_queries;
  0         0  
298              
299             # If there is only one result and an array hasn't been asked for, return
300             # the single value as a scaler instead.
301 0 0 0     0 return (@read_queries == 1 && not wantarray) ? $read_queries[0] : @read_queries;
302             } # ->read
303              
304             =item B<< @result = $mh->write($write_query [, $write_query2 ...] [, $format]) >> or B<< $result = $mh->write($write_query [, $format]) >>
305              
306             The easy way to perform a write query.
307              
308             The syntax and behaviour are exactly the same as C (above).
309              
310             =cut
311              
312             sub write {
313 0     0 1 0 my $self = shift;
314 0         0 my @write_queries = @_;
315 0         0 my ($i, $format);
316              
317             # This method works exactly the same as the read method.
318            
319 0         0 $self->clear_write_queries;
320            
321 0         0 for ($i = 0; $i < @write_queries; $i++) {
322 0 0 0     0 if ($write_queries[$i] eq 'perl' || $write_queries[$i] eq 'json') {
323 0         0 $format = $write_queries[$i];
324 0         0 delete $write_queries[$i];
325             }
326             else {
327 0         0 my $write_query = $write_queries[$i];
328 0         0 $write_queries[$i] = "query$i";
329              
330 0         0 $self->add_write_query($write_queries[$i] => $write_query);
331             }
332              
333             }
334              
335 0 0       0 return undef unless defined $self->send_write_envelope;
336              
337 0         0 map { $_ = $self->result($_, $format); } @write_queries;
  0         0  
338              
339 0 0 0     0 return (@write_queries == 1 && not wantarray) ? $write_queries[0] : @write_queries;
340             } # ->write
341              
342             =back
343              
344             =head2 Translation Service
345              
346             =over
347              
348             =item B<< $content = $mh->trans($translation, $guid) >>
349              
350             Gets the content for a C in the format specified by C<$translation>. Metaweb currently supports the translations C, C and C.
351              
352             C<$translation> is not checked for validity, but an error will most likely be returned by the server.
353              
354             C<$guid> should be the global identifier of a Metaweb object of type C or C and/or C depending on the translation requested, if not the Metaweb will return an error. The global identifier can be prefixed with either a '#' or the URI escaped version '%23' then followed by the usual string of lower case hex.
355              
356             =cut
357              
358             sub trans {
359 0     0 1 0 my $self = shift;
360 0         0 my $translation = shift;
361 0         0 my $guid = lc shift;
362 0         0 my ($url, $response);
363              
364             # Check that the guid looks mostly correct and replace a hash at the
365             # beginning of the guid with the URI escape code.
366 0 0       0 unless ($guid =~ s/^(\#|\%23)([\da-f]+)$/\%23$2/) {
367 0         0 $WWW::Metaweb::errstr = "Bad guid: $guid";
368 0         0 return undef;
369             }
370              
371 0         0 $url = $self->server.$self->{trans_uri}.'/'.$translation.'/'.$guid;
372 0         0 $response = $self->useragent->get($url);
373            
374             # An HTTP response that isn't success indicates something bad has
375             # happened and there's nothing I can do about it.
376 0 0       0 unless ($response->is_success) {
377 0         0 $WWW::Metaweb::errstr = "Trans query failed, HTTP response: " . $response->status_line;
378 0         0 return undef;
379             }
380              
381 0         0 return $response->content;
382             } # ->trans
383              
384             =item B<< $content = $mh->raw($guid) >>
385              
386             Convenience method for getting a C translation of the object with C<$guid>. See C for more details.
387              
388             =cut
389              
390             sub raw {
391 0     0 1 0 my $self = shift;
392 0         0 my $guid = shift;
393              
394 0         0 return $self->trans('raw', $guid);
395             } # ->raw
396              
397             =item B<< $content = $mh->image_thumb($guid) >>
398              
399             Convenience method for getting a C translation of the object with C<$guid>. See C for more details.
400              
401             =cut
402              
403             sub image_thumb {
404 0     0 1 0 my $self = shift;
405 0         0 my $guid = shift;
406              
407 0         0 return $self->trans('image_thumb', $guid);
408             } # ->image_thumb
409              
410             =item B<< $content = $mh->blurb($guid) >>
411              
412             Convenience method for getting a C translation of the object with C<$guid>. See C for more details.
413              
414             =cut
415              
416             sub blurb {
417 0     0 1 0 my $self = shift;
418 0         0 my $guid = shift;
419              
420 0         0 return $self->trans('blurb', $guid);
421             } # ->blurb
422              
423             =back
424              
425             =head2 Complicated Querying
426              
427             =over
428              
429             =item B<< $mh->add_query($method, query_name1 => $query1 [, query_name2 => $query2 [, ...]]) >>
430              
431             This method adds queries to a query envelope. C<$method> must have a value of either 'read' or 'write'.
432              
433             Each query must have a unique name, otherwise a new query will overwrite an old one. By the same token, if you wish to change a query in the query envelope, simply specify a new query with the old query name to overwrite the original.
434              
435             A query may either be specified as a Perl structure, or as a JSON string. The first example below is a query as a Perl structure.
436              
437             $query_perl = {
438             name => "Nico Minoru",
439             id => undef,
440             type => [],
441             '/comic_books/comic_book_character/cover_appearances' => [{
442             name => null
443             }]
444             };
445              
446             The same query as a JSON string:
447              
448             $query_json = '
449             {
450             "name":"Nico Minoru",
451             "id":null,
452             "type":[],
453             "/comic_books/comic_book_character/cover_appearances":[{
454             "name":null
455             }]
456             }';
457              
458             For the same of completeness this JSON query can be submitted the same way as in the query editor, a shortened version formatted like this is below:
459              
460             $query_json_ext = '
461             {
462             "query":{
463             "name":"Nico Minoru",
464             "type":[]
465             }
466             }';
467              
468             Now we can add all three queries specified above to the envelope with one call.
469              
470             $mh->add_query( query_perl => $query_perl, query_json => $query_json, query_json_ext => $query_json_ext );
471              
472             =cut
473              
474             sub add_query {
475 2     2 1 4 my $self = shift;
476 2         4 my $method = shift;
477 2         4 my ($envelope, $queries);
478              
479 2 50       8 return undef unless $envelope = __test_envelope($method, 'add_query');
480              
481 2 100 33     22 if (@_ == 1) {
    50          
482 1         1 my $query = shift;
483 1         3 $queries = { netmetawebquery => $query };
484             }
485             elsif (@_ > 1 && (@_ % 2) == 0) {
486 1         8 $queries = { @_ };
487             }
488             else {
489 0         0 $WWW::Metaweb::errstr = "Query name found with missing paired query. You probably have an odd number of query names and queries.";
490 0         0 return undef;
491             }
492              
493 2         4 my ($query_name, $query);
494 2         3 my $no_error = 1;
495 2         9 foreach $query_name (keys %$queries) {
496 2         4 $query = $queries->{$query_name};
497 2 50       10 $no_error = 0 unless $self->check_query_syntax($method, $queries->{$query_name});
498              
499 2 50 33     21 if (ref $query eq 'HASH' or ref $query eq 'ARRAY') {
    50          
500             # It's a Perl structure.
501 0 0 0     0 if (((ref $query) eq 'HASH' && (not defined $query->{query})) || ((ref $query) eq 'ARRAY' && (not defined $query->[0]->{query}))) {
      0        
      0        
502 0         0 $query = { query => $query };
503             }
504 0         0 $query->{anti_cache} = (time . $self->{query_counter}++);
505 0 0 0     0 $query->{cursor} = JSON::XS::true if $self->{auto_cursors} && not defined $query->{cursor};
506             }
507             elsif ((not ref $query)) {
508             # It's a JSON string - but we'll convert it to Perl and
509             # back again to manipulate it.
510 2         4 my ($jxs, $p_query);
511 2         640 $p_query = from_json($query);
512 0 0 0     0 if (((ref $p_query) eq 'HASH' && (not defined $p_query->{query})) || ((ref $p_query eq 'ARRAY') && (not defined $p_query->[0]->{query}))) {
      0        
      0        
513 0         0 $p_query = { query => $p_query };
514             }
515 0         0 $p_query->{anti_cache} = (time . $self->{query_counter}++);
516 0 0 0     0 $p_query->{cursor} = JSON::XS::true if $self->{auto_cursors} && not defined $query->{cursor};
517 0         0 $query = to_json($p_query);
518             }
519             # Now store it for sending.
520 0         0 $self->{$envelope}->{$query_name} = $query;
521             }
522              
523 0         0 return $no_error;
524             } # ->add_query
525              
526             =item B<< $mh->clear_queries($method) >>
527              
528             Clears all the previous queries from the envelope.
529              
530             C<$method> must be either 'read' or 'write'.
531              
532             =cut
533              
534             sub clear_queries {
535 1     1 1 1 my $self = shift;
536 1         2 my $method = shift;
537 1         2 my $envelope;
538              
539 1 50       5 return undef unless $envelope = __test_envelope($method, 'clear_envelope');
540              
541 1         5 $self->{$envelope} = { };
542              
543 1         3 return 1;
544             } # ->clear_queries
545              
546             =item B<< $count = $mh->query_count($method) >>
547              
548             Returns the number of queries held in the C<$method> query envelope.
549              
550             =cut
551              
552             sub query_count {
553 0     0 1 0 my $self = shift;
554 0         0 my $method = shift;
555 0         0 my ($envelope, @keys, $key_count);
556              
557 0 0       0 return undef unless $envelope = __test_envelope($method, 'query_count');
558 0         0 @keys = keys %{$self->{$envelope}};
  0         0  
559 0         0 $key_count = @keys;
560            
561 0         0 return $key_count;
562             } # ->query_count
563              
564             =item B<< $bool = $mh->check_query_syntax($method, $query) >>
565              
566             Returns a boolean value to indicate whether the query provided (either as a Perl structure or a JSON string) follows correct MQL syntax. C<$method> should be either 'read' or 'write' to indicate which syntax to check query against.
567              
568             Note: This method has not yet been implemented, it will always return TRUE.
569              
570             =cut
571              
572             sub check_query_syntax {
573 2     2 1 4 my $self = shift;
574 2         3 my $method = shift;
575 2         3 my $query = shift;
576              
577 2         9 return 1;
578             } # ->check_query_syntax
579              
580             =item B<< $http_was_successful = $mh->send_envelope($method) >>
581              
582             Sends the current query envelope and returns whether the HTTP portion was successful. This does not indicate that the query itself was well formed or correct.
583              
584             C<$method> must be either 'read' or 'write'.
585              
586             =cut
587              
588             sub send_envelope {
589 0     0 1 0 my $self = shift;
590 0         0 my $method = shift;
591 0         0 my $envelope;
592              
593 0 0       0 return undef unless $envelope = __test_envelope($method, 'send_envelope');
594              
595 0         0 my $jsonxs = JSON::XS->new->utf8;
596 0         0 my ($json_envelope, $url, $request, $response);
597              
598             # Create a list of pre-processors
599 0         0 my @preprocessors;
600 0 0       0 if (ref $self->{json_preprocessor} eq 'CODE') {
    0          
601 0         0 @preprocessors = ( $self->{json_preprocessor} );
602             }
603             elsif (ref $self->{json_preprocessor} eq 'ARRAY') {
604 0         0 foreach my $sub (@{$self->{json_preprocessor}}) {
  0         0  
605 0 0       0 push @preprocessors, $sub if (ref $sub eq 'CODE');
606             }
607             }
608            
609 0         0 my $first = 1;
610 0         0 $json_envelope = '{';
611 0         0 foreach my $query_name (keys %{$self->{$envelope}}) {
  0         0  
612 0 0       0 my $query = (ref $self->{$envelope}->{$query_name}) ? $jsonxs->encode($self->{$envelope}->{$query_name}) : $self->{$envelope}->{$query_name};
613             #$query =~ s/"format":"(?:json|perl)",//;
614              
615 0         0 foreach my $sub (@preprocessors) {
616 0         0 $query = &$sub($query);
617             }
618             # If the query has been botched - set it to an empty string.
619 0 0       0 $query = '' unless defined $query;
620              
621 0 0       0 $json_envelope .= ',' if $first == 0;
622 0         0 $json_envelope .= '"'.$query_name.'":'.$query;
623              
624 0         0 $first = 0;
625             }
626 0         0 $json_envelope .= '}';
627              
628 0 0       0 print $json_envelope . "\n" if $self->{debug};
629            
630             # Set up the request depending on whether this is a read or write op.
631 0         0 $request = HTTP::Request->new;
632 0         0 $request->header( 'X-Metaweb-Request' => 'True' );
633 0 0       0 if ($method eq 'read') {
634 0         0 $request->method('GET');
635 0         0 $request->uri($self->server.$self->{$method.'_uri'}.'?queries='.uri_escape($json_envelope));
636             }
637             else {
638 0         0 $request->method('POST');
639 0         0 $request->uri($self->server.$self->{$method.'_uri'});
640 0         0 $request->content_type('application/x-www-form-urlencoded');
641 0         0 $request->content('queries='.uri_escape($json_envelope));
642             }
643 0         0 $response = $self->useragent->request($request);
644              
645 0         0 $self->{last_envelope_sent} = $method;
646              
647 0 0       0 unless ($response->is_success) {
648 0         0 $WWW::Metaweb::errstr = "Query failed, HTTP response: " . $response->status_line;
649 0         0 return undef;
650             }
651            
652 0 0       0 return ($self->set_result($method, $response->content)) ? $response->is_success : undef;
653             } # ->send_envelope
654              
655             =back
656              
657             =head2 Query Convenience Methods (for complicated queries)
658              
659             As most of the query and result methods require a C<$method> argument as the first parameter, I've included methods to call them for each method explicitly.
660              
661             If you know that you will always be using a method call for either a read or a write query/result, then it's safer to user these methods as you'll get a compile time error if you spell read or write incorrectly (eg. a typo), rather than a run time error.
662              
663             Of course it's probably much easier to just use C and C from the L section above.
664              
665             =over
666              
667             =item B<< $mh->add_read_query(query_name1 => $query1 [, query_name2 => $query2 [, ...]]) >>
668              
669             Convenience method to add a read query. See C for details.
670              
671             =cut
672              
673             sub add_read_query {
674 2     2 1 782 my $self = shift;
675              
676 2         35 return $self->add_query('read', @_);
677             } # ->add_read_query
678              
679             =item B<< $mh->add_write_query(query_name1 => $query1 [, query_name2 => $query2 [, ...]]) >>
680              
681             Convenience method to add a write query. See C for details.
682              
683             =cut
684              
685             sub add_write_query {
686 0     0 1 0 my $self = shift;
687              
688 0         0 return $self->add_query('write', @_);
689             } # ->add_write_query
690              
691             =item B<< $mh->clear_read_queries >>
692              
693             Convenience method to clear the read envelope. See C for details.
694              
695             =cut
696              
697             sub clear_read_queries {
698 1     1 1 3 my $self = shift;
699              
700 1         6 return $self->clear_queries('read', @_);
701             } # ->clear_read_queries
702              
703             =item B<< $mh->clear_write_queries >>
704              
705             Convenience method to clear the write envelope. See C for details.
706              
707             =cut
708              
709             sub clear_write_queries {
710 0     0 1 0 my $self = shift;
711              
712 0         0 return $self->clear_queries('write', @_);
713             } # ->clear_write_queries
714              
715             =item B<< $count = $mh->read_query_count >>
716              
717             Convenience method, returns the number of queries in the read envelope. See C for details.
718              
719             =cut
720              
721             sub read_query_count {
722 0     0 1 0 my $self = shift;
723              
724 0         0 return $self->query_count('read', @_);
725             } # ->read_query_count
726              
727             =item B<< $count = $mh->write_query_count >>
728              
729             Convenience method, returns the number of queries in the write envelope. See C for details.
730              
731             =cut
732              
733             sub write_query_count {
734 0     0 1 0 my $self = shift;
735              
736 0         0 return $self->query_count('write', @_);
737             } # ->write_query_count
738              
739             =item B<< $http_was_successful = $mh->send_read_envelope >>
740              
741             Convenience method, sends the read envelope. See C for details.
742              
743             =cut
744              
745             sub send_read_envelope {
746 0     0 1 0 my $self = shift;
747              
748 0         0 return $self->send_envelope('read');
749             } # ->send_read_envelope
750              
751             =item B<< $http_was_successful = $mh->send_write_envelope >>
752              
753             Convenience method, sends the write envelope. See C for details.
754              
755             =cut
756              
757             sub send_write_envelope {
758 0     0 1 0 my $self = shift;
759              
760 0         0 return $self->send_envelope('write');
761             } # ->send_write_envelope
762              
763             =back
764              
765             =head2 Result manipulation (for complicated queries)
766              
767             =over
768              
769             =item B<< $mh->set_result($json) >>
770              
771             Sets the result envelope up so that results can be accessed for the latest query. Any previous results are destroyed.
772              
773             This method is mostly used internally.
774              
775             =cut
776              
777             sub set_result {
778 0     0 1 0 my $self = shift;
779 0         0 my $method = shift;
780 0         0 my $json_result = shift;
781 0         0 my $envelope;
782              
783 0 0       0 return undef unless $envelope = __test_envelope($method, 'set_result');
784            
785 0         0 $self->{result_envelope} = $json_result;
786 0         0 my $perl_result = from_json($json_result);
787              
788 0         0 my $status = $perl_result->{status};
789 0 0       0 unless ($status eq '200 OK') {
790 0         0 $WWW::Metaweb::errstr = 'Bad outer envelope status: ' . $status;
791 0         0 return 0;
792             }
793              
794 0         0 $self->{result_format} = { };
795 0         0 foreach my $query_name (keys %{$self->{$envelope}}) {
  0         0  
796 0 0       0 $self->{result_format}->{$query_name} = (ref $self->{$envelope}->{$query_name}) ? 'perl' : 'json';
797             }
798              
799 0         0 return 1;
800             } # ->set_result
801              
802             =item B<< $bool = $mh->result_is_ok($query_name) >>
803              
804             Returns a boolean result indicating whether the query named C<$query_name> returned a status ok. Returns C if there is no result for C.
805              
806             =cut
807              
808             sub result_is_ok {
809 0     0 1 0 my $self = shift;
810 0   0     0 my $query_name = shift || 'netmetawebquery';
811 0         0 my $result_is_ok = undef;
812              
813 0         0 my $result = from_json($self->{result_envelope})->{$query_name};
814 0 0       0 if (defined $result) {
815 0         0 my ($code, $message);
816 0         0 $code = $result->{code};
817 0 0       0 if ($code eq '/api/status/ok') {
818 0         0 $result_is_ok = 1;
819             }
820             else {
821 0         0 $message = $result->{messages}->[0]->{message};
822 0         0 $WWW::Metaweb::errstr = "Result status not okay for $query_name: $code; error: $message;";
823             }
824              
825             }
826             else {
827 0         0 $WWW::Metaweb::errstr = 'No result found for query name: ' . $query_name;
828 0         0 $result_is_ok = undef;
829             }
830            
831 0         0 return $result_is_ok;
832             } # ->result_is_okay
833              
834             =item B<< $mh->result($query_name [, $format]) >>
835              
836             Returns the result of query named C<$query_name> in the format C<$format>, which should be either 'perl' for a Perl structure or 'json' for a JSON string.
837              
838             if C<$query_name> is not defined then the default query name 'netmetawebquery' will be used instead.
839              
840             If C<$format> is not specified then the result is returned in the format the original query was supplied.
841              
842             Following the previous example, we have three separate results stored, so let's get each of them out.
843              
844             $result1 = $mh->result('query_perl');
845             $result2 = $mh->result('query_json');
846             $result3 = $mh->result('query_json_ext', 'perl');
847              
848             The first two results will be returned in the format their matching queries were submitted in - Perl structure and JSON string respectively - the third will be returned as a Perl structure, as it has been explicitly asked for in that format.
849              
850             Fetching a result does not effect it, so a result fetched in one format can be later fetched using another.
851              
852             =cut
853              
854             sub result {
855 0     0 1 0 my $self = shift;
856 0   0     0 my $query_name = shift || 'netmetawebquery';
857 0         0 my $format = shift;
858 0         0 my $result;
859             my $raw_result;
860 0         0 my $perl_result;
861              
862             # If the query isn't okay - just return undef, errstr will have been set
863 0 0       0 return undef unless $self->result_is_ok($query_name);
864              
865             # Check the return format if it hasn't been explicitly set.
866 0 0       0 $format = $self->{result_format}->{$query_name} unless defined $format;
867            
868 0         0 $JSON::UnMapping = 1;
869 0         0 $perl_result = from_json($self->{result_envelope})->{$query_name}->{result};
870              
871 0 0       0 if ($format eq 'json') {
872 0         0 $result = JSON::XS->new->utf8->pretty($self->{pretty_json})->encode($perl_result);
873             }
874             else {
875 0         0 $result = $perl_result;
876             }
877            
878 0         0 return $result;
879             } # ->result
880              
881             =item B<< $text = $mh->raw_result >>
882              
883             Returns the raw result from the last time an envelope was sent.
884              
885             After a successful query this will most likely be a JSON structure consisting of the outer envelope with the code and status as well as a result for each query sent in the last batch.
886              
887             After an unsuccessful query this will contain error messages detailing what went wrong as well as code and status sections to similar effect.
888              
889             If the transaction itself failed then the returned text will probably be empty, but at the very least this method will always return an empty string, never C.
890              
891             =cut
892              
893             sub raw_result {
894 0     0 1 0 my $self = shift;
895              
896 0   0     0 return $self->{result_envelope} || '';
897             } # ->raw_result
898              
899             =back
900              
901             =head2 Accessors
902              
903             =over
904              
905             =item B<< $ua = $mh->useragent >> or B<< $mh->useragent($ua) >>
906              
907             Gets or sets the LWP::UserAgent object which is used to communicate with the Metaweb. This method can be used to change the user agent settings (eg. C<$mh->useragent->timeout($seconds)>).
908              
909             =cut
910              
911             sub useragent {
912 3     3 1 19758 my $self = shift;
913 3         9 my $new_useragent = shift;
914              
915 3 50       23 $self->{ua} = $new_useragent if defined $new_useragent;
916              
917 3         10 return $self->{ua};
918             } # ->useragent
919              
920             =item B<< $host = $mh->server >> or B<< $mh->server($new_host) >>
921              
922             Gets or sets the host for this Metaweb (eg. www.freebase.com). No checking is currently done as to the validity of this host.
923              
924             =cut
925              
926             sub server {
927 3     3 1 8 my $self = shift;
928 3         9 my $new_server = shift;
929            
930 3 50       33 $self->{server} = $new_server if defined $new_server;
931 3 50       24 $self->{server} = 'http://'.$self->{server} unless $self->{server} =~ /^http:\/\//;
932              
933 3         9 return $self->{server};
934             } # ->server
935              
936             =back
937              
938             =head1 BUGS AND TODO
939              
940             Still very much in development. I'm waiting to hear from you.
941              
942             There is not query syntax checking - the method exists, but doesn't actually do anything.
943              
944             If authentication fails not much notice is given.
945              
946             More information needs to be given when a query fails.
947              
948             I would like to implement transparent cursors in read queries so a single query can fetch as many results as exist (rather than the standard 100 limit).
949              
950             =head1 ACKNOWLEDGEMENTS
951              
952             While entirely rewritten, I think it's only fair to mention that the basis for the core of this code is the Perl example on Freebase (http://www.freebase.com/view/helptopic?id=%239202a8c04000641f800000000544e139).
953              
954             Michael Jones has also been a great help - pointing out implementation issues and providing suggested fixes and code.
955              
956             =head1 SEE ALSO
957              
958             Freebase, Metaweb
959              
960             =head1 AUTHORS
961              
962             Hayden Stainsby Ehds@cpan.orgE
963              
964             =head1 COPYRIGHT AND LICENSE
965              
966             Copyright (C) 2007 by Hayden Stainsby
967              
968             This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
969              
970             =cut
971              
972             ################################################################################
973             # Below here are private functions - so no POD for here.
974              
975             # __test_envelope
976             # Tests that an envelope is either 'read' or 'write'. If it is, '_envelope' is
977             # appended and returned. If not, undef is returned and an error message is set.
978             sub __test_envelope {
979 3     3   5 my $envelope = shift;
980 3         6 my $method = shift;
981              
982 3 50 33     18 if ($envelope eq 'read' || $envelope eq 'write') {
983 3         7 $envelope .= '_envelope';
984             }
985             else {
986 0         0 $WWW::Metaweb::errstr = "Envelope must have a value of 'read' or 'write' in $method()";
987 0         0 $envelope = undef;
988             }
989              
990 3         14 return $envelope;
991             } # &__test_envelope
992              
993             return 1;
994             __END__