simple.pm

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

require 5;
package Pod::Simple;
use strict;
use Carp ();
BEGIN           { *DEBUG = sub () {0} unless defined &DEBUG }
use integer;
use Pod::Escapes 1.03 ();
use Pod::Simple::LinkSection ();
use Pod::Simple::BlackBox ();
#use utf8;

use vars qw(
  $VERSION @ISA
  @Known_formatting_codes  @Known_directives
  %Known_formatting_codes  %Known_directives
  $NL
);

@ISA = ('Pod::Simple::BlackBox');
$VERSION = '3.05';

@Known_formatting_codes = qw(I B C L E F S X Z); 
%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
@Known_directives       = qw(head1 head2 head3 head4 item over back); 
%Known_directives       = map(($_=>'Plain'), @Known_directives);
$NL = $/ unless defined $NL;

#-----------------------------------------------------------------------------
# Set up some constants:

BEGIN {
  if(defined &ASCII)    { }
  elsif(chr(65) eq 'A') { *ASCII = sub () {1}  }
  else                  { *ASCII = sub () {''} }

  unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
  DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n";
  unless(MANY_LINES() >= 1) {
    die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
  }
  if(defined &UNICODE) { }
  elsif($] >= 5.008)   { *UNICODE = sub() {1}  }
  else                 { *UNICODE = sub() {''} }
}
if(DEBUG > 2) {
  print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
  print "# We are under a Unicode-safe Perl.\n";
}

# Design note:
# This is a parser for Pod.  It is not a parser for the set of Pod-like
#  languages which happens to contain Pod -- it is just for Pod, plus possibly
#  some extensions.

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

__PACKAGE__->_accessorize(
  'nbsp_for_S',        # Whether to map S<...>'s to \xA0 characters
  'source_filename',   # Filename of the source, for use in warnings
  'source_dead',       # Whether to consider this parser's source dead

  'output_fh',         # The filehandle we're writing to, if applicable.
                       # Used only in some derived classes.

  'hide_line_numbers', # For some dumping subclasses: whether to pointedly
                       # suppress the start_line attribute
                      
  'line_count',        # the current line number
  'pod_para_count',    # count of pod paragraphs seen so far

  'no_whining',        # whether to suppress whining
  'no_errata_section', # whether to suppress the errata section
  'complain_stderr',   # whether to complain to stderr

  'doc_has_started',   # whether we've fired the open-Document event yet

  'bare_output',       # For some subclasses: whether to prepend
                       #  header-code and postpend footer-code

  'fullstop_space_harden', # Whether to turn ".  " into ".[nbsp] ";

  'nix_X_codes',       # whether to ignore X<...> codes
  'merge_text',        # whether to avoid breaking a single piece of
                       #  text up into several events

  'preserve_whitespace', # whether to try to keep whitespace as-is

 'content_seen',      # whether we've seen any real Pod content
 'errors_seen',       # TODO: document.  whether we've seen any errors (fatal or not)

 'codes_in_verbatim', # for PseudoPod extensions

 'code_handler',      # coderef to call when a code (non-pod) line is seen
 'cut_handler',       # coderef to call when a =cut line is seen
 #Called like:
 # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
 #  $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
  
);

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

sub any_errata_seen {  # good for using as an exit() value...
  return shift->{'errors_seen'} || 0;
}

#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Pull in some functions that, for some reason, I expect to see here too:
BEGIN {
  *pretty        = \&Pod::Simple::BlackBox::pretty;
  *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
}

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

sub version_report {
  my $class = ref($_[0]) || $_[0];
  if($class eq __PACKAGE__) {
    return "$class $VERSION";
  } else {
    my $v = $class->VERSION;
    return "$class $v (" . __PACKAGE__ . " $VERSION)";
  }
}

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

#sub curr_open { # read-only list accessor
#  return @{ $_[0]{'curr_open'} || return() };
#}
#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }


sub output_string {
  # Works by faking out output_fh.  Simplifies our code.
  #
  my $this = shift;
  return $this->{'output_string'} unless @_;  # GET.
  
  require Pod::Simple::TiedOutFH;
  my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
  $$x = '' unless defined $$x;
  DEBUG > 4 and print "# Output string set to $x ($$x)\n";
  $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
  return
    $this->{'output_string'} = $_[0];
    #${ ${ $this->{'output_fh'} } };
}

sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
sub abandon_output_fh     { $_[0]->output_fh(undef) }
# These don't delete the string or close the FH -- they just delete our
#  references to it/them.
# TODO: document these

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

sub new {
  # takes no parameters
  my $class = ref($_[0]) || $_[0];
  #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
  #  . __PACKAGE__ );
  return bless {
    'accept_codes'      => { map( ($_=>$_), @Known_formatting_codes ) },
    'accept_directives' => { %Known_directives },
    'accept_targets'    => {},
  }, $class;
}



# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.

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

sub _handle_element_start {     # OVERRIDE IN DERIVED CLASS
  my($self, $element_name, $attr_hash_r) = @_;
  return;
}

sub _handle_element_end {       # OVERRIDE IN DERIVED CLASS
  my($self, $element_name) = @_;
  return;
}

sub _handle_text          {     # OVERRIDE IN DERIVED CLASS
  my($self, $text) = @_;
  return;
}

#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And now directives (not targets)

