perldoc.pm

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

        } or die;
    }
    
    return 1;
      # i.e., an UNSUCCESSFUL return value!
}

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

sub check_file {
    my($self, $dir, $file) = @_;
    
    unless( ref $self ) {
      # Should never get called:
      $Carp::Verbose = 1;
      require Carp;
      Carp::croak( join '',
        "Crazy ", __PACKAGE__, " error:\n",
        "check_file must be an object_method!\n",
        "Aborting"
      );
    }
    
    if(length $dir and not -d $dir) {
      DEBUG > 3 and print "  No dir $dir -- skipping.\n";
      return "";
    }
    
    if ($self->opt_m) {
	return $self->minus_f_nocase($dir,$file);
    }
    
    else {
	my $path = $self->minus_f_nocase($dir,$file);
        if( length $path and $self->containspod($path) ) {
            DEBUG > 3 and print
              "  The file $path indeed looks promising!\n";
            return $path;
        }
    }
    DEBUG > 3 and print "  No good: $file in $dir\n";
    
    return "";
}

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

sub containspod {
    my($self, $file, $readit) = @_;
    return 1 if !$readit && $file =~ /\.pod\z/i;


    #  Under cygwin the /usr/bin/perl is legal executable, but
    #  you cannot open a file with that name. It must be spelled
    #  out as "/usr/bin/perl.exe".
    #
    #  The following if-case under cygwin prevents error
    #
    #     $ perldoc perl
    #     Cannot open /usr/bin/perl: no such file or directory
    #
    #  This would work though
    #
    #     $ perldoc perl.pod

    if ( IS_Cygwin  and  -x $file  and  -f "$file.exe" )
    {
        warn "Cygwin $file.exe search skipped\n"  if DEBUG or $self->opt_v;
        return 0;
    }

    local($_);
    open(TEST,"<", $file) 	or die "Can't open $file: $!";   # XXX 5.6ism
    while (<TEST>) {
	if (/^=head/) {
	    close(TEST) 	or die "Can't close $file: $!";
	    return 1;
	}
    }
    close(TEST) 		or die "Can't close $file: $!";
    return 0;
}

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

sub maybe_diddle_INC {
  my $self = shift;
  
  # Does this look like a module or extension directory?
  
  if (-f "Makefile.PL") {

    # Add "." and "lib" to @INC (if they exist)
    eval q{ use lib qw(. lib); 1; } or die;

    # don't add if superuser
    if ($< && $> && -f "blib") {   # don't be looking too hard now!
      eval q{ use blib; 1 };
      warn $@ if $@ && $self->opt_v;
    }
  }
  
  return;
}

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

sub new_output_file {
  my $self = shift;
  my $outspec = $self->opt_d;  # Yes, -d overrides all else!
                               # So don't call this twice per format-job!
  
  return $self->new_tempfile(@_) unless defined $outspec and length $outspec;

  # Otherwise open a write-handle on opt_d!f

  my $fh;
  # If we are running before perl5.6.0, we can't autovivify
  if ($] < 5.006) {
    require Symbol;
    $fh = Symbol::gensym();
  }
  DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
  die "Can't write-open $outspec: $!"
   unless open($fh, ">", $outspec); # XXX 5.6ism
  
  DEBUG > 3 and print "Successfully opened $outspec\n";
  binmode($fh) if $self->{'output_is_binary'};
  return($fh, $outspec);
}

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

sub useful_filename_bit {
  # This tries to provide a meaningful bit of text to do with the query,
  # such as can be used in naming the file -- since if we're going to be
  # opening windows on temp files (as a "pager" may well do!) then it's
  # better if the temp file's name (which may well be used as the window
  # title) isn't ALL just random garbage!
  # In other words "perldoc_LWPSimple_2371981429" is a better temp file
  # name than "perldoc_2371981429".  So this routine is what tries to
  # provide the "LWPSimple" bit.
  #
  my $self = shift;
  my $pages = $self->{'pages'} || return undef;
  return undef unless @$pages;
  
  my $chunk = $pages->[0];
  return undef unless defined $chunk;
  $chunk =~ s/:://g;
  $chunk =~ s/\.\w+$//g; # strip any extension
  if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
    $chunk = $1;
  } else {
    return undef;
  }
  $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
  $chunk = substr($chunk, -10) if length($chunk) > 10;
  return $chunk;
}

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

