simple.pm

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

             "  Splitting to page [...$1] + section [$2...]\n";

          push @section_name, splice @ell_content, 1+$j;
            # leaving only things before and including J
          
          @ell_content  = grep ref($_)||length($_), @ell_content  ;
          @section_name = grep ref($_)||length($_), @section_name ;

          # Turn L<.../"foo"> into L<.../foo>
          if(@section_name
            and !ref($section_name[0]) and !ref($section_name[-1])
            and $section_name[ 0] =~ m/^\"/s
            and $section_name[-1] =~ m/\"$/s
            and !( # catch weird degenerate case of L<"> !
              @section_name == 1 and $section_name[0] eq '"'
            )
          ) {
            $section_name[ 0] =~ s/^\"//s;
            $section_name[-1] =~ s/\"$//s;
            DEBUG > 3 and
             print "     Quotes removed: ", pretty(@section_name), "\n";
          } else {
            DEBUG > 3 and
             print "     No need to remove quotes in ", pretty(@section_name), "\n";
          }

          $section_name = \@section_name;
          last;
        }
      }

      # Turn L<"Foo Bar"> into L</Foo Bar>
      if(!$section_name and @ell_content
         and !ref($ell_content[0]) and !ref($ell_content[-1])
         and $ell_content[ 0] =~ m/^\"/s
         and $ell_content[-1] =~ m/\"$/s
         and !( # catch weird degenerate case of L<"> !
           @ell_content == 1 and $ell_content[0] eq '"'
         )
      ) {
        $section_name = [splice @ell_content];
        $section_name->[ 0] =~ s/^\"//s;
        $section_name->[-1] =~ s/\"$//s;
      }

      # Turn L<Foo Bar> into L</Foo Bar>.
      if(!$section_name and !$link_text and @ell_content
         and grep !ref($_) && m/ /s, @ell_content
      ) {
        $section_name = [splice @ell_content];
        # That's support for the now-deprecated syntax.
        # (Maybe generate a warning eventually?)
        # Note that it deliberately won't work on L<...|Foo Bar>
      }


      # Now make up the link_text
      # L<Foo>     -> L<Foo|Foo>
      # L</Bar>    -> L<"Bar"|Bar>
      # L<Foo/Bar> -> L<"Bar" in Foo/Foo>
      unless($link_text) {
        $ell->[1]{'content-implicit'} = 'yes';
        $link_text = [];
        push @$link_text, '"', @$section_name, '"' if $section_name;

        if(@ell_content) {
          $link_text->[-1] .= ' in ' if $section_name;
          push @$link_text, @ell_content;
        }
      }


      # And the E resolver will have to deal with all our treeletty things:

      if(@ell_content == 1 and !ref($ell_content[0])
         and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s
      ) {
        $ell->[1]{'type'}    = 'man';
        DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n";
      } else {
        $ell->[1]{'type'}    = 'pod';
        DEBUG > 3 and print "Considering this a pod link (not man or url).\n";
      }

      if( defined $section_name ) {
        $ell->[1]{'section'} = Pod::Simple::LinkSection->new(
          ['', {}, @$section_name]
        );
        DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n";
      }

      if( @ell_content ) {
        $ell->[1]{'to'} = Pod::Simple::LinkSection->new(
          ['', {}, @ell_content]
        );
        DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n";
      }
      
      # And update children to be the link-text:
      @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
      
      DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n";

      unshift @stack, $treelet->[$i]; # might as well recurse
    }
  }

  return;
}

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

sub _treat_Es {
  my($self,@stack) = @_;

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

  # A recursive algorithm implemented iteratively!  Whee!


  # Has frightening side effects on L nodes' attributes.

  #my @ells_to_tweak;

  while($treelet = shift @stack) {
    for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
      next unless ref $treelet->[$i];  # text nodes are uninteresting
      if($treelet->[$i][0] eq 'L') {
        # SPECIAL STUFF for semi-processed L<>'s
        
        my $thing;
        foreach my $attrname ('section', 'to') {        
          if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
            unshift @stack, $thing;
            DEBUG > 2 and print "  Enqueuing ",
             pretty( $treelet->[$i][1]{$attrname} ),
             " as an attribute value to tweak.\n";
          }
        }
        
        unshift @stack, $treelet->[$i]; # recurse
        next;
      } elsif($treelet->[$i][0] ne 'E') {
        unshift @stack, $treelet->[$i]; # recurse
        next;
      }
      
      DEBUG > 1 and print "Ogling E node ", pretty($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 E<>" );
        $treelet->[$i] = 'E<>'; # splice in a literal
        next;
      }
        
      # bitch if content is weird
      unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
        $self->whine( $start_line, "An E<...> surrounding strange content" );
        $replacer = $treelet->[$i]; # scratch
        splice(@$treelet, $i, 1,   # fake out a literal
          'E<',
          splice(@$replacer,2), # promote its content
          '>'
        );
        # Don't need to do --$i, as the 'E<' we just added isn't interesting.
        next;
      }

      DEBUG > 1 and print "Ogling E<$content>\n";

      $charnum  = Pod::Escapes::e2charnum($content);
      DEBUG > 1 and print " Considering E<$content> with char ",
        defined($charnum) ? $charnum : "undef", ".\n";

      if(!defined( $charnum )) {
        DEBUG > 1 and print "I don't know how to deal with E<$content>.\n";
        $self->whine( $start_line, "Unknown E content in E<$content>" );
        $replacer = "E<$content>"; # better than nothing
      } elsif($charnum >= 255 and !UNICODE) {
        $replacer = ASCII ? "\xA4" : "?";
        DEBUG > 1 and print "This Perl version can't handle ", 
          "E<$content> (chr $charnum), so replacing with $replacer\n";
      } else {
        $replacer = Pod::Escapes::e2char($content);
        DEBUG > 1 and print " Replacing E<$content> with $replacer\n";
      }

      splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
    }
  }

  return;
}


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

