simple.pm

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

}

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

sub parse_file {
  my($self, $source) = (@_);

  if(!defined $source) {
    Carp::croak("Can't use empty-string as a source for parse_file");
  } elsif(ref(\$source) eq 'GLOB') {
    $self->{'source_filename'} = '' . ($source);
  } elsif(ref $source) {
    $self->{'source_filename'} = '' . ($source);
  } elsif(!length $source) {
    Carp::croak("Can't use empty-string as a source for parse_file");
  } else {
    {
      local *PODSOURCE;
      open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
      $self->{'source_filename'} = $source;
      $source = *PODSOURCE{IO};
    }
    $self->_init_fh_source($source);
  }
  # By here, $source is a FH.

  $self->{'source_fh'} = $source;
  
  my($i, @lines);
  until( $self->{'source_dead'} ) {
    splice @lines;
    for($i = MANY_LINES; $i--;) {  # read those many lines at a time
      local $/ = $NL;
      push @lines, scalar(<$source>);  # readline
      last unless defined $lines[-1];
       # but pass thru the undef, which will set source_dead to true
    }
    $self->parse_lines(@lines);
  }
  delete($self->{'source_fh'}); # so it can be GC'd
  return $self;
}

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

sub parse_from_file {
  # An emulation of Pod::Parser's interface, for the sake of Perldoc.
  # Basically just a wrapper around parse_file.

  my($self, $source, $to) = @_;
  $self = $self->new unless ref($self); # so we tolerate being a class method
  
  if(!defined $source)             { $source = *STDIN{IO}
  } elsif(ref(\$source) eq 'GLOB') { # stet
  } elsif(ref($source)           ) { # stet
  } elsif(!length $source
     or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i
  ) { 
    $source = *STDIN{IO};
  }

  if(!defined $to) {             $self->output_fh( *STDOUT{IO}   );
  } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
  } elsif(ref($to)) {            $self->output_fh( $to );
  } elsif(!length $to
     or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
  ) {
    $self->output_fh( *STDOUT{IO} );
  } else {
    require Symbol;
    my $out_fh = Symbol::gensym();
    DEBUG and print "Write-opening to $to\n";
    open($out_fh, ">$to")  or  Carp::croak "Can't write-open $to: $!";
    binmode($out_fh)
     if $self->can('write_with_binmode') and $self->write_with_binmode;
    $self->output_fh($out_fh);
  }

  return $self->parse_file($source);
}

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

sub whine {
  #my($self,$line,$complaint) = @_;
  my $self = shift(@_);
  ++$self->{'errors_seen'};
  if($self->{'no_whining'}) {
    DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
    return;
  }
  return $self->_complain_warn(@_) if $self->{'complain_stderr'};
  return $self->_complain_errata(@_);
}

sub scream {    # like whine, but not suppressable
  #my($self,$line,$complaint) = @_;
  my $self = shift(@_);
  ++$self->{'errors_seen'};
  return $self->_complain_warn(@_) if $self->{'complain_stderr'};
  return $self->_complain_errata(@_);
}

sub _complain_warn {
  my($self,$line,$complaint) = @_;
  return printf STDERR "%s around line %s: %s\n",
    $self->{'source_filename'} || 'Pod input', $line, $complaint;
}

sub _complain_errata {
  my($self,$line,$complaint) = @_;
  if( $self->{'no_errata_section'} ) {
    DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
  } else {
    DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n";
    push @{$self->{'errata'}{$line}}, $complaint
      # for a report to be generated later!
  }
  return 1;
}

#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

sub _get_initial_item_type {
  # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
  my($self, $para) = @_;
  return $para->[1]{'~type'}  if $para->[1]{'~type'};

  return $para->[1]{'~type'} = 'text'
   if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
  # Else fall thru to the general case:
  return $self->_get_item_type($para);
}



sub _get_item_type {       # mutates the item!!
  my($self, $para) = @_;
  return $para->[1]{'~type'} if $para->[1]{'~type'};


  # Otherwise we haven't yet been to this node.  Maybe alter it...
  
  my $content = join "\n", @{$para}[2 .. $#$para];

  if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
    # Like: "=item *", "=item   *   ", "=item"
    splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
    $para->[1]{'~orig_content'} = $content;
    return $para->[1]{'~type'} = 'bullet';

  } elsif($content =~ m/^\s*\*\s+(.+)/s) {  # tolerance
  
    # Like: "=item * Foo bar baz";
    $para->[1]{'~orig_content'}      = $content;
    $para->[1]{'~_freaky_para_hack'} = $1;
    DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n";
    splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
    return $para->[1]{'~type'} = 'bullet';

  } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
    # Like: "=item 1.", "=item    123412"
    
    $para->[1]{'~orig_content'} = $content;
    $para->[1]{'number'} = $1;  # Yes, stores the number there!

    splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
    return $para->[1]{'~type'} = 'number';
    
  } else {
    # It's anything else.
    return $para->[1]{'~type'} = 'text';

  }
}

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

sub _make_treelet {
  my $self = shift;  # and ($para, $start_line)
  my $treelet;
  if(!@_) {
    return [''];
  } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
    # Hack so we can pass in fake-o pre-cooked paragraphs:
    #  just have the first line be a reference to a ['~Top', {}, ...]
    # We use this feechure in gen_errata and stuff.

    DEBUG and print "Applying precooked treelet hack to $_[0][0]\n";
    $treelet = $_[0][0];
    splice @$treelet, 0, 2;  # lop the top off
    return $treelet;
  } else {
    $treelet = $self->_treelet_from_formatting_codes(@_);
  }
  
  if( $self->_remap_sequences($treelet) ) {
    $self->_treat_Zs($treelet);  # Might as well nix these first
    $self->_treat_Ls($treelet);  # L has to precede E and S
    $self->_treat_Es($treelet);
    $self->_treat_Ss($treelet);  # S has to come after E

    $self->_wrap_up($treelet); # Nix X's and merge texties
    
  } else {
    DEBUG and print "Formatless treelet gets fast-tracked.\n";
     # Very common case!
  }
  
  splice @$treelet, 0, 2;  # lop the top off

  return $treelet;
}

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

