added experimental JSON Pointer support

mojolicious · Dec 23, 2011 · eb1c2da · eb1c2da
1 parent 9121e68
commit eb1c2da
Show file tree

Hide file tree

Showing 9 changed files with 220 additions and 16 deletions.
diff --git a/Changes b/Changes
@@ -1,6 +1,7 @@
 This file documents the revision history for Perl extension Mojolicious.
 
 2.40    2011-12-23 00:00:00
+        - Added EXPERIMENTAL JSON Pointer support. (crab)
         - Improved inactivity timeouts by allowing them to be disabled.
         - Fixed repository to not favor specific editors.
 

diff --git a/lib/Mojo/JSON/Pointer.pm b/lib/Mojo/JSON/Pointer.pm
@@ -0,0 +1,76 @@
+package Mojo::JSON::Pointer;
+use Mojo::Base -base;
+
+use Mojo::Util 'url_unescape';
+use Scalar::Util 'looks_like_number';
+
+sub contains { shift->_pointer(1, @_) }
+sub get      { shift->_pointer(0, @_) }
+
+# "Google, even though you've enslaved half the world,
+#  you're still a damn fine search engine."
+sub _pointer {
+  my ($self, $contains, $data, $pointer) = @_;
+
+  # Parse pointer and walk data structure
+  return unless $pointer =~ s|^/||;
+  for my $p (split '/', $pointer) {
+    $p = url_unescape $p;
+    utf8::decode $p;
+
+    # Hash
+    if (ref $data eq 'HASH' && exists $data->{$p}) { $data = $data->{$p} }
+
+    # Array
+    elsif (ref $data eq 'ARRAY' && looks_like_number($p) && @$data > $p) {
+      $data = $data->[$p];
+    }
+
+    # Nothing
+    else {return}
+  }
+
+  return $contains ? 1 : $data;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Mojo::JSON::Pointer - JSON Pointers
+
+=head1 SYNOPSIS
+
+  use Mojo::JSON::Pointer;
+
+  my $p = Mojo::JSON::Pointer->new;
+  say $p->get({foo => [23, 'bar']}, '/foo/1');
+  say 'Contains "/foo".' if $p->contains({foo => [23, 'bar']}, '/foo');
+
+=head1 DESCRIPTION
+
+L<Mojo::JSON::Pointer> implements JSON Pointers as described in
+L<http://tools.ietf.org/html/draft-pbryan-zyp-json-pointer-02>. Note that
+this module is EXPERIMENTAL and might change without warning!
+
+=head1 METHODS
+
+=head2 C<contains>
+
+  my $success = $p->contains($data, '/foo/1');
+
+Check if data structure contains a value that can be identified with the
+given JSON Pointer.
+
+=head2 C<get>
+
+  my $value = $p->get($data, '/foo/bar');
+
+Extract value identified by the given JSON Pointer.
+
+=head1 SEE ALSO
+
+L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
+
+=cut
diff --git a/lib/Mojo/Message.pm b/lib/Mojo/Message.pm
@@ -6,6 +6,7 @@ use Mojo::Asset::Memory;
 use Mojo::Content::Single;
 use Mojo::DOM;
 use Mojo::JSON;
+use Mojo::JSON::Pointer;
 use Mojo::Parameters;
 use Mojo::Upload;
 use Mojo::Util qw/decode url_unescape/;
@@ -287,9 +288,10 @@ sub is_limit_exceeded {
 sub is_multipart { shift->content->is_multipart }
 
 sub json {
-  my $self = shift;
+  my ($self, $pointer) = @_;
   return if $self->is_multipart;
-  return $self->json_class->new->decode($self->body);
+  my $data = $self->json_class->new->decode($self->body);
+  return $pointer ? Mojo::JSON::Pointer->get($data, $pointer) : $data;
 }
 
 sub leftovers { shift->content->leftovers }
@@ -785,11 +787,15 @@ Check if message content is a L<Mojo::Content::MultiPart> object.
 
   my $object = $message->json;
   my $array  = $message->json;
+  my $value  = $message->json('/foo/bar');
 
 Decode JSON message body directly using L<Mojo::JSON> if possible, returns
-C<undef> otherwise.
+C<undef> otherwise. An optional JSON Pointer can be used to extract a
+specific value. Note that the JSON Pointer argument of this method is
+EXPERIMENTAL and might change without warning!
 
   say $message->json->{foo}->{bar}->[23];
+  say $message->json('/foo/bar/23');
 
 =head2 C<leftovers>
 

diff --git a/lib/Mojolicious/Command/get.pm b/lib/Mojolicious/Command/get.pm
@@ -4,6 +4,8 @@ use Mojo::Base 'Mojo::Command';
 use Getopt::Long 'GetOptions';
 use Mojo::DOM;
 use Mojo::IOLoop;
+use Mojo::JSON;
+use Mojo::JSON::Pointer;
 use Mojo::Transaction::HTTP;
 use Mojo::UserAgent;
 use Mojo::Util qw/decode encode/;
@@ -12,7 +14,7 @@ has description => <<'EOF';
 Perform HTTP 1.1 request.
 EOF
 has usage => <<"EOF";
-usage: $0 get [OPTIONS] URL [SELECTOR] [COMMANDS]
+usage: $0 get [OPTIONS] URL [SELECTOR|JSON-POINTER] [COMMANDS]
 
   mojo get /
   mojo get mojolicio.us
@@ -24,6 +26,7 @@ usage: $0 get [OPTIONS] URL [SELECTOR] [COMMANDS]
   mojo get mojolicio.us a attr href
   mojo get mojolicio.us '*' attr id
   mojo get mojolicio.us 'h1, h2, h3' 3 text
+  mojo get http://search.twitter.com/search.json /error
 
 These options are available:
   --charset <charset>     Charset of HTML5/XML content, defaults to auto
@@ -141,9 +144,21 @@ sub run {
   $url = encode 'UTF-8', $url;
   warn qq/Problem loading URL "$url". ($message)\n/ if $message && !$code;
 
-  # Select
-  $charset //= $tx->res->content->charset;
-  $self->_select($buffer, $charset, $selector) if $selector;
+  # JSON
+  return unless $selector;
+  return $self->_json($buffer, $selector)
+    if $tx->res->headers->content_type =~ /JSON/i;
+
+  # Selector
+  $self->_select($buffer, $charset // $tx->res->content->charset, $selector);
+}
+
+sub _json {
+  my ($self, $buffer, $pointer) = @_;
+  my $j = Mojo::JSON->new;
+  return unless my $data = $j->decode($buffer);
+  return unless $data = Mojo::JSON::Pointer->get($data, $pointer);
+  say ref $data eq 'HASH' || ref $data eq 'ARRAY' ? $j->encode($data) : $data;
 }
 
 sub _say {

diff --git a/lib/Mojolicious/Guides/Cookbook.pod b/lib/Mojolicious/Guides/Cookbook.pod
@@ -601,7 +601,8 @@ Just be aware that the resulting transactions will be in random order.
 
 Don't you hate checking huge HTML files from the command line?
 Thanks to the C<mojo get> command that is about to change. You can just pick
-the parts that actually matter with the CSS3 selectors from L<Mojo::DOM>.
+the parts that actually matter with the CSS3 selectors from L<Mojo::DOM> and
+JSON Pointers from L<Mojo::JSON::Pointer>.
 
   $ mojo get http://mojolicio.us 'head > title'
 
@@ -630,6 +631,10 @@ You can follow redirects and view the headers for all messages.
 
   $ mojo get --redirect --verbose http://reddit.com 'head > title'
 
+Extract just the information you really need from JSON data structures.
+
+  $ mojo get http://search.twitter.com/search.json /error
+
 This can be an invaluable tool for testing your applications.
 
   $ ./myapp.pl get /welcome 'head > title'

diff --git a/lib/Test/Mojo.pm b/lib/Test/Mojo.pm
@@ -164,13 +164,41 @@ sub header_unlike {
 }
 
 sub json_content_is {
-  my ($self, $struct, $desc) = @_;
+  my ($self, $data, $desc) = @_;
   local $Test::Builder::Level = $Test::Builder::Level + 1;
-  Test::More::is_deeply $self->tx->res->json, $struct,
+  Test::More::is_deeply $self->tx->res->json, $data,
     $desc || 'exact match for JSON structure';
   return $self;
 }
 
+sub json_is {
+  my ($self, $p, $data, $desc) = @_;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  Test::More::is_deeply $self->tx->res->json($p),
+    $data, $desc || qq/exact match for JSON Pointer "$p"/;
+  return $self;
+}
+
+sub json_has {
+  my ($self, $p, $desc) = @_;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  Test::More::ok(
+    Mojo::JSON::Pointer->contains($self->tx->res->json, $p),
+    $desc || qq/has value for JSON Pointer "$p"/
+  );
+  return $self;
+}
+
+sub json_hasnt {
+  my ($self, $p, $desc) = @_;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  Test::More::ok(
+    !Mojo::JSON::Pointer->contains($self->tx->res->json, $p),
+    $desc || qq/has no value for JSON Pointer "$p"/
+  );
+  return $self;
+}
+
 sub max_redirects {
   my $self = shift;
   return $self->ua->max_redirects unless @_;
@@ -559,11 +587,37 @@ Opposite of C<header_like>.
 =head2 C<json_content_is>
 
   $t = $t->json_content_is([1, 2, 3]);
-  $t = $t->json_content_is([1, 2, 3], 'right content!');
-  $t = $t->json_content_is({foo => 'bar', baz => 23}, 'right content!');
+  $t = $t->json_content_is([1, 2, 3], 'right content');
+  $t = $t->json_content_is({foo => 'bar', baz => 23}, 'right content');
 
 Check response content for JSON data.
 
+=head2 C<json_is>
+
+  $t = $t->json_is('/foo' => {bar => [1, 2, 3]});
+  $t = $t->json_is('/foo/bar' => [1, 2, 3]);
+  $t = $t->json_is('/foo/bar/1' => 2, 'right value');
+
+Check the value extracted from JSON response using the given JSON Pointer.
+Note that this method is EXPERIMENTAL and might change without warning!
+
+=head2 C<json_has>
+
+  $t = $t->json_has('/foo');
+  $t = $t->json_has('/minibar', 'has a minibar');
+
+Check if JSON response contains a value that can be identified with the given
+JSON Pointer. Note that this method is EXPERIMENTAL and might change without
+warning!
+
+=head2 C<json_hasnt>
+
+  $t = $t->json_hasnt('/foo');
+  $t = $t->json_hasnt('/minibar', 'no minibar');
+
+Opposite of C<json_has>. Note that this method is EXPERIMENTAL and might
+change without warning!
+
 =head2 C<max_redirects>
 
   my $max_redirects = $t->max_redirects;

diff --git a/t/mojo/json.t b/t/mojo/json.t
@@ -9,9 +9,8 @@ use Mojo::ByteStream 'b';
 # "We should be safe up here. I'm pretty sure fires can't climb trees."
 use_ok 'Mojo::JSON';
 
-my $json = Mojo::JSON->new;
-
 # Decode array
+my $json  = Mojo::JSON->new;
 my $array = $json->decode('[]');
 is_deeply $array, [], 'decode []';
 $array = $json->decode('[ [ ]]');

diff --git a/t/mojo/json_pointer.t b/t/mojo/json_pointer.t
@@ -0,0 +1,47 @@
+use Mojo::Base -strict;
+
+use utf8;
+
+use Test::More tests => 19;
+
+# "I've had it with this school, Skinner.
+#  Low test scores, class after class of ugly, ugly children..."
+use_ok 'Mojo::JSON::Pointer';
+
+# "contains" (hash)
+my $p = Mojo::JSON::Pointer->new;
+ok $p->contains({foo => 23}, '/foo'), 'contains "/foo"';
+ok !$p->contains({foo => 23}, '/bar'), 'does not contains "/bar"';
+ok $p->contains({foo => {bar => undef}}, '/foo/bar'), 'contains "/foo/bar"';
+
+# "contains" (mixed)
+ok $p->contains({foo => [0, 1, 2]}, '/foo/0'), 'contains "/foo/0"';
+ok !$p->contains({foo => [0, 1, 2]}, '/foo/9'), 'does not contain "/foo/9"';
+ok !$p->contains({foo => [0, 1, 2]}, '/foo/bar'),
+  'does not contain "/foo/bar"';
+ok !$p->contains({foo => [0, 1, 2]}, '/0'), 'does not contain "/0"';
+
+# "get" (hash)
+is $p->get({foo => 'bar'}, '/foo'), 'bar', '"/foo" is "bar"';
+is $p->get({foo => {bar => 42}}, '/foo/bar'), 42, '"/foo/bar" is "42"';
+is_deeply $p->get({foo => {23 => {baz => 0}}}, '/foo/23'), {baz => 0},
+  '"/foo/23" is "{baz => 0}"';
+
+# "get" (mixed)
+is_deeply $p->get({foo => {bar => [1, 2, 3]}}, '/foo/bar'), [1, 2, 3],
+  '"/foo/bar" is "[1, 2, 3]"';
+is $p->get({foo => {bar => [0, undef, 3]}}, '/foo/bar/0'), 0,
+  '"/foo/bar/0" is "0"';
+is $p->get({foo => {bar => [0, undef, 3]}}, '/foo/bar/1'), undef,
+  '"/foo/bar/1" is "undef"';
+is $p->get({foo => {bar => [0, undef, 3]}}, '/foo/bar/2'), 3,
+  '"/foo/bar/2" is "3"';
+is $p->get({foo => {bar => [0, undef, 3]}}, '/foo/bar/6'), undef,
+  '"/foo/bar/6" is "undef"';
+
+# "get" (encoded)
+is $p->get([{'foob ar' => 'foo'}], '/0/foob%20ar'), 'foo',
+  '"/0/foob%20ar" is "foo"';
+is $p->get([{'foo/bar' => 'bar'}], '/0/foo%2Fbar'), 'bar',
+  '"/0/foo%2Fbar" is "bar"';
+is $p->get({'♥' => [0, 1]}, '/%E2%99%A5/0'), 0, '"/%E2%99%A5/0" is "0"';
diff --git a/t/mojolicious/lite_app.t b/t/mojolicious/lite_app.t
@@ -9,7 +9,7 @@ BEGIN {
   $ENV{MOJO_MODE}       = 'development';
 }
 
-use Test::More tests => 711;
+use Test::More tests => 714;
 
 # "Wait you're the only friend I have...
 #  You really want a robot for a friend?
@@ -1169,7 +1169,8 @@ is $tx->res->body, '%E1', 'right content';
 $t->get_ok('/json')->status_is(200)->header_is(Server => 'Mojolicious (Perl)')
   ->header_is('X-Powered-By' => 'Mojolicious (Perl)')
   ->content_type_is('application/json')
-  ->json_content_is({foo => [1, -2, 3, 'b☃r']});
+  ->json_content_is({foo => [1, -2, 3, 'b☃r']})->json_is('/foo/3', 'b☃r')
+  ->json_has('/foo')->json_hasnt('/bar');
 
 # GET /autostash
 $t->get_ok('/autostash?bar=23')->status_is(200)