sub _treat_Ss {
  my($self,$treelet) = @_;
  
  _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};

  # TODO: or a change_nbsp_to_S
  #  Normalizing nbsp's to S is harder: for each text node, make S content
  #  out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/


  return;
}


sub _change_S_to_nbsp { #  a recursive function
  # Sanely assumes that the top node in the excursion won't be an S node.
  my($treelet, $in_s) = @_;
  
  my $is_s = ('S' eq $treelet->[0]);
  $in_s ||= $is_s; # So in_s is on either by this being an S element,
                   #  or by an ancestor being an S element.

  for(my $i = 2; $i < @$treelet; ++$i) {
    if(ref $treelet->[$i]) {
      if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
        my $to_pull_up = $treelet->[$i];
        splice @$to_pull_up,0,2;   # ...leaving just its content
        splice @$treelet, $i, 1, @$to_pull_up;  # Pull up content
        $i +=  @$to_pull_up - 1;   # Make $i skip the pulled-up stuff
      }
    } else {
      $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s;
       # (If not in ASCIIland, we can't assume that \xA0 == nbsp.)
       
       # Note that if you apply nbsp_for_S to text, and so turn
       # "foo S<bar baz> quux" into "foo bar&#160;faz quux", you
       # end up with something that fails to say "and don't hyphenate
       # any part of 'bar baz'".  However, hyphenation is such a vexing
       # problem anyway, that most Pod renderers just don't render it
       # at all.  But if you do want to implement hyphenation, I guess
       # that you'd better have nbsp_for_S off.
    }
  }

  return $is_s;
}

#-----------------------------------------------------------------------------

sub _accessorize {  # A simple-minded method-maker
  no strict 'refs';
  foreach my $attrname (@_) {
    next if $attrname =~ m/::/; # a hack
    *{caller() . '::' . $attrname} = sub {
      use strict;
      $Carp::CarpLevel = 1,  Carp::croak(
       "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
      ) unless (@_ == 1 or @_ == 2) and ref $_[0];
      (@_ == 1) ?  $_[0]->{$attrname}
                : ($_[0]->{$attrname} = $_[1]);
    };
  }
  # Ya know, they say accessories make the ensemble!
  return;
}

# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
#=============================================================================

sub filter {
  my($class, $source) = @_;
  my $new = $class->new;
  $new->output_fh(*STDOUT{IO});
  
  if(ref($source || '') eq 'SCALAR') {
    $new->parse_string_document( $$source );
  } elsif(ref($source)) {  # it's a file handle
    $new->parse_file($source);
  } else {  # it's a filename
    $new->parse_file($source);
  }
  
  return $new;
}


#-----------------------------------------------------------------------------

sub _out {
  # For use in testing: Class->_out($source)
  #  returns the transformation of $source
  
  my $class = shift(@_);

  my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';

  DEBUG and print "\n\n", '#' x 76,
   "\nAbout to parse source: {{\n$_[0]\n}}\n\n";
  
  
  my $parser = $class->new;
  $parser->hide_line_numbers(1);

  my $out = '';
  $parser->output_string( \$out );
  DEBUG and print " _out to ", \$out, "\n";
  
  $mutor->($parser) if $mutor;

  $parser->parse_string_document( $_[0] );
  # use Data::Dumper; print Dumper($parser), "\n";
  return $out;
}


sub _duo {
  # For use in testing: Class->_duo($source1, $source2)
  #  returns the parse trees of $source1 and $source2.
  # Good in things like: &ok( Class->duo(... , ...) );
  
  my $class = shift(@_);
  
  Carp::croak "But $class->_duo is useful only in list context!"
   unless wantarray;

  my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';

  Carp::croak "But $class->_duo takes two parameters, not: @_"
   unless @_ == 2;

  my(@out);
  
  while( @_ ) {
    my $parser = $class->new;

    push @out, '';
    $parser->output_string( \( $out[-1] ) );

    DEBUG and print " _duo out to ", $parser->output_string(),
      " = $parser->{'output_string'}\n";

    $parser->hide_line_numbers(1);
    $mutor->($parser) if $mutor;
    $parser->parse_string_document( shift( @_ ) );
    # use Data::Dumper; print Dumper($parser), "\n";
  }

  return @out;
}



#-----------------------------------------------------------------------------
1;
__END__

TODO:
A start_formatting_code and end_formatting_code methods, which in the
base class call start_L, end_L, start_C, end_C, etc., if they are
defined.

have the POD FORMATTING ERRORS section note the localtime, and the
version of Pod::Simple.

option to delete all E<shy>s?
option to scream if under-0x20 literals are found in the input, or
under-E<32> E codes are found in the tree. And ditto \x7f-\x9f

Option to turn highbit characters into their compromised form? (applies
to E parsing too)

TODO: BOM/encoding things.

TODO: ascii-compat things in the XML classes?