sub _wrap_up {
  my($self, @stack) = @_;
  my $nixx  = $self->{'nix_X_codes'};
  my $merge = $self->{'merge_text' };
  return unless $nixx or $merge;

  DEBUG > 2 and print "\nStarting _wrap_up traversal.\n",
   $merge ? (" Merge mode on\n") : (),
   $nixx  ? (" Nix-X mode on\n") : (),
  ;    
  

  my($i, $treelet);
  while($treelet = shift @stack) {
    DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
    for($i = 2; $i < @$treelet; ++$i) { # iterate over children
      DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n";
      if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
        DEBUG > 3 and print "   Nixing X node at $i\n";
        splice(@$treelet, $i, 1); # just nix this node (and its descendants)
        # no need to back-update the counter just yet
        redo;

      } elsif($merge and $i != 2 and  # non-initial
         !ref $treelet->[$i] and !ref $treelet->[$i - 1]
      ) {
        DEBUG > 3 and print "   Merging ", $i-1,
         ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
        $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
        DEBUG > 4 and print "    Now: ", $i-1, ":[$treelet->[$i-1]]\n";
        --$i;
        next; 
        # since we just pulled the possibly last node out from under
        #  ourselves, we can't just redo()

      } elsif( ref $treelet->[$i] ) {
        DEBUG > 4 and print "  Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
        push @stack, $treelet->[$i];

        if($treelet->[$i][0] eq 'L') {
          my $thing;
          foreach my $attrname ('section', 'to') {        
            if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
              unshift @stack, $thing;
              DEBUG > 4 and print "  +Enqueuing ",
               pretty( $treelet->[$i][1]{$attrname} ),
               " as an attribute value to tweak.\n";
            }
          }
        }
      }
    }
  }
  DEBUG > 2 and print "End of _wrap_up traversal.\n\n";

  return;
}

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

sub _remap_sequences {
  my($self,@stack) = @_;
  
  if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
    # VERY common case: abort it.
    DEBUG and print "Skipping _remap_sequences: formatless treelet.\n";
    return 0;
  }
  
  my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");

  my $start_line = $stack[0][1]{'start_line'};
  DEBUG > 2 and printf
   "\nAbout to start _remap_sequences on treelet from line %s.\n",
   $start_line || '[?]'
  ;
  DEBUG > 3 and print " Map: ",
    join('; ', map "$_=" . (
        ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
      ),
      sort keys %$map ),
    ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
     ? "  (all normal)\n" : "\n"
  ;

  # A recursive algorithm implemented iteratively!  Whee!
  
  my($is, $was, $i, $treelet); # scratch
  while($treelet = shift @stack) {
    DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
    for($i = 2; $i < @$treelet; ++$i) { # iterate over children
      next unless ref $treelet->[$i];  # text nodes are uninteresting
      
      DEBUG > 4 and print "  Noting child $i : $treelet->[$i][0]<...>\n";
      
      $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
      if( DEBUG > 3 ) {
        if(!defined $is) {
          print "   Code $was<> is UNKNOWN!\n";
        } elsif($is eq $was) {
          DEBUG > 4 and print "   Code $was<> stays the same.\n";
        } else  {
          print "   Code $was<> maps to ",
           ref($is)
            ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
            : "tag $is<...>.\n";
        }
      }
      
      if(!defined $is) {
        $self->whine($start_line, "Deleting unknown formatting code $was<>");
        $is = $treelet->[$i][0] = '1';  # But saving the children!
        # I could also insert a leading "$was<" and tailing ">" as
        # children of this node, but something about that seems icky.
      }
      if(ref $is) {
        my @dynasty = @$is;
        DEBUG > 4 and print "    Renaming $was node to $dynasty[-1]\n"; 
        $treelet->[$i][0] = pop @dynasty;
        my $nugget;
        while(@dynasty) {
          DEBUG > 4 and printf
           "    Grafting a new %s node between %s and %s\n",
           $dynasty[-1], $treelet->[0], $treelet->[$i][0], 
          ;
          
          #$nugget = ;
          splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
            # relace node with a new parent
        }
      } elsif($is eq '0') {
        splice(@$treelet, $i, 1); # just nix this node (and its descendants)
        --$i;  # back-update the counter
      } elsif($is eq '1') {
        splice(@$treelet, $i, 1 # replace this node with its children!
          => splice @{ $treelet->[$i] },2
              # (not catching its first two (non-child) items)
        );
        --$i;  # back up for new stuff
      } else {
        # otherwise it's unremarkable
        unshift @stack, $treelet->[$i];  # just recurse
      }
    }
  }
  
  DEBUG > 2 and print "End of _remap_sequences traversal.\n\n";

  if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
    DEBUG and print "Noting that the treelet is now formatless.\n";
    return 0;
  }
  return 1;
}

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

sub _ponder_extend {

  # "Go to an extreme, move back to a more comfortable place"
  #  -- /Oblique Strategies/,  Brian Eno and Peter Schmidt
  
  my($self, $para) = @_;
  my $content = join ' ', splice @$para, 2;