X-Git-Url: http://wagnertech.de/git?p=kivitendo-erp.git;a=blobdiff_plain;f=modules%2Foverride%2FYAML%2FDumper.pm;fp=modules%2Foverride%2FYAML%2FDumper.pm;h=0000000000000000000000000000000000000000;hp=5f75ab21682432443babd541b318d2ffa35ea322;hb=53593baa211863fbf66540cf1bcc36c8fb37257f;hpb=deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44

diff --git a/modules/override/YAML/Dumper.pm b/modules/override/YAML/Dumper.pm
deleted file mode 100644
index 5f75ab216..000000000
--- a/modules/override/YAML/Dumper.pm
+++ /dev/null
@@ -1,575 +0,0 @@
-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;