view release on metacpan or  search on metacpan

lib/Pod/Simple/HTML.pm  view on Meta::CPAN

    $section =~ tr/\x00-\x1F\x80-\x9F//d;
  }
  $section = $self->unicode_escape_url($section);
  $section = '_' unless length $section;
  return $section;
}

sub section_url_escape  { shift->general_url_escape(@_) }
sub pagepath_url_escape { shift->general_url_escape(@_) }
sub manpage_url_escape  { shift->general_url_escape(@_) }

sub general_url_escape {
  my($self, $string) = @_;

  $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
     # express Unicode things as urlencode(utf(orig)).

  # A pretty conservative escaping, behoovey even for query components
  #  of a URL (see RFC 2396)

  if ("$]" >= 5.007_003) {
    $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',utf8::native_to_unicode(ord($1)))/eg;
  } else { # Is broken for non-ASCII platforms on early perls
    $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
  }
   # Yes, stipulate the list without a range, so that this can work right on
   #  all charsets that this module happens to run under.

  return $string;
}

#--------------------------------------------------------------------------
#
# Oh look, a yawning portal to Hell!  Let's play touch football right by it!
#

sub resolve_pod_page_link {
  # resolve_pod_page_link must return a properly escaped URL
  my $self = shift;
  return $self->batch_mode()
   ? $self->resolve_pod_page_link_batch_mode(@_)
   : $self->resolve_pod_page_link_singleton_mode(@_)
  ;
}

sub resolve_pod_page_link_singleton_mode {
  my($self, $it) = @_;
  return undef unless defined $it and length $it;
  my $url = $self->pagepath_url_escape($it);

  $url =~ s{::$}{}s; # probably never comes up anyway
  $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM?

  return undef unless length $url;
  return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix;
}

sub resolve_pod_page_link_batch_mode {
  my($self, $to) = @_;
  DEBUG > 1 and print STDERR " During batch mode, resolving $to ...\n";
  my @path = grep length($_), split m/::/s, $to, -1;
  unless( @path ) { # sanity
    DEBUG and print STDERR "Very odd!  Splitting $to gives (nil)!\n";
    return undef;
  }
  $self->batch_mode_rectify_path(\@path);
  my $out = join('/', map $self->pagepath_url_escape($_), @path)
    . $HTML_EXTENSION;
  DEBUG > 1 and print STDERR " => $out\n";
  return $out;
}

sub batch_mode_rectify_path {
  my($self, $pathbits) = @_;
  my $level = $self->batch_mode_current_level;
  $level--; # how many levels up to go to get to the root
  if($level < 1) {
    unshift @$pathbits, '.'; # just to be pretty
  } else {
    unshift @$pathbits, ('..') x $level;
  }
  return;
}

sub resolve_man_page_link {
  my ($self, $to, $frag) = @_;
  my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;

  return undef unless defined $page and length $page;
  $section ||= 1;

  return $self->man_url_prefix . "$section/"
      . $self->manpage_url_escape($page) . ".$section"
      . $self->man_url_postfix
      . (defined $frag ? '#' . $frag : '');
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub resolve_pod_link_by_table {
  # A crazy hack to allow specifying custom L<foo> => URL mappings

  return unless $_[0]->{'podhtml_LOT'};  # An optimizy shortcut

  my($self, $to, $section) = @_;

  # TODO: add a method that actually populates podhtml_LOT from a file?

  if(defined $section) {
    $to = '' unless defined $to and length $to;
    return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef!
  } else {
    return $self->{'podhtml_LOT'}{$to};            # quite possibly undef!
  }
  return;
}

###########################################################################

sub linearize_tokens {  # self, tokens
  my $self = shift;