+++ /dev/null
-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;
projects / kivitendo-erp.git / blobdiff