summaryrefslogtreecommitdiff
path: root/lib/YAML/Dumper.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/YAML/Dumper.pm')
-rw-r--r--lib/YAML/Dumper.pm575
1 files changed, 575 insertions, 0 deletions
diff --git a/lib/YAML/Dumper.pm b/lib/YAML/Dumper.pm
new file mode 100644
index 0000000..5f75ab2
--- /dev/null
+++ b/lib/YAML/Dumper.pm
@@ -0,0 +1,575 @@
+package YAML::Dumper;
+
+use YAML::Mo;
+extends 'YAML::Dumper::Base';
+
+use YAML::Dumper::Base;
+use YAML::Node;
+use YAML::Types;
+use Scalar::Util qw();
+
+# Context constants
+use constant KEY => 3;
+use constant BLESSED => 4;
+use constant FROMARRAY => 5;
+use constant VALUE => "\x07YAML\x07VALUE\x07";
+
+# Common YAML character sets
+my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
+my $LIT_CHAR = '|';
+
+#==============================================================================
+# OO version of Dump. YAML->new->dump($foo);
+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;
+}
+
+# Every YAML document in the stream must begin with a YAML header, unless
+# there is only a single document and the user requests "no header".
+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;
+ # XXX Also croak if aliased, blessed, or ynode
+ $self->headless(1);
+ return;
+ }
+ $self->{stream} .= '---';
+# XXX Consider switching to 1.1 style
+ if ($self->use_version) {
+# $self->{stream} .= " #YAML:1.0";
+ }
+}
+
+# Walk the tree to be dumped and keep track of its reference counts.
+# This function is where the Dumper does all its work. All type
+# transfers happen here.
+sub _prewalk {
+ my $self = shift;
+ my $stringify = $self->stringify;
+ my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
+
+ # Handle typeglobs
+ if ($type eq 'GLOB') {
+ $self->transferred->{$node_id} =
+ YAML::Type::glob->yaml_dump($_[0]);
+ $self->_prewalk($self->transferred->{$node_id});
+ return;
+ }
+
+ # Handle regexps
+ if (ref($_[0]) eq 'Regexp') {
+ return;
+ }
+
+ # Handle Purity for scalars.
+ # XXX can't find a use case yet. Might be YAGNI.
+ if (not ref $_[0]) {
+ $self->{id_refcnt}{$node_id}++ if $self->purity;
+ return;
+ }
+
+ # Make a copy of original
+ my $value = $_[0];
+ ($class, $type, $node_id) = $self->node_info($value, $stringify);
+
+ # Must be a stringified object.
+ return if (ref($value) and not $type);
+
+ # Look for things already transferred.
+ 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;
+ }
+
+ # Handle code refs
+ 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;
+ }
+
+ # Handle blessed things
+ 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);
+ }
+
+ # Handle YAML Blessed things
+ require YAML;
+ 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;
+ }
+
+ # Handle hard refs
+ 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);
+ }
+
+ # Handle ref-to-glob's
+ 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;
+ }
+
+ # Increment ref count for node
+ return if ++($self->{id_refcnt}{$node_id}) > 1;
+
+ # Keep on walking
+ if ($type eq 'HASH') {
+ $self->_prewalk($value->{$_})
+ for keys %{$value};
+ return;
+ }
+ elsif ($type eq 'ARRAY') {
+ $self->_prewalk($_)
+ for @{$value};
+ return;
+ }
+
+ # Unknown type. Need to know about it.
+ $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;
+}
+
+# Every data element and sub data element is a node.
+# Everything emitted goes through this function.
+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") # Stringified object
+ 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");
+}
+
+# A YAML mapping is akin to a Perl hash.
+sub _emit_mapping {
+ my $self = shift;
+ my ($value, $tag, $node_id, $context) = @_;
+ $self->{stream} .= " !$tag" if $tag;
+
+ # Sometimes 'keys' fails. Like on a bad tie implementation.
+ my $empty_hash = not(eval {keys %$value});
+ $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@;
+ return ($self->{stream} .= " {}\n") if $empty_hash;
+
+ # If CompressSeries is on (default) and legal is this context, then
+ # use it and make the indent level be 2 for this node.
+ 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;
+ }
+ # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
+ 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;
+ }
+ # Force the YAML::VALUE ('=') key to sort last.
+ 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}--;
+}
+
+# A YAML series is akin to a Perl array.
+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));
+
+ # XXX Really crufty feature. Better implemented by ynodes.
+ 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 == $#{$value};
+ $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}--;
+}
+
+# Emit a mapping key
+sub _emit_key {
+ my $self = shift;
+ my ($value, $context) = @_;
+ $self->{stream} .= ' ' x $self->offset->[$self->level]
+ unless $context == FROMARRAY;
+ $self->_emit_str($value, KEY);
+}
+
+# Emit a blessed SCALAR
+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 '', @_;
+}
+
+# Emit a string value. YAML has many scalar styles. This routine attempts to
+# guess the best style for the text.
+sub _emit_str {
+ my $self = shift;
+ my $type = $_[1] || 0;
+
+ # Use heuristics to find the best scalar emission style.
+ $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_number($_[0]),
+ $self->_emit($ef), last
+ if $self->is_literal_number($_[0]);
+ $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_literal_number {
+ my $self = shift;
+ # Stolen from JSON::Tiny
+ return B::svref_2object(\$_[0])->FLAGS & (B::SVp_IOK | B::SVp_NOK)
+ && 0 + $_[0] eq $_[0];
+}
+
+sub _emit_number {
+ my $self = shift;
+ return $self->_emit_plain($_[0]);
+}
+
+# Check whether or not a scalar should be emitted as an plain scalar.
+sub is_valid_plain {
+ my $self = shift;
+ return 0 unless length $_[0];
+ return 0 if $self->quote_numeric_strings and Scalar::Util::looks_like_number($_[0]);
+ # refer to YAML::Loader::parse_inline_simple()
+ 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);
+}
+
+# Plain means that the scalar is unquoted.
+sub _emit_plain {
+ my $self = shift;
+ $self->{stream} .= defined $_[0] ? $_[0] : '~';
+}
+
+# Double quoting is for single lined escaped strings.
+sub _emit_double {
+ my $self = shift;
+ (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
+ $self->{stream} .= qq{"$escaped"};
+}
+
+# Single quoting is for single lined unescaped strings.
+sub _emit_single {
+ my $self = shift;
+ my $item = shift;
+ $item =~ s{'}{''}g;
+ $self->{stream} .= "'$item'";
+}
+
+#==============================================================================
+# Utility subroutines.
+#==============================================================================
+
+# Indent a scalar to the current indentation level.
+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;
+}
+
+# Escapes for unprintable characters
+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
+ );
+
+# Escape the unprintable characters
+sub escape {
+ my $self = shift;
+ my ($text) = @_;
+ $text =~ s/\\/\\\\/g;
+ $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
+ return $text;
+}
+
+1;
View Lorry Controller Status