simple.pm

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

  $content =~ s/^\s+//s;
  $content =~ s/\s+$//s;

  DEBUG > 2 and print "Ogling extensor: =extend $content\n";

  if($content =~
    m/^
      (\S+)         # 1 : new item
      \s+
      (\S+)         # 2 : fallback(s)
      (?:\s+(\S+))? # 3 : element name(s)
      \s*
      $
    /xs
  ) {
    my $new_letter = $1;
    my $fallbacks_one = $2;
    my $elements_one;
    $elements_one = defined($3) ? $3 : $1;

    DEBUG > 2 and print "Extensor has good syntax.\n";

    unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
      DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n";
      $self->whine(
        $para->[1]{'start_line'},
        "You can extend only formatting codes A-Z, not like \"$new_letter\""
      );
      return;
    }
    
    if(grep $new_letter eq $_, @Known_formatting_codes) {
      DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n";
      $self->whine(
        $para->[1]{'start_line'},
        "You can't extend an established code like \"$new_letter\""
      );
      
      #TODO: or allow if last bit is same?
      
      return;
    }

    unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s  # like "B", "M,I", etc.
      or $fallbacks_one eq '0' or $fallbacks_one eq '1'
    ) {
      $self->whine(
        $para->[1]{'start_line'},
        "Format for second =extend parameter must be like"
        . " M or 1 or 0 or M,N or M,N,O but you have it like "
        . $fallbacks_one
      );
      return;
    }
    
    unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
      $self->whine(
        $para->[1]{'start_line'},
        "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
        . $elements_one
      );
      return;
    }

    my @fallbacks  = split ',', $fallbacks_one,  -1;
    my @elements   = split ',', $elements_one, -1;

    foreach my $f (@fallbacks) {
      next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
      DEBUG > 2 and print "  Can't fall back on unknown code $f\n";
      $self->whine(
        $para->[1]{'start_line'},
        "Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
      );
      return;
    }

    DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n",
     @fallbacks, @elements;

    my $canonical_form;
    foreach my $e (@elements) {
      if(exists $self->{'accept_codes'}{$e}) {
        DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n";
        $canonical_form = $e;
        last; # first acceptable elementname wins!
      } else {
        DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n";
      }
    }


    if( defined $canonical_form ) {
      # We found a good N => elementname mapping
      $self->{'accept_codes'}{$new_letter} = $canonical_form;
      DEBUG > 2 and print
       "Extensor maps $new_letter => known element $canonical_form.\n";
    } else {
      # We have to use the fallback(s), which might be '0', or '1'.
      $self->{'accept_codes'}{$new_letter}
        = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
      DEBUG > 2 and print
       "Extensor maps $new_letter => fallbacks @fallbacks.\n";
    }

  } else {
    DEBUG > 2 and print "Extensor has bad syntax.\n";
    $self->whine(
      $para->[1]{'start_line'},
      "Unknown =extend syntax: $content"
    )
  }
  return;
}


#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.

sub _treat_Zs {  # Nix Z<...>'s
  my($self,@stack) = @_;

  my($i, $treelet);
  my $start_line = $stack[0][1]{'start_line'};

  # A recursive algorithm implemented iteratively!  Whee!

  while($treelet = shift @stack) {
    for($i = 2; $i < @$treelet; ++$i) { # iterate over children
      next unless ref $treelet->[$i];  # text nodes are uninteresting
      unless($treelet->[$i][0] eq 'Z') {
        unshift @stack, $treelet->[$i]; # recurse
        next;
      }
        
      DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n";
        
      # bitch UNLESS it's empty
      unless(  @{$treelet->[$i]} == 2
           or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
      ) {
        $self->whine( $start_line, "A non-empty Z<>" );
      }      # but kill it anyway
        
      splice(@$treelet, $i, 1); # thereby just nix this node.
      --$i;
        
    }
  }
  
  return;
}

# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

# Quoting perlpodspec:

# In parsing an L<...> code, Pod parsers must distinguish at least four
# attributes:

