view release on metacpan or  search on metacpan

lib/JSON/Eval.pm  view on Meta::CPAN

package JSON::Eval;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.002';

use Scalar::Util qw(blessed);

sub new {
	my $class = shift;
	my $json = @_ ? $_[0] : do { require JSON::MaybeXS; JSON::MaybeXS->new };
	bless \$json, $class;
}

sub AUTOLOAD {
	my $self = shift;
	our $AUTOLOAD;
	( my $method = $AUTOLOAD ) =~ s/.*:://;
	my $r = $$self->$method(@_);
	return $self if $r == $$self;
	$r;
}

sub decode {
	my $self = shift;
	my $o    = $$self->decode(@_);
	$self->eval_object($o);
}

sub encode {
	my $self = shift;
	my $o    = $self->deparse_object(@_);
	$$self->encode($o);
}

sub eval_object {
	my $self = shift;
	my ($o) = @_;
	if (ref $o eq 'HASH' and keys(%$o)==1 and exists $o->{'$eval'}) {
		return $safe_eval->($o->{'$eval'});
	}
	if (ref $o eq 'HASH' and keys(%$o)==1 and exists $o->{'$scalar'}) {
		my $x = $self->eval_object($o->{'$scalar'});
		return \$x;
	}
	if (ref $o eq 'ARRAY') {
		local $_;
		return [ map(ref($_)?$self->eval_object($_):$_, @$o) ];
	}
	if (ref $o eq 'HASH') {
		local $_;
		return { map { $_ => ref($o->{$_})?$self->eval_object($o->{$_}):$o->{$_} } keys %$o };
	}
	$o;
}

sub deparse_object {
	my $self = shift;
	my ($o) = @_;
	if (ref $o eq 'CODE') {
		require PadWalker;
		my $lexicals = PadWalker::closed_over($o);
		if (keys %$lexicals) {
			require Carp;
			Carp::croak("Cannot serialize coderef that closes over lexical variables to JSON: ".join ",", sort keys %$lexicals);
		}
		require B::Deparse;
		my $dp = 'B::Deparse'->new;
		$dp->ambient_pragmas(strict => 'all', warnings => 'all');
		return { '$eval' => 'sub ' . $dp->coderef2text($o) };
	}
	if (ref $o eq 'ARRAY') {
		local $_;
		return [ map(ref($_)?$self->deparse_object($_):$_, @$o) ];
	}
	if (ref $o eq 'SCALAR' or ref $o eq 'REF') {
		local $_;
		return { '$scalar' => $self->deparse_object($$o) };
	}
	if (ref $o eq 'HASH') {
		local $_;
		return { map { $_ => ref($o->{$_})?$self->deparse_object($o->{$_}):$o->{$_} } keys %$o };
	}
	if (blessed($o) and $o->isa('Type::Tiny')) {
		if ($o->has_library and not $o->is_anon and $o->library->has_type($o->name)) {
			require B;
			return { '$eval' => sprintf('do { require %s; %s->get_type(%s) }', $o->library, B::perlstring($o->library), B::perlstring($o->name)) };
		}
		else {
			require Carp;
			Carp::croak('Very limited support for serializing Type::Tiny objects right now');
		}
	}
	if (blessed($o) and $self->convert_blessed and $o->can('TO_JSON')) {
		my $unblessed = $o->TO_JSON;
		return $self->deparse_object($unblessed);
	}
	$o;
}

sub DESTROY { }

1;

__END__

=pod

=encoding utf-8

=head1 NAME

JSON::Eval - eval Perl code found in JSON

=head1 SYNOPSIS

  my $encoder = JSON::Eval->new();
  
  my $object = {
    coderef   => sub { 2 + shift },
    scalarref => do { my $x = 40; \$x },
  };