Toby Inkster avatar Toby Inkster committed 72df116

initial version

Comments (0)

Files changed (20)

+use inc::Module::Package 'RDF:tobyink 0.009';
+
+use 5.010;
+use JSON::MultiValueOrdered;
+
+my $json = JSON::MultiValueOrdered->new;
+my $data = $json->decode(q( {"a":1,"b":2,"b":3} ))
+	or die $json->error;
+
+say $json->encode($data);

lib/JSON/MultiValueOrdered.pm

+use 5.008;
+use strict;
+use warnings;
+
+{
+	package JSON::MultiValueOrdered;
+	
+	our $AUTHORITY = 'cpan:TOBYINK';
+	our $VERSION   = '0.001';
+	
+	use base qw(JSON::Tiny::Subclassable);
+	
+	use Tie::Hash::MultiValueOrdered ();
+	
+	sub _new_hash { tie my %h, 'Tie::Hash::MultiValueOrdered'; return \%h }
+	
+	sub _encode_object {
+		my $self = shift;
+		my $object = shift;
+		
+		my $indent;
+		if (exists $self->{_indent}) {
+			$indent = $self->{_indent};
+			$self->{_indent} .= "\t";
+		}
+		
+		my @pairs;
+		my $space = defined $indent ? q( ) : q();
+		my $tied = tied(%$object);
+		if ($tied and $tied->DOES('Tie::Hash::MultiValueOrdered')) {
+			my @list = $tied->pairs;
+			for (my $i = 0; $i < @list; $i+=2) {
+				push @pairs, sprintf(
+					'%s:%s%s',
+					$self->_encode_string($list[$i]),
+					$space,
+					$self->_encode_values($list[$i + 1]),
+				);
+			}
+		}
+		else {
+			while (my ($k, $v) = each %$object) {
+				push @pairs, sprintf(
+					'%s:%s%s',
+					$self->_encode_string($k),
+					$space,
+					$self->_encode_values($v),
+				);
+			}
+		}
+		
+		if (defined $indent)
+		{
+			$self->{_indent} =~ s/^.//;
+			return "{}" unless @pairs;
+			return "\{\n$indent\t" . join(",\n$indent\t", @pairs) . "\n$indent\}";
+		}
+		else
+		{
+			return '{' . join(',', @pairs) . '}';
+		}
+	}
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+JSON::MultiValueOrdered - handle JSON like {"a":1, "a":2}
+
+=head1 SYNOPSIS
+
+  use Test::More tests => 4;
+  use JSON::MultiValueOrdered;
+  
+  my $j = JSON::MultiValueOrdered->new;
+  isa_ok $j, 'JSON::Tiny';
+  
+  my $data = $j->decode(<<'JSON');
+  {
+    "a": 1,
+    "b": 2,
+    "a": 3,
+    "b": 4
+  }
+  JSON
+  
+  # As you'd expect, for repeated values, the last value is used
+  is_deeply(
+    $data,
+    { a => 3, b => 4 },
+  );
+  
+  # But hashes within the structure are tied to Tie::Hash::MultiValueOrdered
+  is_deeply(
+    [ tied(%$data)->get('b') ],
+    [ 2, 4 ],
+  );
+  
+  # And the extra information from the tied hash is used when re-encoding
+  is(
+    $j->encode($data),
+    q({"a":1,"b":2,"a":3,"b":4}),
+  );
+  
+  done_testing;
+
+=head1 DESCRIPTION
+
+The JSON specification allows keys to be repeated within objects. It remains
+silent on how repeated keys should be interpreted. Most JSON implementations
+end up choosing just one of the values; sometimes the first, sometimes the
+last.
+
+JSON::MultiValueOrdered is a subclass of L<JSON::Tiny> which treats objects as
+ordered lists of key-value pairs, with duplicate keys allowed. It achieves this
+by returning all hashes as tied using L<Tie::Hash::MultiValueOrdered>. While
+these hashes behave like standard Perl hashes (albeit while preserving the
+original order of the keys), they provide a tied object interface allowing you
+to retrieve additional values for each key.
+
+JSON::MultiValueOrdered serialisation also serialises these additional values
+and preserves order.
+
+JSON::MultiValueOrdered is a subclass of L<JSON::Tiny::Subclassable> and
+L<JSON::Tiny>, which is itself a fork of L<Mojo::JSON>. Except where noted,
+the methods listed below behave identically to the methods of the same names
+in the superclasses.
+
+=head2 Constructor
+
+=over
+
+=item C<< new(%attributes) >>
+
+=back
+
+=head2 Attributes
+
+=over
+
+=item C<< pretty >>
+
+=item C<< error >>
+
+=back
+
+=head2 Methods
+
+=over
+
+=item C<< decode($bytes) >>
+
+=item C<< encode($ref) >>
+
+=item C<< false >>
+
+=item C<< true >>
+
+=back
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=JSON-MultiValueOrdered>.
+
+=head1 SEE ALSO
+
+L<JSON::Tiny::Subclassable>,
+L<JSON::Tiny>,
+L<Mojo::JSON>.
+
+L<Tie::Hash::MultiValueOrdered>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

lib/JSON/Tiny/Subclassable.pm

+use 5.008;
+use strict;
+use warnings;
+
+{
+	package JSON::Tiny::Subclassable;
+
+	our $AUTHORITY = 'cpan:TOBYINK';
+	our $VERSION   = '0.001';
+
+	our @ISA = qw(JSON::Tiny);
+	
+	use B;
+	use Scalar::Util ();
+	use Encode ();
+	
+	sub new {
+		my $class = shift;
+		bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, $class;
+	}
+	
+	sub error {
+		$_[0]->{error} = $_[1] if @_ > 1;
+		return $_[0]->{error};
+	}
+	
+	sub pretty {
+		$_[0]->{pretty} = $_[1] if @_ > 1;
+		return $_[0]->{pretty};
+	}
+	
+	# Literal names
+	my $FALSE = bless \(my $false = 0), 'JSON::Tiny::_Bool';
+	my $TRUE  = bless \(my $true  = 1), 'JSON::Tiny::_Bool';
+	
+	# Escaped special character map (with u2028 and u2029)
+	my %ESCAPE = (
+		'"'     => '"',
+		'\\'    => '\\',
+		'/'     => '/',
+		'b'     => "\x07",
+		'f'     => "\x0C",
+		'n'     => "\x0A",
+		'r'     => "\x0D",
+		't'     => "\x09",
+		'u2028' => "\x{2028}",
+		'u2029' => "\x{2029}"
+	);
+	my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
+	for (0x00 .. 0x1F, 0x7F) { $REVERSE{pack 'C', $_} //= sprintf '\u%.4X', $_ }
+	
+	# Unicode encoding detection
+	my $UTF_PATTERNS = {
+		'UTF-32BE' => qr/^\0\0\0[^\0]/,
+		'UTF-16BE' => qr/^\0[^\0]\0[^\0]/,
+		'UTF-32LE' => qr/^[^\0]\0\0\0/,
+		'UTF-16LE' => qr/^[^\0]\0[^\0]\0/
+	};
+	
+	my $WHITESPACE_RE = qr/[\x20\x09\x0a\x0d]*/;
+	
+	sub DOES {
+		my ($proto, $role) = @_;
+		return 1 if $role eq 'Mojo::JSON';
+		return $proto->SUPER::DOES($role);
+	}
+	
+	sub decode {
+		my ($self, $bytes) = @_;
+		
+		# Cleanup
+		$self->error(undef);
+		
+		# Missing input
+		$self->error('Missing or empty input') and return undef unless $bytes; ## no critic (undef)
+		
+		# Remove BOM
+		$bytes =~ s/^(?:\357\273\277|\377\376\0\0|\0\0\376\377|\376\377|\377\376)//g;
+		
+		# Wide characters
+		$self->error('Wide character in input') and return undef ## no critic (undef)
+			unless utf8::downgrade($bytes, 1);
+		
+		# Detect and decode Unicode
+		my $encoding = 'UTF-8';
+		$bytes =~ $UTF_PATTERNS->{$_} and $encoding = $_ for keys %$UTF_PATTERNS;
+		
+		my $d_res = eval { $bytes = Encode::decode($encoding, $bytes, 1); 1 };
+		$bytes = undef unless $d_res;
+		
+		# Object or array
+		my $res = eval {
+			local $_ = $bytes;
+			
+			# Leading whitespace
+			m/\G$WHITESPACE_RE/gc;
+			
+			# Array
+			my $ref;
+			if (m/\G\[/gc) { $ref = $self->_decode_array() }
+			
+			# Object
+			elsif (m/\G\{/gc) { $ref = $self->_decode_object() }
+			
+			# Unexpected
+			else { $self->_exception('Expected array or object') }
+			
+			# Leftover data
+			unless (m/\G$WHITESPACE_RE\z/gc) {
+				my $got = ref $ref eq 'ARRAY' ? 'array' : 'object';
+				$self->_exception("Unexpected data after $got");
+			}
+			
+			$ref;
+		};
+		
+		# Exception
+		if (!$res && (my $e = $@)) {
+			chomp $e;
+			$self->error($e);
+		}
+		
+		return $res;
+	}
+	
+	sub encode {
+		my ($self, $ref) = @_;
+		
+		my $eof = '';
+		if ($self->pretty) {
+			$self->{_indent} = '';
+			$eof .= "\n";
+		}
+		
+		return Encode::encode 'UTF-8', $self->_encode_values($ref).$eof;
+	}
+	
+	sub false {$FALSE}
+	sub true  {$TRUE}
+	
+	sub _new_hash  {+{}}
+	sub _new_array {+[]}
+	
+	sub _decode_array {
+		my $self  = shift;
+		my $array = $self->_new_array;
+		until (m/\G$WHITESPACE_RE\]/gc) {
+			
+			# Value
+			push @$array, $self->_decode_value();
+			
+			# Separator
+			redo if m/\G$WHITESPACE_RE,/gc;
+			
+			# End
+			last if m/\G$WHITESPACE_RE\]/gc;
+			
+			# Invalid character
+			$self->_exception('Expected comma or right square bracket while parsing array');
+		}
+		
+		return $array;
+	}
+	
+	sub _decode_object {
+		my $self = shift;
+		my $hash = $self->_new_hash;
+		until (m/\G$WHITESPACE_RE\}/gc) {
+			
+			# Quote
+			m/\G$WHITESPACE_RE"/gc
+				or $self->_exception('Expected string while parsing object');
+			
+			# Key
+			my $key = $self->_decode_string();
+			
+			# Colon
+			m/\G$WHITESPACE_RE:/gc
+				or $self->_exception('Expected colon while parsing object');
+			
+			# Value
+			$hash->{$key} = $self->_decode_value();
+			
+			# Separator
+			redo if m/\G$WHITESPACE_RE,/gc;
+			
+			# End
+			last if m/\G$WHITESPACE_RE\}/gc;
+			
+			# Invalid character
+			$self->_exception('Expected comma or right curly bracket while parsing object');
+		}
+		
+		return $hash;
+	}
+	
+	sub _decode_string {
+		my $self = shift;
+		my $pos = pos;
+		
+		# Extract string with escaped characters
+		m#\G(((?:[^\x00-\x1F\\"]|\\(?:["\\/bfnrt]|u[[:xdigit:]]{4})){0,32766})*)#gc;
+		my $str = $1;
+		
+		# Missing quote
+		unless (m/\G"/gc) {
+			$self->_exception('Unexpected character or invalid escape while parsing string')
+				if m/\G[\x00-\x1F\\]/;
+			$self->_exception('Unterminated string');
+		}
+		
+		# Unescape popular characters
+		if (index($str, '\\u') < 0) {
+			$str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
+			return $str;
+		}
+		
+		# Unescape everything else
+		my $buffer = '';
+		while ($str =~ m/\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
+			$buffer .= $1;
+			
+			# Popular character
+			if ($2) { $buffer .= $ESCAPE{$2} }
+			
+			# Escaped
+			else {
+				my $ord = hex $3;
+				
+				# Surrogate pair
+				if (($ord & 0xF800) == 0xD800) {
+					
+					# High surrogate
+					($ord & 0xFC00) == 0xD800
+						or pos($_) = $pos + pos($str), $self->_exception('Missing high-surrogate');
+					
+					# Low surrogate
+					$str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
+						or pos($_) = $pos + pos($str), $self->_exception('Missing low-surrogate');
+					
+					# Pair
+					$ord = 0x10000 + ($ord - 0xD800) * 0x400 + (hex($1) - 0xDC00);
+				}
+				
+				# Character
+				$buffer .= pack 'U', $ord;
+			}
+		}
+		
+		# The rest
+		return $buffer . substr $str, pos($str), length($str);
+	}
+	
+	sub _decode_value {
+		my $self = shift;
+		
+		# Leading whitespace
+		m/\G$WHITESPACE_RE/gc;
+		
+		# String
+		return $self->_decode_string() if m/\G"/gc;
+		
+		# Array
+		return $self->_decode_array() if m/\G\[/gc;
+		
+		# Object
+		return $self->_decode_object() if m/\G\{/gc;
+		
+		# Number
+		return 0 + $1
+			if m/\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
+		
+		# True
+		return $self->true if m/\Gtrue/gc;
+		
+		# False
+		return $self->false if m/\Gfalse/gc;
+		
+		# Null
+		return undef if m/\Gnull/gc;  ## no critic (return)
+		
+		# Invalid data
+		$self->_exception('Expected string, array, object, number, boolean or null');
+	}
+	
+	sub _encode_array {
+		my $self = shift;
+		
+		return "[]" unless @{$_[0]};
+		
+		return '[' . join(',', map { $self->_encode_values($_) } @{shift()}) . ']'
+			unless exists $self->{_indent};
+		
+		my $indent = $self->{_indent};
+		return "\[\n$indent\t"
+			. join(",\n$indent\t", map {
+				local $self->{_indent} = "$indent\t"; $self->_encode_values($_)
+			} @{shift()})
+			. "\n$indent\]";
+	}
+	
+	sub _encode_object {
+		my $self = shift;
+		my $object = shift;
+		
+		my $indent;
+		if (exists $self->{_indent}) {
+			$indent = $self->{_indent};
+			$self->{_indent} .= "\t";
+		}
+		
+		# Encode pairs
+		my @pairs;
+		my $space = defined $indent ? q( ) : q();
+		while (my ($k, $v) = each %$object) {
+			push @pairs, sprintf(
+				'%s:%s%s',
+				$self->_encode_string($k),
+				$space,
+				$self->_encode_values($v),
+			);
+		}
+		
+		if (defined $indent)
+		{
+			$self->{_indent} =~ s/^.//;
+			return "{}" unless @pairs;
+			return "\{\n$indent\t" . join(",\n$indent\t", @pairs) . "\n$indent\}";
+		}
+		else
+		{
+			return '{' . join(',', @pairs) . '}';
+		}
+	}
+	
+	sub _encode_string {
+		my $self = shift;
+		my $string = shift;
+		
+		# Escape string
+		$string =~ s!([\x00-\x1F\x7F\x{2028}\x{2029}\\"/\b\f\n\r\t])!$REVERSE{$1}!gs;
+		
+		# Stringify
+		return "\"$string\"";
+	}
+	
+	sub _encode_values {
+		my $self = shift;
+		my $value = shift;
+		
+		# Reference
+		if (my $ref = ref $value) {
+			
+			# Array
+			return $self->_encode_array($value) if $ref eq 'ARRAY';
+			
+			# Object
+			return $self->_encode_object($value) if $ref eq 'HASH';
+			
+			# True or false
+			return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
+			return $value  ? 'true' : 'false' if $ref eq 'JSON::Tiny::_Bool';
+			
+			# Blessed reference with TO_JSON method
+			if (Scalar::Util::blessed $value && (my $sub = $value->can('TO_JSON'))) {
+				return $self->_encode_values($value->$sub);
+			}
+		}
+		
+		# Null
+		return 'null' unless defined $value;
+		
+		# Number
+		my $flags = B::svref_2object(\$value)->FLAGS;
+		return $value
+			if $flags & (B::SVp_IOK | B::SVp_NOK) && !($flags & B::SVp_POK);
+		
+		# String
+		return $self->_encode_string($value);
+	}
+	
+	sub _exception {
+		my $self = shift;
+		
+		# Leading whitespace
+		m/\G$WHITESPACE_RE/gc;
+		
+		# Context
+		my $context = 'Malformed JSON: ' . shift;
+		if (m/\G\z/gc) { $context .= ' before end of data' }
+		else {
+			my @lines = split /\n/, substr($_, 0, pos);
+			$context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
+		}
+		
+		# Throw
+		die "$context\n";
+	}
+}
+
+{
+	package JSON::Tiny::_Bool;
+	no warnings;
+	use overload
+		'0+' => sub { ${$_[0]} },
+		'""' => sub { ${$_[0]} },
+		fallback => 1,
+	;
+	sub DOES {
+		my ($proto, $role) = @_;
+		return 1 if $role eq 'Mojo::JSON::_Bool';
+		return 1 if $role =~ /^JSON::(?:PP::|XS::)?Boolean$/;
+		return $proto->SUPER::DOES($role);
+	}
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+JSON::Tiny::Subclassable
+
+=head1 DESCRIPTION
+
+Although technically this is a subclass of L<JSON::Tiny>, in practice
+it's a fork because it overrides every method, and never calls the
+supermethods. In fact, even though this is a subclass of L<JSON::Tiny>,
+you don't need to have the latter installed to use this module.
+
+The main difference between this module and its parent is that all the
+internal calls to private functions have been replaces with calls to
+private methods. This makes it easy to override particular parts of the
+JSON parsing/generation algorithm.
+
+The other tiny added feature is to support pretty indented output.
+
+This module was written was to make developing L<JSON::MultiValueOrdered>
+simpler, but it may be of some use for other purposes as well.
+
+JSON::Tiny::Subclassable is a subclass of L<JSON::Tiny>, which is itself a
+fork of L<Mojo::JSON>. Except where noted, the methods listed below behave
+identically to the methods of the same names in the superclass.
+
+=head2 Constructor
+
+=over
+
+=item C<< new(%attributes) >>
+
+=back
+
+=head2 Attributes
+
+=over
+
+=item C<< pretty >>
+
+If set to true, indents generated JSON in a pretty fashion.
+
+=item C<< error >>
+
+=back
+
+=head2 Methods
+
+=over
+
+=item C<< decode($bytes) >>
+
+=item C<< encode($ref) >>
+
+=item C<< false >>
+
+=item C<< true >>
+
+=item C<< DOES($role) >>
+
+As per L<UNIVERSAL>::C<DOES>. Returns true for L<Mojo::DOM>.
+
+=back
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=JSON-MultiValueOrdered>.
+
+=head1 SEE ALSO
+
+L<JSON::Tiny>,
+L<Mojo::JSON>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

lib/Tie/Hash/MultiValueOrdered.pm

+use 5.008;
+use strict;
+use warnings;
+
+{
+	package Tie::Hash::MultiValueOrdered;
+	
+	our $AUTHORITY = 'cpan:TOBYINK';
+	our $VERSION   = '0.001';
+	
+	use constant {
+		IDX_DATA  => 0,
+		IDX_ORDER => 1,
+		IDX_LAST  => 2,
+		IDX_SEEN  => 3,
+		IDX_MODE  => 4,
+		NEXT_IDX  => 5,
+	};
+	use constant {
+		MODE_LAST  => -1,
+		MODE_FIRST => 0,
+		MODE_REF   => 'ref',
+		MODE_ITER  => 'iter',
+	};
+	
+	sub fetch_first    { $_[0][IDX_MODE] = MODE_FIRST }
+	sub fetch_last     { $_[0][IDX_MODE] = MODE_LAST }
+	sub fetch_list     { $_[0][IDX_MODE] = MODE_REF }
+	sub fetch_iterator { $_[0][IDX_MODE] = MODE_ITER }
+	
+	use Storable qw( dclone );
+	sub TIEHASH {
+		my $class = shift;
+		bless [{}, [], 0, {}, -1], $class;
+	}
+	sub STORE {
+		my ($tied, $key, $value) = @_;
+		$key = "$key";
+		push @{$tied->[IDX_ORDER]}, $key;
+		push @{$tied->[IDX_DATA]{$key}}, $value;
+	}
+	sub FETCH {
+		my ($tied, $key) = @_;
+		my $mode = $tied->[IDX_MODE];
+		if ($mode eq 'ref')
+		{
+			return $tied->[IDX_DATA]{$key} || [];
+		}
+		elsif ($mode eq 'iter')
+		{
+			my @values = @{ $tied->[IDX_DATA]{$key} || [] };
+			return sub { shift @values };
+		}
+		else
+		{
+			return unless exists $tied->[IDX_DATA]{"$key"};
+			return $tied->[IDX_DATA]{$key}[$mode];
+		}
+	}
+	sub EXISTS {
+		my ($tied, $key) = @_;
+		return exists $tied->[IDX_DATA]{"$key"};
+	}
+	sub DELETE {
+		my ($tied, $key) = @_;
+		my $r = delete $tied->[IDX_DATA]{"$key"};
+		return $r->[-1] if $r;
+		return;
+	}
+	sub CLEAR {
+		my $tied = shift;
+		$tied->[IDX_DATA]  = {};
+		$tied->[IDX_ORDER] = [];
+		$tied->[IDX_LAST]  = 0;
+		$tied->[IDX_SEEN]  = {};
+		return;
+	}
+	sub FIRSTKEY {
+		my $tied = shift;
+		$tied->[IDX_LAST] = -1;
+		$tied->[IDX_SEEN] = {};
+		return $tied->NEXTKEY;
+	}
+	sub NEXTKEY {
+		no warnings qw(uninitialized);
+		my $tied = shift;
+		my $i = ++$tied->[IDX_LAST];
+		$i++ while $tied->[IDX_SEEN]{ $tied->[IDX_ORDER][$i] };
+		$tied->[IDX_SEEN]{ $tied->[IDX_ORDER][$i] }++;
+		my $key = $tied->[IDX_ORDER][$i];
+		if (wantarray) {
+			return (
+				$tied->[IDX_ORDER][$i],
+				$tied->FETCH( $tied->[IDX_ORDER][$i] ),
+			);
+		}
+		return $tied->[IDX_ORDER][$i];
+	}
+	sub get {
+		my ($tied, $key) = @_;
+		return my @list = @{ $tied->[IDX_DATA]{"$key"} || [] };
+	}
+	sub pairs {
+		my $tied = shift;
+		my $clone = dclone( $tied->[IDX_DATA] );
+		return map {
+			$_, shift @{$clone->{$_}}
+		} @{$tied->[IDX_ORDER]}
+	}
+	sub pair_refs {
+		my $tied = shift;
+		my $clone = dclone( $tied->[IDX_DATA] );
+		return map {
+			[ $_, shift @{$clone->{$_}} ]
+		} @{$tied->[IDX_ORDER]}
+	}
+	sub all_keys {
+		my $tied = shift;
+		return @{$tied->[IDX_ORDER]};
+	}
+	sub keys {
+		my $tied = shift;
+		my %seen;
+		return grep { not $seen{$_}++ } @{$tied->[IDX_ORDER]};
+	}
+	sub rr_keys {
+		my $tied = shift;
+		my %seen;
+		return reverse grep { not $seen{$_}++ } reverse @{$tied->[IDX_ORDER]};
+	}
+	sub all_values {
+		my $tied = shift;
+		my $alt = 1;
+		return grep { $alt=!$alt } $tied->pairs;
+	}
+	sub values {
+		my $tied = shift;
+		return map { $tied->[IDX_DATA]{$_}[-1] } $tied->keys;
+	}
+	sub rr_values {
+		my $tied = shift;
+		return map { $tied->[IDX_DATA]{$_}[0] } $tied->keys;
+	}
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Tie::Hash::MultiValueOrdered - hash with multiple values per key, and ordered keys
+
+=head1 SYNOPSIS
+
+	use Test::More;
+	use Tie::Hash::MultiValueOrdered;
+	
+	my $tied = tie my %hash, "Tie::Hash::MultiValueOrdered";
+	
+	$hash{a} = 1;
+	$hash{b} = 2;
+	$hash{a} = 3;
+	$hash{b} = 4;
+	
+	# Order of keys is predictable
+	is_deeply(
+		[ keys %hash ],
+		[ qw( a b ) ],
+	);
+	
+	# Order of values is predictable
+	# Note that the last values of 'a' and 'b' are returned.
+	is_deeply(
+		[ values %hash ],
+		[ qw( 3 4 ) ],
+	);
+	
+	# Can retrieve list of all key-value pairs
+	is_deeply(
+		[ $tied->pairs ],
+		[ qw( a 1 b 2 a 3 b 4 ) ],
+	);
+	
+	# Switch the retrieval mode for the hash.
+	$tied->fetch_first;
+	
+	# Now the first values of 'a' and 'b' are returned.
+	is_deeply(
+		[ values %hash ],
+		[ qw( 1 2 ) ],
+	);
+	
+	# Switch the retrieval mode for the hash.
+	$tied->fetch_list;
+	
+	# Now arrayrefs are returned.
+	is_deeply(
+		[ values %hash ],
+		[ [1,3], [2,4] ],
+	);
+	
+	# Restore the default retrieval mode for the hash.
+	$tied->fetch_last;
+	
+	done_testing;
+
+=head1 DESCRIPTION
+
+A hash tied to this class acts more or less like a standard hash, except that
+when you assign a new value to an existing key, the old value is retained
+underneath. An explicit C<delete> deletes all values associated with a key.
+
+By default, the old values are inaccessible through the hash interface, but
+can be retrieved via the tied object:
+
+	my @values = tied(%hash)->get($key);
+
+However, the C<< fetch_* >> methods provide a means to alter the behaviour of
+the hash.
+
+=head2 Tied Object Methods
+
+=over
+
+=item C<< pairs >>
+
+Returns all the hash's key-value pairs (including duplicates) as a flattened
+list.
+
+=item C<< pair_refs >>
+
+Returns all the hash's key-value pairs (including duplicates) as a list of two
+item arrayrefs.
+
+=item C<< get($key) >>
+
+Returns the list of all values associated with a key.
+
+=item C<< keys >>
+
+The list of all hash keys in their original order. Where a key is duplicated,
+only the first occurance is returned.
+
+=item C<< rr_keys >>
+
+The list of all hash keys in their original order. Where a key is duplicated,
+only the last occurance is returned.
+
+=item C<< all_keys >>
+
+The list of all hash keys in their original order, including duplicates.
+
+=item C<< values >>
+
+The values correponding to C<keys>.
+
+=item C<< rr_values >>
+
+The values correponding to C<rr_keys>.
+
+=item C<< all_values >>
+
+The values correponding to C<all_keys>.
+
+=back
+
+=head2 Fetch Styles
+
+=over
+
+=item C<< fetch_last >>
+
+This is the default style of fetching.
+
+	tie my %hash, "Tie::Hash::MultiValueOrdered";
+	
+	$hash{a} = 1;
+	$hash{b} = 2;
+	$hash{b} = 3;
+	
+	tied(%hash)->fetch_last;
+	
+	is($hash{a}, 1);
+	is($hash{b}, 3);
+
+=item C<< fetch_first >>
+
+	tie my %hash, "Tie::Hash::MultiValueOrdered";
+	
+	$hash{a} = 1;
+	$hash{b} = 2;
+	$hash{b} = 3;
+	
+	tied(%hash)->fetch_first;
+	
+	is($hash{a}, 1);
+	is($hash{b}, 2);
+
+=item C<< fetch_list >>
+
+	tie my %hash, "Tie::Hash::MultiValueOrdered";
+	
+	$hash{a} = 1;
+	$hash{b} = 2;
+	$hash{b} = 3;
+	
+	tied(%hash)->fetch_first;
+	
+	is_deeply($hash{a}, [1]);
+	is_deeply($hash{b}, [2, 3]);
+
+=item C<< fetch_iterator >>
+
+This fetch style is experimental and subject to change.
+
+	tie my %hash, "Tie::Hash::MultiValueOrdered";
+	
+	$hash{a} = 1;
+	$hash{b} = 2;
+	$hash{b} = 3;
+	
+	tied(%hash)->fetch_iterator;
+	
+	my $A = $hash{a};
+	my $B = $hash{b};
+	
+	is($A->(), 1);
+	is($B->(), 2);
+	is($B->(), 3);
+
+=back
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=JSON-MultiValueOrdered>.
+
+=head1 SEE ALSO
+
+L<JSON::Tiny::Subclassable>,
+L<JSON::Tiny>,
+L<Mojo::JSON>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

meta/changes.pret

+# This file acts as the project's changelog.
+
+`JSON-MultiValueOrdered 0.001 cpan:TOBYINK`
+	issued  2012-11-08;
+	label   "Initial release".
+
+# This file contains general metadata about the project.
+
+@prefix : <http://usefulinc.com/ns/doap#>.
+
+`JSON-MultiValueOrdered`
+	:programming-language "Perl" ;
+	:shortdesc            "handle JSON like {\"a\":1, \"a\":2}";
+	:homepage             <https://metacpan.org/release/JSON-MultiValueOrdered>;
+	:download-page        <https://metacpan.org/release/JSON-MultiValueOrdered>;
+	:bug-database         <http://rt.cpan.org/Dist/Display.html?Queue=JSON-MultiValueOrdered>;
+	:repository           [ a :HgRepository; :browse <https://bitbucket.org/tobyink/p5-json-multivalueordered> ];
+	:created              2012-11-08;
+	:license              <http://dev.perl.org/licenses/>;
+	:maintainer           cpan:TOBYINK;
+	:developer            cpan:TOBYINK.
+
+<http://dev.perl.org/licenses/>
+	dc:title  "the same terms as the perl 5 programming language system itself".
+

meta/makefile.pret

+# This file provides instructions for packaging.
+
+`JSON-MultiValueOrdered`
+	perl_version_from m`JSON::MultiValueOrdered`;
+	version_from      m`JSON::MultiValueOrdered`;
+	readme_from       m`JSON::MultiValueOrdered`;
+	test_requires     p`Test::More 0.61` ;
+	.
+
+# This file contains data about the project developers.
+
+@prefix : <http://xmlns.com/foaf/0.1/>.
+
+cpan:TOBYINK
+	:name  "Toby Inkster";
+	:mbox  <mailto:tobyink@cpan.org>.
+
+use Test::More tests => 1;
+BEGIN { use_ok('JSON::MultiValueOrdered') };
+
+use Test::More tests => 4;
+use JSON::MultiValueOrdered;
+
+my $j = JSON::MultiValueOrdered->new;
+isa_ok $j, 'JSON::Tiny';
+
+my $data = $j->decode(<<'JSON');
+{
+	"a": 1,
+	"b": 2,
+	"a": 3,
+	"b": 4
+}
+JSON
+
+# As you'd expect, for repeated values, the last value is used
+is_deeply(
+	$data,
+	{ a => 3, b => 4 },
+);
+
+# But hashes within the structure are tied to Tie::Hash::MultiValueOrdered
+is_deeply(
+	[ tied(%$data)->get('b') ],
+	[ 2, 4 ],
+);
+
+# And the extra information from the tied hash is used when re-encoding
+is(
+	$j->encode($data),
+	q({"a":1,"b":2,"a":3,"b":4}),
+);
+
+done_testing;
+use Test::More tests => 2;
+use JSON::MultiValueOrdered;
+
+my $str = <<'JSON';
+{
+	"a": [
+		1,
+		2,
+		3
+	],
+	"b": {
+		"c": 4,
+		"d": [
+			1
+		],
+		"e": [],
+		"f": {}
+	}
+}
+JSON
+
+my $json = JSON::MultiValueOrdered->new(pretty => 1);
+
+ok($json->pretty);
+
+is(
+	$json->encode($json->decode($str)),
+	$str,
+);
+use Test::More;
+use Tie::Hash::MultiValueOrdered;
+
+my $tied = tie my %hash, "Tie::Hash::MultiValueOrdered";
+
+$hash{a} = 1;
+$hash{b} = 2;
+$hash{a} = 3;
+$hash{b} = 4;
+
+# Order of keys is predictable
+is_deeply(
+	[ keys %hash ],
+	[ qw( a b ) ],
+);
+
+# Order of values is predictable
+# Note that the last values of 'a' and 'b' are returned.
+is_deeply(
+	[ values %hash ],
+	[ qw( 3 4 ) ],
+);
+
+# Can retrieve list of all key-value pairs
+is_deeply(
+	[ $tied->pairs ],
+	[ qw( a 1 b 2 a 3 b 4 ) ],
+);
+
+# Switch the retrieval mode for the hash.
+$tied->fetch_first;
+
+# Now the first values of 'a' and 'b' are returned.
+is_deeply(
+	[ values %hash ],
+	[ qw( 1 2 ) ],
+);
+
+# Switch the retrieval mode for the hash.
+$tied->fetch_list;
+
+# Now arrayrefs are returned.
+is_deeply(
+	[ values %hash ],
+	[ [1,3], [2,4] ],
+);
+
+# Restore the default retrieval mode for the hash.
+$tied->fetch_last;
+
+done_testing;
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+

xt/02pod_coverage.t

+use XT::Util;
+use Test::More;
+use Test::Pod::Coverage;
+
+plan skip_all => __CONFIG__->{skip_all}
+	if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+	my @modules = @{ __CONFIG__->{modules} };
+	pod_coverage_ok($_, "$_ is covered") for @modules;
+	done_testing(scalar @modules);
+}
+else
+{
+	all_pod_coverage_ok();
+}
+

xt/03meta_uptodate.config

+{"package":"JSON-MultiValueOrdered"}
+

xt/03meta_uptodate.t

+use XT::Util;
+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok(__CONFIG__->{package}, __CONFIG__->{version_from});
+
+use Test::EOL;
+all_perl_files_ok();
+use Test::Tabs;
+all_perl_files_ok();
+use XT::Util;
+use Test::More;
+use Test::HasVersion;
+
+plan skip_all => __CONFIG__->{skip_all}
+	if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+	my @modules = @{ __CONFIG__->{modules} };
+	pm_version_ok($_, "$_ is covered") for @modules;
+	done_testing(scalar @modules);
+}
+else
+{
+	all_pm_version_ok();
+}
+
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.