############# Not used.  Expressed via the element children plus
#############  the value of the "content-implicit" flag.
# First:
# The link-text. If there is none, this must be undef. (E.g., in "L<Perl
# Functions|perlfunc>", the link-text is "Perl Functions". In
# "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
# that link text may contain formatting.)
# 

############# The element children
# Second:
# The possibly inferred link-text -- i.e., if there was no real link text,
# then this is the text that we'll infer in its place. (E.g., for
# "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
#

############# The "to" attribute (which might be text, or a treelet)
# Third:
# The name or URL, or undef if none. (E.g., in "L<Perl
# Functions|perlfunc>", the name -- also sometimes called the page -- is
# "perlfunc". In "L</CAVEATS>", the name is undef.)
# 

############# The "section" attribute (which might be next, or a treelet)
# Fourth:
# The section (AKA "item" in older perlpods), or undef if none. E.g., in
# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
# is not the same as a manpage section like the "5" in "man 5 crontab".
# "Section Foo" in the Pod sense means the part of the text that's
# introduced by the heading or item whose text is "Foo".)
# 
# Pod parsers may also note additional attributes including:
#

############# The "type" attribute.
# Fifth:
# A flag for whether item 3 (if present) is a URL (like
# "http://lists.perl.org" is), in which case there should be no section
# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
# possibly a man page name (like "crontab(5)" is).
#

############# Not implemented, I guess.
# Sixth:
# The raw original L<...> content, before text is split on "|", "/", etc,
# and before E<...> codes are expanded.


# For L<...> codes without a "name|" part, only E<...> and Z<> codes may
# occur -- no other formatting codes. That is, authors should not use
# "L<B<Foo::Bar>>".
#
# Note, however, that formatting codes and Z<>'s can occur in any and all
# parts of an L<...> (i.e., in name, section, text, and url).

