loader.pm

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

        }
    }
    return $seq;
}

# Parse an inline value. Since YAML supports inline collections, this is
# the top level of a sub parsing.
sub _parse_inline {
    my $self = shift;
    my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
    $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
    my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
    ($anchor, $alias, $explicit, $implicit, $self->{inline}) = 
      $self->_parse_qualifiers($self->inline);
    if ($anchor) {
        $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
    }
    $implicit ||= $top_implicit;
    $explicit ||= $top_explicit;
    ($top_implicit, $top_explicit) = ('', '');
    if ($alias) {
        $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
          unless defined $self->anchor2node->{$alias};
        if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
            $node = $self->anchor2node->{$alias};
        }
        else {
            $node = do {my $sv = "*$alias"};
            push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; 
        }
    }
    elsif ($self->inline =~ /^\{/) {
        $node = $self->_parse_inline_mapping($anchor);
    }
    elsif ($self->inline =~ /^\[/) {
        $node = $self->_parse_inline_seq($anchor);
    }
    elsif ($self->inline =~ /^"/) {
        $node = $self->_parse_inline_double_quoted();
        $node = $self->_unescape($node);
        $node = $self->_parse_implicit($node) if $implicit;
    }
    elsif ($self->inline =~ /^'/) {
        $node = $self->_parse_inline_single_quoted();
        $node = $self->_parse_implicit($node) if $implicit;
    }
    else {
        if ($top) {
            $node = $self->inline;
            $self->inline('');
        }
        else {
            $node = $self->_parse_inline_simple();
        }
        $node = $self->_parse_implicit($node) unless $explicit;
    }
    if ($explicit) {
        $node = $self->_parse_explicit($node, $explicit);
    }
    if ($anchor) {
        if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
            for my $ref (@{$self->anchor2node->{$anchor}}) {
                ${$ref->[0]} = $node;
                $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
                    $anchor, $ref->[1]);
            }
        }
        $self->anchor2node->{$anchor} = $node;
    }
    return $node;
}

# Parse the inline YAML mapping into a Perl hash
sub _parse_inline_mapping {
    my $self = shift;
    my ($anchor) = @_;
    my $node = {};
    $self->anchor2node->{$anchor} = $node;

    $self->die('YAML_PARSE_ERR_INLINE_MAP')
      unless $self->{inline} =~ s/^\{\s*//;
    while (not $self->{inline} =~ s/^\s*\}//) {
        my $key = $self->_parse_inline();
        $self->die('YAML_PARSE_ERR_INLINE_MAP')
          unless $self->{inline} =~ s/^\: \s*//;
        my $value = $self->_parse_inline();
        if (exists $node->{$key}) {
            $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
        }
        else {
            $node->{$key} = $value;
        }
        next if $self->inline =~ /^\s*\}/;
        $self->die('YAML_PARSE_ERR_INLINE_MAP')
          unless $self->{inline} =~ s/^\,\s*//;
    }
    return $node;
}

# Parse the inline YAML sequence into a Perl array
sub _parse_inline_seq {
    my $self = shift;
    my ($anchor) = @_;
    my $node = [];
    $self->anchor2node->{$anchor} = $node;

    $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
      unless $self->{inline} =~ s/^\[\s*//;
    while (not $self->{inline} =~ s/^\s*\]//) {
        my $value = $self->_parse_inline();
        push @$node, $value;
        next if $self->inline =~ /^\s*\]/;
        $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') 
          unless $self->{inline} =~ s/^\,\s*//;
    }
    return $node;
}

# Parse the inline double quoted string.
sub _parse_inline_double_quoted {
    my $self = shift;
    my $node;
    if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) {
        $node = $1;
        $self->inline($2);
        $node =~ s/\\"/"/g;
    }
    else {
        $self->die('YAML_PARSE_ERR_BAD_DOUBLE');
    }
    return $node;
}


# Parse the inline single quoted string.
sub _parse_inline_single_quoted {
    my $self = shift;
    my $node;
    if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) {
        $node = $1;
        $self->inline($2);
        $node =~ s/''/'/g;
    }
    else {
        $self->die('YAML_PARSE_ERR_BAD_SINGLE');
    }
    return $node;
}

# Parse the inline unquoted string and do implicit typing.
sub _parse_inline_simple {
    my $self = shift;
    my $value;
    if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) {
        $value = $1;
        substr($self->{inline}, 0, length($1)) = '';
    }
    else {
        $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value);
    }
    return $value;
}

