home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_utl.zip / pod2ipf.cmd < prev    next >
OS/2 REXX Batch file  |  1997-12-01  |  59KB  |  1,874 lines
  1. extproc perl -wS
  2. #!perl -w
  3. use strict qw(refs subs);
  4. use File::Find;
  5. use File::Copy 'copy';
  6. use Cwd;
  7. use Config '%Config';
  8. use Getopt::Long 'GetOptions';
  9. use vars qw{%do_file_hash %do_dirs_hash %bin_hash %faqs_hash %pragmas_hash
  10.         %mods_hash %pod_hash %add_mods_hash @add_dirs %tree_hash};
  11. # use Fatal qw(open close); # would not work: interprets filehandles as barewords.
  12. sub intern_modnamehash;
  13. sub do_libdir;
  14. sub output_file;
  15. sub hash_diff;
  16. sub auto_beautify;
  17. sub create_tree;
  18. sub format_args;
  19. sub output_index;
  20. sub count_index;
  21. sub untabify;
  22. sub untabify_after;
  23. sub strip;
  24. sub find_parent;
  25. sub insert_back;
  26.  
  27. require 5.004;            # Otherwise pos() in recursive sub cores.
  28.  
  29. #require 'dumpvar.pl';
  30.  
  31. $VERSION = "1.11";
  32.  
  33. # by Marko.Macek@snet.fri.uni-lj.si, mark@hermes.si
  34. # with additions by Ilya Zakharevich ilya@math.ohio-state.edu
  35. #
  36. # TODO:
  37. #   eliminate blank panes that link to next pane when =item XX\n\n=itemYY used
  38. #   rewrite ?<> parsing
  39. #   better index (mostly done)
  40. #   cleaner xref heuristics (mostly done)
  41. #   process embeded pods (done)
  42. #   IPFC doesn't seem to handle tabs - are 
  43. #   handle perl/SYNOPSIS properly (tabs, indented lines) -- or is it a bug in doc
  44. #     probably should process as pre but with markup -- done below (ok?)
  45. #   remove =head1 NAME and use it as toplevel heading
  46. #     (also collapse DESCRIPTION if the only section).
  47. #   pod2ipf needs to be split into index generator and translator
  48. #     this should enable separate translation of each .pod
  49. #     and use of .INF concatenation to view the full docs together
  50. #     (with linking if index was used).
  51. #     IPF requires numerical references when concatenation is used, not symbolic :-(
  52. #   improved handling of windows (started to be done)
  53. #   ...
  54. #
  55. #  Changes:
  56. #
  57. #  10.2: parml used instead of ul if needed.
  58. #      Readability of .ipf improved.
  59. #      BI partially supported, F<> and C<> are distinct.
  60. #    Some options supported.
  61. #
  62. # 10.3:    C<> works again. 
  63. #    --head_off works (0 and 1).
  64. #
  65. # 10.4:    Auto-beautifies some words, vars and functions, finds links
  66. #    --head_off works (0 and 1 and 2).
  67. #
  68. # 10.5:    --section-name works
  69. #    Bugs with modules in subdirectories corrected.
  70. #    --about works.
  71. #    Better auto-crosslinking.
  72. #
  73. #    2-level indices. (Since we do not know until the second pass
  74. #    whether we put something into an index, there are some false
  75. #    positives.)
  76. #    Handles tabs (checked with Tk).
  77. #    Secondary names used for crosslinking.
  78. # 11:   Additional logic for links like C<-M>.
  79. #    Will process ../INSTALL and ../Porting/pumpkin.pod as well.
  80. #    Additional argument --bin-dir.
  81. #    Support for WWW links via lynx.
  82. #
  83. # Use of uninit value comes from findrefid for pod2ipf it it is not present.
  84. # 1.5:  Add back perltoc - have refs to it.
  85. #    :i[12] tags are shortened to avoid segfaults.
  86. # 1.6:    `pod2ipf myfile.pod' works again;
  87. #    --www added.
  88. #    <-processing could use substr with negative length for C<<=>.
  89. #    Index entries X<> handled (invisible).
  90. #    Will not produce links to "contents" pages from higher level
  91. #      contents pages (YES!).
  92. # 1.7:    Add implicit links for targets defined by C<>.
  93. #    Uplinks added.
  94. # 1.8:    Will not reference -8.
  95. #    out[12] removed, substituted by 'require 5.004'.
  96.  
  97. # 1.9:  Better handling of 'Go up' (last item was going to the following
  98. #    section).
  99.  
  100. $font = ''; #':font facename=Helv size=16x8.';
  101.  
  102. $debug = 0;
  103. $debug_xref = 0;
  104. $dump_xref = 0;
  105. $dump_contents = 0;
  106. $dump_manpages = 1;
  107. $ref_delta = 1;     # start from 1
  108. $maxtoc = 5;
  109. $dots = 0;
  110. $multi_win = 1;     # 1 = use alternate window for toc
  111. @do_dirs = ();
  112. @do_file = ();
  113. @bin_dirs = ();
  114. $do_burst = 1;
  115. $do_about = 1;
  116. $do_bin = 1;
  117. $do_mods = 1;
  118. $do_std = 1;
  119. $head_off = 2;
  120. $do_tree = 1;
  121. $do_faqs = 1;
  122. $by_files = $by_dirs = 0;
  123. @add_dirs = ();
  124. my @args = @ARGV;
  125. my $foundrefs = 0;
  126. my %i1ids;
  127. my %index_seen;
  128. my %index_output;
  129. my $www = 'lynx.exe';
  130.  
  131. sub by_dirs { by_files();   $by_files = 0;  $by_dirs = 1; }
  132. sub by_files {
  133.   $dump_manpages = 0;
  134.   $do_burst = 0;
  135.   $do_bin = 0;
  136.   $do_mods = 0;
  137.   $do_std = 0;
  138. #  $head_off = 0;
  139.   $do_tree = 0;
  140.   $do_faqs = 0;
  141.   $by_files = 1;
  142.   $by_dirs = 0;
  143. }
  144.  
  145. %cat_descr = (
  146.           pod => 'Perl documentation',
  147.           faqs => 'Frequently asked questions',
  148.           bin => 'Perl utilities (with POD documentation)',
  149.           mods => 'Standard Perl modules',
  150.           add_mods => 'Additional Perl modules',
  151.           do_file => 'Additional modules',
  152.           do_dirs => 'Additional directories',
  153.           tree => 'Hierarchy of documented perl modules',
  154.           pragmas => 'Pragmata: change Perl\'s behaviour',
  155.          );
  156.  
  157. sub add_dir {            # If without args, just finish processing
  158.   my $name = $_[1];
  159.   print STDERR "Starting section `$name'.\n" if @_ and $debug;
  160.   if (@do_dirs) {
  161.     @add_dir = ($cat_descr{do_dirs},[]) unless @add_dir;
  162.     push @{$add_dir[-1]}, @do_dirs;
  163.     @do_dirs = ();
  164.   }
  165.   push @add_dir, $name, [] if @_;
  166. }
  167.  
  168. if (@ARGV >= 1 and $ARGV[0] !~ /^-/) {
  169.     unshift @ARGV, '--by-files';
  170.     unshift @ARGV, '--head-off=0' if @ARGV == 2;
  171. }
  172.  
  173. GetOptions(
  174.        "debug!" => \$debug,
  175.        "burst!" => \$do_burst, # Print Logo page
  176.        "about!" => \$do_about, # Print About page
  177.        "mods!" => \$do_mods, # Scan through @INC
  178.        "std!" => \$do_std,    # Scan through standard Perl PODs
  179.        "bin!" => \$do_bin,    # Scan through $Config{bin}
  180.        "tree!" => \$do_tree, # Output tree
  181.        "faqs!" => \$do_faqs, # Output faqs
  182.        "file=s@" => \@do_file, # If present, do these files too
  183.        "dir=s@" => \@do_dirs, # Which addnl directories to scan
  184.        "dump_xref!" => \$dump_xref,    # Dump them to STDERR
  185.        "dump-contents!" => \$dump_contents,    # Dump it to STDERR
  186.        "dump-manpages!" => \$dump_manpages,    # Dump unknown to STDERR
  187.        "title=s" => \$DocTitle,
  188.        "head-off=i" => \$head_off,
  189.        "to-bold=s@" => \@make_bold,
  190.        "to-code=s@" => \@make_code,
  191.        "by-files" => \&by_files,
  192.        "by-dirs" => \&by_dirs,
  193.        "www" => \$www,    # Browser
  194.        "section-name=s" => \&add_dir,
  195.        "bin-dir=s@" => \@bin_dirs, # If present, search for bins here too
  196.       );
  197. if ($by_dirs) {
  198.   push @do_dirs, @ARGV;
  199. } elsif ($by_files) {
  200.   push @do_file, @ARGV;
  201. } else {
  202.   warn "Ignoring \@ARGV: `@ARGV'.\n" if @ARGV;
  203. }
  204.  
  205. add_dir();
  206. $do_about = 1 if $do_burst;
  207.  
  208. @make_bold = qw(EMX RSX WPS Object-REXX HPFS HTML WWW GNU Perl C
  209.         XFree86 OS/2 CRT PM DOS VIO CPAN IBM URL) unless @make_bold;
  210. @make_code = qw(VCPI DPMI groff awk gawk STDIN STDOUT STDERR Emacs EPM
  211.         CMD 4os2 sh pdksh zip unzip pkunzip man gcc link386 tr
  212.         PATH LIBPATH) unless @make_code;
  213.  
  214. $make_bold = join '|', @make_bold;
  215. $make_code = join '|', @make_code;
  216.  
  217. $print_index = 1;        # Do not output index for tables of contents
  218.  
  219. debug("Module pod/pm discovery");
  220.   
  221. $curdir = cwd;
  222. my $site_perl_prefix;
  223. my $libdir;
  224.  
  225. if ((substr $Config{sitelib}, 0, length $Config{privlib}) 
  226.     eq $Config{privlib}) {
  227.   $site_perl_prefix = substr $Config{sitelib}, (length $Config{privlib}) + 1;
  228.   $site_perl_prefix =~ s!\\!/!g ;
  229. }
  230.   
  231. if (@do_file) {
  232.   foreach $file (@do_file) {
  233.     # Fake File::Find
  234.     $File::Find::name = $_ = $file;
  235.     $libdir = ".";
  236.     intern_modnamehash();
  237.   }
  238. }
  239. %do_file_hash = %modnamehash;
  240. %old_hash = %modnamehash;
  241. {
  242.   no strict 'refs';
  243.   foreach (1 .. @add_dir/2) {
  244.     foreach $libdir (@{$add_dir[2*$_-1]}) {
  245.       do_libdir $libdir;
  246.     }
  247.     print STDERR "Doing section `$_' named `$add_dir[2*$_-2]': `@{$add_dir[2*$_-1]}'.\n" if $debug;
  248.     %{"do_dirs$ {_}_hash"} = hash_diff(\%old_hash, \%modnamehash);
  249.     $cat_descr{"do_dirs$_"} = $add_dir[2*$_-2];
  250.     %old_hash = %modnamehash;
  251.   }
  252. }
  253.  
  254. if ($do_mods or $do_faqs) {
  255.   foreach $libdir ( @INC ) {
  256.     do_libdir $libdir;
  257.   }
  258.   %mods_hash = hash_diff(\%old_hash, \%modnamehash);
  259.   %old_hash = %modnamehash;
  260.   
  261.   my $regex = quotemeta $Config{sitelib};
  262.   foreach $key (keys %mods_hash) {
  263.     next unless $modnamehash{$key} =~ /^$regex/o;
  264.     $add_mods_hash{$key} = delete $mods_hash{$key};
  265.   }
  266. }
  267.  
  268. foreach $libdir ( $do_bin ? ($Config{bin}, @bin_dirs) : () ) {
  269.   do_libdir $libdir;
  270. }
  271. %bin_hash = hash_diff(\%old_hash, \%modnamehash);
  272.  
  273. @modnames = sort keys %modnamehash;
  274.   
  275. print STDERR "Found `@modnames'.\n";
  276.   
  277. # %modnamehash now maps module name -> file name.
  278. # %moddesc now maps module name -> description.
  279.   
  280. @files = ();
  281.  
  282. if ($do_std and -f 'perl.pod') {
  283.   open MPOD, 'perl.pod';
  284.   @files = ();
  285.   while (<MPOD>) {
  286.     last if /sections/;
  287.   }
  288.   while (<MPOD>) {
  289.     last if /^\S/;
  290.     push @files, [$1, $2] if /^\s+(\S*)\s+(.*)/ and $1 !~ /^perlfaq/; 
  291.                 # and $1 ne 'perltoc';
  292.   }
  293.   close MPOD;
  294.   open MPOD, 'perltoc.pod';
  295.   while (<MPOD>) {
  296.     last if /^=head1\s+pragma/i;
  297.   }
  298.   while (<MPOD>) {
  299.     last if /^=head1/;
  300.     push @pragmas, $1 if /^=head2\s+(\S*)\s+-\s/; 
  301.   }
  302.   close MPOD;
  303.   foreach $key (@pragmas) {
  304.     $pragmas_hash{$key} = delete $mods_hash{$key};
  305.   }
  306.   splice @files, 1, 0, [ 'perlos2',      'Perl under OS/2' ],
  307.      [ 'perltoc',      'Internal table of contents for Perl' ];
  308.   push @files, [ 'perlinstall',  'Installation/compilation of Perl'],
  309.                ['Pumpkin', 'Notes on handling the Perl Patch Pumpkin'];
  310.   if (-f '../INSTALL' and not -f 'perlinstall.pod') {
  311.       copy '../INSTALL', 'perlinstall.pod';
  312.   }
  313.   if (-f '../Porting/pumpkin.pod' and not -f 'Pumpkin.pod') {
  314.       copy '../Porting/pumpkin.pod', 'Pumpkin.pod';
  315.   }
  316.   if (-f '../README.os2' and not -f 'perlos2.pod') {
  317.       copy '../README.os2', 'perlos2.pod';
  318.   }
  319.   for $file (@files) {
  320.     push @pods, $file->[0];
  321.     $pod_hash{$file->[0]}++;
  322.     $moddesc{$file->[0]} = $file->[1];
  323.   }
  324. }
  325.  
  326. if ($do_faqs and -f 'perlfaq.pod') {
  327.   opendir DOT, '.';
  328.   while (defined($file = readdir DOT)) {
  329.     next unless $file =~ /(perlfaq.*)[.]pod/i;
  330.     push @faqsfiles, $1;
  331.   }
  332.   closedir DOT;
  333.   # push @faqsfiles, [$1, $2] if /^\s+(\S*)\s+(.*)/ and $1 =~ /^perlfaq/; 
  334.   
  335.   for $file (@faqsfiles) {
  336.     #$faqs_hash{$file}++;
  337.     print STDERR "Doing faq `$file'\n";
  338.     
  339.     $faqs_hash{$file} = delete $mods_hash{"Pod::$file"} || 
  340.       delete $mods_hash{"pod::$file"} || delete $mods_hash{$file};
  341.     delete $mods_hash{"pod::$file"};
  342.     delete $mods_hash{"$file"};
  343.     delete $mods_hash{"Pod::$file"};
  344.     delete $modnamehash{"pod::$file"};
  345.     delete $modnamehash{"$file"};
  346.     delete $modnamehash{"Pod::$file"};
  347.     # $moddesc{$file->[0]} = $file->[1];
  348.     if ($moddesc{$file} =~ s/(\(\$.*\$\))//) {
  349.       $add_info{$file} = $1;
  350.     }
  351.   }
  352.   unless ($do_mods) {
  353.     %mods_hash = %add_mods_hash = ();
  354.   }
  355. }
  356.  
  357. foreach $module (keys %skipNAMEs) {
  358.   $skip_sections{"$module/NAME"}++;
  359. }
  360.  
  361. #if ($do_tree) {
  362. #  create_tree([keys %modnamehash]);  
  363. #}
  364.  
  365. my @std_categories = (qw(pod pragmas mods add_mods bin faqs do_dirs),
  366.               (map "do_dirs$_", 1 .. @add_dir/2),
  367.               qw(do_file tree));
  368. print STDERR "Categories: `@std_categories'.\n" if $debug;
  369.  
  370. $tree_hash{'::emit_tree'}++ if $do_tree;
  371.  
  372. {
  373.   no strict 'refs';
  374.   for $cat (@std_categories) {
  375.     $categories{$cat} = \%{$cat . "_hash"} if %{$cat . "_hash"};
  376.   }
  377. }
  378.  
  379. for $pod (@files) {
  380.   $doing_pod{$pod->[0] . ".pod"}++;
  381. }
  382.  
  383. for $pod (qw(perlovl.pod)) {
  384.   $obsolete{$pod}++;
  385. }
  386.  
  387. for $pod (<*.pod>) {
  388.   $not_doing_pod{$pod}++ 
  389.     unless $doing_pod{$pod} or $obsolete{$pod} or $pod =~ /perlfaq/;
  390. }
  391.  
  392. for $pod (keys %not_doing_pod) {
  393.   print STDERR "\n!!! Unknown POD: `$pod'\n" if $do_std;
  394. }
  395.  
  396. for $name (sort {lc $a cmp lc $b or $a cmp $b} keys %modnamehash) {
  397.   push @files, [$name, ($moddesc{$name} || "Perl module $name")]
  398. }
  399.  
  400.  
  401. # in these sections an =item will be treated as an =head[n]
  402. # this is necessary because .IPF/.INF format/compiler have
  403. # some limitations for pane size and linking. :-(
  404.  
  405. @split_sections =
  406.     (
  407.      'perlfunc/DESCRIPTION/Alphabetical Listing of Perl Functions',
  408.      'perldiag/DESCRIPTION',
  409.      'perlvar/DESCRIPTION/Predefined Names',
  410.     );
  411.  
  412. @index_sections =        # Put first words in =item into index there
  413.     (
  414.      'perlfunc/DESCRIPTION/Alphabetical Listing of Perl Functions',
  415.      'perlvar/DESCRIPTION/Predefined Names',
  416.     );
  417.  
  418. $section_head[0] = '';        # To simplify warnings
  419. $section_head[1] = '';        # To simplify warnings
  420.  
  421. %groups = (
  422.        links => 1,
  423.        text => 2,
  424.        logo => 3,
  425.        camel => 4,
  426.        l_camel => 5,
  427.        r_camel => 6,
  428.        sublinks => 7,
  429.        about => 8,
  430.        tree_nodes => 9,
  431.       );
  432.  
  433. %panelwidths = (        # Make a gap.
  434.         links => '29%',
  435.         text => '69%',
  436.         sublinks => '28%',
  437.            );
  438.  
  439. # Pickup modules which are not plain words, so it is safer to
  440. # auto-crosslink them (with :: or _, or with mixed capitalization, or
  441. # without vowels with at least 3 letters - avoid B and Tk):
  442. @auto_link = grep /::|_|[a-z][A-Z]|^[^aAeEoOyYiIuU]{3,}$/, keys %addref;
  443. @auto_link{@auto_link} = (1) x @auto_link;
  444.  
  445.  
  446. # This is the rest without vowels, will be highlighted only in obvious places:
  447. @auto_link_hard = grep !/::|_|[a-z][A-Z]|^[^aAeEoOyYiIuU]+$/, keys %addref;
  448. @auto_link_hard{@auto_link_hard} = (1) x @auto_link_hard;
  449.  
  450. sub out;
  451. sub contents;
  452. sub escape;
  453. sub addref;
  454. sub findref;
  455. sub winhead;
  456. sub winlink;
  457. sub no_markup_len;
  458. sub insert_nl;
  459.  
  460. $/ = "";
  461.  
  462. foreach $sc (@split_sections) { $as_head{$sc} = 1; }
  463.  
  464. foreach $sc (@index_sections) { $fine_index{$sc} = 1; }
  465.  
  466. if (not defined $DocTitle) {
  467.   $DocTitle = @files >= 2 ? 'Perl Manual' : $files[0][0];
  468.   $DocTitle = escape($DocTitle);
  469. }
  470.  
  471. $in_item_header = 0;
  472.  
  473. for ($pass = 1; $pass <= 2; $pass++) {
  474.     if ($pass == 2) {
  475.       $auto_link_hard = join '|', keys %auto_link_hard;
  476.       $auto_link = join '|', keys %auto_link;
  477.       $auto_link_both = join '|', keys %auto_link, keys %auto_link_hard;
  478.       print STDERR "\nautolink: $auto_link\nautolink_hard: $auto_link_hard\n" 
  479.     if $debug;
  480.     }
  481.     $headno = 0; # make refs hash for this on first pass
  482.  
  483.     print STDERR "pass: $pass\n";
  484.       print <<EOI if $pass == 2;
  485. :userdoc.
  486. :title.$DocTitle
  487. EOI
  488.  
  489.     # Insert the Logo page.
  490.  
  491.     if ($pass == 2 and $do_burst) {
  492.       # We position burst window low, so it does not obsure Contents and/or
  493.       # titles of information windows, and Contents does not obsure us
  494.       # (completely).
  495.       print <<EOI;
  496. :h1 group=$groups{logo} x=7% width=87% y=1% height=90% id=63999 scroll=none.Logo
  497. :i1.Logo
  498. :link reftype=hd refid=63998 auto split group=$groups{l_camel}
  499.        vpx=left vpy=center vpcx=25c vpcy=12c
  500.        scroll=none titlebar=none rules=none.
  501. :link reftype=hd refid=63997 auto split group=$groups{r_camel}
  502.        vpx=right vpy=center vpcx=25c vpcy=12c
  503.        scroll=none titlebar=none rules=none.
  504. :link reftype=hd refid=63996 auto split group=$groups{camel}
  505.        vpx=center vpy=center vpcx=312x vpcy=390p
  506.        scroll=none titlebar=none rules=none.
  507. :h2 hide noprint nosearch id=63998.Dummy
  508. :lines.
  509. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perl')]}.Enter here!:elink.
  510.  
  511. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlos2')]}.Perl and OS/2:elink.
  512.  
  513. :link reftype=hd group=$groups{text} dependent vpx=right vpcx=$panelwidths{text} refid=@{[findrefid('CPAN')]}.Where to get ...:elink.
  514.  
  515. :link reftype=hd group=$groups{text} dependent vpx=right vpcx=$panelwidths{text} refid=@{[findrefid('ExtUtils::MakeMaker/Default Makefile Behaviour')]}.After you got it:elink.
  516.  
  517. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perltrap')]}.This should work!:elink.
  518.  
  519. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perldebug')]}.But it does not!:elink.
  520. :elines.
  521. :h2 hide noprint nosearch id=63997.Dummy
  522. :lines align=right.
  523. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlbook')]}.The fine book:elink.
  524.  
  525. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlmod')]}.Perl extensions:elink.
  526.  
  527. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlxs')]}.C extensions:elink.
  528.  
  529. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlguts')]}.Inside Camel:elink.
  530.  
  531. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlstyle')]}.Ugly code:elink.
  532.  
  533. :link reftype=hd group=$groups{about} dependent refid=63900.About:elink.
  534. :elines.
  535. :h2 hide noprint nosearch id=63996.Dummy
  536. :artwork align=center name='CamelGrayBig.BMP'.
  537. Do not forget that you can alway click on :hp9.Contents:ehp9., :hp9.Search:ehp9., and :hp9.Index:ehp9. buttons (or use :hp8.Alt-t:ehp8., :hp8.Alt-s:ehp8., :hp8.Alt-i:ehp8. correspondingly).
  538. :font facename=Courier size=7x5. The use of a camel image in conjunction with Perl is a trademark of
  539. O'Reilly &. Associates, Inc.:font facename=default size=0x0.
  540.  
  541. EOI
  542.     }
  543.     if ($pass == 2 and $do_about) {
  544.       print <<EOI;
  545. :h1 toc=1 group=$groups{about} x=center width=100% y=center height=20% id=63900.About
  546. Generated on @{[out(scalar localtime, 1)]}, by
  547. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perl')]}.Perl:elink.
  548. version $], 
  549. :link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('pod2ipf')]}.pod2ipf:elink.
  550. version $VERSION @{[format_args]} in directory @{[escape(cwd)]}.
  551.  
  552. EOI
  553.     }
  554.     if ($head_off <= 1 or (keys %categories) <= 1) {
  555.       if ($head_off > 1) {
  556.     print <<EOP if $pass == 2;
  557. :h1 toc=$maxtoc group=$groups{links} x=left width=$panelwidths{links} id=63000.$DocTitle
  558. $DocTitle.
  559.  
  560. EOP
  561.       }
  562.       for ($fn = 0; $fn <= $#files; $fn++) {
  563.     output_file($files[$fn][0]);
  564.       }
  565.     } else {
  566.       # Separate into categories:
  567.       my @titles;
  568.       for $cat (@std_categories) {
  569.     next unless $categories{$cat};
  570.     category_emit($cat) if $pass == 2;
  571.     @titles = sort {lc $a cmp lc $b or $a cmp $b} 
  572.         keys %{$categories{$cat}};
  573.     @titles = @pods if $cat eq 'pod'; # Preserve the sorting order
  574.     for $title (@titles) {
  575.       if ($title eq '::emit_tree') {
  576.         output_tree(create_tree([keys %modnamehash]), '', 2) if $pass == 2;
  577.       } else {
  578.         output_file($title);
  579.       }
  580.     }
  581.       }
  582.     }
  583. }
  584.  
  585. print "\n:euserdoc.\n";
  586.  
  587. if ($dump_xref) {
  588.     foreach (keys %links) {
  589.         print STDERR $_ . "->" . $links{$_} . "\n";
  590.     }
  591. }
  592. if ($dump_contents) {
  593.     for($i = 0; $i <= $#head; $i++) {
  594.         print STDERR "    " x $headlevel[$i], $head[$i], "\n";
  595.     }
  596. }
  597. if ($dump_manpages) {
  598.   my @arr = sort keys %unknown_manpages;
  599.   print STDERR "Unknown manpages: @arr.\n";
  600. }
  601. print STDERR "Found $foundrefs crosslinks.\n";
  602.  
  603. sub category_emit {
  604.   my $cat = shift;
  605.   $cat_id ||= 63000;
  606.   $cat_id++;
  607.   print <<EOP;
  608. :h1 toc=$maxtoc group=$groups{links} x=left width=$panelwidths{links} id=$cat_id.$cat_descr{$cat}
  609. $cat_descr{$cat}.
  610.  
  611. EOP
  612. }
  613.  
  614. sub process_index {
  615.   unless ($print_index) {
  616.     @index = ();
  617.     return;
  618.   }
  619.   my %seen;
  620.   for (@index) {
  621.     $seen{$_}++;
  622.   }
  623.   print "\n" if @index;
  624.   for (keys %seen) {
  625.     print ":i1." . out($_, 0) . "\n";    
  626.   }
  627.   @index = ();
  628. }
  629.  
  630. sub output_file {
  631.         my $ftitle = shift;
  632.         my $fcomment = $moddesc{$ftitle} || "Perl module $ftitle";
  633.     
  634.         $fname = $ftitle . '.pod';
  635.     if (not -f $fname) {
  636.       $fname = $modnamehash{$ftitle};
  637.     }
  638.         $page = $ftitle;
  639.         $toc = $maxtoc;
  640.     @index = ();
  641.         
  642.         open(IN, $fname) || die "$ftitle: open `$fname': $!";
  643.         print STDERR $fname . ": ";
  644.         print STDERR "\n" if !$dots;
  645.  
  646.         $section = $ftitle . ' - ' . $fcomment;
  647.         if ($pass == 1) {
  648.             addsection($section, $headno, 1);
  649.             addref($page, $headno);
  650.         $is_head{$ftitle}++;
  651.         }
  652.         $section_head[1] = $page;
  653.         $path = $section_head[1];
  654.         if ($pass == 2) {
  655.         insert_nl;
  656.         my $hlevel = $head_off >= 1 ? $head_off : 1;
  657.         insert_back($hlevel,$headno - 1);
  658.             print ":h$hlevel toc=$toc " . winhead($headno)
  659.                 . " id=" . ($headno + $ref_delta) . "."
  660.                 . out($section, 0) . "\n" . $font; # Headers take no fonts.
  661.             output_index($section, $ftitle);
  662.             output_index($ftitle, $ftitle);
  663.         if (exists $add_info{$ftitle}) {
  664.           print out($add_info{$ftitle}, 0), ":p.\n"
  665.         }
  666.         $was_nl = 1;
  667.     } else {
  668.         count_index($section);
  669.         count_index($ftitle);
  670.     }
  671.         $headno++;
  672.         
  673.         @lstack = ();
  674.         $emptypane = $emptysection = 1;
  675.     $inpod = 0;
  676.         
  677.         PARA: while (defined ($line = <IN>)) {
  678.             chomp $line;
  679.         if ($line =~ /^=\w+/) {
  680.           if ($line =~ /^=head(\d+)\b\s*/) {
  681.             $inpod = 1;
  682.                 $nopara = 0;
  683.                 $heading = $';
  684.         {
  685.           $heading =~ s/\s*$//;    # localize $1
  686.           $heading = untabify $heading;
  687.         }
  688.         
  689.         if (@lstack) {
  690.           warn "List not finished (@lstack) in (@section_head[1..$hl]).\n"
  691.             if $pass == 1;
  692.           while ($#lstack >= 0) {
  693.                     $t = pop(@lstack);
  694.                     if ($t eq 'ul') {
  695.               print ":eul.\n" if $pass == 2;
  696.               $was_nl = 1;
  697.                     } elsif ($t eq 'ol') {
  698.               print ":eol.\n" if $pass == 2;
  699.               $was_nl = 1;
  700.                     } elsif ($t eq 'parml') {
  701.               print ":eparml.\n" if $pass == 2;
  702.               $was_nl = 1;
  703.                     } elsif ($t eq 'head' or $t eq 'finehead') {
  704.               $hl--;
  705.               $path = join('/', @section_head[1..$hl]);
  706.                     }
  707.           }    
  708.         }
  709.  
  710.         $old_hl = $hl;
  711.                 $hl = $1 + 1;
  712.                 $section_head[$hl] = $heading;
  713.                 $path = join('/', @section_head[1..$hl]);
  714.         $sh_path = join('/', @section_head[1..$hl-1]);
  715.         if ($skip_sections{$path}) {
  716.           $inpod = 0;
  717.           next PARA;
  718.         }
  719.                 contents($hl, $headno) if $emptypane;
  720.         insert_back($old_hl,$headno); # Previous header
  721.                 if ($pass == 1) {
  722.                     addsection($heading, $headno, $hl);
  723.             # XXXX Is wrong with some escapes:
  724.             #1 while $heading =~ s/[A-Z]<.*?>/$1/g;
  725.                     addref(qq|$page/"$heading"|, $headno);
  726.             $is_head{$heading}++;
  727.                 }
  728.                 if ($pass == 2) {
  729.             insert_nl;
  730.                     print ":h", $hl + $head_off - 1 , " " . winhead($headno)
  731.                         . " id=" . ($headno + $ref_delta) . "."
  732.                         . out($heading, 0) . "\n" . $font; # Headers take no fonts
  733.             output_index($heading, $path);            
  734.         } else {
  735.             count_index($heading);
  736.         }
  737.                 $headno++;
  738.                 print STDERR "." if $dots;
  739.                 $emptypane = $emptysection = 1;
  740.           } elsif ($line =~ /^=over\b\s*/) {
  741.             $inpod = 1;
  742.         $step = 5;    # Default
  743.         $step = $& if $' =~ /\d+/;
  744.         $step = int($step * 4/3 + 0.5); # Take into account proportional font
  745.                 # look ahead, to see how the list should look like
  746.         if ($pass == 1 and $inpod) {
  747.           $auto_link_hard{$1}++,
  748.           $x_index{$1} = $headno
  749.             while $line =~ /X<([^<>]+)>/g;
  750.         }
  751.                 chomp($line = <IN>);
  752.         if ($pass == 1) {
  753.           $auto_link_hard{$1}++ while /X<([^<>]+)+>/g;
  754.         }
  755.                 if ($line =~ /^\=item(\s*$|\s+\*)/) { # item * (or empty)
  756.                     push(@lstack, "ul");
  757.             insert_nl if $pass == 2;
  758.                     print ":ul.\n" if $pass == 2;
  759.             $was_nl = 1;
  760.                 } elsif ($line =~ /^\=item\s+1\.?/) {  # item 1. 
  761.                     push(@lstack, "ol");
  762.             insert_nl if $pass == 2;
  763.                     print ":ol.\n" if $pass == 2;
  764.             $was_nl = 1;
  765.                 } elsif (defined($as_head{$path})) {
  766.                     # in some cases we use headings instead of lists
  767.                     warn "toc for $page, id=$headno too low" if ! $toc >= $hl + 1;
  768.                     push(@lstack, $fine_index{$path} ? "finehead" : "head");
  769.                     $hl++;
  770.             $section_head[$hl] = 'list_start';
  771.                     $eitems = "";
  772.                 } else {
  773.                     push(@lstack, "parml");
  774.             insert_nl if $pass == 2;
  775.                     print ":parml break=fit tsize=$step.\n" if $pass == 2;
  776.             $was_nl = 1;
  777.                 }
  778.                 $nopara = 0;
  779.                 redo PARA;
  780.           } elsif ($line =~ /^=back\b/) {
  781.             $inpod = 1;
  782.                 if ($#lstack >= 0) {
  783.                     $t = pop(@lstack);
  784.                     if ($t eq 'ul') {
  785.                 insert_nl if $pass == 2;
  786.                         print ":eul.\n" if $pass == 2;
  787.             $was_nl = 1;
  788.                     } elsif ($t eq 'ol') {
  789.                 insert_nl if $pass == 2;
  790.                         print ":eol.\n" if $pass == 2;
  791.             $was_nl = 1;
  792.                     } elsif ($t eq 'parml') {
  793.                 insert_nl if $pass == 2;
  794.                         print ":eparml.\n" if $pass == 2;
  795.             $was_nl = 1;
  796.                     } elsif ($t eq 'head' or $t eq 'finehead') {
  797.                         $hl--;
  798.             $path = join('/', @section_head[1..$hl]);
  799.                     }
  800.                 } else {
  801.                     warn "stack empty on page=$page, id=$headno";
  802.                     $hl--;
  803.                 }
  804.                 $nopara = 0;
  805.           } elsif ($line =~ /^=item\b\s*/) {
  806.             $inpod = 1;
  807.                 $nopara = 0;
  808.                 $heading = $';
  809.         $heading =~ s/\s+$//;
  810.         $heading = untabify($heading);
  811.                 $headx = $heading;
  812.         $headx =~ s/E<(.*?)>/$HTML_Escapes{$1}/ge; # Primitive: $<digit>
  813.         1 while $headx =~ s/[A-Z]<(.*?)>/$1/g; # Primitive: $<digit>
  814.                 print STDERR "." if $dots;
  815.         if ($#lstack == -1) {
  816.                     push(@lstack, "parml");
  817.             insert_nl if $pass == 2;
  818.                     print ":parml break=fit tsize=7.\n" if $pass == 2;
  819.             $was_nl = 1;
  820.             warn "An =item without =over in (@section_head[1..$hl])\n" 
  821.         }
  822.                 if ($lstack[$#lstack] eq 'head'
  823.             or $lstack[$#lstack] eq 'finehead') {
  824.                     contents($hl, $headno) if $emptypane;
  825.             insert_back($hl,$headno) unless $emptysection; # Previous header
  826.  
  827.                     # lowest level never empty, IPFC uses next page
  828.                     # by default (but Back button doesn't work :-()
  829.             # 
  830.             # However, we treat it specially anyway
  831.                     $emptypane = 0;
  832.             $emptysection = 1;
  833.             
  834.             my ($word1, $word2);
  835.             $headx =~ /(\^?\w+)/; # $^A
  836.             $word1 = $1;
  837.             $headx =~ /(\S+)/;
  838.             $word2 = $1;
  839.                     if ($pass == 1) {
  840.                         addsection($heading, $headno, $hl);
  841.                         addref(qq|$page/"$headx"|, $headno);
  842.                         addref(qq|$page/"$word1"|, $headno) if defined $word1;
  843.                         addref(qq|$page/"$word2"|, $headno) if defined $word2;
  844.                     }
  845.                     $section_head[$hl] = $heading;
  846.                     $path = join('/', @section_head[1..$hl]);
  847.             $sh_path = join('/', @section_head[1..$hl-1]);
  848.             insert_nl if $pass == 2;
  849.             print ":h", $hl + $head_off - 1, " " . winhead($headno)
  850.               . " id=" . ($headno + $ref_delta) . "."
  851.             . out($heading, 0) . "\n" . $font 
  852.               if $pass == 2; # Headers take no fonts
  853.             output_index($heading, $path);            
  854.             $was_nl = 1;
  855.             if ($#lstack >= 0 
  856.             and $lstack[$#lstack] eq 'finehead') {
  857.               output_index($word1, $path)
  858.             if defined $word1 and $word1 ne $heading;
  859.               output_index($word2, $path)            
  860.             if defined $word2 and $word2 ne $heading
  861.               and $word2 ne $word1;
  862.             }
  863.             $is_head{$heading}++ if $pass == 1; # XXXX Need to strip?
  864.                     $headno++;
  865.  
  866.                     # look ahead to see if this =item is empty.
  867.                     # if it is, create a list of empty pages of
  868.                     # on first non-empty.
  869.             if ($pass == 1 and $inpod) {
  870.               $auto_link_hard{$1}++,
  871.               $x_index{$1} = $headno
  872.             while $line =~ /X<([^<>]+)>/g;
  873.             }
  874.                     chomp($line = <IN>);
  875.                     if ($pass == 2) {
  876.                         if ($line =~ /^=item\b/) {
  877.                             $eitems .= $heading . "\n";
  878.                         } elsif ($eitems ne "") {
  879.                             $eitems .= $heading . "\n";
  880.                             foreach $l (split("\n", $eitems)) {
  881.                                 print ":p.:hp2." . out($l, 1) . ":ehp2.";
  882.                             }
  883.                             $eitems = "";
  884.                         }
  885.             } else {
  886.               $auto_link_hard{$1}++ while /X<([^<>]+)+>/g;
  887.             }
  888.                     redo PARA;
  889.                 } else {    # Different list's items
  890.             local $in_item_header = 1;
  891.                     $emptypane = $emptysection = 0;
  892.             addref(qq|$page/"$headx"|, $headno, 1);
  893.                     if ($lstack[$#lstack] eq 'ul' && $heading =~ /^\s*\*\s*(.*)$/ or
  894.                         $lstack[$#lstack] eq 'ol' && $heading =~ /^\s*\d+\.?\s*(.*)$/)
  895.               {        # Bulleted or numbered item matching list type.
  896.                             print ":li." if $pass == 2;
  897.                             $heading = $1;
  898.                             if ($1 ne "") {
  899.                                 print out($heading, 1) . "\n" if $pass == 2;
  900.                 output_index($heading, $path)
  901.                   unless $is_head{$heading};
  902.                 $was_nl = 1;
  903.                             } else {
  904.                                 $nopara = 1;
  905.                 $was_nl = 0;
  906.                             }
  907.               } elsif ($lstack[$#lstack] eq 'parml') {
  908.             print ":pt." if $pass == 2;
  909.             $heading =~ s/^\s*\*?\s+//;
  910.             $heading =~ s/\s+$//;
  911.             $heading = '*' if $heading eq '';
  912.             print out($heading, 1) . "\n" if $pass == 2;
  913.             output_index($heading, $path)
  914.               unless $is_head{$heading} or $heading eq '*' or $heading eq '';
  915.             print ":pd." if $pass == 2;
  916.             $nopara = 1;
  917.             $was_nl = 0;
  918.               } else {
  919.               print ":li." . out($heading, 1) . "\n" if $pass == 2;
  920.               output_index($heading, $path)
  921.                 unless $heading eq '' or $heading eq '*' or $is_head{$heading};
  922.               $was_nl = 1;
  923.               $nopara = 1;
  924.               }
  925.                 }
  926.           } elsif ($line =~ /^=cut/) {
  927.             $inpod = 0;
  928.           } elsif ($line =~ /^=pod/) {
  929.             $inpod = 1;
  930.           } else {
  931.                 warn "what to do with '$line'?\n";
  932.           }
  933.             } elsif ($inpod == 0) {
  934.           # Just ignore this chunk
  935.             } elsif ($line =~ /^\s+\S/) {
  936.                 if ($pass == 2) {
  937.                     $pre = untabify($line);
  938.             insert_nl;
  939.                     print ":xmp.\n" . escape_with_url($pre) . "\n:exmp.\n";
  940.             $was_nl = 1;
  941.         }
  942.                 $nopara = 0;
  943.                 $emptypane = $emptysection = 0;
  944.             } elsif ($line =~ /^\s+\S/m) { # see perl(run)?/SYNOPSIS for this
  945.                 if ($pass == 2) {
  946.                     $mark = out($line, 1);
  947.  
  948.                     # hack hack ;-)
  949.                     # IPFC doesn't handle tabs
  950.                     # no_markup_len tries to guess the # of ' ' to next tab,
  951.                     # but even when the guess is correct, things don't seem
  952.                     # to align when bold,.. is used :-(
  953.                     $pre = untabify_after($mark);
  954.                     
  955.             insert_nl;
  956.                     print ":xmp.\n" . $pre . "\n:exmp.\n";
  957.             $was_nl = 1;
  958.                 }
  959.                 $nopara = 0;
  960.                 $emptypane = $emptysection = 0;
  961.             } else {
  962.                 if ($pass == 2) {
  963.                     print ":p.\n" unless $nopara;
  964.                     print out(untabify($line), 1);
  965.             process_index();
  966.             $was_nl = 0;
  967.                 } else {
  968.                     if ($line =~ /^\s+$/) {
  969.                         warn "line with blanks in $page, id=$headno\n";
  970.                     }
  971.                 }
  972.                 $nopara = 0;
  973.                 $emptypane = $emptysection = 0;
  974.             }
  975.         if ($pass == 1 and $inpod) {
  976.           $auto_link_hard{$1}++,
  977.           $x_index{$1} = $headno
  978.         while $line =~ /X<([^<>]+)>/g;
  979.         }
  980.         }
  981.         close(IN);
  982.         print STDERR "\n" if $dots;
  983.     }
  984.  
  985. sub output_tree {
  986.   my ($tree, $prefix, $level) = @_;
  987.   my ($node, $mod);
  988.   foreach $node (sort keys %$tree) {
  989.     $cat_id++;
  990.     if ($prefix eq '') {
  991.       $mod = substr $node, 2;
  992.     } else {
  993.       $mod = "$prefix$node";      
  994.     }
  995.     if (ref $tree->{$node}) {    # Subtree
  996.       print <<EOP;
  997. :h$level group=$groups{tree_nodes} x=left width=10% y=top height=10% id=$cat_id.@{[escape $mod]}...
  998.  
  999. EOP
  1000.       output_tree($tree->{$node}, $mod, $level + 1);
  1001.     } else {
  1002.       print <<EOP;
  1003. :h$level group=$groups{tree_nodes} x=left width=10% y=top height=10% id=$cat_id.@{[escape $mod]}
  1004. :link reftype=hd group=$groups{links} auto vpx=left vpcx=$panelwidths{links} refid=@{[findrefid($mod)]}.
  1005. @{[escape $mod]}
  1006.  
  1007. EOP
  1008.     }
  1009.   }
  1010. }
  1011.  
  1012. sub untabify {
  1013.   my @tlines = split(/\n/, shift);
  1014.   my $tline;
  1015.   foreach $tline (@tlines) {
  1016.     1 while $tline =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
  1017.   }
  1018.   join("\n", @tlines);
  1019. }
  1020.  
  1021. sub untabify_after {        # Some markup is already there.
  1022.   my @tlines = split(/\n/, shift);
  1023.   my $tline;
  1024.   foreach $tline (@tlines) {
  1025.     1 while $tline =~ s/\t+/' 'x (length($&) * 8 - &no_markup_len($`) % 8)/e;
  1026.   }
  1027.   join("\n", @tlines);
  1028. }
  1029.  
  1030. {
  1031.   my $id_c = 0;
  1032.   sub i1id {
  1033.     return $i1ids{$_[0]} if exists $i1ids{$_[0]};
  1034.     $i1ids{$_[0]} = "id_" . ++$id_c;
  1035.   }
  1036. }
  1037.  
  1038. sub output_index {
  1039.   return &count_index if $pass == 1;
  1040.   my ($heading, $path) = (shift, shift);
  1041.   $heading = substr($heading, 0, 110) . "..." if length $heading > 124;
  1042.   $path = substr($path, 0, 110) . "..." if length $path > 124;
  1043.   if ($index_seen{$heading} > 1) {
  1044.     my $id = $i1ids{$heading};
  1045.     unless ($id) {
  1046.       $id = i1id($heading);
  1047.       print ":i1 id=$id." . out($heading, 0) . "\n";
  1048.     }
  1049.     print ":i2 refid=$id." . out("[$path]", 0) . "\n" 
  1050.       unless $index_output{$id}{$headno}++;
  1051.   } else {
  1052.     print ":i1." . out($heading, 0) . "\n";    
  1053.   }
  1054. }
  1055.  
  1056. sub count_index { $index_seen{shift()}++ }
  1057.  
  1058. sub maybe_link {
  1059.   my $txt = shift;
  1060.   exists $links{findref($txt)} ? "L<$txt>" : $txt;
  1061. }
  1062.  
  1063. sub strip {
  1064.     my $in = shift;
  1065.  
  1066.     1 while $in =~ s/X<([^<>]*)>//;
  1067.     1 while $in =~ s/[A-Z]<([^<>]*)>/$1/;
  1068.     
  1069.     return $in;
  1070. }
  1071.  
  1072. sub try_external_link {
  1073.     my $txt = shift;
  1074.     $foundrefs++, return ":link reftype=hd refid=$x_index{$txt}."
  1075.       . out($txt) . ":elink."
  1076.     if exists $x_index{$txt};
  1077.     
  1078.     print STDERR "trying `$txt'" if $debug;
  1079.     
  1080.     if ($txt =~ m,^(http|file|ftp|mailto|news|newsrc|gopher)://,) {
  1081.     my $link = strip($txt);
  1082.     return 
  1083.       ":link reftype=launch object='$www' data='$link'."
  1084.         . out($txt) . ":elink.";
  1085.  
  1086.     } elsif ($txt =~ m,^\"(http|file|ftp|mailto|news|newsrc|gopher)://, 
  1087.          and $txt =~ /\"$/) {
  1088.     my $link = strip(substr $txt, 1, length($txt) - 2);
  1089.     return 
  1090.       ":link reftype=launch object='$www' data='$link'."
  1091.         . out($txt) . ":elink.";
  1092.  
  1093.     } elsif ($txt =~ m,^(\w+)\([23]\)|POSIX\s*\(3\)/(\w+)|(emx\w+)$,i) {
  1094.     return 
  1095.       ":link reftype=launch object='view.exe' data='emxbook $+'."
  1096.         . out($txt) . ":elink.";
  1097.     }
  1098.     return undef;
  1099. }
  1100.  
  1101. sub auto_beautify {
  1102.     my $para = $_[0];
  1103.     # We start with links to make as many of them as we can:
  1104.     $para =~ s/(^|[^<:\$@%])\b($auto_link)\b(?=$|[^>:]|:[^:])/$1L<$2>/go 
  1105.       if $auto_link;
  1106.     # perl(1) Tix(n)
  1107.     $para =~ 
  1108.       s/ (^|[^<]) \b ( [\w:]+ \b \([\dn]\) ) (?=$|[^>]) /$1 . maybe_link($2)/gxe;
  1109.     # words in "SEE ALSO"
  1110.     $para =~ s/ (^|[^<]) \b ( $auto_link_hard ) \b (?=$|[^>]) /$1L<$2>/gox
  1111.     if $section_head[$hl] eq "SEE ALSO" and $auto_link_hard;
  1112.     # Link sections which are highlighted
  1113.     $para =~ s/([CBI])<($auto_link_both)>/$1<L<$2>>/go if $auto_link_both;
  1114.     $para =~ s/C<-([^\W\d])>/C<L<-$1>>/g;
  1115.     $para =~ s/ ^ ( $auto_link_hard ) $  /L<$1>/ox 
  1116.       if $in_item_header and $auto_link_hard;
  1117.     # URLs inside F<>
  1118.     $para =~ s, F< ((http|file|ftp|mailto|news|newsrc|gopher):// [^\s<>]* ) > 
  1119.               ,L<$1>,xg ;
  1120.     # free-standing URLs.
  1121.     $para =~ s% ( \s | ^ ) 
  1122.                 ( (?:http|file|ftp|mailto|news|newsrc|gopher)
  1123.           :// 
  1124.           [^\s<>]* 
  1125.           [^\s.,:;!?\"\'\)] # Strip trailing punctuation.
  1126.         )
  1127.                 ( [.,:;!?\"\'\)]* ( \s | $ ) | $ )
  1128.               %$1L<$2>$3%xg ;
  1129.     # <> below is to avoid BOLDing of C in C<>
  1130.     $para =~ s/(^|[^<:\$@%])\b($make_bold)\b(?=$|[^<>:]|:[^:])/$1B<$2>/go 
  1131.       if $make_bold;
  1132.     $para =~ s/(^|[^<:\$@%])\b($make_code)\b(?=$|[^>:]|:[^:])/$1C<$2>/go 
  1133.       if $make_code;
  1134.     $para =~ s/ (\s+ | ^) ( [\$%\@] [\w:]+ \b) (?=$|[^>]) /$1C<$2>/gx; # $var
  1135.     $para =~ s/ (^|[^<]) \b ( [\w:]+ \b \(\) ) (?=$|[^>]) /$1C<$2>/gx; # func()
  1136.     $para;
  1137. }
  1138.  
  1139. sub out {
  1140.     my $para = $_[0];
  1141.     my $markup = $_[1];
  1142.     my $beautify = $markup && ! $_[2];
  1143.     my @stack = ();
  1144.     my $output = "";
  1145.     my ($c, $cpos, $opos);
  1146.  
  1147.     return if ($pass == 1);
  1148.     
  1149.     $para = auto_beautify($para) if $beautify;
  1150.     
  1151.     $cpos = 0;
  1152.     $opos = 0;
  1153.     TAG: while ($para =~ m{([<>])}g) { # ;-) ;-)
  1154.         $cpos = pos $para;
  1155.         $c = $1;
  1156.         
  1157.         if ($c eq '<' && $cpos >= 0) {
  1158.             $output .= escape(substr($para, $opos, $cpos - $opos - 2))
  1159.           if $cpos - $opos > 2;
  1160.             
  1161.             $c = substr($para, $cpos - 2, 1);
  1162.             if ($c !~ /[A-Z]/) {
  1163.           $output .= escape(($cpos - $opos > 1 ? $c : '') . '<');
  1164.                 pos($para) = $opos = $cpos;
  1165.                 next TAG;
  1166.             }
  1167.             if ($c eq 'B') {
  1168.           if (grep {$_ eq 'I'} @stack) {
  1169.                 $output .= ':hp3.' if $markup;
  1170.                 push (@stack, 'BI');
  1171.           } else {
  1172.                 $output .= ':hp2.' if $markup;
  1173.                 push (@stack, $c);
  1174.           }
  1175.             } elsif ($c eq 'F') {
  1176.                 $output .= ':hp6.' if $markup;
  1177.                 push (@stack, $c);
  1178.             } elsif ($c eq 'S') {
  1179.                 # $output .= ':hp2.' if $markup; # XXXX Should not!
  1180.                 push (@stack, $c);
  1181.             } elsif ($c eq 'I') {
  1182.           if (grep {$_ eq 'B'} @stack) {
  1183.                 $output .= ':hp3.' if $markup;
  1184.                 push (@stack, 'BI');
  1185.           } else {
  1186.                 $output .= ':hp1.' if $markup;
  1187.                 push (@stack, $c);
  1188.           }
  1189.             } elsif ($c eq 'C') {
  1190.                 $output .= ':font facename=Courier size=18x10.' if $markup;
  1191.                 push (@stack, $c);
  1192.             } elsif ($c eq 'L') {
  1193.                 my $link;
  1194.             #push (@stack, $c);
  1195.                 # link
  1196.                 pos $para = $cpos;
  1197.         # Allow one level of included modifiers:
  1198.                 if ($para =~ m/\G(([A-Z]<[^<>]*>|[^>])+)\>/g) {
  1199.                     $cpos = pos $para;
  1200.                     $link = $1;
  1201.                     $foundlink = findref($link); 
  1202.                     if (defined $links{$foundlink}) {
  1203.                 my $blink = $link;
  1204.             $blink =~ s|^"(.+)"$|$1|sm or
  1205.               $blink =~ s|^([-\w:]+)/"(.+)"$|$1: $2|sm;
  1206.                         $output .= ":link reftype=hd refid=" .
  1207.                             ($links{$foundlink} + $ref_delta) . '.'
  1208.                             if $markup;
  1209.                         $output .= out($blink);
  1210.                         $output .= ":elink." if $markup;
  1211.                     } elsif ($foundlink = try_external_link($link)) {
  1212.                         $output .= $foundlink if $markup;
  1213.             } else {
  1214.                         warn "   unresolved link: $link\n";
  1215.                         $output .= out($link);
  1216.                     }
  1217.                 }
  1218.             } elsif ($c eq 'E') {
  1219.                 pos ($para) = $cpos;
  1220.                 if ($para =~ m/\G(([A-Za-z]+)|\d+)>/g) {
  1221.                     my $esc;
  1222.                     $cpos = pos $para;
  1223.             if (defined $2) {
  1224.               $esc = exists $HTML_Escapes{$1} 
  1225.                 ? $HTML_Escapes{$1} : "E<$1>";
  1226.             } else {
  1227.               $esc = chr $1;
  1228.             }
  1229.                     $output .= escape($esc);
  1230.                 } else {
  1231.                     warn "$fname: E<> ??? `" . (substr $para, $cpos-2, 10) . "'\n";
  1232.                 }
  1233.             } elsif ($c eq 'X') {
  1234.                 pos ($para) = $cpos;
  1235.                 if ($para =~ m/\G([^<>]+)>/g) {
  1236.                     my $esc;
  1237.                     $cpos = pos $para;
  1238.                     #$output .= escape($1);
  1239.             push @index, $1 if $print_index;
  1240.                 } else {
  1241.                     warn "$fname: X<> ??? `" . (substr $para, $cpos-2, 160) . "'\n";
  1242.                 }
  1243.             } elsif ($c eq 'Z') {
  1244.                 pos ($para) = $cpos;
  1245.                 if ($para =~ m/\G>/g) {
  1246.                     $cpos = pos $para;
  1247.                 } else {
  1248.                     warn "funny: Z<...> ???\n";
  1249.                 }
  1250.             } else {
  1251.                 warn "$fname: what to do with $c<> ?\n";
  1252.             }
  1253.         } elsif ($c eq '>' && $#stack >= 0) {
  1254.             $output .= escape(substr($para, $opos, $cpos - $opos - 1));
  1255.             
  1256.             $c = pop(@stack);
  1257.             if ($c eq 'B') {
  1258.                 $output .= ':ehp2.' if $markup;
  1259.             } elsif ($c eq 'F') {
  1260.                 $output .= ':ehp6.' if $markup;
  1261.             } elsif ($c eq 'S') {
  1262.                 # $output .= ':ehp2.' if $markup;
  1263.             } elsif ($c eq 'I') {
  1264.                 $output .= ':ehp1.' if $markup;
  1265.             } elsif ($c eq 'BI') {
  1266.                 $output .= ':ehp3.' if $markup;
  1267.             } elsif ($c eq 'C') {
  1268.                 $output .= ':font facename=default size=0x0.' if $markup;
  1269.             } elsif ($c eq 'L') {
  1270.                 # end link
  1271.             } else {
  1272.                 $output .= escape('>');
  1273.             }
  1274.         } else {
  1275.             $output .= escape(substr($para, $opos, $cpos - $opos));
  1276.         }
  1277.         pos($para) = $opos = $cpos;
  1278.     }
  1279.     $output .= escape(substr($para, $opos, length($para) - $opos));
  1280.     if (!$markup) { # for toc/index/...
  1281.         $output =~ s/\n\s*/ /g;
  1282.         $output = substr($output, 0, 140); # strip too long stuff
  1283.     }
  1284.     $output =~ s/^\./&per./m;    # period
  1285.     return $output;
  1286. }
  1287.  
  1288. sub insert_back {
  1289.   return unless $pass == 2;
  1290.   my $parent = find_parent(@_) + $ref_delta;
  1291.   return if $parent == $_[1];
  1292.   insert_nl;
  1293.   print " :link reftype=hd refid=$parent.:font facename=Courier size=8x6.Go Up:font facename=default size=0x0.:elink.\n";
  1294.   $was_nl = 1;
  1295. }
  1296.  
  1297. sub find_parent {
  1298.     my $level = $_[0];
  1299.     my $i = $_[1] - 1;
  1300.  
  1301.     while ($i > 0 && $headlevel[$i] >= $level) { $i--; }
  1302.  
  1303.     return $i;
  1304. }
  1305.  
  1306. sub contents {
  1307.     my $level = $_[0];
  1308.     my $no = $_[1];
  1309.     my ($i, $cl, $toplevel);
  1310.     local $print_index = 0;
  1311.  
  1312.     $isempty{$no-1}++;
  1313.     if ($pass == 1) {
  1314.         $wingroup[$no - 1] = $groups{links};
  1315.         return ;
  1316.     }
  1317.     
  1318.     $i = find_parent($level,$no);
  1319.  
  1320.     $toplevel = $headlevel[$i];
  1321.  
  1322.     print ":p." . out($head[$i], 1) . "\n";
  1323.     $was_nl = 1;
  1324.     $i++;
  1325.     $cl = $toplevel;
  1326.     for (; $i <= $#head && $headlevel[$i] > $toplevel; $i++) {
  1327.         if ($headlevel[$i] > $cl) {
  1328.             warn "bad nesting: $toplevel, $headlevel[$i], $cl, $i, `$head[$i]`\n" if $headlevel[$i] != $cl + 1;
  1329.             print ":ul compact.\n";
  1330.         $was_nl = 1;
  1331.             $cl++;
  1332.         } elsif ($cl > $headlevel[$i]) {
  1333.             while ($cl > $headlevel[$i]) {
  1334.                 print ":eul.\n";
  1335.         $was_nl = 1;
  1336.                 $cl--;
  1337.             }
  1338.         }
  1339.     if (exists $isempty{$i}) {
  1340.       print ":li.", out($head[$i], 1, 1), "\n";    
  1341.     } else {
  1342.       print ":li.:link reftype=hd " . winlink($i)
  1343.             . " refid=" . ($i + $ref_delta) . "."
  1344.           . out($head[$i], 1, 1) . ":elink.\n";
  1345.     }
  1346.     $was_nl = 1;
  1347.     }
  1348.  
  1349.     while ($cl > $toplevel) {
  1350.         print ":eul.\n";
  1351.         $cl--;
  1352.     $was_nl = 1;
  1353.     }
  1354. }
  1355.  
  1356. sub findrefid {
  1357.   my $in = shift;
  1358.   my $out = $links{findref($in)} || $x_index{$in};
  1359.   warn "No refid for `$in'\n" if $debug and not defined $out;
  1360.   ($out || 0) + $ref_delta;
  1361. }
  1362.  
  1363. sub findref { # various heuristics to get a valid link
  1364.     my $link = $_[0];
  1365.     
  1366.     $link =~ tr/\n/ /;
  1367.     print STDERR "link: $link\n" if $debug_xref;
  1368.     if (!defined $links{$link}) {
  1369.       if ($link =~ m|\.pod/|) {
  1370.     $link = "$`/$'";    # Remove .pod from page name
  1371.       } elsif ($link =~ m|\.pod$| and defined $links{$`}) {
  1372.     $link = $`;
  1373.       }
  1374.     }
  1375.     if (!defined $links{$link}) { # try harder
  1376.         if (defined $links{qq|$page/"$link"|}) {
  1377.             $link = qq|$page/"$link"|;
  1378.         } elsif ($link =~ /^\"/) {
  1379.             $link = "$page/$link";
  1380.         } elsif ($link =~ m|^/\"|) {
  1381.             $link = "$page$link";
  1382.         } elsif ($link =~ m|^/|) {
  1383.             $link = qq|$page/"$'"|;
  1384.         } elsif ($link =~ m|^([^/ ]+)/([^\"]+)$|) {
  1385.             $link = qq|$1/"$2"|;
  1386.         } elsif (exists $addref{$link} and exists $links{$addref{$link}}) {
  1387.             $link = $addref{$link};
  1388.     } elsif ($link =~ /^-[^\W\d]$/) {
  1389.         $link = qq|perlfunc/"-X"|;
  1390.     }
  1391.         if ($link =~ m|^([^/ ]+)/"([^\"]+)"$| && !defined $links{$link}) {
  1392.             my $a = $1;
  1393.             my $b = $2;
  1394.             my $linka;
  1395.             
  1396.             if ($b =~ /\(\)$/) { $b = $`; } # open() -> open, ...
  1397.             $linka = qq|$a/"$b"|;
  1398.             if (defined $links{$linka}) {
  1399.                 $link = $linka;
  1400.             }
  1401.     } elsif ($link =~ /\([\dn]\)$/ && defined $links{$`}) {    # perl(1)
  1402.       $link = $`;
  1403.     } elsif ($link =~ /\([\dn]\)$/) {
  1404.       $unknown_manpages{$link}++;
  1405.     }
  1406.         print STDERR "trans: $link\n" if $debug_xref;
  1407.     }
  1408.     $foundrefs++ if defined $links{$link};
  1409.     return $link;
  1410. }
  1411.  
  1412. sub addref {
  1413.     my $page = $_[0];
  1414.     my $num = $_[1];
  1415.     my $check = $_[2];
  1416.  
  1417.     $page =~ s/\s*$//;
  1418.     
  1419.     $links{$page} = $num unless $check and exists $links{$page};
  1420.     if ($page =~ /[A-Z]</) {
  1421.       1 while $page =~ s/[A-Z]<(.*?)>/$1/;
  1422.       $links{$page} = $num unless $check and exists $links{$page};
  1423.     }
  1424.     my $b = auto_beautify($page);
  1425.     $links{$b} = $num unless $b eq $page;
  1426. }
  1427.  
  1428. sub addsection {
  1429.     my $section = $_[0];
  1430.     my $num = $_[1];
  1431.     my $level = $_[2];
  1432.  
  1433.     $head[$num] = $section;
  1434.     $headlevel[$num] = $level;
  1435. }
  1436.  
  1437. sub escape {
  1438.     my $l = $_[0];
  1439.  
  1440.     $l =~ s/\&/\&./g;
  1441.     $l =~ s/\:/\&colon./g;
  1442.     return $l;
  1443. }
  1444.  
  1445. sub remove_colon {
  1446.     my $in = shift;
  1447.     $in =~ s/\&colon\./:/g;
  1448.     $in;
  1449. }
  1450.  
  1451. sub escape_with_url {
  1452.     my $l = escape(shift);
  1453.  
  1454.     $l =~ s% ( \s | ^ ) 
  1455.              (
  1456.           (?:http|file|ftp|mailto|news|newsrc|gopher)
  1457.           \&colon\.//
  1458.           [^\s<>]* 
  1459.           [^\s.,:;!?\"\'\)] # Strip trailing punctuation.
  1460.          )
  1461.              ( [.,:;!?\"\'\)]* ( \s | $ ) | $ )
  1462.            % "$1:link reftype=launch object='$www' data='" 
  1463.          . remove_colon($2)
  1464.          . "'.$2:elink.$3" 
  1465.            %xeg ;
  1466.  
  1467.     return $l;
  1468. }
  1469.  
  1470. BEGIN {
  1471.     %HTML_Escapes =        # We provide a _practical_ list.
  1472.         (
  1473.          'amp'    =>    '&',    #   ampersand
  1474.          'lt'    =>    '<',    #   left chevron, less-than
  1475.          'gt'    =>    '>',    #   right chevron, greater-than
  1476.          'quot'    =>    '"',    #   double quote
  1477.      39    =>    "'",    #   single quote
  1478.         );
  1479. }
  1480.  
  1481. sub winhead {
  1482.     my $no = $_[0];
  1483.  
  1484.     if ($multi_win) {
  1485.         if (defined $wingroup[$no]) {
  1486.             return "group=$groups{links} x=left width=$panelwidths{links}";
  1487.         }
  1488.     }
  1489.     return "";
  1490. }
  1491.  
  1492. sub winlink {
  1493.     my $no = $_[0];
  1494.     
  1495.     if ($multi_win) {
  1496.         if (defined $wingroup[$no]) {
  1497.             return "group=$groups{sublinks} vpx=2% vpcx=$panelwidths{sublinks}";
  1498.         } else {
  1499.             return "group=$groups{text} dependent vpx=right vpcx=$panelwidths{text}"
  1500.         }
  1501.     } 
  1502.     return "";
  1503. }
  1504.  
  1505. sub no_markup_len { # quick hack
  1506.     my $l = $_[0];
  1507.  
  1508.     $l =~ s/\:.*?\.//g;
  1509.     $l =~ s/\&.*?\./x/g;
  1510.     return length $l;
  1511. }
  1512.  
  1513. sub insert_nl {
  1514.   print "\n" if not $was_nl or shift;
  1515.   $was_nl = 1;
  1516. }
  1517.  
  1518. sub do_libdir {
  1519.   local $_;
  1520.   $libdir = shift;
  1521.   chdir $libdir;
  1522.   debug("Looking in $libdir:");
  1523.   find (\&intern_modnamehash , '.');
  1524.   chdir $curdir;
  1525. }
  1526.  
  1527. sub intern_modnamehash {
  1528. # File::Find is pretty screwy.
  1529. # I think we can't modify $_ or File::Find can screw up
  1530.  
  1531.     my $shortpath;
  1532.     
  1533. # this could be a problem - if we search $sitelibdir,
  1534. # its usually a subdir of $libdir, in which case we don't want it
  1535. # to think 'site_perl' is a class name.
  1536.  
  1537. # site_perl and 5.00309 may be seen earlier than needed due to bad
  1538. # ordering of @INC.
  1539.   if ( defined $site_perl_prefix and
  1540.        $File::Find::name =~ m!/($site_perl_prefix|5\.\d{3,5})/!o
  1541.        and $libdir !~ m!/($site_perl_prefix|5\.\d{3,5})($|/)! ) {
  1542.     return;
  1543.   }
  1544.  
  1545. # XXX - may be doing toplevel modules incorrectly in the above case
  1546. # is 'name' just the filename?  thats not good ....
  1547.     $shortpath = $_;
  1548.     local $_ = $File::Find::name;
  1549.  
  1550. # kill leading './'
  1551.  
  1552.     s{^[.]/}{};
  1553.     my $longname = "$libdir/$_";
  1554.     $longname =~ s{^[.]/}{};
  1555.  
  1556. # XXX - take the current $libdir (/foo/bar) 
  1557. # and see if the file were testing (/foo/bar/site_perl/Plugh/Blah.pm) is
  1558. # in any *other*, deeper subdir in @INC
  1559. # (/foo/bar/site_perl) - if so, skip this entry, cuz the deeper 
  1560. # subdir will catch it properly (Plugh::Blah)
  1561.  
  1562. # for other libraries that are proper subdirs of the current libdir
  1563.     foreach $otherlibrary (grep /^\Q$libdir\E.+/, @INC) {
  1564.  
  1565. # if the other library is part of the current files path, skip it
  1566. # because it will be caught when the other library is used
  1567.  
  1568.     if ($longname =~ /^\Q$otherlibrary\//) {
  1569.         print STDERR ".";
  1570. #        print "Skipping $_\n";
  1571. #        print "cuz $otherlibrary caught/will catch it\n";
  1572.         return;
  1573.     }
  1574.     }
  1575.  
  1576. # exclude base pods - perlfoo.pod, but not perlfaqs
  1577.     /perl(?!faq).*[.]pod/ && $do_std && return;
  1578.  
  1579. # for each file entry, kill trailing '.(pod|pm|cmd)'
  1580.     (-f $shortpath) &&
  1581.     s{^(.*)[.](pod|pm|cmd|bat)$ }{$1}x or return;
  1582.  
  1583. # '.pod' files nonhierarchical - keep only last component as module name.
  1584. # well, hierarchical in Tk ... keep it hierarchical for now
  1585.  
  1586. #    if ($2 eq 'pod') {$_ =~ s{.*/([^/]+)}{$1}; }
  1587.     
  1588. # translate to module syntax
  1589.  
  1590.     s{/}{::}g;
  1591.  
  1592. # if its already in the hash, skip it.  We're following @INC order,
  1593. # which means if its found in a earlier @INC directory, it will
  1594. # be the one thats `use'd.  So rather than overwriting an earlier
  1595. # @INC entry with a newer one, we skip the newer one if the earlier
  1596. # one exists (or, we could do the foreach on (reverse @INC) instead
  1597. # of (@INC)).
  1598.  
  1599.     
  1600.     if (defined $seen{lc $_}) {
  1601. #    print "already found $_\n";
  1602. #    print "in $modnamehash{$_}\n";
  1603.     return
  1604.     };
  1605.  
  1606. # If this is a .pm file, is there actually any documentation in it?
  1607.  
  1608. # Under OS/2 perl utilites can have extension .cmd. To be safe, allow
  1609. # .bat as well. Since we look into $Config{bin}, we may allow files
  1610. # without extension as well, if they are text files.
  1611.     
  1612.     if ($longname =~ /[.](pm|cmd|bat|pod)$/i
  1613.         or $longname !~ /[.]/ and -T $longname) {
  1614.         $good = 0;
  1615.         open(MODULE, $shortpath) or die "Cannot open `$shortpath': $!";
  1616.       line: while (defined ($theline = <MODULE>)) {
  1617.         $theline =~ /^=head\d/ and $good = 1 and last line;
  1618.         }
  1619.         $used_name = $_;
  1620.         if ($good and $theline =~ /^=head\d\s+NAME\b/ ) {
  1621.           my @addrefs;
  1622.           
  1623.           # Skip whitespace:
  1624.           $theline = "";
  1625.           $theline = <MODULE> while defined $theline and $theline !~ /\S/;
  1626.           # Now have the name, find the description:
  1627.           if ($theline =~ /^((\S+)(,\s+\S+)*)\s*-\s*(.*)/ ) {
  1628.         my $desc = $4;
  1629.         my $skipNAME;    # safe to skip NAME section
  1630.         if (lc($used_name) eq lc($2)) {
  1631.           $skipNAME = length($2) == length($1);
  1632.           # dumpValue(\%addref);
  1633.         } else {
  1634.           print STDERR "\n!!! Not matching: `$_' vs. `$2'\n"
  1635.             unless /perlfaq/;
  1636.         }
  1637.         $firstline_name = $2;
  1638.         # Now process additional names this manpage may
  1639.         # appear under (first from the first line only):
  1640.         @addrefs = ($1 =~ /([\w:]+)/g);
  1641.         # Second from additional lines
  1642.         while (defined ($theline = <MODULE>) 
  1643.                and not $theline =~ /\A=/) {
  1644.           if ($theline =~ /^((\S+)(,\s+\S+)*)\s*-\s*(.*)/) {
  1645.             push @addrefs, ($1 =~ /([\w:]+)/g);
  1646.             $skipNAME = 0;
  1647.           } elsif ($theline =~ /\S/) {
  1648.             $skipNAME = 0;
  1649.           }
  1650.         }
  1651.         # Prefer the name on the line over the file name:
  1652.         if ($skipNAME and $used_name ne $firstline_name) {
  1653.           $used_name = $firstline_name;
  1654.         }
  1655.         @addref{@addrefs} = ($used_name) x @addrefs;
  1656.         print STDERR "Adding `@addrefs' for `$used_name'.\n" if $debug;
  1657.         $moddesc{$used_name} = $desc;
  1658.         $skipNAMEs{$used_name}++ if $skipNAME;
  1659.         #print STDERR "moddesc: `$_' `$oldname' `$3'\n";
  1660.           } else {
  1661.         print STDERR "\n!!! $_: bad NAME: `$theline'\n";
  1662.           }
  1663.         } elsif ($good) {
  1664.           print STDERR "\n!!! $_: no NAME\n";
  1665.         }
  1666.         if ($good) {
  1667.           $seen{lc $used_name}++;
  1668.           $modnamehash{$used_name} = $longname;
  1669.           $addref{$used_name} = $used_name;
  1670.         }
  1671.     }
  1672.  
  1673.     echopod($_) if $modnamehash{$_};
  1674. }
  1675.  
  1676. sub debug {
  1677.   print STDERR "\n", '=' x 79, "\n$_[0]\n", '=' x 79 , "\n";
  1678. }
  1679.  
  1680. sub echopod {
  1681.  
  1682.     $savenew = $_[0];
  1683.     $oldpod ||= "";
  1684.  
  1685. # if neither has a ::, same line
  1686.  
  1687.     if ($oldpod !~ /::/ && $_[0] !~ /::/) {
  1688.  
  1689. # if old one has a ::, different lines
  1690.  
  1691.     } elsif ($oldpod =~ /::/ && $_[0] !~ /::/) {
  1692.  
  1693.     print STDERR "\n";
  1694.  
  1695.     } elsif ($oldpod !~ /::/ && $_[0] =~ /::/) {
  1696.  
  1697. # if its the new one that has ::, start a header line
  1698.  
  1699.     ($new) = ($_[0] =~ /^([^:]+)::/);
  1700.     print STDERR "\n${new} modules: ";
  1701.     $_[0] = $';
  1702.  
  1703.     } else {
  1704.  
  1705. # if both have ::, if stuff before first :: is different, newline
  1706. # if stuff before is the same, trim it before printing (same line)
  1707.  
  1708.     ($old) = ($oldpod =~ /^([^:]+)::/);
  1709.     ($new) = ($_[0] =~ /^([^:]+)::/);
  1710.     if ($old eq $new) {
  1711.         # kill leading stuff
  1712.         $_[0] = $';
  1713.     } else {
  1714.         print STDERR "\n${new} modules: ";
  1715.         $_[0] = $';
  1716.     }
  1717.     } 
  1718.  
  1719.     $oldpod = $savenew;
  1720.     
  1721.     print STDERR $_[0], " ";
  1722.  
  1723. }
  1724.  
  1725. sub hash_diff {
  1726.   my ($old, $new) = @_;
  1727.   my @keys = grep {not exists $old->{$_}} keys %$new;
  1728.   my %diff;
  1729.   @diff{@keys} = $new->{@keys};
  1730.   %diff;
  1731. }
  1732.  
  1733. # Retval: hash: keys: toplevel nodes, values: '' or refs to lower-level-hashes.
  1734. # Keys have :: prepended.
  1735. sub create_tree {        
  1736.   my $in = shift;
  1737.   my %branch;
  1738.   my (%ret, $leaf, $branch, $subbranch);
  1739.   
  1740.   # If $leaf is undef, it means ''. The rest has implicit :: prepended.
  1741.   foreach $leaf (@$in) {
  1742.     $ret{''} = '', next unless  defined $leaf;
  1743.     if ($leaf =~ /::/) {
  1744.       push @{$branch{$`}}, $';
  1745.     } else {
  1746.       push @{$branch{$leaf}}, undef; # Cooky to denote a leaf
  1747.     }
  1748.   }
  1749.   if (exists $ret{''} or keys %branch > 1) { # Need this level!
  1750.     foreach $branch (keys %branch) {
  1751.       $subbranch = create_tree($branch{$branch});
  1752.       if (keys %$subbranch > 1) {
  1753.     $ret{"::$branch"} = $subbranch;
  1754.       } else {
  1755.     $ret{"::$branch" . (keys %$subbranch)[0]} = '';
  1756.       }
  1757.     }
  1758.   } elsif (%branch) {        # This level is not needed, just copy sublevel.
  1759.     my $key = (keys %branch)[0];
  1760.     $subbranch = create_tree($branch{(keys %branch)[0]});
  1761.     foreach $leaf (keys %$subbranch) {
  1762.       $ret{"::$key$leaf"} = $subbranch->{$leaf};
  1763.     }    
  1764.   }  
  1765.   \%ret;
  1766. }
  1767.  
  1768. sub format_args {
  1769.   return "with no command-line arguments" unless @args;
  1770.   out('with arguments C<"' . (join '"> C<"', @args) . '">', 1);
  1771. }
  1772.  
  1773. __END__
  1774.  
  1775. =head1 NAME
  1776.  
  1777. pod2ipf - translator from POD format to IBM's F<.INF> format.
  1778.  
  1779. =head1 SYNOPSYS
  1780.  
  1781.   cd \perllib\lib\pod
  1782.   pod2ipf > perl.ipf
  1783.   ipfc /inf perl.ipf
  1784.  
  1785.   pod2ipf my.pod > my.ipf
  1786.  
  1787.   pod2ipf --by-files "--title=My first book" \
  1788.           chapter1.pod chapter2.pod > mybook.ipf
  1789.  
  1790.   pod2ipf --by-dirs "--title=Book for /this/dir" /this/dir > book.ipf
  1791.  
  1792.   pod2ipf --by-dirs "--title=Book with chapters" \
  1793.           "--section-name=General topics" --dir=gen1 --dir=gen2 \
  1794.           "--section-name=Specific topics" --dir=spe1
  1795.           --dir=spe2 --dir spe3      >   longbook.ipf
  1796.  
  1797. =head1 DESCRIPTION
  1798.  
  1799. By default, if no command-line options: processes all the
  1800. standard Perl pods in the current directory, as well as all the Perl
  1801. libraries and all the Perl utilities it can find using F<Config.pm>,
  1802.  
  1803. The result should be converted to .INF via F<ipfc.exe>.
  1804.  
  1805. Both steps produce a lot of warnings, mostly because of malformed
  1806. C<POD>s. Some warnings (n306) from the current design, which intentionally
  1807. generates empty pages.
  1808.  
  1809. Recognized command-line switches (with defaults);
  1810.  
  1811.   --(no)burst        Print Logo and About pages    (y)
  1812.   --(no)about        Print About page        (y)
  1813.   --(no)mods        Scan through @INC        (y)
  1814.   --(no)std        Scan through standard Perl PODs    (y)
  1815.   --(no)bin        Scan through $Config{bin}    (y)
  1816.   --(no)tree        Output modules tree        (y)
  1817.   --(no)faqs        Output faqs            (y)
  1818.   --file        If present, do these files too (multiple OK)
  1819.   --dir            Which addnl directories to scan (multiple OK)
  1820.   --(no)dump-xref    Dump them to STDERR        (n)
  1821.   --(no)dump-contents    Dump it to STDERR        (n)
  1822.   --(no)dump-manpages    Dump unknown manpages to STDERR    (y)
  1823.   --(no)debug        Print an additional debug info    (n)
  1824.   --head-off        Offset of .IPF headings wrt POD    (2|0)
  1825.   --to-bold        If present, words to make bold (multiple OK)
  1826.   --to-code        If present, words to make code-like (multiple OK)
  1827.   --section-name    Groups following --dir into a section (multiple OK)
  1828.   --bin-dir        If present, search for binaries here too (multiple OK)
  1829.   --by-files        Interpret extra args as file names (n if options seen)
  1830.   --by-dirs        Interpret extra args as dir names (n)
  1831.   --www            Which browser to use        (lynx.exe)
  1832.  
  1833. Depending on the value of C<head_off>, the toplevel sections of the generated book are formed basing on:
  1834.  
  1835. =over 4
  1836.  
  1837. =item 0
  1838.  
  1839. C<=head1>-entries of the POD document(s);
  1840.  
  1841. =item 1
  1842.  
  1843. processed POD documents;
  1844.  
  1845. =item 2
  1846.  
  1847. processed groups of POD documents.
  1848.  
  1849. =back 
  1850.  
  1851. Options C<--by-files> and C<--by-dirs> reset the values to
  1852.  
  1853.  --nodump-manpages --noburst --nobin --nomods --nostd --notree --nofaqs
  1854.  
  1855. and interpret the unprocessed command-line parameters as names of
  1856. files or directories to process.
  1857.  
  1858. =head1 PREREQUISITES
  1859.  
  1860. Developer toolkit for OS/2 is required (for C<ifpc>).  It is reported that C<ipfc> is also on DDK which is freely available from IBM site.
  1861.  
  1862. =head1 AUTHOR
  1863.  
  1864. C<Marko.Macek@snet.fri.uni-lj.si>, C<mark@hermes.si>, reworked
  1865. by Ilya Zakharevich C<ilya@math.ohio-state.edu>.
  1866.  
  1867. =head1 SEE ALSO
  1868.  
  1869. L<perlpod>, L<perl>, L<pod2man>, L<perldoc>, L<pod2html>, L<pod2latex>,  L<pod2texi>, L<pod2text>.
  1870.  
  1871. =cut
  1872.  
  1873. No docs:  L<pod2html>, L<pod2latex>,  L<pod2texi>, L<pod2text>,
  1874.