sub _treat_Ls {  # Process our dear dear friends, the L<...> sequences

  # L<name>
  # L<name/"sec"> or L<name/sec>
  # L</"sec"> or L</sec> or L<"sec">
  # L<text|name>
  # L<text|name/"sec"> or L<text|name/sec>
  # L<text|/"sec"> or L<text|/sec> or L<text|"sec">
  # L<scheme:...>

  my($self,@stack) = @_;

  my($i, $treelet);
  my $start_line = $stack[0][1]{'start_line'};

  # A recursive algorithm implemented iteratively!  Whee!

  while($treelet = shift @stack) {
    for(my $i = 2; $i < @$treelet; ++$i) {
      # iterate over children of current tree node
      next unless ref $treelet->[$i];  # text nodes are uninteresting
      unless($treelet->[$i][0] eq 'L') {
        unshift @stack, $treelet->[$i]; # recurse
        next;
      }
      
      
      # By here, $treelet->[$i] is definitely an L node
      DEBUG > 1 and print "Ogling L node $treelet->[$i]\n";
        
      # bitch if it's empty
      if(  @{$treelet->[$i]} == 2
       or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
      ) {
        $self->whine( $start_line, "An empty L<>" );
        $treelet->[$i] = 'L<>';  # just make it a text node
        next;  # and move on
      }
     
      # Catch URLs:
      # URLs can, alas, contain E<...> sequences, so we can't /assume/
      #  that this is one text node.  But it has to START with one text
      #  node...
      if(! ref $treelet->[$i][2] and
        $treelet->[$i][2] =~ m/^\w+:[^:\s]\S*$/s
      ) {
        $treelet->[$i][1]{'type'} = 'url';
        $treelet->[$i][1]{'content-implicit'} = 'yes';

        # TODO: deal with rel: URLs here?

        if( 3 == @{ $treelet->[$i] } ) {
          # But if it IS just one text node (most common case)
          DEBUG > 1 and printf qq{Catching "%s as " as ho-hum L<URL> link.\n},
            $treelet->[$i][2]
          ;
          $treelet->[$i][1]{'to'} = Pod::Simple::LinkSection->new(
            $treelet->[$i][2]
          );                   # its own treelet
        } else {
          # It's a URL but complex (like "L<foo:bazE<123>bar>").  Feh.
          #$treelet->[$i][1]{'to'} = [ @{$treelet->[$i]} ];
          #splice @{ $treelet->[$i][1]{'to'} }, 0,2;
          #DEBUG > 1 and printf qq{Catching "%s as " as complex L<URL> link.\n},
          #  join '~', @{$treelet->[$i][1]{'to'  }};
          
          $treelet->[$i][1]{'to'} = Pod::Simple::LinkSection->new(
            $treelet->[$i]  # yes, clone the whole content as a treelet
          );
          $treelet->[$i][1]{'to'}[0] = ''; # set the copy's tagname to nil
          die "SANITY FAILURE" if $treelet->[0] eq ''; # should never happen!
          DEBUG > 1 and print
           qq{Catching "$treelet->[$i][1]{'to'}" as a complex L<URL> link.\n};
        }

        next; # and move on
      }
      
      
      # Catch some very simple and/or common cases
      if(@{$treelet->[$i]} == 3 and ! ref $treelet->[$i][2]) {
        my $it = $treelet->[$i][2];
        if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections
          # Hopefully neither too broad nor too restrictive a RE
          DEBUG > 1 and print "Catching \"$it\" as manpage link.\n";
          $treelet->[$i][1]{'type'} = 'man';
          # This's the only place where man links can get made.
          $treelet->[$i][1]{'content-implicit'} = 'yes';
          $treelet->[$i][1]{'to'  } =
            Pod::Simple::LinkSection->new( $it ); # treelet!

          next;
        }
        if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
          # Extremely forgiving idea of what constitutes a bare
          #  modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
          DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n";
          $treelet->[$i][1]{'type'} = 'pod';
          $treelet->[$i][1]{'content-implicit'} = 'yes';
          $treelet->[$i][1]{'to'  } =
            Pod::Simple::LinkSection->new( $it ); # treelet!
          next;
        }
        # else fall thru...
      }
      
      

      # ...Uhoh, here's the real L<...> parsing stuff...
      # "With the ill behavior, with the ill behavior, with the ill behavior..."

      DEBUG > 1 and print "Running a real parse on this non-trivial L\n";
      
      
      my $link_text; # set to an arrayref if found
      my $ell = $treelet->[$i];
      my @ell_content = @$ell;
      splice @ell_content,0,2; # Knock off the 'L' and {} bits

      DEBUG > 3 and print " Ell content to start: ",
       pretty(@ell_content), "\n";


      # Look for the "|" -- only in CHILDREN (not all underlings!)
      # Like L<I like the strictness|strict>
      DEBUG > 3 and
         print "  Peering at L content for a '|' ...\n";
      for(my $j = 0; $j < @ell_content; ++$j) {
        next if ref $ell_content[$j];
        DEBUG > 3 and
         print "    Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";

        if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
          my @link_text = ($1);   # might be 0-length
          $ell_content[$j] = $2;  # might be 0-length

          DEBUG > 3 and
           print "     FOUND a '|' in it.  Splitting into [$1] + [$2]\n";

          unshift @link_text, splice @ell_content, 0, $j;
            # leaving only things at J and after
          @ell_content =  grep ref($_)||length($_), @ell_content ;
          $link_text   = [grep ref($_)||length($_), @link_text  ];
          DEBUG > 3 and printf
           "  So link text is %s\n  and remaining ell content is %s\n",
            pretty($link_text), pretty(@ell_content);
          last;
        }
      }
      
      
      # Now look for the "/" -- only in CHILDREN (not all underlings!)
      # And afterward, anything left in @ell_content will be the raw name
      # Like L<Foo::Bar/Object Methods>
      my $section_name;  # set to arrayref if found
      DEBUG > 3 and print "  Peering at L-content for a '/' ...\n";
      for(my $j = 0; $j < @ell_content; ++$j) {
        next if ref $ell_content[$j];
        DEBUG > 3 and
         print "    Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";

        if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
          my @section_name = ($2); # might be 0-length
          $ell_content[$j] =  $1;  # might be 0-length

          DEBUG > 3 and
           print "     FOUND a '/' in it.",