sub new_tempfile {    # $self->new_tempfile( [$suffix, [$infix] ] )
  my $self = shift;

  ++$Temp_Files_Created;

  if( IS_MSWin32 ) {
    my @out = $self->MSWin_perldoc_tempfile(@_);
    return @out if @out;
    # otherwise fall thru to the normal stuff below...
  }
  
  require File::Temp;
  return File::Temp::tempfile(UNLINK => 1);
}

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

sub page {  # apply a pager to the output file
    my ($self, $output, $output_to_stdout, @pagers) = @_;
    if ($output_to_stdout) {
        $self->aside("Sending unpaged output to STDOUT.\n");
	open(TMP, "<", $output)  or  die "Can't open $output: $!"; # XXX 5.6ism
	local $_;
	while (<TMP>) {
	    print or die "Can't print to stdout: $!";
	} 
	close TMP  or die "Can't close while $output: $!";
	$self->unlink_if_temp_file($output);
    } else {
        # On VMS, quoting prevents logical expansion, and temp files with no
        # extension get the wrong default extension (such as .LIS for TYPE)

        $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;

        $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
          # Altho "/" under MSWin is in theory good as a pathsep,
          #  many many corners of the OS don't like it.  So we
          #  have to force it to be "\" to make everyone happy.

        foreach my $pager (@pagers) {
            $self->aside("About to try calling $pager $output\n");
            if (IS_VMS) {
                last if system("$pager $output") == 0;
            } else {
	        last if system("$pager \"$output\"") == 0;
            }
	}
    }
    return;
}

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

