adiary開発日誌

正しいもののみ正しくパースされるスクリプトです。

• 外部モジュール不要。
• 正しくないものは解析できるところまで動きます。
• かっこ「{[」と「]}」の対応は見てません（閉じかっこの入れ違えがあっても動きます）
• ライセンスはWTFPLですが、一言「使ったよ」ってコメントくれると嬉しいです。

バグがあったら具体的なデータと共にコメントください。

スクリプト

外部モジュールにしない場合は、変数の初期化を perse_join の中に入れてください。

#-------------------------------------------------
# Copyright (C)nabe@abk  
#-------------------------------------------------
my %json_esc = (
"/" => "/",
'"' => '"',
"\\" => "\\",
"b" => "\x08",
"f" => "\x0c",
"n" => "\n",
"r" => "\r",
"t" => "\t"
);
my %json_val = (
'true'  => 1,
'false' => 0,
'null'  => undef
);
sub parse_json {
	my $json = shift;
	my @str;
	$json =~ s/[\x00-\x01]//g;
	$json =~ s/\\"/\x01/g;
	$json =~ s/"([^"]*)"/push(@str,$1),"\x00$#str\x00"/eg;
	# 文字列の処理
	foreach(@str) {
		$_ =~ s|\\([/\\bfnrt])|$json_esc{$1}|g;
		$_ =~ s/\x01/"/g;
		$_ =~ s/\\u([0-9A-Za-z][0-9A-Za-z][0-9A-Za-z][0-9A-Za-z])/
			my $x = hex($1);
			if ($x < 2) { 
				"";
			} elsif ($x < 0x100) { 
				chr($x);
			} else {
				# UTF-16 to UTF-8
				  chr(0xE0 | (($x>>12) & 0x0f))
				. chr(0x80 | (($x>> 6) & 0x3f))
				. chr(0x80 | ( $x      & 0x3f));
			}
		/eg;
	}
	$json =~ s/\s*//g;
	#-------------------------------------------------------
	# JSON解析
	#-------------------------------------------------------
	my @ary;
	foreach(split(/,/, $json)) {
		while($_ =~ /^(.*?)([\[\]\{\}])(.*)$/) {
			if ($1 ne '') { push(@ary, $1); }
			push(@ary, $2);
			$_ = $3;
		}
		if ($_ ne '') { push(@ary, $_); }
	}
	my @stack;
	my $ret = (shift(@ary) eq '{') ? {} : [];
	my $c = $ret;
	eval {
	while(@ary) {
		my $v = shift(@ary);
		if ($v eq '}' || $v eq ']') {
			$c = pop(@stack);
			next;
		}
		# ハッシュの場合
		if (ref($c) eq 'HASH') {
			my $x = index($v, ':');
			my $key = substr($v, 0, $x);
			my $val = substr($v, $x+1);
			$key =~ s/^\x00(\d+)\x00$/$str[$1]/;
			if (exists $json_val{$val}) {
				$val = $json_val{$val};
			} else {
				$val =~ s/^\x00(\d+)\x00$/$str[$1]/;
			}
			if ($ary[0] eq '{') {
				shift(@ary);
				push(@stack, $c);
				$c = $c->{$key} = {};
			} elsif ($ary[0] eq '[') {
				shift(@ary);
				push(@stack, $c);
				$c = $c->{$key} = [];
			} else {
				$c->{$key} = $val;
			}
			next;
		}
		# 配列の場合
		if ($v eq '{') {
			push(@stack, $c);
			push(@$c, {});
			$c = $c->[ $#$c ];
		} elsif ($v eq '[') {
			push(@stack, $c);
			push(@$c, []);
			$c = $c->[ $#$c ];
		} elsif (exists $json_val{$v}) {
			push(@$c, $json_val{$v});
		} else {
			$v =~ s/^\x00(\d+)\x00$/$str[$1]/;
			push(@$c, $v);
		}
	}
	}; # eval

	return $ret;
}

パース結果確認用のスクリプト

sub nest_hash_to_string {
	my $data = shift;
	my $sp   = shift || '';
	my $ret = '';
	if (ref($data) eq 'HASH') {
		foreach(sort(keys(%$data))) {
			my $k = $_;
			my $v = $data->{$_};
			if (ref($v) eq 'ARRAY') {
				$ret .= "$sp$k=[\n";
				$ret .= &nest_hash_to_string($v, "  $sp");
				$ret .= "$sp]\n";
				next;
			}
			if (ref($v) eq 'HASH') {
				$ret .= "$sp$k={\n";
				$ret .= &nest_hash_to_string($v, "  $sp");
				$ret .= "$sp}\n";
				next;
			}
			$ret .= "$sp$k=$v\n";
		}
	} else {
		foreach(@$data) {
			if (ref($_) eq 'ARRAY') {
				$ret .= "$sp\[\n";
				$ret .= &nest_hash_to_string($_, "  $sp");
				$ret .= "$sp]\n";
				next;
			}
			if (ref($_) eq 'HASH') {
				$ret .= "$sp\{\n";
				$ret .= &nest_hash_to_string($_, "  $sp");
				$ret .= "$sp}\n";
				next;
			}
			$ret .= "$sp$_\n";
		}
	}
	return $ret;
}

速度比較

twitterにstatus updateしたときに戻ってきたJSONでテストしました。

  JSON::PP:  4 wallclock secs ( 3.85 usr +  0.00 sys =  3.85 CPU) @ 259.74/s (n=1000)
  JSON::XS:  0 wallclock secs ( 0.03 usr +  0.00 sys =  0.03 CPU) @ 33333.33/s (n=1000)
            (warning: too few iterations for a reliable count)
parse_json:  1 wallclock secs ( 1.22 usr +  0.00 sys =  1.22 CPU) @ 819.67/s (n=1000)

XSはさすがに圧倒的ですね（苦笑）