dumper.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

    }
    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_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;
}

# 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];
    # 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 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;

__END__

=head1 NAME

YAML::Dumper - YAML class for dumping Perl objects to YAML

=head1 SYNOPSIS

    use YAML::Dumper;
    my $dumper = YAML::Dumper->new;
    $dumper->indent_width(4);
    print $dumper->dump({foo => 'bar'});

=head1 DESCRIPTION

YAML::Dumper is the module that YAML.pm used to serialize Perl objects to
YAML. It is fully object oriented and usable on its own.

=head1 AUTHOR

Ingy d枚t Net <[e-mail]>

=head1 COPYRIGHT

Copyright (c) 2006. Ingy d枚t Net. All rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut