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__ |