use
constant
VALUE
=>
"\x07YAML\x07VALUE\x07"
;
my
$ESCAPE_CHAR
=
'[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'
;
my
$LIT_CHAR
=
'|'
;
sub
dump
{
my
$self
=
shift
;
$self
->stream(
''
);
$self
->document(0);
for
my
$document
(
@_
) {
$self
->{document}++;
$self
->transferred({});
$self
->id_refcnt({});
$self
->id_anchor({});
$self
->anchor(1);
$self
->level(0);
$self
->offset->[0] = 0 -
$self
->indent_width;
$self
->_prewalk(
$document
);
$self
->_emit_header(
$document
);
$self
->_emit_node(
$document
);
}
return
$self
->stream;
}
sub
_emit_header {
my
$self
=
shift
;
my
(
$node
) =
@_
;
if
(not
$self
->use_header and
$self
->document == 1
) {
$self
->
die
(
'YAML_DUMP_ERR_NO_HEADER'
)
unless
ref
(
$node
) =~ /^(HASH|ARRAY)$/;
$self
->
die
(
'YAML_DUMP_ERR_NO_HEADER'
)
if
ref
(
$node
) eq
'HASH'
and
keys
(
%$node
) == 0;
$self
->
die
(
'YAML_DUMP_ERR_NO_HEADER'
)
if
ref
(
$node
) eq
'ARRAY'
and
@$node
== 0;
$self
->headless(1);
return
;
}
$self
->{stream} .=
'---'
;
if
(
$self
->use_version) {
}
}
sub
_prewalk {
my
$self
=
shift
;
my
$stringify
=
$self
->stringify;
my
(
$class
,
$type
,
$node_id
) =
$self
->node_info(\
$_
[0],
$stringify
);
if
(
$type
eq
'GLOB'
) {
$self
->transferred->{
$node_id
} =
YAML::Type::
glob
->yaml_dump(
$_
[0]);
$self
->_prewalk(
$self
->transferred->{
$node_id
});
return
;
}
if
(
ref
(
$_
[0]) eq
'Regexp'
) {
return
;
}
if
(not
ref
$_
[0]) {
$self
->{id_refcnt}{
$node_id
}++
if
$self
->purity;
return
;
}
my
$value
=
$_
[0];
(
$class
,
$type
,
$node_id
) =
$self
->node_info(
$value
,
$stringify
);
return
if
(
ref
(
$value
) and not
$type
);
if
(
$self
->transferred->{
$node_id
}) {
(
undef
,
undef
,
$node_id
) = (
ref
$self
->transferred->{
$node_id
})
?
$self
->node_info(
$self
->transferred->{
$node_id
},
$stringify
)
:
$self
->node_info(\
$self
->transferred->{
$node_id
},
$stringify
);
$self
->{id_refcnt}{
$node_id
}++;
return
;
}
if
(
$type
eq
'CODE'
) {
$self
->transferred->{
$node_id
} =
'placeholder'
;
YAML::Type::code->yaml_dump(
$self
->dump_code,
$_
[0],
$self
->transferred->{
$node_id
}
);
(
$class
,
$type
,
$node_id
) =
$self
->node_info(\
$self
->transferred->{
$node_id
},
$stringify
);
$self
->{id_refcnt}{
$node_id
}++;
return
;
}
if
(
defined
$class
) {
if
(
$value
->can(
'yaml_dump'
)) {
$value
=
$value
->yaml_dump;
}
elsif
(
$type
eq
'SCALAR'
) {
$self
->transferred->{
$node_id
} =
'placeholder'
;
YAML::Type::blessed->yaml_dump
(
$_
[0],
$self
->transferred->{
$node_id
});
(
$class
,
$type
,
$node_id
) =
$self
->node_info(\
$self
->transferred->{
$node_id
},
$stringify
);
$self
->{id_refcnt}{
$node_id
}++;
return
;
}
else
{
$value
= YAML::Type::blessed->yaml_dump(
$value
);
}
$self
->transferred->{
$node_id
} =
$value
;
(
undef
,
$type
,
$node_id
) =
$self
->node_info(
$value
,
$stringify
);
}
if
(
defined
YAML->global_object()->{blessed_map}{
$node_id
}) {
$value
= YAML->global_object()->{blessed_map}{
$node_id
};
$self
->transferred->{
$node_id
} =
$value
;
(
$class
,
$type
,
$node_id
) =
$self
->node_info(
$value
,
$stringify
);
$self
->_prewalk(
$value
);
return
;
}
if
(
$type
eq
'REF'
or
$type
eq
'SCALAR'
) {
$value
= YAML::Type::
ref
->yaml_dump(
$value
);
$self
->transferred->{
$node_id
} =
$value
;
(
undef
,
$type
,
$node_id
) =
$self
->node_info(
$value
,
$stringify
);
}
elsif
(
$type
eq
'GLOB'
) {
my
$ref_ynode
=
$self
->transferred->{
$node_id
} =
YAML::Type::
ref
->yaml_dump(
$value
);
my
$glob_ynode
=
$ref_ynode
->{
&VALUE
} =
YAML::Type::
glob
->yaml_dump(
$$value
);
(
undef
,
undef
,
$node_id
) =
$self
->node_info(
$glob_ynode
,
$stringify
);
$self
->transferred->{
$node_id
} =
$glob_ynode
;
$self
->_prewalk(
$glob_ynode
);
return
;
}
return
if
++(
$self
->{id_refcnt}{
$node_id
}) > 1;
if
(
$type
eq
'HASH'
) {
$self
->_prewalk(
$value
->{
$_
})
for
keys
%{
$value
};
return
;
}
elsif
(
$type
eq
'ARRAY'
) {
$self
->_prewalk(
$_
)
for
@{
$value
};
return
;
}
$self
->
warn
(
<<"...");
YAML::Dumper can't handle dumping this type of data.
Please report this to the author.
id: $node_id
type: $type
class: $class
value: $value
...
return
;
}
sub
_emit_node {
my
$self
=
shift
;
my
(
$type
,
$node_id
);
my
$ref
=
ref
(
$_
[0]);
if
(
$ref
) {
if
(
$ref
eq
'Regexp'
) {
$self
->_emit(
' !!perl/regexp'
);
$self
->_emit_str(
"$_[0]"
);
return
;
}
(
undef
,
$type
,
$node_id
) =
$self
->node_info(
$_
[0],
$self
->stringify);
}
else
{
$type
=
$ref
||
'SCALAR'
;
(
undef
,
undef
,
$node_id
) =
$self
->node_info(\
$_
[0],
$self
->stringify);
}
my
(
$ynode
,
$tag
) = (
''
) x 2;
my
(
$value
,
$context
) = (
@_
, 0);
if
(
defined
$self
->transferred->{
$node_id
}) {
$value
=
$self
->transferred->{
$node_id
};
$ynode
= ynode(
$value
);
if
(
ref
$value
) {
$tag
=
defined
$ynode
?
$ynode
->tag->short :
''
;
(
undef
,
$type
,
$node_id
) =
$self
->node_info(
$value
,
$self
->stringify);
}
else
{
$ynode
= ynode(
$self
->transferred->{
$node_id
});
$tag
=
defined
$ynode
?
$ynode
->tag->short :
''
;
$type
=
'SCALAR'
;
(
undef
,
undef
,
$node_id
) =
$self
->node_info(
\
$self
->transferred->{
$node_id
},
$self
->stringify
);
}
}
elsif
(
$ynode
= ynode(
$value
)) {
$tag
=
$ynode
->tag->short;
}
if
(
$self
->use_aliases) {
$self
->{id_refcnt}{
$node_id
} ||= 0;
if
(
$self
->{id_refcnt}{
$node_id
} > 1) {
if
(
defined
$self
->{id_anchor}{
$node_id
}) {
$self
->{stream} .=
' *'
.
$self
->{id_anchor}{
$node_id
} .
"\n"
;
return
;
}
my
$anchor
=
$self
->anchor_prefix .
$self
->{anchor}++;
$self
->{stream} .=
' &'
.
$anchor
;
$self
->{id_anchor}{
$node_id
} =
$anchor
;
}
}
return
$self
->_emit_str(
"$value"
)
if
ref
(
$value
) and not
$type
;
return
$self
->_emit_scalar(
$value
,
$tag
)
if
$type
eq
'SCALAR'
and
$tag
;
return
$self
->_emit_str(
$value
)
if
$type
eq
'SCALAR'
;
return
$self
->_emit_mapping(
$value
,
$tag
,
$node_id
,
$context
)
if
$type
eq
'HASH'
;
return
$self
->_emit_sequence(
$value
,
$tag
)
if
$type
eq
'ARRAY'
;
$self
->
warn
(
'YAML_DUMP_WARN_BAD_NODE_TYPE'
,
$type
);
return
$self
->_emit_str(
"$value"
);
}
sub
_emit_mapping {
my
$self
=
shift
;
my
(
$value
,
$tag
,
$node_id
,
$context
) =
@_
;
$self
->{stream} .=
" !$tag"
if
$tag
;
my
$empty_hash
= not(
eval
{
keys
%$value
});
$self
->
warn
(
'YAML_EMIT_WARN_KEYS'
, $@)
if
$@;
return
(
$self
->{stream} .=
" {}\n"
)
if
$empty_hash
;
if
(
$context
== FROMARRAY and
$self
->compress_series and
not (
defined
$self
->{id_anchor}{
$node_id
} or
$tag
or
$empty_hash
)
) {
$self
->{stream} .=
' '
;
$self
->offset->[
$self
->level+1] =
$self
->offset->[
$self
->level] + 2;
}
else
{
$context
= 0;
$self
->{stream} .=
"\n"
unless
$self
->headless && not(
$self
->headless(0));
$self
->offset->[
$self
->level+1] =
$self
->offset->[
$self
->level] +
$self
->indent_width;
}
$self
->{level}++;
my
@keys
;
if
(
$self
->sort_keys == 1) {
if
(ynode(
$value
)) {
@keys
=
keys
%$value
;
}
else
{
@keys
=
sort
keys
%$value
;
}
}
elsif
(
$self
->sort_keys == 2) {
@keys
=
sort
keys
%$value
;
}
elsif
(
ref
(
$self
->sort_keys) eq
'ARRAY'
) {
my
$i
= 1;
my
%order
=
map
{ (
$_
,
$i
++) } @{
$self
->sort_keys};
@keys
=
sort
{
(
defined
$order
{
$a
} and
defined
$order
{
$b
})
? (
$order
{
$a
} <=>
$order
{
$b
})
: (
$a
cmp
$b
);
}
keys
%$value
;
}
else
{
@keys
=
keys
%$value
;
}
if
(
exists
$value
->{
&VALUE
}) {
for
(
my
$i
= 0;
$i
<
@keys
;
$i
++) {
if
(
$keys
[
$i
] eq
&VALUE
) {
splice
(
@keys
,
$i
, 1);
push
@keys
,
&VALUE
;
last
;
}
}
}
for
my
$key
(
@keys
) {
$self
->_emit_key(
$key
,
$context
);
$context
= 0;
$self
->{stream} .=
':'
;
$self
->_emit_node(
$value
->{
$key
});
}
$self
->{level}--;
}
sub
_emit_sequence {
my
$self
=
shift
;
my
(
$value
,
$tag
) =
@_
;
$self
->{stream} .=
" !$tag"
if
$tag
;
return
(
$self
->{stream} .=
" []\n"
)
if
@$value
== 0;
$self
->{stream} .=
"\n"
unless
$self
->headless && not(
$self
->headless(0));
if
(
$self
->inline_series and
@$value
<=
$self
->inline_series and
not (
scalar
grep
{
ref
or /\n/}
@$value
)
) {
$self
->{stream} =~ s/\n\Z/ /;
$self
->{stream} .=
'['
;
for
(
my
$i
= 0;
$i
<
@$value
;
$i
++) {
$self
->_emit_str(
$value
->[
$i
], KEY);
last
if
$i
== $
$self
->{stream} .=
', '
;
}
$self
->{stream} .=
"]\n"
;
return
;
}
$self
->offset->[
$self
->level + 1] =
$self
->offset->[
$self
->level] +
$self
->indent_width;
$self
->{level}++;
for
my
$val
(
@$value
) {
$self
->{stream} .=
' '
x
$self
->offset->[
$self
->level];
$self
->{stream} .=
'-'
;
$self
->_emit_node(
$val
, FROMARRAY);
}
$self
->{level}--;
}
sub
_emit_key {
my
$self
=
shift
;
my
(
$value
,
$context
) =
@_
;
$self
->{stream} .=
' '
x
$self
->offset->[
$self
->level]
unless
$context
== FROMARRAY;
$self
->_emit_str(
$value
, KEY);
}
sub
_emit_scalar {
my
$self
=
shift
;
my
(
$value
,
$tag
) =
@_
;
$self
->{stream} .=
" !$tag"
;
$self
->_emit_str(
$value
, BLESSED);
}
sub
_emit {
my
$self
=
shift
;
$self
->{stream} .=
join
''
,
@_
;
}
sub
_emit_str {
my
$self
=
shift
;
my
$type
=
$_
[1] || 0;
$self
->offset->[
$self
->level + 1] =
$self
->offset->[
$self
->level] +
$self
->indent_width;
$self
->{level}++;
my
$sf
=
$type
== KEY ?
''
:
' '
;
my
$sb
=
$type
== KEY ?
'? '
:
' '
;
my
$ef
=
$type
== KEY ?
''
:
"\n"
;
my
$eb
=
"\n"
;
while
(1) {
$self
->_emit(
$sf
),
$self
->_emit_plain(
$_
[0]),
$self
->_emit(
$ef
),
last
if
not
defined
$_
[0];
$self
->_emit(
$sf
,
'='
,
$ef
),
last
if
$_
[0] eq VALUE;
$self
->_emit(
$sf
),
$self
->_emit_double(
$_
[0]),
$self
->_emit(
$ef
),
last
if
$_
[0] =~ /
$ESCAPE_CHAR
/;
if
(
$_
[0] =~ /\n/) {
$self
->_emit(
$sb
),
$self
->_emit_block(
$LIT_CHAR
,
$_
[0]),
$self
->_emit(
$eb
),
last
if
$self
->use_block;
Carp::cluck
"[YAML] \$UseFold is no longer supported"
if
$self
->use_fold;
$self
->_emit(
$sf
),
$self
->_emit_double(
$_
[0]),
$self
->_emit(
$ef
),
last
if
length
$_
[0] <= 30;
$self
->_emit(
$sf
),
$self
->_emit_double(
$_
[0]),
$self
->_emit(
$ef
),
last
if
$_
[0] !~ /\n\s*\S/;
$self
->_emit(
$sb
),
$self
->_emit_block(
$LIT_CHAR
,
$_
[0]),
$self
->_emit(
$eb
),
last
;
}
$self
->_emit(
$sf
),
$self
->_emit_plain(
$_
[0]),
$self
->_emit(
$ef
),
last
if
$self
->is_valid_plain(
$_
[0]);
$self
->_emit(
$sf
),
$self
->_emit_double(
$_
[0]),
$self
->_emit(
$ef
),
last
if
$_
[0] =~ /'/;
$self
->_emit(
$sf
),
$self
->_emit_single(
$_
[0]),
$self
->_emit(
$ef
);
last
;
}
$self
->{level}--;
return
;
}
sub
is_valid_plain {
my
$self
=
shift
;
return
0
unless
length
$_
[0];
return
0
if
$_
[0] =~ /^[\s\{\[\~\`\'\"\!\@\
return
0
if
$_
[0] =~ /[\{\[\]\},]/;
return
0
if
$_
[0] =~ /[:\-\?]\s/;
return
0
if
$_
[0] =~ /\s
return
0
if
$_
[0] =~ /\:(\s|$)/;
return
0
if
$_
[0] =~ /[\s\|\>]$/;
return
0
if
$_
[0] eq
'-'
;
return
1;
}
sub
_emit_block {
my
$self
=
shift
;
my
(
$indicator
,
$value
) =
@_
;
$self
->{stream} .=
$indicator
;
$value
=~ /(\n*)\Z/;
my
$chomp
=
length
$1 ? (
length
$1 > 1) ?
'+'
:
''
:
'-'
;
$value
=
'~'
if
not
defined
$value
;
$self
->{stream} .=
$chomp
;
$self
->{stream} .=
$self
->indent_width
if
$value
=~ /^\s/;
$self
->{stream} .=
$self
->indent(
$value
);
}
sub
_emit_plain {
my
$self
=
shift
;
$self
->{stream} .=
defined
$_
[0] ?
$_
[0] :
'~'
;
}
sub
_emit_double {
my
$self
=
shift
;
(
my
$escaped
=
$self
->escape(
$_
[0])) =~ s/
"/\\"
/g;
$self
->{stream} .=
qq{"$escaped"}
;
}
sub
_emit_single {
my
$self
=
shift
;
my
$item
=
shift
;
$item
=~ s{
'}{'
'}g;
$self
->{stream} .=
"'$item'"
;
}
sub
indent {
my
$self
=
shift
;
my
(
$text
) =
@_
;
return
$text
unless
length
$text
;
$text
=~ s/\n\Z//;
my
$indent
=
' '
x
$self
->offset->[
$self
->level];
$text
=~ s/^/
$indent
/gm;
$text
=
"\n$text"
;
return
$text
;
}
my
@escapes
=
qw(\0 \x01 \x02 \x03 \x04 \x05 \x06 \a
\x08 \t \n \v \f \r \x0e \x0f
\x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
\x18 \x19 \x1a \e \x1c \x1d \x1e \x1f
)
;
sub
escape {
my
$self
=
shift
;
my
(
$text
) =
@_
;
$text
=~ s/\\/\\\\/g;
$text
=~ s/([\x00-\x1f])/
$escapes
[
ord
($1)]/ge;
return
$text
;
}
1;