sub _parse_implicit {
    my $self = shift;
    my ($value) = @_;
    $value =~ s/\s*$//;
    return $value if $value eq '';
    return undef if $value =~ /^~$/;
    return $value
      unless $value =~ /^[\@\`\^]/ or
             $value =~ /^[\-\?]\s/;
    $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value);
}

# Unfold a YAML multiline scalar into a single string.
sub _parse_unfold {
    my $self = shift;
    my ($chomp) = @_;
    my $node = '';
    my $space = 0;
    while (not $self->done and $self->indent == $self->offset->[$self->level]) {
        $node .= $self->content. "\n";
        $self->_parse_next_line(LEAF);
    }
    $node =~ s/^(\S.*)\n(?=\S)/$1 /gm;
    $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm;
    $node =~ s/\n*\Z// unless $chomp eq '+';
    $node .= "\n" unless $chomp;
    return $node;
}

# Parse a YAML block style scalar. This is like a Perl here-document.
sub _parse_block {
    my $self = shift;
    my ($chomp) = @_;
    my $node = '';
    while (not $self->done and $self->indent == $self->offset->[$self->level]) {
        $node .= $self->content . "\n";
        $self->_parse_next_line(LEAF);
    }
    return $node if '+' eq $chomp;
    $node =~ s/\n*\Z/\n/;
    $node =~ s/\n\Z// if $chomp eq '-';
    return $node;
}

# Handle Perl style '#' comments. Comments must be at the same indentation
# level as the collection line following them.
sub _parse_throwaway_comments {
    my $self = shift;
    while (@{$self->lines} and
           $self->lines->[0] =~ m{^\s*(\#|$)}
          ) {
        shift @{$self->lines};
        $self->{line}++;
    }
    $self->eos($self->{done} = not @{$self->lines});
}

# This is the routine that controls what line is being parsed. It gets called
# once for each line in the YAML stream.
#
# This routine must:
# 1) Skip past the current line
# 2) Determine the indentation offset for a new level
# 3) Find the next _content_ line
#   A) Skip over any throwaways (Comments/blanks)
#   B) Set $self->indent, $self->content, $self->line
# 4) Expand tabs appropriately  
sub _parse_next_line {
    my $self = shift;
    my ($type) = @_;
    my $level = $self->level;
    my $offset = $self->offset->[$level];
    $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset;
    shift @{$self->lines};
    $self->eos($self->{done} = not @{$self->lines});
    return if $self->eos;
    $self->{line}++;

    # Determine the offset for a new leaf node
    if ($self->preface =~
        qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/
       ) {
        $self->die('YAML_PARSE_ERR_ZERO_INDENT')
          if length($1) and $1 == 0;
        $type = LEAF;
        if (length($1)) {
            $self->offset->[$level + 1] = $offset + $1;
        }
        else {
            # First get rid of any comments.
            while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) {
                $self->lines->[0] =~ /^( *)/ or die;
                last unless length($1) <= $offset;
                shift @{$self->lines};
                $self->{line}++;
            }
            $self->eos($self->{done} = not @{$self->lines});
            return if $self->eos;
            if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) {
                $self->offset->[$level+1] = length($1);
            }
            else {
                $self->offset->[$level+1] = $offset + 1;
            }
        }
        $offset = $self->offset->[++$level];
    }
    # Determine the offset for a new collection level
    elsif ($type == COLLECTION and 
           $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
        $self->_parse_throwaway_comments();
        if ($self->eos) {
            $self->offset->[$level+1] = $offset + 1;
            return;
        }
        else {
            $self->lines->[0] =~ /^( *)\S/ or die;
            if (length($1) > $offset) {
                $self->offset->[$level+1] = length($1);
            }
            else {
                $self->offset->[$level+1] = $offset + 1;
            }
        }
        $offset = $self->offset->[++$level];
    }
        
    if ($type == LEAF) {
        while (@{$self->lines} and
               $self->lines->[0] =~ m{^( *)(\#)} and
               length($1) < $offset
              ) {
            shift @{$self->lines};
            $self->{line}++;
        }
        $self->eos($self->{done} = not @{$self->lines});
    }
    else {
        $self->_parse_throwaway_comments();
    }
    return if $self->eos; 
    
    if ($self->lines->[0] =~ /^---(\s|$)/) {
        $self->done(1);
        return;
    }
    if ($type == LEAF and 
        $self->lines->[0] =~ /^ {$offset}(.*)$/
       ) {
        $self->indent($offset);
        $self->content($1);
    }
    elsif ($self->lines->[0] =~ /^\s*$/) {
        $self->indent($offset);
        $self->content('');
    }
    else {
        $self->lines->[0] =~ /^( *)(\S.*)$/;
        while ($self->offset->[$level] > length($1)) {
            $level--;
        }
        $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION') 
          if $self->offset->[$level] != length($1);
        $self->indent(length($1));
        $self->content($2);
    }
    $self->die('YAML_PARSE_ERR_INDENTATION')
      if $self->indent - $offset > 1;
}

#==============================================================================
# Utility subroutines.
#==============================================================================

# Printable characters for escapes
my %unescapes = 
  (
   0 => "\x00", a => "\x07", t => "\x09",
   n => "\x0a", v => "\x0b", f => "\x0c",
   r => "\x0d", e => "\x1b", '\\' => '\\',
  );
   
# Transform all the backslash style escape characters to their literal meaning
sub _unescape {
    my $self = shift;
    my ($node) = @_;
    $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
              (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
    return $node;
}

1;

__END__

=head1 NAME

YAML::Loader - YAML class for loading Perl objects to YAML

=head1 SYNOPSIS

    use YAML::Loader;
    my $loader = YAML::Loader->new;
    my $hash = $loader->load(<<'...');
    foo: bar
    ...

=head1 DESCRIPTION

YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl
objects. 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