sub searchfor {
    my($self, $recurse,$s,@dirs) = @_;
    $s =~ s!::!/!g;
    $s = VMS::Filespec::unixify($s) if IS_VMS;
    return $s if -f $s && $self->containspod($s);
    $self->aside( "Looking for $s in @dirs\n" );
    my $ret;
    my $i;
    my $dir;
    $self->{'target'} = (splitdir $s)[-1];  # XXX: why not use File::Basename?
    for ($i=0; $i<@dirs; $i++) {
	$dir = $dirs[$i];
	next unless -d $dir;
	($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
	if (       (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
		or ( $ret = $self->check_file($dir,"$s.pm"))
		or ( $ret = $self->check_file($dir,$s))
		or ( IS_VMS and
		     $ret = $self->check_file($dir,"$s.com"))
		or ( IS_OS2 and
		     $ret = $self->check_file($dir,"$s.cmd"))
		or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
		     $ret = $self->check_file($dir,"$s.bat"))
		or ( $ret = $self->check_file("$dir/pod","$s.pod"))
		or ( $ret = $self->check_file("$dir/pod",$s))
		or ( $ret = $self->check_file("$dir/pods","$s.pod"))
		or ( $ret = $self->check_file("$dir/pods",$s))
	) {
	    DEBUG > 1 and print "  Found $ret\n";
	    return $ret;
	}

	if ($recurse) {
	    opendir(D,$dir)	or die "Can't opendir $dir: $!";
	    my @newdirs = map catfile($dir, $_), grep {
		not /^\.\.?\z/s and
		not /^auto\z/s  and   # save time! don't search auto dirs
		-d  catfile($dir, $_)
	    } readdir D;
	    closedir(D)		or die "Can't closedir $dir: $!";
	    next unless @newdirs;
	    # what a wicked map!
	    @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
	    $self->aside( "Also looking in @newdirs\n" );
	    push(@dirs,@newdirs);
	}
    }
    return ();
}

#..........................................................................
{
  my $already_asserted;
  sub assert_closing_stdout {
    my $self = shift;

    return if $already_asserted;

    eval  q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
     # What for? to let the pager know that nothing more will come?
  
    die $@ if $@;
    $already_asserted = 1;
    return;
  }
}

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

sub tweak_found_pathnames {
  my($self, $found) = @_;
  if (IS_MSWin32) {
    foreach (@$found) { s,/,\\,g }
  }
  return;
}

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

sub am_taint_checking {
    my $self = shift;
    die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
    my($k,$v) = each %ENV;
    return is_tainted($v);  
}

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

sub is_tainted { # just a function
    my $arg  = shift;
    my $nada = substr($arg, 0, 0);  # zero-length!
    local $@;  # preserve the caller's version of $@
    eval { eval "# $nada" };
    return length($@) != 0;
}

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

sub drop_privs_maybe {
    my $self = shift;
    
    # Attempt to drop privs if we should be tainting and aren't
    if (!(IS_VMS || IS_MSWin32 || IS_Dos
          || IS_OS2
         )
        && ($> == 0 || $< == 0)
        && !$self->am_taint_checking()
    ) {
        my $id = eval { getpwnam("nobody") };
        $id = eval { getpwnam("nouser") } unless defined $id;
        $id = -2 unless defined $id;
            #
            # According to Stevens' APUE and various
            # (BSD, Solaris, HP-UX) man pages, setting
            # the real uid first and effective uid second
            # is the way to go if one wants to drop privileges,
            # because if one changes into an effective uid of
            # non-zero, one cannot change the real uid any more.
            #
            # Actually, it gets even messier.  There is
            # a third uid, called the saved uid, and as
            # long as that is zero, one can get back to
            # uid of zero.  Setting the real-effective *twice*
            # helps in *most* systems (FreeBSD and Solaris)
            # but apparently in HP-UX even this doesn't help:
            # the saved uid stays zero (apparently the only way
            # in HP-UX to change saved uid is to call setuid()
            # when the effective uid is zero).
            #
        eval {
            $< = $id; # real uid
            $> = $id; # effective uid
            $< = $id; # real uid
            $> = $id; # effective uid
        };
        if( !$@ && $< && $> ) {
          DEBUG and print "OK, I dropped privileges.\n";
        } elsif( $self->opt_U ) {
          DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
        } else {
          DEBUG and print "Hm, couldn't drop privileges.  Ah well.\n";
          # We used to die here; but that seemed pointless.
        }
    }
    return;
}

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

1;

__END__

# See "perldoc perldoc" for basic details.
#
# Perldoc -- look up a piece of documentation in .pod format that
# is embedded in the perl installation tree.
# 
#~~~~~~
#
# See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
#
# Version 3.01: Sun Nov 10 21:38:09 MST 2002
#       Sean M. Burke <[e-mail]>
#       Massive refactoring and code-tidying.
#       Now it's a module(-family)!
#       Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
#       Added -T, -d, -o, -M, -w.
#       Added some improved MSWin funk.
#
#~~~~~~
#
# Version 2.05: Sat Oct 12 16:09:00 CEST 2002
#	Hugo van der Sanden <[e-mail]>
#	Made -U the default, based on patch from Simon Cozens
# Version 2.04: Sun Aug 18 13:27:12 BST 2002
#	Randy W. Sims <[e-mail]>
#	allow -n to enable nroff under Win32
# Version 2.03: Sun Apr 23 16:56:34 BST 2000
#	Hugo van der Sanden <[e-mail]>
#	don't die when 'use blib' fails
# Version 2.02: Mon Mar 13 18:03:04 MST 2000
#       Tom Christiansen <[e-mail]>
#	Added -U insecurity option
# Version 2.01: Sat Mar 11 15:22:33 MST 2000 
#       Tom Christiansen <[e-mail]>, querulously.
#       Security and correctness patches.
#       What a twisted bit of distasteful spaghetti code.
# Version 2.0: ????
#
#~~~~~~
#
# Version 1.15: Tue Aug 24 01:50:20 EST 1999
#       Charles Wilson <[e-mail]>
#	changed /pod/ directory to /pods/ for cygwin
#         to support cygwin/win32
# Version 1.14: Wed Jul 15 01:50:20 EST 1998
#       Robin Barker <[e-mail]>
#	-strict, -w cleanups
# Version 1.13: Fri Feb 27 16:20:50 EST 1997
#       Gurusamy Sarathy <[e-mail]>
#	-doc tweaks for -F and -X options
# Version 1.12: Sat Apr 12 22:41:09 EST 1997
#       Gurusamy Sarathy <[e-mail]>
#	-various fixes for win32
# Version 1.11: Tue Dec 26 09:54:33 EST 1995
#       Kenneth Albanowski <[e-mail]>
#   -added Charles Bailey's further VMS patches, and -u switch
#   -added -t switch, with pod2text support
#
# Version 1.10: Thu Nov  9 07:23:47 EST 1995
#		Kenneth Albanowski <[e-mail]>
#	-added VMS support
#	-added better error recognition (on no found pages, just exit. On
#	 missing nroff/pod2man, just display raw pod.)
#	-added recursive/case-insensitive matching (thanks, Andreas). This
#	 slows things down a bit, unfortunately. Give a precise name, and
#	 it'll run faster.
#
# Version 1.01:	Tue May 30 14:47:34 EDT 1995
#		Andy Dougherty  <[e-mail]>
#   -added pod documentation.
#   -added PATH searching.
#   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
#    and friends.
#
#~~~~~~~
#
# TODO:
#
#	Cache the directories read during sloppy match
#       (To disk, or just in-memory?)
#
#       Backport this to perl 5.005?
#
#       Implement at least part of the "perlman" interface described
#       in Programming Perl 3e?