sub accept_directive_as_verbatim  { shift->_accept_directives('Verbatim', @_) }
sub accept_directive_as_data      { shift->_accept_directives('Data',     @_) }
sub accept_directive_as_processed { shift->_accept_directives('Plain',    @_) }

sub _accept_directives {
  my($this, $type) = splice @_,0,2;
  foreach my $d (@_) {
    next unless defined $d and length $d;
    Carp::croak "\"$d\" isn't a valid directive name"
     unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
    Carp::croak "\"$d\" is already a reserved Pod directive name"
     if exists $Known_directives{$d};
    $this->{'accept_directives'}{$d} = $type;
    DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n";
  }
  DEBUG > 6 and print "$this\'s accept_directives : ",
   pretty($this->{'accept_directives'}), "\n";
  
  return sort keys %{ $this->{'accept_directives'} } if wantarray;
  return;
}

#--------------------------------------------------------------------------
# TODO: document these:

sub unaccept_directive { shift->unaccept_directives(@_) };

sub unaccept_directives {
  my $this = shift;
  foreach my $d (@_) {
    next unless defined $d and length $d;
    Carp::croak "\"$d\" isn't a valid directive name"
     unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
    Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
     if exists $Known_directives{$d};
    delete $this->{'accept_directives'}{$d};
    DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n";
  }
  return sort keys %{ $this->{'accept_directives'} } if wantarray;
  return
}

#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And now targets (not directives)

sub accept_target         { shift->accept_targets(@_)         } # alias
sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias


sub accept_targets         { shift->_accept_targets('1', @_) }

sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
 # forces them to be processed, even when there's no ":".

sub _accept_targets {
  my($this, $type) = splice @_,0,2;
  foreach my $t (@_) {
    next unless defined $t and length $t;
    # TODO: enforce some limitations on what a target name can be?
    $this->{'accept_targets'}{$t} = $type;
    DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n";
  }    
  return sort keys %{ $this->{'accept_targets'} } if wantarray;
  return;
}

#--------------------------------------------------------------------------
sub unaccept_target         { shift->unaccept_targets(@_) }

sub unaccept_targets {
  my $this = shift;
  foreach my $t (@_) {
    next unless defined $t and length $t;
    # TODO: enforce some limitations on what a target name can be?
    delete $this->{'accept_targets'}{$t};
    DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n";
  }    
  return sort keys %{ $this->{'accept_targets'} } if wantarray;
  return;
}

#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
# And now codes (not targets or directives)

sub accept_code { shift->accept_codes(@_) } # alias

sub accept_codes {  # Add some codes
  my $this = shift;
  
  foreach my $new_code (@_) {
    next unless defined $new_code and length $new_code;
    if(ASCII) {
      # A good-enough check that it's good as an XML Name symbol:
      Carp::croak "\"$new_code\" isn't a valid element name"
        if $new_code =~
          m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
            # Characters under 0x80 that aren't legal in an XML Name.
        or $new_code =~ m/^[-\.0-9]/s
        or $new_code =~ m/:[-\.0-9]/s;
            # The legal under-0x80 Name characters that 
            #  an XML Name still can't start with.
    }
    
    $this->{'accept_codes'}{$new_code} = $new_code;
    
    # Yes, map to itself -- just so that when we
    #  see "=extend W [whatever] thatelementname", we say that W maps
    #  to whatever $this->{accept_codes}{thatelementname} is,
    #  i.e., "thatelementname".  Then when we go re-mapping,
    #  a "W" in the treelet turns into "thatelementname".  We only
    #  remap once.
    # If we say we accept "W", then a "W" in the treelet simply turns
    #  into "W".
  }
  
  return;
}

#--------------------------------------------------------------------------
sub unaccept_code { shift->unaccept_codes(@_) }

sub unaccept_codes { # remove some codes
  my $this = shift;
  
  foreach my $new_code (@_) {
    next unless defined $new_code and length $new_code;
    if(ASCII) {
      # A good-enough check that it's good as an XML Name symbol:
      Carp::croak "\"$new_code\" isn't a valid element name"
        if $new_code =~
          m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
            # Characters under 0x80 that aren't legal in an XML Name.
        or $new_code =~ m/^[-\.0-9]/s
        or $new_code =~ m/:[-\.0-9]/s;
            # The legal under-0x80 Name characters that 
            #  an XML Name still can't start with.
    }
    
    Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
     if grep $new_code eq $_, @Known_formatting_codes;

    delete $this->{'accept_codes'}{$new_code};

    DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n";
  }
  
  return;
}


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

sub parse_string_document {
  my $self = shift;
  my @lines;
  foreach my $line_group (@_) {
    next unless defined $line_group and length $line_group;
    pos($line_group) = 0;
    while($line_group =~
      m/([^\n\r]*)((?:\r?\n)?)/g
    ) {
      #print(">> $1\n"),
      $self->parse_lines($1)
       if length($1) or length($2)
        or pos($line_group) != length($line_group);
       # I.e., unless it's a zero-length "empty line" at the very
       #  end of "foo\nbar\n" (i.e., between the \n and the EOS).
    }
  }
  $self->parse_lines(undef); # to signal EOF
  return $self;
}

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

  #DEBUG > 1 and print "Declaring $source as :raw for starters\n";
  #$self->_apply_binmode($source, ':raw');
  #binmode($source, ":raw");

  return;