File Coverage

blib/lib/Text/JSON/Nibble.pm

Criterion	Covered	Total	%
statement	8	76	10.5
branch	0	32	0.0
condition	0	9	0.0
subroutine	3	10	30.0
pod	6	7	85.7
total	17	134	12.6

package Text::JSON::Nibble;

use 5.006;
use strict;
use warnings;

=head1 NAME

Text::JSON::Nibble - Nibble complete JSON objects from buffers

=head1 VERSION

Version 0.05

=cut

our $VERSION = '0.05';


=head1 SYNOPSIS

=head2 Example1 (Basic usage)

The basic usage of the module, Give it a stream of JSON in text form, it will extract the first complete block of JSON it finds.

	use warnings;
	use strict;

	use Text::JSON::Nibble;
	use JSON::MaybeXS;

	my $json = JSON->new;
	my $item = Text::JSON::Nibble->new();

	my $test = {
			lol => {
					a => [1,2,3],
					b => "lol"
			}
	};

	my $jsontext = $json->encode($test);

	$jsontext = "$jsontext$jsontext";

	print "jsontext: $jsontext\n";

	my ($text,$offset) = $item->digest($jsontext);

	print "Text: $text\n";
	print "Offset: $offset\n";

	# Beware the offset is a real offset so the first character is classed as 0, the literal length is 1 greater;
	$jsontext = substr($jsontext,$offset+1);

	print "new jsontext: $jsontext\n";

=head2 Example2 (Streaming usage)

This is a more efficient version for dealing with sockets that can be connected for a long period, NOTE this is not a
copy/paste example, please read carefully.

	use warnings;
	use strict;

	use Text::JSON::Nibble;
	use POE,ASYNC,...

	sub handler_for_when_socket_connected {
		$mystash->{nibbler} = Text::JSON::Nibble->new();
	}

	sub handler_tor_data_recvd {
		$mystash->{nibbler}->load($information_recvd);

		# queue will return 0 when it has nothing
		while ($mystash->{nibbler}->queue) {
			# Grab the first item from the queue
			my $jsonChunk = $mystash->{nibbler}->pull;

			# Do something with it
			$superCommand->magic($jsonChunk);
		}
	}



=head1 WARNING

This module should be used with caution, it will not handle 'badly formed' json well, its entire purpose was because I was experiencing
segfaults with Cpanel::XS's decode_prefix when dealing with a streamnig socket buffer.

Use this only when needed.

=head1 SUBROUTINES/METHODS

=head2 new

Generate a new JSON Nibble object

=cut

sub new {
	my $class = shift;

	my $self = {
		jsonqueue => [],
		buffer => "",
	};

	bless $self, $class;

	return $self;
}

=head2 digest

Digest the text that is fed and attempt to return a complete JSON object from it, returns two items the JSON object (in text form) and the offset in the buffer.

On a failure it will return "" and 0

=cut

sub digest {
	my $self = shift;
	my $data = shift;

	# If we got passed a blank data scalar just return failure
	return ("",0) if (!$data);

	# Process the data and return the result
	return $self->proc(1,$data);
}

=head2 load

Load information into the buffer for processing

=cut

sub load {
	my $self = shift;
	my $data = shift;

	$self->{buffer} .= $data;

	if (!$self->{state}) {
		$self->{state} = [0,0,"",0];
	}

	$self->proc();
}

=head2 queue

Return how many objects are in the queue

=cut

sub queue {
	my $self = shift;

	return scalar( @{ $self->{jsonqueue} } );
}

=head2 pull

Pull the first object from the queue

=cut

sub pull {
	my $self = shift;

	return if (! queue($self) );

	return shift( @{ $self->{jsonqueue} } );
}

=head2 clear

Clear the internal state and buffer state of nibble, like a brand new() object.

=cut

sub clear {
	my $self = shift;

	$self->{jsonqueue} = [];
	$self->{state} = [0,0,"",0];
	$self->{buffer} = "";
}

=head2 _proc

Proccess text into json (Do not call this directly)

=cut

sub proc {
	my $self = shift;
	my $return = shift;

	# Create a place to store the JSON object and a few tracking scalars
	my @jsonArray;
	my $typeAOpen = 0;
	my $typeBOpen = 0;
	my $arrayPlace = 0;
	my $prevChar = "";

	# Which mode are we operating in? if we have to return we are in simple mode
	if ($return) {
		# Grab data from the call rather than our buffer
		my $data = shift;

		# Return nothing if the buffer is empty
		if (!$data) { return ("",0) }

		@jsonArray = split(//,$data);
	} else {
		# Return nothing if the buffer is empty
		if (!$self->{buffer}) { return }

		# Holder for temporary pos
		my $pos = 0;

		# Ok lets use the place we read up to last time as a starting point
		($typeAOpen,$typeBOpen,$prevChar,$pos) = @{ $self->{state} };

		# Create the JSON array
		@jsonArray = split(//,substr($self->{buffer},$pos));
	}

	# Crawl through the array counting our open data brackets
	foreach my $chr ( @jsonArray ) {
		if ($arrayPlace > 0) { $prevChar = $jsonArray[$arrayPlace - 1] }

		if ( ord($prevChar) != 92 ) {
			my $charCode = ord($chr);

			# Handle { } type brackets
			if ( $charCode == 123 )  { $typeAOpen++ }
			elsif ( $charCode == 125 ) { $typeAOpen-- }

			# Handle [ ] type brackets
			if ( $charCode == 91 ) { $typeBOpen++ }
			elsif ( $charCode == 93 ) { $typeBOpen-- }
		}

		# If we have a complete object then leave
		if ( $arrayPlace > 1 && !$typeAOpen && !$typeBOpen ) {
			# Convert the offset into a length
			last;
		}
		else { $arrayPlace++ }
	}

	if ( !$typeAOpen && !$typeBOpen ) {
		if ( $return ) {
			return ( join('',@jsonArray[0..$arrayPlace]), $arrayPlace );
		} else {
			# Add the complete object to the queue
			push( @{$self->{jsonqueue}}, substr($self->{buffer},0,$arrayPlace+1) );

			# Adjust the buffer
			$self->{buffer} = substr($self->{buffer},$arrayPlace+1);

			# Reset the states
			$self->{state} = [0,0,"",0];

			# Perhaps we receieved more than one complete JSON object in the last addition, lets check!
			return $self->proc();
		}
	} elsif ($return) {
		# If we got no match, lets remember our state so that if any more data is loaded we do not need to re-read it all.
		return ("",0);
	} else {
		# We are in stream mode and we did not match jack, so store our states
		$self->{state} = [$typeAOpen,$typeBOpen,$prevChar,$arrayPlace];

		# And return
		return;
	}
}

=head1 AUTHOR

Paul G Webster, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Text::JSON::Nibble


You can also look for information at:

=over 4

=item * The author publishs this module to GitLab (Please report bugs here)

L

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2017 Paul G Webster.

This program is released under the following license: BSD


=cut

1; # End of Text::JSON::Nibble