package WWW::Metaweb::JSONLikePerl;

use 5.008006;
use strict;
use warnings;

use Exporter;

our @ISA	 = qw(Exporter);
our @EXPORT	 = qw();
our @EXPORT_OK	 = qw(jsonlp_fetch jsonlp_replace jsonlp_insert jsonlp_quote jsonlp_unquote);
our %EXPORT_TAGS = (standard => [qw(jsonlp_fetch jsonlp_replace jsonlp_insert jsonlp_quote jsonlp_unquote)]);
our $VERSION	= 0.01;

=head1 NAME

WWW::Metaweb::JSONLikePerl - Access a JSON string like a Perl structure

=head1 SYNOPSIS

  use strict;
  use WWW::Metaweb::JSONLikePerl qw(:standard);

  my json = qq({
        "cover_appearances": [
          {
            "part_of_series": "Runaways", 
            "type": "/comic_books/comic_book_issue", 
            "name": "Runaways Vol 1 #1"
          }, 
          {
            "part_of_series": "Runaways", 
            "type": "/comic_books/comic_book_issue", 
            "name": "Runaways Vol. 2 #1"
          }, 
          {
            "part_of_series": "Mystic Arcana", 
            "type": "/comic_books/comic_book_issue", 
            "name": "Mystic Arcana Book IV: Fire"
          }
        ], 
        "name": "Nico Minoru", 
        "created_by": ["Brian K. Vaughan"], 
        "/type/object/creator": "/user/metaweb", 
        "type": "/comic_books/comic_book_character", 
        "id": "/topic/en/nico_minoru"
  });

  my $id = $jsonlp_fetch('->{id}', $json);

  my new_json;

  $new_json = jsonlp_replace('->{cover_appearances}->[2]->{name}', $json, 'Mystic Arcana IV: Sister Grimm');

  $new_json = jsonlp_insert('->{created_by}', $json, 'Adrian Alphona');

  my $second_json = qq({
	  "query":{
		  "country":null,
		  "name":99507,
		  "type":["/location/postal_code"]
	  }
  });

  $new_json = jsonlp_quote('->{query}->{name}', $second_json, '"');

  $new_json = jsonlp_unquote('->{query}->{type}', $second_json);

=head1 ABSTRACT

WWW::Metaweb::JSONLikePerl allows manipulation of a JSON string, referencing items like a perl structure, but without actually converting the string.

=head1 EXPORTABLE FUNCTIONS

=over

=item B<< $value = jsonlp_fetch($structure_path, $json_string, [include_quotes]) >>

Returns the value of the item in C<$json_string> pointed to by C<$structure_path>.

If C<include_quotes> is true then whatever may be quoting the value being fetched will also be included, this may be 'C<{ }>' for a hash, 'C<[ ]>' for an array, 'C<" ">' for a string or make no difference if it's a number or bare word.

=cut

sub jsonlp_fetch  {
	my $pp = shift;
	my $js = shift;
	my $quoted = shift || 0;

	return jsonlp_traverse($pp, $js, { fetch_quoted => $quoted });
} # &jsonlp_fetch

=item B<< $new_json = jsonlp_replace($structure_path, $json_string, $replacement_value) >>

Replaces the specified JSON node with C<$replacement_value>.

=cut

sub jsonlp_replace  {
	my $pp = shift;
	my $js = shift;
	my $replacement = shift;

	return jsonlp_traverse($pp, $js, { replace => $replacement });
} # &jsonlp_replace

=item B<< $new_json = jsonlp_insert($structure_path, $json_string, $text_to_insert) >>

Inserts C<$text_to_insert> into the specified JSON node.

=cut

sub jsonlp_insert  {
	my $pp = shift;
	my $js = shift;
	my $insert = shift;

	return jsonlp_traverse($pp, $js, { insert => $insert });
} # &jsonlp_insert

=item B<< $new_json = jsonlp_quote($structure_path, $json_string, $quote_characters) >>

Quotes the specified node as specified by C<$quote_characters>.

If C<$quote_characters> has a length of 1 (such as 'C<">') the specified node will be surrounded by that character (eg. C<"994002">). If it has a length of 2 (such as 'C<{}>') the first character will go before the specified node, the second character will go acter the specified node (eg. C<{994002}>). Any other number o characters and C<undef> will be returned.

=cut

# Actually that's a lie, you can pass an empty string for $char and it will
# behave the same as unquote().

