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