| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 2 require 5; 3 package Pod::Simple::HTML; 4 use strict; 5 use Pod::Simple::PullParser (); 6 use vars qw( 7 @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION 8 $Perldoc_URL_Prefix $Perldoc_URL_Postfix 9 $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex 10 $Doctype_decl $Content_decl 11 ); 12 @ISA = ('Pod::Simple::PullParser'); 13 $VERSION = '3.03'; 14 15 use UNIVERSAL (); 16 BEGIN { 17 if(defined &DEBUG) { } # no-op 18 elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } 19 else { *DEBUG = sub () {0}; } 20 } 21 22 $Doctype_decl ||= ''; # No. Just No. Don't even ask me for it. 23 # qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" 24 # "http://www.w3.org/TR/html4/loose.dtd">\n}; 25 26 $Content_decl ||= 27 q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >}; 28 29 $HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION; 30 $Computerese = "" unless defined $Computerese; 31 $LamePad = '' unless defined $LamePad; 32 33 $Linearization_Limit = 120 unless defined $Linearization_Limit; 34 # headings/items longer than that won't get an <a name="..."> 35 $Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?' 36 unless defined $Perldoc_URL_Prefix; 37 $Perldoc_URL_Postfix = '' 38 unless defined $Perldoc_URL_Postfix; 39 40 $Title_Prefix = '' unless defined $Title_Prefix; 41 $Title_Postfix = '' unless defined $Title_Postfix; 42 %ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text 43 # 'item-text' stuff in the index doesn't quite work, and may 44 # not be a good idea anyhow. 45 46 47 __PACKAGE__->_accessorize( 48 'perldoc_url_prefix', 49 # In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what 50 # to put before the "Foo%3a%3aBar". 51 # (for singleton mode only?) 52 'perldoc_url_postfix', 53 # what to put after "Foo%3a%3aBar" in the URL. Normally "". 54 55 'batch_mode', # whether we're in batch mode 56 'batch_mode_current_level', 57 # When in batch mode, how deep the current module is: 1 for "LWP", 58 # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc 59 60 'title_prefix', 'title_postfix', 61 # What to put before and after the title in the head. 62 # Should already be &-escaped 63 64 'html_header_before_title', 65 'html_header_after_title', 66 'html_footer', 67 68 'index', # whether to add an index at the top of each page 69 # (actually it's a table-of-contents, but we'll call it an index, 70 # out of apparently longstanding habit) 71 72 'html_css', # URL of CSS file to point to 73 'html_javascript', # URL of CSS file to point to 74 75 'force_title', # should already be &-escaped 76 'default_title', # should already be &-escaped 77 ); 78 79 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 80 my @_to_accept; 81 82 %Tagmap = ( 83 'Verbatim' => "\n<pre$Computerese>", 84 '/Verbatim' => "</pre>\n", 85 'VerbatimFormatted' => "\n<pre$Computerese>", 86 '/VerbatimFormatted' => "</pre>\n", 87 'VerbatimB' => "<b>", 88 '/VerbatimB' => "</b>", 89 'VerbatimI' => "<i>", 90 '/VerbatimI' => "</i>", 91 'VerbatimBI' => "<b><i>", 92 '/VerbatimBI' => "</i></b>", 93 94 95 'Data' => "\n", 96 '/Data' => "\n", 97 98 'head1' => "\n<h1>", # And also stick in an <a name="..."> 99 'head2' => "\n<h2>", # '' 100 'head3' => "\n<h3>", # '' 101 'head4' => "\n<h4>", # '' 102 '/head1' => "</a></h1>\n", 103 '/head2' => "</a></h2>\n", 104 '/head3' => "</a></h3>\n", 105 '/head4' => "</a></h4>\n", 106 107 'X' => "<!--\n\tINDEX: ", 108 '/X' => "\n-->", 109 110 changes(qw( 111 Para=p 112 B=b I=i 113 over-bullet=ul 114 over-number=ol 115 over-text=dl 116 over-block=blockquote 117 item-bullet=li 118 item-number=li 119 item-text=dt 120 )), 121 changes2( 122 map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ } 123 qw[ 124 sample=samp 125 definition=dfn 126 kbd=keyboard 127 variable=var 128 citation=cite 129 abbreviation=abbr 130 acronym=acronym 131 subscript=sub 132 superscript=sup 133 big=big 134 small=small 135 underline=u 136 strikethrough=s 137 ] # no point in providing a way to get <q>...</q>, I think 138 ), 139 140 '/item-bullet' => "</li>$LamePad\n", 141 '/item-number' => "</li>$LamePad\n", 142 '/item-text' => "</a></dt>$LamePad\n", 143 'item-body' => "\n<dd>", 144 '/item-body' => "</dd>\n", 145 146 147 'B' => "<b>", '/B' => "</b>", 148 'I' => "<i>", '/I' => "</i>", 149 'F' => "<em$Computerese>", '/F' => "</em>", 150 'C' => "<code$Computerese>", '/C' => "</code>", 151 'L' => "<a href='YOU_SHOULD_NEVER_SEE_THIS'>", # ideally never used! 152 '/L' => "</a>", 153 ); 154 155 sub changes { 156 return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s 157 ? ( $1, => "\n<$2>", "/$1", => "</$2>\n" ) : die "Funky $_" 158 } @_; 159 } 160 sub changes2 { 161 return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s 162 ? ( $1, => "<$2>", "/$1", => "</$2>" ) : die "Funky $_" 163 } @_; 164 } 165 166 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 167 sub go { exit Pod::Simple::HTML->parse_from_file(@ARGV) } 168 # Just so we can run from the command line. No options. 169 # For that, use perldoc! 170 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 171 172 sub new { 173 my $new = shift->SUPER::new(@_); 174 #$new->nix_X_codes(1); 175 $new->nbsp_for_S(1); 176 $new->accept_targets( 'html', 'HTML' ); 177 $new->accept_codes('VerbatimFormatted'); 178 $new->accept_codes(@_to_accept); 179 DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n"; 180 181 $new->perldoc_url_prefix( $Perldoc_URL_Prefix ); 182 $new->perldoc_url_postfix( $Perldoc_URL_Postfix ); 183 $new->title_prefix( $Title_Prefix ); 184 $new->title_postfix( $Title_Postfix ); 185 186 $new->html_header_before_title( 187 qq[$Doctype_decl<html><head><title>] 188 ); 189 $new->html_header_after_title( join "\n" => 190 "</title>", 191 $Content_decl, 192 "</head>\n<body class='pod'>", 193 $new->version_tag_comment, 194 "<!-- start doc -->\n", 195 ); 196 $new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] ); 197 198 $new->{'Tagmap'} = {%Tagmap}; 199 return $new; 200 } 201 202 sub batch_mode_page_object_init { 203 my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; 204 DEBUG and print "Initting $self\n for $module\n", 205 " in $infile\n out $outfile\n depth $depth\n"; 206 $self->batch_mode(1); 207 $self->batch_mode_current_level($depth); 208 return $self; 209 } 210 211 sub run { 212 my $self = $_[0]; 213 return $self->do_middle if $self->bare_output; 214 return 215 $self->do_beginning && $self->do_middle && $self->do_end; 216 } 217 218 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 219 220 sub do_beginning { 221 my $self = $_[0]; 222 223 my $title; 224 225 if(defined $self->force_title) { 226 $title = $self->force_title; 227 DEBUG and print "Forcing title to be $title\n"; 228 } else { 229 # Actually try looking for the title in the document: 230 $title = $self->get_short_title(); 231 unless($self->content_seen) { 232 DEBUG and print "No content seen in search for title.\n"; 233 return; 234 } 235 $self->{'Title'} = $title; 236 237 if(defined $title and $title =~ m/\S/) { 238 $title = $self->title_prefix . esc($title) . $self->title_postfix; 239 } else { 240 $title = $self->default_title; 241 $title = '' unless defined $title; 242 DEBUG and print "Title defaults to $title\n"; 243 } 244 } 245 246 247 my $after = $self->html_header_after_title || ''; 248 if($self->html_css) { 249 my $link = 250 $self->html_css =~ m/</ 251 ? $self->html_css # It's a big blob of markup, let's drop it in 252 : sprintf( # It's just a URL, so let's wrap it up 253 qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n], 254 $self->html_css, 255 ); 256 $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind 257 } 258 $self->_add_top_anchor(\$after); 259 260 if($self->html_javascript) { 261 my $link = 262 $self->html_javascript =~ m/</ 263 ? $self->html_javascript # It's a big blob of markup, let's drop it in 264 : sprintf( # It's just a URL, so let's wrap it up 265 qq[<script type="text/javascript" src="%s"></script>\n], 266 $self->html_javascript, 267 ); 268 $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind 269 } 270 271 print {$self->{'output_fh'}} 272 $self->html_header_before_title || '', 273 $title, # already escaped 274 $after, 275 ; 276 277 DEBUG and print "Returning from do_beginning...\n"; 278 return 1; 279 } 280 281 sub _add_top_anchor { 282 my($self, $text_r) = @_; 283 unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack 284 $$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n"; 285 } 286 return; 287 } 288 289 sub version_tag_comment { 290 my $self = shift; 291 return sprintf 292 "<!--\n generated by %s v%s,\n using %s v%s,\n under Perl v%s at %s GMT.\n\n %s\n\n-->\n", 293 esc( 294 ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(), 295 $], scalar(gmtime), 296 ), $self->_modnote(), 297 ; 298 } 299 300 sub _modnote { 301 my $class = ref($_[0]) || $_[0]; 302 return join "\n " => grep m/\S/, split "\n", 303 304 qq{ 305 If you want to change this HTML document, you probably shouldn't do that 306 by changing it directly. Instead, see about changing the calling options 307 to $class, and/or subclassing $class, 308 then reconverting this document from the Pod source. 309 When in doubt, email the author of $class for advice. 310 See 'perldoc $class' for more info. 311 }; 312 313 } 314 315 sub do_end { 316 my $self = $_[0]; 317 print {$self->{'output_fh'}} $self->html_footer || ''; 318 return 1; 319 } 320 321 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 322 # Normally this would just be a call to _do_middle_main_loop -- but we 323 # have to do some elaborate things to emit all the content and then 324 # summarize it and output it /before/ the content that it's a summary of. 325 326 sub do_middle { 327 my $self = $_[0]; 328 return $self->_do_middle_main_loop unless $self->index; 329 330 if( $self->output_string ) { 331 # An efficiency hack 332 my $out = $self->output_string; #it's a reference to it 333 my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n"; 334 $$out .= $sneakytag; 335 $self->_do_middle_main_loop; 336 $sneakytag = quotemeta($sneakytag); 337 my $index = $self->index_as_html(); 338 if( $$out =~ s/$sneakytag/$index/s ) { 339 # Expected case 340 DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n"; 341 } else { 342 DEBUG and print "Odd, couldn't find where to insert the index in the output!\n"; 343 # I don't think this should ever happen. 344 } 345 return 1; 346 } 347 348 unless( $self->output_fh ) { 349 require Carp; 350 Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that."); 351 } 352 353 # If we get here, we're outputting to a FH. So we need to do some magic. 354 # Namely, divert all content to a string, which we output after the index. 355 my $fh = $self->output_fh; 356 my $content = ''; 357 { 358 # Our horrible bait and switch: 359 $self->output_string( \$content ); 360 $self->_do_middle_main_loop; 361 $self->abandon_output_string(); 362 $self->output_fh($fh); 363 } 364 print $fh $self->index_as_html(); 365 print $fh $content; 366 367 return 1; 368 } 369 370 ########################################################################### 371 372 sub index_as_html { 373 my $self = $_[0]; 374 # This is meant to be called AFTER the input document has been parsed! 375 376 my $points = $self->{'PSHTML_index_points'} || []; 377 378 @$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n]; 379 # There's no point in having a 0-item or 1-item index, I dare say. 380 381 my(@out) = qq{\n<div class='indexgroup'>}; 382 my $level = 0; 383 384 my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent); 385 foreach my $p (@$points, ['head0', '(end)']) { 386 ($tagname, $text) = @$p; 387 $anchorname = $self->section_escape($text); 388 if( $tagname =~ m{^head(\d+)$} ) { 389 $target_level = 0 + $1; 390 } else { # must be some kinda list item 391 if($previous_tagname =~ m{^head\d+$} ) { 392 $target_level = $level + 1; 393 } else { 394 $target_level = $level; # no change needed 395 } 396 } 397 398 # Get to target_level by opening or closing ULs 399 while($level > $target_level) 400 { --$level; push @out, (" " x $level) . "</ul>"; } 401 while($level < $target_level) 402 { ++$level; push @out, (" " x ($level-1)) 403 . "<ul class='indexList indexList$level'>"; } 404 405 $previous_tagname = $tagname; 406 next unless $level; 407 408 $indent = ' ' x $level; 409 push @out, sprintf 410 "%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>", 411 $indent, $level, $anchorname, esc($text) 412 ; 413 } 414 push @out, "</div>\n"; 415 return join "\n", @out; 416 } 417 418 ########################################################################### 419 420 sub _do_middle_main_loop { 421 my $self = $_[0]; 422 my $fh = $self->{'output_fh'}; 423 my $tagmap = $self->{'Tagmap'}; 424 425 my($token, $type, $tagname, $linkto, $linktype); 426 my @stack; 427 my $dont_wrap = 0; 428 429 while($token = $self->get_token) { 430 431 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 432 if( ($type = $token->type) eq 'start' ) { 433 if(($tagname = $token->tagname) eq 'L') { 434 $linktype = $token->attr('type') || 'insane'; 435 436 $linkto = $self->do_link($token); 437 438 if(defined $linkto and length $linkto) { 439 esc($linkto); 440 # (Yes, SGML-escaping applies on top of %-escaping! 441 # But it's rarely noticeable in practice.) 442 print $fh qq{<a href="$linkto" class="podlink$linktype"\n>}; 443 } else { 444 print $fh "<a>"; # Yes, an 'a' element with no attributes! 445 } 446 447 } elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) { 448 print $fh $tagmap->{$tagname} || next; 449 450 my @to_unget; 451 while(1) { 452 push @to_unget, $self->get_token; 453 last if $to_unget[-1]->is_end 454 and $to_unget[-1]->tagname eq $tagname; 455 456 # TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens) 457 } 458 459 my $name = $self->linearize_tokens(@to_unget); 460 461 print $fh "<a "; 462 print $fh "class='u' href='#___top' title='click to go to top of document'\n" 463 if $tagname =~ m/^head\d$/s; 464 465 if(defined $name) { 466 my $esc = esc( $self->section_name_tidy( $name ) ); 467 print $fh qq[name="$esc"]; 468 DEBUG and print "Linearized ", scalar(@to_unget), 469 " tokens as \"$name\".\n"; 470 push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name] 471 if $ToIndex{ $tagname }; 472 # Obviously, this discards all formatting codes (saving 473 # just their content), but ahwell. 474 475 } else { # ludicrously long, so nevermind 476 DEBUG and print "Linearized ", scalar(@to_unget), 477 " tokens, but it was too long, so nevermind.\n"; 478 } 479 print $fh "\n>"; 480 $self->unget_token(@to_unget); 481 482 } elsif ($tagname eq 'Data') { 483 my $next = $self->get_token; 484 next unless defined $next; 485 unless( $next->type eq 'text' ) { 486 $self->unget_token($next); 487 next; 488 } 489 DEBUG and print " raw text ", $next->text, "\n"; 490 printf $fh "\n" . $next->text . "\n"; 491 next; 492 493 } else { 494 if( $tagname =~ m/^over-/s ) { 495 push @stack, ''; 496 } elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) { 497 print $fh $stack[-1]; 498 $stack[-1] = ''; 499 } 500 print $fh $tagmap->{$tagname} || next; 501 ++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted" 502 or $tagname eq 'X'; 503 } 504 505 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 506 } elsif( $type eq 'end' ) { 507 if( ($tagname = $token->tagname) =~ m/^over-/s ) { 508 if( my $end = pop @stack ) { 509 print $fh $end; 510 } 511 } elsif( $tagname =~ m/^item-/s and @stack) { 512 $stack[-1] = $tagmap->{"/$tagname"}; 513 if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) { 514 $self->unget_token($next); 515 if( $next->type eq 'start' and $next->tagname !~ m/^item-/s ) { 516 print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"}; 517 $stack[-1] = $tagmap->{"/item-body"}; 518 } 519 } 520 next; 521 } 522 print $fh $tagmap->{"/$tagname"} || next; 523 --$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X'; 524 525 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 526 } elsif( $type eq 'text' ) { 527 esc($type = $token->text); # reuse $type, why not 528 $type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap; 529 print $fh $type; 530 } 531 532 } 533 return 1; 534 } 535 536 ########################################################################### 537 # 538 539 sub do_link { 540 my($self, $token) = @_; 541 my $type = $token->attr('type'); 542 if(!defined $type) { 543 $self->whine("Typeless L!?", $token->attr('start_line')); 544 } elsif( $type eq 'pod') { return $self->do_pod_link($token); 545 } elsif( $type eq 'url') { return $self->do_url_link($token); 546 } elsif( $type eq 'man') { return $self->do_man_link($token); 547 } else { 548 $self->whine("L of unknown type $type!?", $token->attr('start_line')); 549 } 550 return 'FNORG'; # should never get called 551 } 552 553 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 554 555 sub do_url_link { return $_[1]->attr('to') } 556 557 sub do_man_link { return undef } 558 # But subclasses are welcome to override this if they have man 559 # pages somewhere URL-accessible. 560 561 562 sub do_pod_link { 563 # And now things get really messy... 564 my($self, $link) = @_; 565 my $to = $link->attr('to'); 566 my $section = $link->attr('section'); 567 return undef unless( # should never happen 568 (defined $to and length $to) or 569 (defined $section and length $section) 570 ); 571 572 $section = $self->section_escape($section) 573 if defined $section and length($section .= ''); # (stringify) 574 575 DEBUG and printf "Resolving \"%s\" \"%s\"...\n", 576 $to || "(nil)", $section || "(nil)"; 577 578 { 579 # An early hack: 580 my $complete_url = $self->resolve_pod_link_by_table($to, $section); 581 if( $complete_url ) { 582 DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ", 583 $complete_url, "\n (Returning that.)\n"; 584 return $complete_url; 585 } else { 586 DEBUG > 4 and print " resolve_pod_link_by_table(T,S)", 587 " didn't return anything interesting.\n"; 588 } 589 } 590 591 if(defined $to and length $to) { 592 # Give this routine first hack again 593 my $there = $self->resolve_pod_link_by_table($to); 594 if(defined $there and length $there) { 595 DEBUG > 1 596 and print "resolve_pod_link_by_table(T) gives $there\n"; 597 } else { 598 $there = 599 $self->resolve_pod_page_link($to, $section); 600 # (I pass it the section value, but I don't see a 601 # particular reason it'd use it.) 602 DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n"; 603 unless( defined $there and length $there ) { 604 DEBUG and print "Can't resolve $to\n"; 605 return undef; 606 } 607 # resolve_pod_page_link returning undef is how it 608 # can signal that it gives up on making a link 609 } 610 $to = $there; 611 } 612 613 #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n"; 614 615 my $out = (defined $to and length $to) ? $to : ''; 616 $out .= "#" . $section if defined $section and length $section; 617 618 unless(length $out) { # sanity check 619 DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n", 620 $to || "(nil)", $section || "(nil)"; 621 return undef; 622 } 623 624 DEBUG and print "Resolved to $out\n"; 625 return $out; 626 } 627 628 629 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 630 631 sub section_escape { 632 my($self, $section) = @_; 633 return $self->section_url_escape( 634 $self->section_name_tidy($section) 635 ); 636 } 637 638 sub section_name_tidy { 639 my($self, $section) = @_; 640 $section =~ tr/ /_/; 641 $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters 642 $section = $self->unicode_escape_url($section); 643 $section = '_' unless length $section; 644 return $section; 645 } 646 647 sub section_url_escape { shift->general_url_escape(@_) } 648 sub pagepath_url_escape { shift->general_url_escape(@_) } 649 650 sub general_url_escape { 651 my($self, $string) = @_; 652 653 $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg; 654 # express Unicode things as urlencode(utf(orig)). 655 656 # A pretty conservative escaping, behoovey even for query components 657 # of a URL (see RFC 2396) 658 659 $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg; 660 # Yes, stipulate the list without a range, so that this can work right on 661 # all charsets that this module happens to run under. 662 # Altho, hmm, what about that ord? Presumably that won't work right 663 # under non-ASCII charsets. Something should be done 664 # about that, I guess? 665 666 return $string; 667 } 668 669 #-------------------------------------------------------------------------- 670 # 671 # Oh look, a yawning portal to Hell! Let's play touch football right by it! 672 # 673 674 sub resolve_pod_page_link { 675 # resolve_pod_page_link must return a properly escaped URL 676 my $self = shift; 677 return $self->batch_mode() 678 ? $self->resolve_pod_page_link_batch_mode(@_) 679 : $self->resolve_pod_page_link_singleton_mode(@_) 680 ; 681 } 682 683 sub resolve_pod_page_link_singleton_mode { 684 my($self, $it) = @_; 685 return undef unless defined $it and length $it; 686 my $url = $self->pagepath_url_escape($it); 687 688 $url =~ s{::$}{}s; # probably never comes up anyway 689 $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM? 690 691 return undef unless length $url; 692 return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix; 693 } 694 695 sub resolve_pod_page_link_batch_mode { 696 my($self, $to) = @_; 697 DEBUG > 1 and print " During batch mode, resolving $to ...\n"; 698 my @path = grep length($_), split m/::/s, $to, -1; 699 unless( @path ) { # sanity 700 DEBUG and print "Very odd! Splitting $to gives (nil)!\n"; 701 return undef; 702 } 703 $self->batch_mode_rectify_path(\@path); 704 my $out = join('/', map $self->pagepath_url_escape($_), @path) 705 . $HTML_EXTENSION; 706 DEBUG > 1 and print " => $out\n"; 707 return $out; 708 } 709 710 sub batch_mode_rectify_path { 711 my($self, $pathbits) = @_; 712 my $level = $self->batch_mode_current_level; 713 $level--; # how many levels up to go to get to the root 714 if($level < 1) { 715 unshift @$pathbits, '.'; # just to be pretty 716 } else { 717 unshift @$pathbits, ('..') x $level; 718 } 719 return; 720 } 721 722 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 723 724 sub resolve_pod_link_by_table { 725 # A crazy hack to allow specifying custom L<foo> => URL mappings 726 727 return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut 728 729 my($self, $to, $section) = @_; 730 731 # TODO: add a method that actually populates podhtml_LOT from a file? 732 733 if(defined $section) { 734 $to = '' unless defined $to and length $to; 735 return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef! 736 } else { 737 return $self->{'podhtml_LOT'}{$to}; # quite possibly undef! 738 } 739 return; 740 } 741 742 ########################################################################### 743 744 sub linearize_tokens { # self, tokens 745 my $self = shift; 746 my $out = ''; 747 748 my $t; 749 while($t = shift @_) { 750 if(!ref $t or !UNIVERSAL::can($t, 'is_text')) { 751 $out .= $t; # a string, or some insane thing 752 } elsif($t->is_text) { 753 $out .= $t->text; 754 } elsif($t->is_start and $t->tag eq 'X') { 755 # Ignore until the end of this X<...> sequence: 756 my $x_open = 1; 757 while($x_open) { 758 next if( ($t = shift @_)->is_text ); 759 if( $t->is_start and $t->tag eq 'X') { ++$x_open } 760 elsif($t->is_end and $t->tag eq 'X') { --$x_open } 761 } 762 } 763 } 764 return undef if length $out > $Linearization_Limit; 765 return $out; 766 } 767 768 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 769 770 sub unicode_escape_url { 771 my($self, $string) = @_; 772 $string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg; 773 # Turn char 1234 into "(1234)" 774 return $string; 775 } 776 777 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 778 sub esc { # a function. 779 if(defined wantarray) { 780 if(wantarray) { 781 @_ = splice @_; # break aliasing 782 } else { 783 my $x = shift; 784 $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; 785 return $x; 786 } 787 } 788 foreach my $x (@_) { 789 # Escape things very cautiously: 790 $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg 791 if defined $x; 792 # Leave out "- so that "--" won't make it thru in X-generated comments 793 # with text in them. 794 795 # Yes, stipulate the list without a range, so that this can work right on 796 # all charsets that this module happens to run under. 797 # Altho, hmm, what about that ord? Presumably that won't work right 798 # under non-ASCII charsets. Something should be done about that. 799 } 800 return @_; 801 } 802 803 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 804 805 1; 806 __END__ 807 808 =head1 NAME 809 810 Pod::Simple::HTML - convert Pod to HTML 811 812 =head1 SYNOPSIS 813 814 perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod 815 816 817 =head1 DESCRIPTION 818 819 This class is for making an HTML rendering of a Pod document. 820 821 This is a subclass of L<Pod::Simple::PullParser> and inherits all its 822 methods (and options). 823 824 Note that if you want to do a batch conversion of a lot of Pod 825 documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>. 826 827 828 829 =head1 CALLING FROM THE COMMAND LINE 830 831 TODO 832 833 perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html 834 835 836 837 =head1 CALLING FROM PERL 838 839 TODO make a new object, set any options, and use parse_from_file 840 841 842 =head1 METHODS 843 844 TODO 845 all (most?) accessorized methods 846 847 848 =head1 SUBCLASSING 849 850 TODO 851 852 can just set any of: html_css html_javascript title_prefix 853 'html_header_before_title', 854 'html_header_after_title', 855 'html_footer', 856 857 maybe override do_pod_link 858 859 maybe override do_beginning do_end 860 861 862 863 =head1 SEE ALSO 864 865 L<Pod::Simple>, L<Pod::Simple::HTMLBatch> 866 867 868 TODO: a corpus of sample Pod input and HTML output? Or common 869 idioms? 870 871 872 873 =head1 COPYRIGHT AND DISCLAIMERS 874 875 Copyright (c) 2002-2004 Sean M. Burke. All rights reserved. 876 877 This library is free software; you can redistribute it and/or modify it 878 under the same terms as Perl itself. 879 880 This program is distributed in the hope that it will be useful, but 881 without any warranty; without even the implied warranty of 882 merchantability or fitness for a particular purpose. 883 884 =head1 AUTHOR 885 886 Sean M. Burke C<sburke@cpan.org> 887 888 =cut 889
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |