use
5.008005;
our
$VERSION
=
"0.07"
;
our
@EXPORT
=
qw(encode_pson decode_pson)
;
our
$INDENT
;
my
$WS
=
qr{[ \t]*}
;
sub
encode_pson { PLON->new->encode(
shift
) }
sub
decode_pson { PLON->new->decode(
shift
) }
sub
mk_accessor {
my
(
$pkg
,
$name
) =
@_
;
no
strict
'refs'
;
*{
"${pkg}::${name}"
} =
sub
{
my
$enable
=
defined
(
$_
[1]) ?
$_
[1] : 1;
if
(
$enable
) {
$_
[0]->{
$name
} = 1;
}
else
{
$_
[0]->{
$name
} = 0;
}
$_
[0];
};
*{
"${pkg}::get_${name}"
} =
sub
{
$_
[0]->{
$name
} ? 1 :
''
;
};
}
sub
new {
my
$class
=
shift
;
bless
{
},
$class
;
}
mk_accessor(__PACKAGE__,
$_
)
for
qw(pretty ascii deparse canonical)
;
sub
encode {
my
(
$self
,
$stuff
) =
@_
;
local
$INDENT
= -1;
return
$self
->_encode(
$stuff
);
}
sub
_encode {
my
(
$self
,
$value
) =
@_
;
local
$INDENT
=
$INDENT
+ 1;
my
$blessed
= blessed(
$value
);
if
(
defined
$blessed
) {
'bless('
.
$self
->_encode_basic(
$value
, 1) .
','
.
$self
->_encode_basic(
$blessed
) .
')'
;
}
else
{
$self
->_encode_basic(
$value
);
}
}
sub
_encode_basic {
my
(
$self
,
$value
,
$blessing
) =
@_
;
if
(not
defined
$value
) {
return
'undef'
;
}
my
$reftype
= reftype(
$value
);
if
(not
defined
$reftype
) {
my
$flags
= B::svref_2object(\
$value
)->FLAGS;
return
0 +
$value
if
$flags
& (B::SVp_IOK | B::SVp_NOK) &&
$value
* 0 == 0;
if
(
$self
->{ascii}) {
$value
=~ s/
"/\\"
/g;
if
(Encode::is_utf8(
$value
)) {
my
$buf
=
''
;
for
(
split
//,
$value
) {
if
(
$_
=~ /\G[a-zA-Z0-9_ -]\z/) {
$buf
.= Encode::encode_utf8(
$_
);
}
else
{
$buf
.=
sprintf
"\\x{%X}"
,
ord
$_
;
}
}
$value
=
$buf
;
}
else
{
$value
=
$value
;
}
q{"}
.
$value
.
q{"}
;
}
else
{
my
%special_chars
= (
qq{"}
=>
q{\"}
,
qq{\t}
=>
q{\t}
,
qq{\n}
=>
q{\n}
,
qq{\r}
=>
q{\r}
,
qq{\f}
=>
q{\f}
,
qq{\b}
=>
q{\b}
,
qq{\a}
=>
q{\a}
,
qq{\e}
=>
q{\e}
,
q{$}
=>
q{\$}
,
q{@}
=>
q{\@}
,
q{%}
=>
q{\%}
,
q{\\}
=>
q{\\\\}
,
);
$value
=~ s/(.)/
if
(
exists
(
$special_chars
{$1})) {
$special_chars
{$1};
}
else
{
$1
}
/gexs;
$value
= Encode::is_utf8(
$value
) ? Encode::encode_utf8(
$value
) :
$value
;
q{"}
.
$value
.
q{"}
;
}
}
elsif
(
$reftype
eq
'SCALAR'
) {
if
(
$blessing
) {
'\\(do {my $o='
.
$self
->_encode(
$$value
) .
'})'
;
}
else
{
'\\('
.
$self
->_encode(
$$value
) .
')'
;
}
}
elsif
(
$reftype
eq
'REF'
) {
'\\('
.
$self
->_encode(
$$value
) .
')'
;
}
elsif
(
$reftype
eq
'ARRAY'
) {
join
(
''
,
'['
,
$self
->_nl,
(
map
{
$self
->_indent(1) .
$self
->_encode(
$_
) .
","
.
$self
->_nl }
@$value
),
$self
->_indent,
']'
,
);
}
elsif
(
$reftype
eq
'CODE'
) {
if
(
$self
->get_deparse) {
my
$code
= B::Deparse->new(
$self
->get_pretty ?
''
:
'-si0'
)->coderef2text(
$value
);
$code
=
"sub ${code}"
;
if
(
$self
->get_pretty) {
my
$indent
=
$self
->_indent;
$code
=~ s/^/
$indent
/gm;
$code
;
}
else
{
$code
=~ s/\n//g;
$code
;
}
}
else
{
'sub { "DUMMY" }'
}
}
elsif
(
$reftype
eq
'HASH'
) {
my
@keys
=
keys
%$value
;
if
(
$self
->get_canonical) {
@keys
=
sort
{
$a
cmp
$b
}
@keys
;
}
join
(
''
,
'{'
,
$self
->_nl,
(
map
{
$self
->_indent(1) .
$self
->_encode(
$_
)
.
$self
->_before_sp .
'=>'
.
$self
->_after_sp
.
$self
->_encode(
$value
->{
$_
})
.
","
.
$self
->_nl,
}
@keys
),
$self
->_indent,
'}'
,
);
}
elsif
(
$reftype
eq
'GLOB'
) {
"\\("
.
$$value
.
")"
;
}
else
{
die
"Unknown type: ${reftype}"
;
}
}
sub
_indent {
my
(
$self
,
$n
) =
@_
;
if
(not
defined
$n
) {
$n
= 0 };
$self
->get_pretty ?
' '
x (
$INDENT
+
$n
) :
''
}
sub
_nl {
my
$self
=
shift
;
$self
->get_pretty ?
"\n"
:
''
,
}
sub
_before_sp {
my
$self
=
shift
;
$self
->get_pretty ?
" "
:
''
}
sub
_after_sp {
my
$self
=
shift
;
$self
->get_pretty ?
" "
:
''
}
sub
decode {
my
(
$self
,
$src
) =
@_
;
local
$_
=
$src
;
return
$self
->_decode();
}
sub
_decode {
my
(
$self
) =
@_
;
if
(/\G
$WS
\{/gc) {
return
$self
->_decode_hash();
}
elsif
(/\G
$WS
\[/gc) {
return
$self
->_decode_array();
}
elsif
(/\G
$WS
"/gc) {
return
$self
->_decode_string();
}
elsif
(/\G${WS}
undef
/gc) {
return
undef
;
}
elsif
(/\G${WS}\\\(/gc) {
return
$self
->_decode_scalarref();
}
elsif
(/\G${WS}
sub
\s*\{/gc) {
return
$self
->_decode_code();
}
elsif
(/\G
$WS
"/gc) {
return
$self
->_decode_string;
}
elsif
(/\G
$WS
([0-9\.]+)/gc) {
return
0+$1;
}
elsif
(/\G${WS}
bless
\(/gc) {
return
$self
->_decode_object;
}
elsif
(/\G${WS}
do
\{
my
\
$o
=/gc) {
return
$self
->_decode_do;
}
elsif
(/\G
$WS
\*([a-zA-Z0-9_:]+)/gc) {
no
strict
'refs'
;
*{$1};
}
else
{
Carp::confess(
"Unexpected token: "
.
substr
(
$_
,
pos
, 9));
}
}
sub
_decode_hash {
my
(
$self
) =
@_
;
my
%ret
;
until
(/\G
$WS
(,
$WS
)?\}/gc) {
my
$k
=
$self
->_decode();
/\G
$WS
=>
$WS
/gc
or _exception(
"Unexpected token in Hash"
);
my
$v
=
$self
->_decode();
$ret
{
$k
} =
$v
;
/\G
$WS
,/gc
or
last
;
}
return
\
%ret
;
}
sub
_decode_array {
my
(
$self
) =
@_
;
my
@ret
;
until
(/\G
$WS
,?
$WS
\]/gc) {
my
$term
=
$self
->_decode();
push
@ret
,
$term
;
}
return
\
@ret
;
}
sub
_decode_code {
Carp::confess(
"Cannot decode PLON contains CodeRef."
);
}
sub
_decode_object {
my
(
$self
) =
@_
;
my
$body
=
$self
->_decode;
m!\G${WS},\s*!gc
or _exception(
"Missing comma after bless"
);
my
$str
=
$self
->_decode;
m!\G${WS}\)!gc
or _exception(
"Missing closing paren after bless"
);
return
bless
(
$body
,
$str
);
}
sub
_decode_scalarref {
my
$self
=
shift
;
my
$value
=
$self
->_decode();
/\G\s*\)/gc
or _exception(
"Missing closing paren after scalarref"
);
return
\
$value
;
}
sub
_decode_do {
my
$self
=
shift
;
my
$value
=
$self
->_decode;
m!\G\}!gc
or _exception(
"Missing closing blace after `do {`"
);
return
$value
;
}
sub
_decode_string {
my
$self
=
shift
;
my
$ret
;
until
(/\G"/gc) {
if
(/\G\\"/gc) {
$ret
.=
q{"}
;
}
elsif
(/\G\\\$/gc) {
$ret
.=
qq{\$}
;
}
elsif
(/\G\\t/gc) {
$ret
.=
qq{\t}
;
}
elsif
(/\G\\n/gc) {
$ret
.=
qq{\n}
;
}
elsif
(/\G\\r/gc) {
$ret
.=
qq{\r}
;
}
elsif
(/\G\\f/gc) {
$ret
.=
qq{\f}
;
}
elsif
(/\G\\b/gc) {
$ret
.=
qq{\b}
;
}
elsif
(/\G\\a/gc) {
$ret
.=
qq{\a}
;
}
elsif
(/\G\\e/gc) {
$ret
.=
qq{\e}
;
}
elsif
(/\G\\$/gc) {
$ret
.=
qq{\$}
;
}
elsif
(/\G\\@/gc) {
$ret
.=
qq{\@}
;
}
elsif
(/\G\\%/gc) {
$ret
.=
qq{\%}
;
}
elsif
(/\G\\\\/gc) {
$ret
.=
qq{\\}
;
}
elsif
(/\G\\x\{([0-9a-fA-F]+)\}/gc) {
$ret
.=
chr
(
hex
$1);
}
elsif
(/\G([^"\\]+)/gc) {
$ret
.= $1;
}
else
{
_exception(
"Unexpected EOF in string"
);
}
}
return
Encode::is_utf8(
$ret
) ?
$ret
: Encode::decode_utf8(
$ret
);
}
sub
_exception {
m/\G
$WS
/gc;
my
$context
=
'Malformed PLON: '
.
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
||
''
);
}
die
"$context\n"
;
}
1;
Hide Show 119 lines of Pod