view release on metacpan or  search on metacpan

cpan/Pod-Perldoc/lib/Pod/Perldoc.pm  view on Meta::CPAN

 *is_vms     = $^O eq 'VMS'     ? \&TRUE : \&FALSE unless defined &is_vms;
 *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32;
 *is_dos     = $^O eq 'dos'     ? \&TRUE : \&FALSE unless defined &is_dos;
 *is_os2     = $^O eq 'os2'     ? \&TRUE : \&FALSE unless defined &is_os2;
 *is_cygwin  = $^O eq 'cygwin'  ? \&TRUE : \&FALSE unless defined &is_cygwin;
 *is_linux   = $^O eq 'linux'   ? \&TRUE : \&FALSE unless defined &is_linux;
 *is_hpux    = $^O =~ m/hpux/   ? \&TRUE : \&FALSE unless defined &is_hpux;
 *is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos;
}

$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
  # If it's older than five days, it's quite unlikely
  #  that anyone's still looking at it!!
  # (Currently used only by the MSWin cleanup routine)


#..........................................................................
{ my $pager = $Config{'pager'};
  push @Pagers, $pager if -x (split /\s+/, $pager)[0] or __PACKAGE__->is_vms;
}
$Bindir  = $Config{'scriptdirexp'};
$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );

# End of class-init stuff
#
###########################################################################
#
# Option accessors...

foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULva}) {
  no strict 'refs';
  *$subname = do{ use strict 'refs';  sub () { shift->_elem($subname, @_) } };
}

# And these are so that GetOptsOO knows they take options:
sub opt_a_with { shift->_elem('opt_a', @_) }
sub opt_f_with { shift->_elem('opt_f', @_) }
sub opt_q_with { shift->_elem('opt_q', @_) }
sub opt_d_with { shift->_elem('opt_d', @_) }
sub opt_L_with { shift->_elem('opt_L', @_) }
sub opt_v_with { shift->_elem('opt_v', @_) }

sub opt_w_with { # Specify an option for the formatter subclass
  my($self, $value) = @_;
  if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
    my $option = $1;
    my $option_value = defined($2) ? $2 : "TRUE";
    $option =~ tr/\-/_/s;  # tolerate "foo-bar" for "foo_bar"
    $self->add_formatter_option( $option, $option_value );
  } else {
    $self->warn( qq("$value" isn't a good formatter option name.  I'm ignoring it!\n ) );
  }
  return;
}

sub opt_M_with { # specify formatter class name(s)
  my($self, $classes) = @_;
  return unless defined $classes and length $classes;
  DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
  my @classes_to_add;
  foreach my $classname (split m/[,;]+/s, $classes) {
    next unless $classname =~ m/\S/;
    if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
      # A mildly restrictive concept of what modulenames are valid.
      push @classes_to_add, $1; # untaint
    } else {
      $self->warn(  qq("$classname" isn't a valid classname.  Ignoring.\n) );
    }
  }

  unshift @{ $self->{'formatter_classes'} }, @classes_to_add;

  DEBUG > 3 and print(
    "Adding @classes_to_add to the list of formatter classes, "
    . "making them @{ $self->{'formatter_classes'} }.\n"
  );

  return;
}

sub opt_V { # report version and exit
  print join '',
    "Perldoc v$VERSION, under perl v$] for $^O",

    (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
     ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),

    (chr(65) eq 'A') ? () : " (non-ASCII)",

    "\n",
  ;
  exit;
}

sub opt_t { # choose plaintext as output format
  my $self = shift;
  $self->opt_o_with('text')  if @_ and $_[0];
  return $self->_elem('opt_t', @_);
}

sub opt_u { # choose raw pod as output format
  my $self = shift;
  $self->opt_o_with('pod')  if @_ and $_[0];
  return $self->_elem('opt_u', @_);
}

sub opt_n_with {
  # choose man as the output format, and specify the proggy to run
  my $self = shift;
  $self->opt_o_with('man')  if @_ and $_[0];
  $self->_elem('opt_n', @_);
}

sub opt_o_with { # "o" for output format
  my($self, $rest) = @_;
  return unless defined $rest and length $rest;
  if($rest =~ m/^(\w+)$/s) {
    $rest = $1; #untaint
  } else {
    $self->warn( qq("$rest" isn't a valid output format.  Skipping.\n") );
    return;