sub jsonlp_quote  {
	my $pp = shift;
	my $js = shift;
	my $char = shift;

	return (length $char >= 0 && length $char <= 2) ? jsonlp_traverse($pp, $js, { quote => $char }) : undef;
} # &jsonlp_quote

=item B<< $new_json = jsonlp_unquote($structure_path, $json_string) >>

Removes quotes from the specified node.

=cut

sub jsonlp_unquote  {
	my $pp = shift;
	my $js = shift;

	return jsonlp_traverse($pp, $js, { quote => '' });
} # &jsonlp_unquote

=back

=head1 BUGS AND TODO

None of either as of yet.

=head1 ACCKNOWLEDGEMENTS

Mainly the Barcelona weather for keeping me up late enough to come up with this crazy idea.

=head1 SEE ALSO

JSON, WWW::Metaweb

=head1 AUTHORS

Hayden Stainsby E<lt>hds@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Hayden Stainsby

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut

# jsonlp_traverse - Json like-perl traverse
# This function accepts a perl-like dereferencing / accessing string and a JSON
# string. It will either return the item pointed to - or set that item with a
# replacement and return the new string.
sub jsonlp_traverse  {
	my $pp = shift; # Perl path
	my $js = shift; # JSON string
	my $action = shift; # Replacement for JSON segment
	my $super_inside = shift; # What we're inside
	my ($path_segment, $path_index, $json_segment, $remaining_pp, $parsed_js);

	# This means we've hit the bottom of our parsing.
	if (length $pp == 0)  {
		if (defined $action->{replace})  {
			return $action->{replace};
		}
		elsif (defined $action->{insert})  {
			my $insert = $action->{insert};
			$insert .= ',' if length $js > 0;
			$js =~ s/^(\s*)/$1$insert$1/;
			return $js;
		}
		elsif (defined $action->{quote}) {
			my ($lq, $rq);
			if (length $action->{quote} == 2)  {
				$lq = substr $action->{quote}, 0, 1;
				$rq = substr $action->{quote}, 1, 1;
			}
			elsif (length $action->{quote} == 1)  {
				$lq = $rq = substr $action->{quote}, 0, 1;
			}
			else  {
				$lq = $rq = '';
			}
			
			return $lq.$js.$rq;
		}
		else  {
			return $js;
		}
	}

	# Parse perl path
	$remaining_pp = '';
	if ($pp =~ /^->(\{.+?\})(.*)$/)  {
		$path_segment = $1;
		$remaining_pp = $2;
		$path_segment =~ s/[\{\}]//g;
	}
	elsif ($pp =~ /^->(\[\d+\])(.*)$/)  {
		$path_index = $1;
		$remaining_pp = $2;
		$path_index =~ s/[\[\]]//g;
	}
	elsif ($pp eq '->')  {
		$pp = '';
	}

	# Parse JSON
	my $isquoted = 0;
	my $cur = { curly => 0, square => 0 };
	my $begin = undef;
	my $inside = undef;
	my $am_a = undef;
	my $depth = 0;
	my $content = undef;
	my $current_name = undef;
	my $current_value = undef;
	my $value_index = undef;
	my $parse_value;
	for (my $i = 0; $i < (length $js)+1; $i++)  {
		my $c = substr($js, $i, 1);
		# Get the beginning count for brackets before this character.
		$begin = { posn => $i,
			   curly => $cur->{curly},
			   square => $cur->{square} } unless defined $begin;
		
		# Count the openning and closing of curly and square brackets,
		# they don't count if they're in quotes.
		if ($isquoted)  {
			if ($c eq '"')  {
				$isquoted = 0;
			}
		}
		else  {
			   if ($c eq '{')  { $cur->{curly}++; }
			elsif ($c eq '}')  { $cur->{curly}--; }
			elsif ($c eq '[')  { $cur->{square}++; }
			elsif ($c eq ']')  { $cur->{square}--; }
			elsif ($c eq '"')  {
				$isquoted = 1;
			}
		}

		# We're not inside any sort of delimiters
		if (not defined $inside)  {
			# Check for the beginning of an object
			if ($c eq '{')  {
				$inside = 'HASH';
			}
			elsif ($c eq '[')  {
				$inside = 'ARRAY';
			}
			elsif ($c eq '"')  {
				$inside = 'STRING';
			}
			elsif ($c =~ /[\d\-\+]/)  {
				$inside = 'NUMBER';
				$depth = 1;
			}
			elsif ($c =~ /\w/)  {
				$inside = 'BARE';
				$depth = 1;
			}

			# We've entered an object, decide whether it's a key or
			# value and set the begin hash to what sort of object
			# we're inside.
			if (defined $inside)  {
				$begin->{inside} = $inside;

				if ((not defined $am_a) && $inside eq 'STRING' && ((not defined $super_inside) || $super_inside ne 'ARRAY'))  {
					$am_a = 'key';
				}
				elsif (not defined $am_a)  {
					$am_a = 'value';
				}
			}
			else  {
				# We're not inside an object, sratch begin, but
				# if we're on a ':' then a value is coming up.
				$begin = undef;
				if ((not defined $am_a) && $c eq ':')  {
					$am_a = 'value';
				}
			}

		}
		else  {
			# We can only end an object (leave inside) if the
			# bracket count is the same as before the object
			# started.
			my $matched = 0;
			$matched = 1 if ($begin->{curly} == $cur->{curly} && $begin->{square} == $cur->{square});

			if ($c eq '}' && $inside eq 'HASH' && $matched)  {
				$inside = undef;
			}
			elsif ($c eq ']' && $inside eq 'ARRAY' && $matched)  {
				$inside = undef;
			}
			elsif ($c eq '"' && $inside eq 'STRING' && $matched)  {
				$inside = undef;
			}
			elsif ($c !~ /[\d\.]/ && $inside eq 'NUMBER' && $matched)  {
				$content = substr($js, $i-$depth, $depth);
				$i--;
				$inside = undef;
			}
			elsif ($c !~ /\w/ && $inside eq 'BARE' && $matched)  {
				$content = substr($js, $i-$depth, $depth);
				$i--;
				$inside = undef;
			}
			else  {
				# We're going deeper into the object (in
				# characters).
				$depth++;
			}

			$content = substr($js, $i-$depth, $depth) unless defined $inside || defined $content;
		}

		# We've left an object (gone outside it), time to work.
		if ((not defined $inside) && (defined $content))  {
#debug			print "$content ($am_a)\n";
			if ($am_a eq 'key')  {
				# If it's a key, not much work to do.
				$current_name = $content;
				$current_value = undef;
				$value_index = 0;

			}
			elsif ($am_a eq 'value')  {
				# If this is an array, increase the value_index.
				if (defined $current_value)  {
					$value_index++;
				}
				else  {
					$value_index = 0;
				}
				$current_value = $content;

				my $returned = undef;
				my $traversed = 0;

				# Or if there's no name for this value and we
				# don't know what our outer structure is.
				if ((not defined $current_name) && (not defined $super_inside))  {
					$returned = jsonlp_traverse($pp, $content, $action, $begin->{inside});
					$traversed = 1
				}
				# If this value's name or index matches the perl
				# path (pp) we're following, recurse into it.
				elsif (((defined $path_index) && $value_index == $path_index) || ((defined defined $path_segment) && $current_name eq $path_segment))  {
					$returned = jsonlp_traverse($remaining_pp, $content, $action, $begin->{inside});
					$traversed = 1;
				}

				if ($traversed)  {
					# A value has been returned, that's
					# good, if we were replacing something
					# then replace it, otherwise return
					# just the value asked for.
					if (defined $returned)  {
						my $replace_delimeters = 0;
						print "fucked off!\n" unless defined $remaining_pp;
						$replace_delimeters = 1 if $begin->{inside} ne 'NUMBER' && $begin->{inside} ne 'BARE' && (length $remaining_pp) == 0;
						if (defined $action->{replace} || defined $action->{insert} || defined $action->{quote})  {
							my ($before, $after) = ('', '');

							$before = substr $js, 0, $begin->{posn} + (length $remaining_pp != 0 || defined $action->{insert});
							$after = substr $js, $begin->{posn} + length($content) + ($replace_delimeters*2) + (length $remaining_pp != 0) - (defined $action->{insert});
							$parsed_js = $before . $returned . $after;
						}
						else  {
							$parsed_js = $returned;
							if (length $remaining_pp == 0 && defined $super_inside && $action->{fetch_quoted})  {
								$parsed_js = substr($js, $begin->{posn}, (length $returned) + $replace_delimeters*2);
							}
						}
					}

					# Once a traversal has been attempted,
					# we're on our way out.
					last;
				}
			} # Finished a value
			
			# Still moving sideways, reset all these values.
			$begin = undef;
			$am_a = undef;
			$content = undef;
			$depth = 0;
		}
	} # iterate through each chacter

	return $parsed_js;
} # &jsonlp_traverse


return 1;
__END__