Ticket #186: pod2ipf137.cmd.base

File pod2ipf137.cmd.base, 88.3 KB (added by Shmuel (Seymour J.) Metz, 6 years ago)

base version of pod2ipl.pl 1-37

Line 
1extproc perl -wS
2#!perl -w
3use strict qw(refs subs);
4use File::Find;
5use File::Copy 'copy';
6use Cwd;
7use Config '%Config';
8use Getopt::Long 'GetOptions';
9use vars qw{%do_file_hash %do_dirs_hash %bin_hash %faqs_hash %pragmas_hash
10            %mods_hash %pod_hash %add_mods_hash @add_dir @add_files %tree_hash
11            $skip_embedded_links};
12# use Fatal qw(open close); # would not work: interprets filehandles as barewords.
13sub intern_modnamehash;
14sub do_libdir;
15sub output_file;
16sub hash_diff;
17sub auto_beautify;
18sub create_tree;
19sub format_args;
20sub output_index;
21sub count_index;
22sub untabify;
23sub untabify_after;
24sub strip;
25sub find_parent;
26sub insert_back;
27
28require 5.004;                  # Otherwise pos() in recursive sub cores.
29
30#require 'dumpvar.pl';
31
32# $rcs = ' $Id: pod2ipf.cmd,v 1.37 2010/07/27 01:40:05 vera Exp $ ' ;
33($VERSION) = (' $Revision: 1.37 $ ' =~ /(\d+(\.\d+)*)/);
34
35# by Marko.Macek@snet.fri.uni-lj.si, mark@hermes.si
36# and Ilya Zakharevich ilya@math.ohio-state.edu
37#
38# TODO:
39#   eliminate blank panes that link to next pane when =item XX\n\n=itemYY used
40#   rewrite ?<> parsing
41#   better index (mostly done)
42#   cleaner xref heuristics (mostly done)
43#   process embeded pods (done)
44#   IPFC doesn't seem to handle tabs - are
45#   handle perl/SYNOPSIS properly (tabs, indented lines) -- or is it a bug in doc
46#     probably should process as pre but with markup -- done below (ok?)
47#   remove =head1 NAME and use it as toplevel heading (done)
48#     (also collapse DESCRIPTION if the only section).
49#   pod2ipf needs to be split into index generator and translator
50#     this should enable separate translation of each .pod
51#     and use of .INF concatenation to view the full docs together
52#     (with linking if index was used).
53#     IPF requires numerical references when concatenation is used, not symbolic :-(
54#   improved handling of windows (started to be done)
55#   ...
56#
57#  Changes:
58#
59#  10.2: parml used instead of ul if needed.
60#       Readability of .ipf improved.
61#       BI partially supported, F<> and C<> are distinct.
62#       Some options supported.
63#
64# 10.3: C<> works again.
65#       --head_off works (0 and 1).
66#
67# 10.4: Auto-beautifies some words, vars and functions, finds links
68#       --head_off works (0 and 1 and 2).
69#
70# 10.5: --section-name works
71#       Bugs with modules in subdirectories corrected.
72#       --about works.
73#       Better auto-crosslinking.
74#
75#       2-level indices. (Since we do not know until the second pass
76#       whether we put something into an index, there are some false
77#       positives.)
78#       Handles tabs (checked with Tk).
79#       Secondary names used for crosslinking.
80# 11:   Additional logic for links like C<-M>.
81#       Will process ../INSTALL and ../Porting/pumpkin.pod as well.
82#       Additional argument --bin-dir.
83#       Support for WWW links via lynx.
84#
85# Use of uninit value comes from findrefid for pod2ipf it it is not present.
86# 1.5:  Add back perltoc - have refs to it.
87#       :i[12] tags are shortened to avoid segfaults.
88# 1.6:  `pod2ipf myfile.pod' works again;
89#       --www added.
90#       <-processing could use substr with negative length for C<<=>.
91#       Index entries X<> handled (invisible).
92#       Will not produce links to "contents" pages from higher level
93#         contents pages (YES!).
94# 1.7:  Add implicit links for targets defined by C<>.
95#       Uplinks added.
96# 1.8:  Will not reference -8.
97#       out[12] removed, substituted by 'require 5.004'.
98
99# 1.9:  Better handling of 'Go up' (last item was going to the following
100#       section).
101
102# 1.10: Misprint...
103#       Supports L<foo|bar>
104#       Do not index/create refs for perltoc.
105#       Numeration of panes fixed to be not off-by-one.  (Minor bugs may be created for writing TOC sections and "Go up" links.)
106
107# 1.11: Remove (last piece?) of voodoo - in contents() - it did not work anyway
108#       Allow links to text containing L<> inside.
109
110# 1.12: Allow for --section-name with --file too;
111#       Wrap arguments in "About";
112#       --believe-pod-name implemented.
113#       --alias implemented.
114
115# 1.13: One more piece of voodoo for backrefs removed.
116
117# 1.14: @add_dir was misspelled
118
119# 1.15: Looking for leading whitespace was done with \s instead of [ \t].
120#  Does not help with "By Fermat's little theorem" in PARI tutorial.
121
122# 1.16: Add some more E<name> escapes
123
124#       $rcs = ' $Revision: 1.37 $ ' ;
125
126# $Log: pod2ipf.cmd,v $
127# Revision 1.37  2010/07/27 01:40:05  vera
128# No warnings (Perl or IPFC) when processing perl5.8.8 + OS2::default bundle.
129# Allow for :h6.
130# More debugging and error-logging, more consistent and more visible.
131# Allow for head3 after head1 without intervening head2.
132# Allow for blank heading titles.
133# Remove $' and friends.
134# Slightly smarter cutting off long headers (take into account expansion of : ).
135# Breaking long line could create lines starting with . .
136# Allow for duplicate section names (including path).
137# Now, when X<> contain non-alphanum stuff, more careful with autoexpansion
138#   in SEE ALSO.
139# Allow for non-terminated [CB...]< .
140# When cutting-off long expanded lines, remove parts of &colon. left by the cut.
141# Allow cut of for very long lines without whitespace.
142#
143# Revision 1.36  2006/12/25 21:35:11  vera
144# Take into account trailing X<> when truncating name of the section.
145# Do not double-interpret escapes in X<>: X<< IZ<><> >> lead to an empty
146# index entry.
147# Do not use panel numbers about 64000.
148#
149# Revision 1.35  2006/06/01 06:08:43  vera
150# Minor cosmetic changes.
151# Recognize as links things like C<function(foo)> if "function" is
152# marked as X<>-reference.
153#
154# Revision 1.34  2003/12/17 06:31:14  vera
155# Last uninitialized value warning removed.
156# Include os2/Changes.
157# Update perlos2.pod if needed.
158# Work better with layout of "inherited" directories.
159#
160# Revision 1.33  2003/05/25 08:34:59  vera
161# Tries harder to make links for function calls as Func();
162# works at least if X<Func> is defined somewhere.
163#
164# Revision 1.32  2001/05/26 08:06:31  vera
165# $Revision was mispelled, so not updated. [wrong case]
166#
167# Revision 1.31  2001/05/22 19:11:59  vera
168# Omited entries in perlfunc, perlvar restored; brush up the docs.
169#
170# Revision 1.30  2001/05/22 10:33:27  vera
171# Warnings 306 gone, but the content of perlfunc became much shorter.
172#
173# Revision 1.29  2001/05/22 10:06:42  vera
174# Add a pod2ipf ref from About; no need to add xsubpp; most "Strip conversion
175# warnings" are correct now.
176#
177# Revision 1.28  2001/05/22 08:57:19  vera
178# Find pod2ipf too; Avoid double "Go Up"; allow .pl, .plx
179# and no extension at all; do not leave NAME due only to
180# long description.
181#
182# Revision 1.27  2001/05/16 10:04:04  vera
183# Remove the undefined reference in $index_seen{$heading}; remove too
184# agressive case conversion in auto-linking foo(2), better report of
185# auto-linking Carp to carp.
186#
187# Revision 1.26  2001/05/16 09:15:24  vera
188# More aggressive recognition of longjmp(3) as of a crosslink; more
189# permissive recognition of links with different whitespacing, case
190# conversion, and tags.
191#
192# Revision 1.25  2001/05/15 21:37:12  vera
193# toc=12345 instead of 5; split long lines (Warning 206); debugging
194# output to catch undefined $index_seen{$heading}; link inside a link
195# was possible (warning 208); leading period was not completely removed
196# (warning 208).
197#
198# Warnings remaining:  Warning 306: Missing panel text in head level tag
199#                    Warning 117: Duplicate text in tag
200#                    Warning 121: Invalid head level [h4]       (?!)
201#                    Warning 110: No ID for this reference [4387]
202#
203# Revision 1.24  2001/05/15 07:30:53  vera
204# Better output of About section; auto-increment $VERSION; would output ::link.
205#
206# Revision 1.23  2001/05/15 07:12:43  vera
207# Instead of treating files with only the NAME section differently,
208# added processing of the empty last POD section in the file.
209#
210# Revision 1.22  2001/05/15 06:23:28  vera
211# xsubpp was added too aggressively; Better prefix for last resort
212# description; avoid an uninit warning; the URL was removed in
213# out($txt,1); no not skip NAME if nothing else is present;
214#
215# Revision 1.21  2001/05/15 04:25:42  vera
216# Add a flexible multi-browser support.
217#
218# Revision 1.20  2001/05/15 01:27:37  vera
219# Revision log added.
220#
221
222#revision 1.19   locked by: vera;
223#date: 2001/05/13 10:51:13;  author: vera;  state: Exp;  lines: +3 -2
224#Remove duplicate Pumpkin entry.
225#----------------------------
226#revision 1.18
227#date: 2001/05/13 06:01:58;  author: vera;  state: Exp;  lines: +3 -3
228#Better support for =begin/=end.
229#----------------------------
230#revision 1.17
231#date: 2001/05/13 05:59:09;  author: vera;  state: Exp;  lines: +17 -10
232#Added support for =begin, =end, =for (with no tags supported).
233#----------------------------
234#revision 1.16
235#date: 2001/05/13 05:30:21;  author: vera;  state: Exp;  lines: +69 -59
236#Works.  Courier size made tolerable on both 72 and 96 dpi.
237#Unresolved link C<< (?>pattern) >>...
238
239$font = ''; #':font facename=Helv size=16x8.';
240
241$debug = 0;
242$debug_xref = 0;
243$dump_xref = 0;
244$dump_contents = 0;
245$dump_manpages = 1;
246$maxtoc = '123456';
247$dots = 0;
248$multi_win = 1;     # 1 = use alternate window for toc
249@do_dirs = ();
250@do_file = ();
251@bin_dirs = ();
252$do_burst = 1;
253$do_about = 1;
254$do_bin = 1;
255$do_mods = 1;
256$do_std = 1;
257$head_off = 2;
258$do_tree = 1;
259$do_faqs = 1;
260$by_files = $by_dirs = 0;
261#$sort_files = 1;
262@add_dir = ();
263@add_files = ();
264my @args = @ARGV;
265my $foundrefs = 0;
266my %i1ids;
267my %index_seen;
268my %index_output;
269my $www = '%IPFWWW%||lynx||netscape';
270#my $to_C = ':font facename=Courier size=18x10.';
271#my $to_C = ':font facename=Courier size=14x8.';
272my $to_C = ':font facename=Courier size=11x6.'; # Tolerable on 72/96dpi.
273my $from_C = ':font facename=default size=0x0.'; # Documented: default size
274@make_bold = qw(EMX RSX WPS Object-REXX HPFS HTML WWW GNU Perl C
275                XFree86 OS/2 CRT PM DOS VIO CPAN IBM URL);
276@make_code = qw(VCPI DPMI groff awk gawk STDIN STDOUT STDERR Emacs EPM
277                CMD 4os2 sh pdksh zip unzip pkunzip man gcc link386 tr
278                PATH LIBPATH);
279my %in_INC;
280@in_INC{@INC} = @INC;
281
282sub by_dirs { by_files();   $by_files = 0;  $by_dirs = 1; }
283sub by_files {
284  $dump_manpages = 0;
285  $do_burst = 0;
286  $do_bin = 0;
287  $do_mods = 0;
288  $do_std = 0;
289#  $head_off = 0;
290  $do_tree = 0;
291  $do_faqs = 0;
292  $by_files = 1;
293  $by_dirs = 0;
294}
295
296%cat_descr = (
297              pod => 'Perl documentation',
298              faqs => 'Frequently asked questions',
299              bin => 'Perl utilities (with POD documentation)',
300              mods => 'Standard Perl modules',
301              add_mods => 'Additional Perl modules',
302              do_file => 'Additional modules',
303              do_dirs => 'Additional directories',
304              tree => 'Hierarchy of documented perl modules',
305              pragmas => 'Pragmata: change Perl\'s behaviour',
306             );
307
308sub add_dir {                   # If without args, just finish processing
309  my $name = $_[1];
310  print STDERR "Starting section `$name'.\n" if @_ and $debug;
311  if (@do_dirs) {
312    @add_dir = ($cat_descr{do_dirs},[],[]) unless @add_dir;
313    push @{$add_dir[-2]}, @do_dirs;
314    @do_dirs = ();
315  }
316  if (@do_file) {
317    @add_dir = ($cat_descr{do_file},[],[]) unless @add_dir;
318    push @{$add_dir[-1]}, @do_file;
319    @do_file = ();
320  }
321  push @add_dir, $name, [], [] if @_;
322  push @add_files, $name, [], [] if @_;
323}
324
325sub do_alias {
326  my $alias = $_[1];
327  warn("Ignoring alias $alias: no file name found"), return unless @do_file;
328  $alias{$do_file[-1]} = $alias;
329}
330
331if (@ARGV >= 1 and $ARGV[0] !~ /^-/) {
332    unshift @ARGV, '--by-files';
333    unshift @ARGV, '--head-off=0' if @ARGV == 2;
334}
335
336GetOptions(
337           "debug!" => \$debug,
338           "burst!" => \$do_burst, # Print Logo page
339           "about!" => \$do_about, # Print About page
340           "mods!" => \$do_mods, # Scan through @INC
341           "std!" => \$do_std,  # Scan through standard Perl PODs in ./
342           "bin!" => \$do_bin,  # Scan through $Config{bin}
343           "tree!" => \$do_tree, # Output tree
344           "faqs!" => \$do_faqs, # Output faqs
345           "file=s@" => \@do_file, # If present, do these files too
346           "dir=s@" => \@do_dirs, # Which addnl directories to scan
347           "dump_xref!" => \$dump_xref, # Dump them to STDERR
348           "dump-contents!" => \$dump_contents, # Dump it to STDERR
349           "dump-manpages!" => \$dump_manpages, # Dump unknown to STDERR
350           "title=s" => \$DocTitle,
351           "head-off=i" => \$head_off,
352           "to-bold=s@" => \@make_bold,
353           "to-code=s@" => \@make_code,
354           "by-files" => \&by_files,
355           "by-dirs" => \&by_dirs,
356           "www" => \$www,      # Browser
357           "to-C" => \$to_C,    # How to switch to CODE sections
358           "section-name=s" => \&add_dir,
359           "alias=s" => \&do_alias,
360           "bin-dir=s@" => \@bin_dirs, # If present, search for bins here too
361           "believe-pod-name!" => \$believe_pod_name, # Believe NAME section
362           #"sort-files!" => \$sort_files,
363          );
364if ($by_dirs) {
365  push @do_dirs, @ARGV;
366} elsif ($by_files) {
367  push @do_file, @ARGV;
368} else {
369  warn "Ignoring \@ARGV: `@ARGV'.\n" if @ARGV;
370}
371
372$DocTitle = "Perl $Config{version} Manual"
373  unless defined $DocTitle or @do_dirs or @do_file;
374my $unknownPod_prefix = $do_std ? undef : "File ";
375
376sub unknownPod {
377    my $ftitle = shift;
378    my $fname = $modnamehash{$ftitle};
379    my $pref = $unknownPod_prefix;
380    unless (defined $pref) {
381        $pref = "Perl module" if $fname =~ /\.pm$/;
382        $pref = "Perl script" if $fname =~ /\.(plx?|bat|cmd)$/;
383        $pref = "Perl script" if $fname =~ m,[\\/][^\\/.]*$,;
384        $pref = "Perl documentation file" if $fname =~ /\.pod$/;
385        $pref = "Perl component" unless defined $pref;
386    }
387    "$pref $ftitle";
388}
389
390my @www;
391
392$www =~ s/^\s+//;
393$www =~ s/\s+$//;
394if ($www =~ /\|\||\s|\@\@\@/) {
395  @www = map { /\@\@\@/ ? $_ : $_ . ' "@@@"' } split /\s*\|\|\s*/, $www;
396} elsif (! $www =~ /\./) {
397  $www .= '.exe'
398}
399
400add_dir();
401$do_about = 1 if $do_burst;
402
403$make_bold = join '|', @make_bold;
404$make_code = join '|', @make_code;
405
406$print_index = 1;               # Do not output index for tables of contents
407
408debug("Module pod/pm discovery");
409
410$curdir = cwd;
411my $site_perl_prefix;
412my $libdir;
413
414if ((substr $Config{sitelib}, 0, length $Config{privlib})
415    eq $Config{privlib}) {
416  $site_perl_prefix = substr $Config{sitelib}, (length $Config{privlib}) + 1;
417  $site_perl_prefix =~ s!\\!/!g ;
418}
419
420if (@do_file) {
421  foreach $file (@do_file) {
422    do_onefile($file);
423    # Fake File::Find
424#    $File::Find::name = $_ = $file;
425#    $libdir = ".";
426#    intern_modnamehash();
427  }
428}
429%do_file_hash = %modnamehash;
430%old_hash = %modnamehash;
431
432sub do_onefile {
433  # Fake File::Find
434  local $_ = shift;
435  $libdir = shift;
436  my $odir;
437  if (defined $libdir)  {
438    $File::Find::name = "./$_";
439    $odir = cwd();
440    chdir $libdir or warn "!!! Failed chdir($libdir): $!";
441  } else {
442    $File::Find::name = $_;
443    $libdir = '.';
444  }
445  intern_modnamehash();
446  chdir $odir if defined $odir;
447}
448
449{
450  no strict 'refs';
451  foreach (1 .. @add_dir/3) {
452    foreach $libdir (@{$add_dir[3*$_-2]}) {
453      do_libdir $libdir;
454    }
455    foreach $file (@{$add_dir[3*$_-1]}) {
456      do_onefile($file);
457    }
458    print STDERR "Doing section `$_' named `$add_dir[3*$_-3]': dirs `@{$add_dir[3*$_-2]}', files `@{$add_dir[3*$_-1]}'.\n" if $debug;
459    %{"do_dirs$_\_hash"} = hash_diff(\%old_hash, \%modnamehash);
460    $cat_descr{"do_dirs$_"} = $add_dir[3*$_-3];
461    %old_hash = %modnamehash;
462  }
463}
464
465if ($do_mods or $do_faqs) {
466  foreach $libdir ( @INC ) {
467    do_libdir $libdir;
468  }
469  %mods_hash = hash_diff(\%old_hash, \%modnamehash);
470  %old_hash = %modnamehash;
471
472  my $regex = quotemeta $Config{sitelib};
473  foreach $key (keys %mods_hash) {
474    next unless $modnamehash{$key} =~ /^$regex/o;
475    $add_mods_hash{$key} = delete $mods_hash{$key};
476  }
477}
478
479foreach $libdir ( $do_bin ? ($Config{bin}, @bin_dirs) : () ) {
480  do_libdir $libdir;
481}
482unless (@args) {
483  # my @xsubpp = grep -f "$_/xsubpp", map "$_/ExtUtils", @INC;
484  # do_onefile('xsubpp', $xsubpp[0]) if @xsubpp;
485  my ($dir,$file) = ($0 =~ m,^(.*)[\\/](.*),);
486  do_onefile($file, $dir);
487}
488
489%bin_hash = hash_diff(\%old_hash, \%modnamehash);
490
491@modnames = sort keys %modnamehash;
492
493print STDERR "\nFound `@modnames'.\n";
494
495# %modnamehash now maps module name -> file name.
496# %moddesc now maps module name -> description.
497
498@files = ();
499
500if ($do_std and -f 'perl.pod') {
501  open MPOD, 'perl.pod';
502  @files = ();
503  while (<MPOD>) {
504    last if /sections/;
505  }
506  while (<MPOD>) {
507    last if /^[^\s=]/;
508    push @files, [$1, $2]
509      if /^\s+(\S*)\s+(.*)/ and $1 ne 'perltoc' and $1 !~ /^perlfaq/;
510  }
511  close MPOD;
512  open MPOD, 'perltoc.pod';
513  while (<MPOD>) {
514    last if /^=head1\s+pragma/i;
515  }
516  while (<MPOD>) {
517    last if /^=head1/;
518    push @pragmas, $1 if /^=head2\s+(?:L<)?(\S*?)>?\s+-\s/;
519  }
520  close MPOD;
521  foreach $key (@pragmas) {
522    $pragmas_hash{$key} = delete $mods_hash{$key};
523  }
524  @files = grep $_->[0] ne 'perlos2', @files;
525  splice @files, 1, 0,
526     [ 'perlos2',      'Perl under OS/2' ],
527     [ 'perlos2delta', 'Log of changes to OS/2 port of Perl' ],
528     [ 'perltoc',      'Internal table of contents for Perl' ];
529  push @files, [ 'perlinstall',  'Installation/compilation of Perl'];
530  push @files, ['Pumpkin', 'Notes on handling the Perl Patch Pumpkin']
531    unless $] >= 5.006;         # Included between modules
532  if (-f '../INSTALL' and not -f 'perlinstall.pod') {
533      copy '../INSTALL', 'perlinstall.pod';
534  }
535  if (-f '../Porting/pumpkin.pod' and not -f 'Pumpkin.pod') {
536      copy '../Porting/pumpkin.pod', 'Pumpkin.pod';
537  }
538  if (-f '../README.os2'
539      and ( not -f 'perlos2.pod' or (-M '../README.os2') < -M 'perlos2.pod' )) {
540      chmod 0666, 'perlos2.pod';
541      unlink 'perlos2.pod';
542      copy '../README.os2', 'perlos2.pod';
543      chmod 0444, 'perlos2.pod';
544  }
545  if (-f '../os2/Changes' and
546      (not -f 'perlos2delta.pod' or (-M '../os2/Changes') < -M 'perlos2delta.pod')) {
547     open my $in, '<', '../os2/Changes' or die;
548     chmod 0666, 'perlos2delta.pod';
549     open my $out, '>', 'perlos2delta.pod' or die;
550     print $out <<EOP;
551\=head1 NAME
552
553perlos2delta - a POD copy of \$builddir/os2/Changes.
554
555\=head1 DESCRIPTION
556
557EOP
558     local $_;
559     while (<$in>) {
560        s/^(?=\S)/ /;
561        print $out $_;
562     }
563     chmod 0444, 'perlos2delta.pod';
564  }
565  for $file (@files) {
566    push @pods, $file->[0];
567    $pod_hash{$file->[0]}++;
568    $moddesc{$file->[0]} = $file->[1];
569  }
570}
571
572if ($do_faqs and -f 'perlfaq.pod') {
573  opendir DOT, '.';
574  while (defined($file = readdir DOT)) {
575    next unless $file =~ /(perlfaq.*)[.]pod/i;
576    push @faqsfiles, $1;
577  }
578  closedir DOT;
579  # push @faqsfiles, [$1, $2] if /^\s+(\S*)\s+(.*)/ and $1 =~ /^perlfaq/;
580
581  for $file (@faqsfiles) {
582    #$faqs_hash{$file}++;
583    print STDERR "Doing faq `$file'\n";
584
585    $faqs_hash{$file} = delete $mods_hash{"Pod::$file"} ||
586      delete $mods_hash{"pod::$file"} || delete $mods_hash{$file};
587    delete $mods_hash{"pod::$file"};
588    delete $mods_hash{"$file"};
589    delete $mods_hash{"Pod::$file"};
590    delete $modnamehash{"pod::$file"};
591    delete $modnamehash{"$file"};
592    delete $modnamehash{"Pod::$file"};
593    # $moddesc{$file->[0]} = $file->[1];
594    $add_info{$file} = $1 if $moddesc{$file} =~ s/(\(\$.*\$\))//; # RCS
595  }
596  unless ($do_mods) {
597    %mods_hash = %add_mods_hash = ();
598  }
599}
600
601#if ($do_tree) {
602#  create_tree([keys %modnamehash]);
603#}
604
605my @std_categories = (qw(pod pragmas mods add_mods bin faqs do_dirs),
606                      (map "do_dirs$_", 1 .. @add_dir/3),
607                      qw(do_file tree));
608print STDERR "Categories: `@std_categories'.\n" if $debug;
609
610$tree_hash{'::emit_tree'}++ if $do_tree;
611
612{
613  no strict 'refs';
614  for $cat (@std_categories) {
615    $categories{$cat} = \%{$cat . "_hash"} if %{$cat . "_hash"};
616  }
617}
618
619for $pod (@files) {
620  $doing_pod{$pod->[0] . ".pod"}++;
621}
622
623for $pod (qw(perlovl.pod)) {
624  $obsolete{$pod}++;
625}
626
627for $pod (<*.pod>) {
628  $not_doing_pod{$pod}++
629    unless $doing_pod{$pod} or $obsolete{$pod} or $pod =~ /perlfaq/;
630}
631
632for $pod (keys %not_doing_pod) {
633  print STDERR "\n!!! Unknown POD: `$pod'\n" if $do_std;
634}
635
636for $name (sort {lc $a cmp lc $b or $a cmp $b} keys %modnamehash) {
637  push @files, [$name, ($moddesc{$name} || unknownPod $name)]
638}
639
640
641# in these sections an =item will be treated as an =head[n]
642# this is necessary because .IPF/.INF format/compiler have
643# some limitations for pane size and linking. :-(
644
645@split_sections =
646    (
647     'perlfunc/DESCRIPTION/Alphabetical Listing of Perl Functions',
648     'perldiag/DESCRIPTION',
649     'perlvar/DESCRIPTION/Predefined Names',
650    );
651
652@index_sections =               # Put first words in =item into index there
653    (
654     'perlfunc/DESCRIPTION/Alphabetical Listing of Perl Functions',
655     'perlvar/DESCRIPTION/Predefined Names',
656    );
657
658$section_head[0] = '';          # To simplify warnings
659$section_head[1] = '';          # To simplify warnings
660
661%groups = (
662           links => 1,
663           text => 2,
664           logo => 3,
665           camel => 4,
666           l_camel => 5,
667           r_camel => 6,
668           sublinks => 7,
669           about => 8,
670           tree_nodes => 9,
671          );
672
673%panelwidths = (                # Make a gap.
674                links => '29%',
675                text => '69%',
676                sublinks => '28%',
677               );
678
679# Pickup modules which are not plain words, so it is safer to
680# auto-crosslink them (with :: or _, or with mixed capitalization, or
681# without vowels with at least 3 letters - avoid B and Tk):
682@auto_link = grep /::|_|[a-z][A-Z]|^[^aAeEoOyYiIuU]{3,}$/, keys %alternative_name;
683@auto_link{@auto_link} = (1) x @auto_link;
684
685
686# This is the rest without vowels, will be highlighted only in obvious places:
687@auto_link_hard = grep !/::|_|[a-z][A-Z]|^[^aAeEoOyYiIuU]+$/, keys %alternative_name;
688@auto_link_hard{@auto_link_hard} = (1) x @auto_link_hard;
689
690$debug and print STDERR "\n=== Alternative names:\n";
691$debug and print STDERR "    ``$_''\n" for sort keys %alternative_name;
692
693sub out;
694sub contents;
695sub escape;
696sub add_ref;
697sub findref;
698sub winhead;
699sub winlink;
700sub no_markup_len;
701sub insert_nl;
702
703$/ = "";
704
705foreach $sc (@split_sections) { $as_head{$sc} = 1; }
706
707foreach $sc (@index_sections) { $fine_index{$sc} = 1; }
708
709if (not defined $DocTitle) {
710  $DocTitle = @files >= 2 ? "Manual" : $files[0][0];
711  $DocTitle = escape($DocTitle);
712}
713
714$in_item_header = 0;
715
716# Smaller values used for some absolute ids in inline IPF
717my $first_node = 30;
718
719for ($pass = 1; $pass <= 2; $pass++) {
720    if ($pass == 2) {
721      $auto_link_hard = join '|', map quotemeta, keys %auto_link_hard;
722      $auto_link = join '|',      map quotemeta, keys %auto_link;
723      $auto_link_both = join '|', map quotemeta, keys %auto_link, keys %auto_link_hard;
724      print STDERR "\nautolink: $auto_link\nautolink_hard: $auto_link_hard\n"
725        if $debug;
726    }
727    $headno_2nd = $headno;      # Used for out-of-order stuff
728    $headno = $first_node; # make refs hash for this on first pass
729
730    print STDERR "pass: $pass\n";
731      print <<EOI if $pass == 2;
732:userdoc.
733:title.$DocTitle
734EOI
735
736    # Insert the Logo page.
737
738    if ($pass == 2 and $do_burst) {
739      # We position burst window low, so it does not obsure Contents and/or
740      # titles of information windows, and Contents does not obsure us
741      # (completely).
742      print <<EOI;
743:h1 group=$groups{logo} x=7% width=87% y=1% height=90% id=11 scroll=none.Logo
744:i1.Logo
745:link reftype=hd refid=12 auto split group=$groups{l_camel}
746       vpx=left vpy=center vpcx=25c vpcy=12c
747       scroll=none titlebar=none rules=none.
748:link reftype=hd refid=13 auto split group=$groups{r_camel}
749       vpx=right vpy=center vpcx=25c vpcy=12c
750       scroll=none titlebar=none rules=none.
751:link reftype=hd refid=14 auto split group=$groups{camel}
752       vpx=center vpy=center vpcx=312x vpcy=390p
753       scroll=none titlebar=none rules=none.
754:h2 hide noprint nosearch id=12.Dummy
755:lines.
756:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perl')]}.Enter here!:elink.
757
758:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlos2')]}.Perl and OS/2:elink.
759
760:link reftype=hd group=$groups{text} dependent vpx=right vpcx=$panelwidths{text} refid=@{[findrefid('CPAN')]}.Where to get ...:elink.
761
762:link reftype=hd group=$groups{text} dependent vpx=right vpcx=$panelwidths{text} refid=@{[findrefid('ExtUtils::MakeMaker/Default Makefile Behaviour')]}.After you got it:elink.
763
764:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perltrap')]}.This should work!:elink.
765
766:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perldebug')]}.But it does not!:elink.
767:elines.
768:h2 hide noprint nosearch id=13.Dummy
769:lines align=right.
770:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlbook')]}.The fine book:elink.
771
772:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlmod')]}.Perl extensions:elink.
773
774:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlxs')]}.C extensions:elink.
775
776:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlguts')]}.Inside Camel:elink.
777
778:link reftype=hd group=$groups{links} dependent vpx=left vpcx=$panelwidths{links} refid=@{[findrefid('perlstyle')]}.Ugly code:elink.
779
780:link reftype=hd group=$groups{about} dependent refid=29.About:elink.
781:elines.
782:h2 hide noprint nosearch id=14.Dummy
783:artwork align=center name='CamelGrayBig.BMP'.
784Do 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).
785:font facename=Courier size=7x5. The use of a camel image in conjunction with Perl is a trademark of
786O'Reilly &amp. Associates, Inc.:font facename=default size=0x0.
787
788EOI
789    }
790    if ($pass == 2 and $do_about) {
791      print <<EOI;
792:h1 toc=1 group=$groups{about} x=center width=100% y=center height=20% id=29.About
793EOI
794      print out(<<EOI, 1);
795Generated on @{[scalar localtime]}, by L<perl> version $],
796L<pod2ipf> version $VERSION @{[format_args]} in directory F<@{[cwd]}>.
797EOI
798    }
799    if ($head_off <= 1 or (keys %categories) <= 1) {
800      if ($head_off > 1) {
801        $headno_2nd++;
802        print <<EOP if $pass == 2;
803:h1 toc=$maxtoc group=$groups{links} x=left width=$panelwidths{links} id=$headno_2nd.$DocTitle
804$DocTitle.
805
806EOP
807      }
808      for ($fn = 0; $fn <= $#files; $fn++) {
809        output_file($files[$fn][0]);
810      }
811    } else {
812      # Separate into categories:
813      my @titles;
814      for $cat (@std_categories) {
815        next unless $categories{$cat};
816        insert_back($headno) if $pass == 2;;
817        category_emit($cat) if $pass == 2;
818        @titles = sort {lc $a cmp lc $b or $a cmp $b}
819                keys %{$categories{$cat}};
820        @titles = @pods if $cat eq 'pod'; # Preserve the sorting order
821        for $title (@titles) {
822          if ($title eq '::emit_tree') {
823            output_tree(create_tree([keys %modnamehash]), '', 2) if $pass == 2;
824          } else {
825            output_file($title);
826          }
827        }
828      }
829    }
830}
831
832print "\n:euserdoc.\n";
833
834if ($dump_xref) {
835    foreach (keys %links) {
836        print STDERR $_ . "->" . $links{$_} . "\n";
837    }
838}
839if ($dump_contents) {
840    for($i = 0; $i <= $#head; $i++) {
841        print STDERR "    " x $headlevel[$i], $head[$i], "\n";
842    }
843}
844if ($dump_manpages) {
845  my @arr = sort keys %unknown_manpages;
846  print STDERR "Unknown manpages: @arr.\n";
847}
848print STDERR "Found $foundrefs crosslinks.\n";
849
850sub category_emit {
851  my $cat = shift;
852  $headno_2nd++;
853  print <<EOP;
854:h1 toc=$maxtoc group=$groups{links} x=left width=$panelwidths{links} id=$headno_2nd.$cat_descr{$cat}
855$cat_descr{$cat}.
856
857EOP
858}
859
860sub process_index {
861  unless ($print_index) {
862    @index = ();
863    return;
864  }
865  my %seen;
866  for (@index) {
867    $seen{$_}++;
868  }
869  print "\n" if @index;
870  for (keys %seen) {
871    print ":i1." . out($_, 0) . "\n";
872  }
873  @index = ();
874}
875
876my $last_hl = 123;              # Very big
877sub output_preheader ($) {      # Fix head3 coming after head2; wrong for IPF
878  my $level = shift;            # Warning 121 ==> Warning 110
879  print STDERR "     Jump in level: was $last_hl, now $level.\n"
880    if $level > $last_hl + 1;
881  while ($level > $last_hl + 1) {
882    $last_hl++;                 # Same as tree nodes:
883    print ":h$last_hl group=$groups{tree_nodes} x=left width=10% y=top height=10%.---fake-fix-level-node---\n:p.\n------------ Intentionally blank (missing level in the source POD) -----------\n"
884  }
885  $last_hl = $level;
886}
887
888sub non_empty ($) {
889  my $p = shift;
890  (length $p) ? $p : '=' x 40;
891}
892
893sub output_file {
894  my $ftitle = shift;
895  #warn "<<<doing file for `$ftitle'\n";
896  my $fcomment = $moddesc{$ftitle} || unknownPod $ftitle;
897  my $begin_depth = 0;
898
899  $fname = $ftitle . '.pod';
900  if (not -f "./$fname") {      # Protect 'B::C.pod' from accessing B drive
901    $fname = $modnamehash{$ftitle};
902  }
903  $page = $ftitle;
904  $toc = substr $maxtoc, -1, 1;
905  @index = ();
906
907  open(IN, $fname) || die "$ftitle: open `$fname': $!";
908  print STDERR $fname . ": ";
909  print STDERR "\n" if !$dots;
910
911  $section = $ftitle . ' - ' . $fcomment;
912  $section_head[1] = $page;
913  $path = $section_head[1];
914  $headno++;
915  #warn "<<<incremented headno to $headno, page='$page', washead='$heading' out='$section'\n";
916  if ($pass == 1) {
917    addsection($section, $headno, 1);
918    add_ref($page, $headno);
919    $is_head{$ftitle}++;
920  }
921  if ($pass == 2) {
922    insert_nl;
923    my $hlevel = $head_off >= 1 ? $head_off : 1;
924    # Done with $processing_endfile now:
925    output_preheader($hlevel);
926    print ":h$hlevel toc=$maxtoc " . winhead($headno)
927      . " id=$headno."
928        # See DBD::CVS: empty =head; Warning 113: No text found in tag [h3]
929        . non_empty(out($section, 0))
930          . "\n" . $font; # Headers take no fonts.
931    output_index($section, $ftitle);
932    output_index($ftitle, $ftitle);
933    if (exists $add_info{$ftitle}) {
934      print out($add_info{$ftitle}, 0), ":p.\n"
935    }
936    $was_nl = 1;
937  } else {
938    count_index($section);
939    count_index($ftitle);
940  }
941
942  @lstack = ();
943  # These variables are different when =item is treated as =head
944  $emptypane = $emptysection = 1; # Always: TOC for the file
945  $inpod = 0;
946  my $processing_endfile;
947
948 PARA: while (defined ($line = <IN>) or ++$processing_endfile) {
949    chomp $line unless $processing_endfile;
950    if ($processing_endfile or $line =~ /^=\w+((?s:.*))/) {
951      if ($processing_endfile or $line =~ /^=head(\d+)\b\s*((?s:.*))/) {
952        $inpod = 1;
953        $nopara = 0;
954        $heading = $+;
955        unless ($processing_endfile) {
956          $heading =~ s/\s*$//; # localize $1
957          $heading = untabify $heading;
958        }
959
960        if (@lstack) {
961          print STDERR "     List not finished (@lstack) in (@section_head[1..$hl]).\n"
962            if $pass == 1;
963          while ($#lstack >= 0) {
964            $t = pop(@lstack);
965            if ($t eq 'ul') {
966              print ":eul.\n" if $pass == 2;
967              $was_nl = 1;
968            } elsif ($t eq 'ol') {
969              print ":eol.\n" if $pass == 2;
970              $was_nl = 1;
971            } elsif ($t eq 'parml') {
972              print ":eparml.\n" if $pass == 2;
973              $was_nl = 1;
974            } elsif ($t eq 'head' or $t eq 'finehead') {
975              $hl--;
976              $path = join('/', @section_head[1..$hl]);
977            }
978          }
979        }
980
981        unless ($processing_endfile) {
982          $hl = $1 + 1;
983          $section_head[$hl] = $heading;
984          $path = join('/', @section_head[1..$hl]);
985          $sh_path = join('/', @section_head[1..$hl-1]);
986          if ($skip_sections{$path}) {
987            $inpod = 0;
988            next PARA;
989          }
990        }
991        # Finish the previous sections:
992        contents($headno) if $emptypane;
993        insert_back($headno);   # Previous header
994        last PARA if $processing_endfile;
995
996        $headno++;
997        if ($pass == 1) {
998          addsection($heading, $headno, $hl);
999          # XXXX Is wrong with some escapes:
1000          #1 while $heading =~ s/[A-Z]<.*?>/$1/g;
1001          add_ref(qq|$page/"$heading"|, $headno);
1002          $is_head{$heading}++;
1003        }
1004        if ($pass == 2) {
1005          insert_nl;
1006          output_preheader($hl + $head_off - 1);
1007          print ":h$last_hl " . winhead($headno)
1008            . " id=$headno."
1009              # See DBD::CVS: empty =head; Warning 113: No text found in tag [h3]
1010              . non_empty(out($heading, 0)) . "\n" . $font; # Headers take no fonts
1011          output_index($heading, $path);
1012        } else {
1013          count_index($heading);
1014        }
1015        print STDERR "." if $dots;
1016        $emptypane = $emptysection = 1;
1017      } elsif ($line =~ /^=over\b\s*((?s:.*))/) {
1018        $inpod = 1;
1019        $step = 5;              # Default
1020        $step = $1 if $1 =~ /(\d+)/;
1021        $step = int($step * 4/3 + 0.5); # Take into account proportional font
1022        # look ahead, to see how the list should look like
1023        if ($pass == 1 and $inpod and $begin_depth == 0) {
1024          $auto_link_hard{$1}++,
1025            $x_index{$1} = $headno
1026              while $line =~ /X<([^<>]+)>/g;
1027        }
1028        chomp($line = <IN>);
1029        if ($pass == 1) {
1030          $auto_link_hard{$1}++ while $line =~ /X<([^<>]+)+>/g;
1031        }
1032        if ($line =~ /^\=item(\s*$|\s+\*)/) { # item * (or empty)
1033          push(@lstack, "ul");
1034          insert_nl if $pass == 2;
1035          print ":ul.\n" if $pass == 2;
1036          $was_nl = 1;
1037        } elsif ($line =~ /^\=item\s+1\.?/) { # item 1.
1038          push(@lstack, "ol");
1039          insert_nl if $pass == 2;
1040          print ":ol.\n" if $pass == 2;
1041          $was_nl = 1;
1042        } elsif (defined($as_head{$path})) {
1043          # in some cases we use headings instead of lists
1044          warn "toc for $page, id=$headno too low" if ! $toc >= $hl + 1;
1045          push(@lstack, $fine_index{$path} ? "finehead" : "head");
1046          $hl++;
1047          $section_head[$hl] = 'list_start';
1048          @eitems = ();
1049        } else {
1050          push(@lstack, "parml");
1051          insert_nl if $pass == 2;
1052          print ":parml break=fit tsize=$step.\n" if $pass == 2;
1053          $was_nl = 1;
1054        }
1055        $nopara = 0;
1056        redo PARA;
1057      } elsif ($line =~ /^=back\b/) {
1058        $inpod = 1;
1059        if ($#lstack >= 0) {
1060          $t = pop(@lstack);
1061          if ($t eq 'ul') {
1062            insert_nl if $pass == 2;
1063            print ":eul.\n" if $pass == 2;
1064            $was_nl = 1;
1065          } elsif ($t eq 'ol') {
1066            insert_nl if $pass == 2;
1067            print ":eol.\n" if $pass == 2;
1068            $was_nl = 1;
1069          } elsif ($t eq 'parml') {
1070            insert_nl if $pass == 2;
1071            print ":eparml.\n" if $pass == 2;
1072            $was_nl = 1;
1073          } elsif ($t eq 'head' or $t eq 'finehead') {
1074            $hl--;
1075            $path = join('/', @section_head[1..$hl]);
1076          }
1077        } else {
1078          print STDERR "     stack empty on page=$page, id=$headno";
1079          $hl--;
1080        }
1081        $nopara = 0;
1082      } elsif ($line =~ /^=item\b\s*((?s:.*))/) {
1083        $inpod = 1;
1084        $nopara = 0;
1085        $heading = $1;
1086        $heading =~ s/\s+$//;
1087        $heading = untabify($heading);
1088        $heading =~ s/^\*\s*//; # Too late to process \* anyway
1089        #warn "<<<set head='$heading'\n";
1090        $headx = $heading;
1091        # Unescape
1092        $headx =~ s/E<(.*?)>/$HTML_Escapes{$1} or "E<$1>"/ge;
1093        1 while $headx =~ s/[A-Z]<(.*?)>/$1/g;
1094        print STDERR "." if $dots;
1095        if ($#lstack == -1) {
1096          push(@lstack, "parml");
1097          insert_nl if $pass == 2;
1098          print ":parml break=fit tsize=7.\n" if $pass == 2;
1099          $was_nl = 1;
1100          print STDERR "     An =item without =over in (@section_head[1..$hl])\n"
1101        }
1102        if ($lstack[$#lstack] eq 'head'
1103            or $lstack[$#lstack] eq 'finehead') {
1104          contents($headno - 1) if $emptypane and not @eitems;
1105          insert_back($headno - 1)
1106            unless $emptysection or @eitems; # Previous uplink
1107
1108          # lowest level never empty, IPFC uses next page
1109          # by default (but Back button doesn't work :-()
1110          #
1111          # However, we treat it specially anyway
1112          $emptypane = 0;
1113          $emptysection = 1;
1114
1115          my ($word1, $word2);
1116          $headx =~ /(\^?\w+)/; # $^A
1117          $word1 = $1;
1118          $headx =~ /(\S+)/;
1119          $word2 = $1;
1120          $section_head[$hl] = $heading;
1121          $path = join('/', @section_head[1..$hl]);
1122          $sh_path = join('/', @section_head[1..$hl-1]);
1123          insert_nl if $pass == 2;
1124          $headno++;
1125          #warn "<<<incremented headno to $headno, page='$page', head='$heading'\n";
1126          if ($pass == 1) {
1127            addsection($heading, $headno, $hl);
1128            add_ref(qq|$page/"$headx"|, $headno);
1129            add_ref(qq|$page/"$word1"|, $headno) if defined $word1;
1130            add_ref(qq|$page/"$word2"|, $headno) if defined $word2;
1131          }
1132          if ($pass == 2 and not @eitems) {
1133            output_preheader($hl + $head_off - 1);
1134            # See DBD::CVS: empty =head; Warning 113: No text found in tag [h3]
1135            print ":h$last_hl " . winhead($headno) . " id=$headno."
1136                . non_empty(out($heading, 0)) . "\n" . $font;
1137          }                             # Headers take no fonts
1138          output_index($heading, $path);
1139          $was_nl = 1;
1140          if ($#lstack >= 0
1141              and $lstack[$#lstack] eq 'finehead') {
1142            output_index($word1, $path)
1143              if defined $word1 and $word1 ne $heading;
1144            output_index($word2, $path)
1145              if defined $word2 and $word2 ne $heading
1146                and $word2 ne $word1;
1147          }
1148          $is_head{$heading}++ if $pass == 1; # XXXX Need to strip?
1149
1150          if ($pass == 1 and $inpod and $begin_depth == 0) {
1151            $auto_link_hard{$1}++,
1152              $x_index{$1} = $headno
1153                while $line =~ /X<([^<>]+)>/g;
1154          }
1155
1156          # look ahead to see if this =item is empty.
1157          # if it is, create a list of the items
1158          # on first non-empty pane.
1159          chomp($line = <IN>);
1160          if ($line =~ /^=item\b/) {
1161            push @eitems, $heading;
1162            $headno--;
1163          } elsif (@eitems) {
1164            push @eitems, $heading;
1165            if ($pass == 1) {
1166              $hl_eitems{$headno} = [@eitems];
1167            } else {
1168              foreach $l (@eitems) {
1169                print ":p.:hp2." . out($l, 1) . ":ehp2.";
1170              }
1171            }
1172            @eitems = ();
1173          }
1174          if ($pass == 1) {
1175            $auto_link_hard{$1}++ while /X<([^<>]+)+>/g;
1176          }
1177          redo PARA;
1178        } else {                # Different list's items
1179          local $in_item_header = 1;
1180          $emptypane = $emptysection = 0;
1181          add_ref(qq|$page/"$headx"|, $headno, 1);
1182          if ($lstack[$#lstack] eq 'ul' && $heading =~ /^\s*\*\s*(.*)$/ or
1183              $lstack[$#lstack] eq 'ol' && $heading =~ /^\s*\d+\.?\s*(.*)$/) {           # Bulleted or numbered item matching list type.
1184            print ":li." if $pass == 2;
1185            $heading = $1;
1186            #warn "<<<set head='$heading'\n";
1187            if ($1 ne "") {
1188              print out($heading, 1) . "\n" if $pass == 2;
1189              output_index($heading, $path)
1190                unless $is_head{$heading};
1191              $was_nl = 1;
1192            } else {
1193              $nopara = 1;
1194              $was_nl = 0;
1195            }
1196          } elsif ($lstack[$#lstack] eq 'parml') {
1197            print ":pt." if $pass == 2;
1198            $heading =~ s/^\s*\*?\s+//;
1199            $heading =~ s/\s+$//;
1200            $heading = '*' if $heading eq '';
1201            #warn "<<<set head='$heading'\n";
1202            print out($heading, 1) . "\n" if $pass == 2;
1203            output_index($heading, $path)
1204              unless $is_head{$heading} or $heading eq '*' or $heading eq '';
1205            print ":pd." if $pass == 2;
1206            $nopara = 1;
1207            $was_nl = 0;
1208          } else {
1209            print ":li." . out($heading, 1) . "\n" if $pass == 2;
1210            output_index($heading, $path)
1211              unless $heading eq '' or $heading eq '*' or $is_head{$heading};
1212            $was_nl = 1;
1213            $nopara = 1;
1214          }
1215        }
1216      } elsif ($line =~ /^=cut/) {
1217        $inpod = 0;
1218      } elsif ($line =~ /^=pod/) {
1219        $inpod = 1;
1220      } elsif ($line =~ /^=for\b/) { # Ignore
1221      } elsif ($line =~ /^=begin\b/) {
1222        $begin_depth++;
1223      } elsif ($line =~ /^=end\b/) {
1224        $begin_depth--;
1225      } else {
1226        warn "what to do with '$line'?\n";
1227      }
1228    } elsif ($inpod == 0 or $begin_depth) {
1229      # Just ignore this chunk
1230    } elsif ($line =~ /^[ \t]+\S/) {
1231      if ($pass == 2) {
1232        $pre = untabify($line);
1233        insert_nl;
1234        # A long code line with : expanded to &colon.
1235        1 while $pre =~ s/^((?:\:|(?>[^\n:]{1,7})){33})(?=[^\n])/$1\n/gm; # Warning 206
1236        $pre =~ s/^\./&per./mg; # period.  Warning 204
1237        print ":xmp.$to_C\n" . escape_with_url($pre)
1238          . "\n:exmp.$from_C\n";
1239        $was_nl = 1;
1240      }
1241      $nopara = 0;
1242      $emptypane = $emptysection = 0;
1243    } elsif ($line =~ /^[ \t]+\S/m) { # see perl(run)?/SYNOPSIS for this
1244      if ($pass == 2) {
1245        $mark = out($line, 1);
1246
1247        # hack hack ;-)
1248        # IPFC doesn't handle tabs
1249        # no_markup_len tries to guess the # of ' ' to next tab,
1250        # but even when the guess is correct, things don't seem
1251        # to align when bold,.. is used :-(
1252        $pre = untabify_after($mark);
1253
1254        insert_nl;
1255        # Do not split inside &something.
1256        1 while $pre =~ s/^(.{240}(?=.{13}))[^\n&]{0,12}(?=[^\n])/$1\n/gm; # Warning 206
1257        $pre =~ s/^\./&per./mg; # period.  Warning 204
1258        print ":xmp.$to_C\n" . $pre . "\n:exmp.$from_C\n";
1259        $was_nl = 1;
1260      }
1261      $nopara = 0;
1262      $emptypane = $emptysection = 0;
1263    } else {
1264      if ($pass == 2) {
1265        print ":p.\n" unless $nopara;
1266        print out(untabify($line), 1);
1267        process_index();
1268        $was_nl = 0;
1269      } else {
1270        if ($line =~ /^\s+$/) {
1271          warn "line with blanks in $page, id=$headno\n";
1272        }
1273      }
1274      $nopara = 0;
1275      $emptypane = $emptysection = 0;
1276    }
1277    if ($pass == 1 and $inpod and $begin_depth == 0) {
1278      $auto_link_hard{$1}++,
1279        $x_index{$1} = $headno
1280          while $line =~ /X<([^<>]+)>/g;
1281    }
1282  }
1283  close(IN);
1284  print STDERR "\n" if $dots;
1285}
1286
1287sub output_tree {
1288  my ($tree, $prefix, $level) = @_;
1289  my ($node, $mod);
1290  foreach $node (sort keys %$tree) {
1291    $headno_2nd++;
1292    if ($prefix eq '') {
1293      $mod = substr $node, 2;
1294    } else {
1295      $mod = "$prefix$node";
1296    }
1297    if (ref $tree->{$node}) {   # Subtree
1298      print <<EOP;
1299:h$level group=$groups{tree_nodes} x=left width=10% y=top height=10% id=$headno_2nd.@{[escape $mod]}...
1300
1301EOP
1302      output_tree($tree->{$node}, $mod, $level + 1);
1303    } else {
1304      print <<EOP;
1305:h$level group=$groups{tree_nodes} x=left width=10% y=top height=10% id=$headno_2nd.@{[escape $mod]}
1306:link reftype=hd group=$groups{links} auto vpx=left vpcx=$panelwidths{links} refid=@{[findrefid($mod)]}.
1307@{[escape $mod]}
1308
1309EOP
1310    }
1311  }
1312}
1313
1314sub untabify {
1315  my @tlines = split(/\n/, shift);
1316  my $tline;
1317  foreach $tline (@tlines) {
1318    1 while $tline =~ s/^(.*?)(\t+)/$1.(' 'x (length($2) * 8 - length($1) % 8))/e;
1319  }
1320  join("\n", @tlines);
1321}
1322
1323sub untabify_after {            # Some markup is already there.
1324  my @tlines = split(/\n/, shift);
1325  my $tline;
1326  foreach $tline (@tlines) {
1327    1 while $tline =~ s/^(.*?)(\t+)/$1.(' 'x (length($2) * 8 - &no_markup_len($1) % 8))/e;
1328  }
1329  join("\n", @tlines);
1330}
1331
1332{
1333  my ($id_c, %path_c) = (0);
1334  sub i1id {
1335    return $i1ids{$_[0]} if exists $i1ids{$_[0]};
1336    $i1ids{$_[0]} = "id_" . ++$id_c;
1337  }
1338  sub path_c ($) {
1339    my $p = shift;
1340    $p = s/^((:|[^:]{7}){17})(?=...)/$1.../; # Warning 205: Text too long in tag [i2]
1341    return $p unless $path_c{$p}++;
1342    return "$p\[$path_c{$p}]";  # Warning 117: duplicate text in tag
1343  }
1344}
1345
1346sub trunc_heading {
1347  my ($h, $with_ind) = (shift, shift);
1348  # Some indexes are merged into headings; do a naive search
1349  $h =~ s/\b((X(<[^<>]+>|<< (?>.*? >>)|<<< (?>.*? >>>))\s*)+)//;
1350  my $x = $1;
1351  $h =~ s/\s+/ /g;
1352  $h =~ s/\s$//;
1353  $h = substr($h, 0, 110) . "..." if length $h > 124;
1354  return $h unless $with_ind;
1355  ($h, $x)
1356}
1357
1358sub output_index {
1359  return &count_index if $pass == 1;
1360  my ($heading, $path) = (shift, shift);
1361  return if $path =~ m,^perltoc/,;
1362  ($heading) = trunc_heading($heading);
1363  $path = trunc_heading($path);
1364  warn "Undefined \$index_seen{\$heading}, \$heading='$heading'.\n"
1365    unless defined $index_seen{$heading};
1366  if (length $heading == 0) {                   # Do nothing for =item *
1367  } elsif ($index_seen{$heading} > 1) { # Multiply occurning header name
1368    my $id = $i1ids{$heading};
1369    unless ($id) {              # First occurence of the header name
1370      $id = i1id($heading);
1371      print ":i1 id=$id." . out($heading, 0) . "\n";
1372    }
1373    my $uniq;
1374    $uniq = path_c($path), print ":i2 refid=$id." . out("[$uniq]", 0) . "\n"
1375      unless $index_output{$id}{$headno}++;
1376  } else {
1377    print ":i1." . out($heading, 0) . "\n";
1378  }
1379}
1380
1381sub count_index { $index_seen{trunc_heading shift}++ }
1382
1383sub maybe_link {
1384  my $txt = shift;
1385  return "L<$txt>" if
1386    exists $links{findref($txt,1)} or $txt =~ m,^((\w+)\([23]\)|POSIX\s*\(3\)/(\w+)|(emx\w+))$,i;
1387
1388  return $txt;
1389}
1390
1391sub strip {
1392    my $in = shift;
1393
1394    1 while $in =~ s/X<([^<>]*)>//;
1395    1 while $in =~ s/[A-Z]<([^<>]*)>/$1/;
1396
1397    return $in;
1398}
1399
1400sub link_url {
1401  my $url = shift;
1402  if (@www) {
1403    my $cmd = join ' || ', map { s/\@\@\@/$url/; $_ } @www;
1404    ":link reftype=launch object='cmd.exe' data='/c $cmd'."
1405  } else {
1406    ":link reftype=launch object='$www' data='$url'."
1407  }
1408}
1409
1410sub try_external_link {
1411    my ($txt, $outtxt) = shift;
1412    $outtxt = $txt unless defined $outtxt;
1413    my $link;
1414
1415    $foundrefs++, return ":link reftype=hd refid=$x_index{$txt}."
1416      . out($outtxt) . ":elink."
1417        if exists $x_index{$txt};
1418
1419    $txt = $1 if $txt =~ m!^[BCI]<{2,}\s+(.*?)\s+>{2,}$!s;
1420    $txt = $1 if $txt =~ m!^[BCI]<(.*?)>$!s;
1421    if ($txt =~ m,^(http|file|ftp|mailto|news|newsrc|gopher)://,) {
1422        $link = strip($txt);
1423    } elsif ($txt =~ m,^\"(http|file|ftp|mailto|news|newsrc|gopher)://,
1424             and $txt =~ /\"$/) {
1425        $link = strip(substr $txt, 1, length($txt) - 2);
1426    } elsif ($txt =~ m,^((\w+)\([23]\)|POSIX\s*\(3\)/(\w+)|(emx\w+))$,i) {
1427        return ":link reftype=launch object='view.exe' data='emxbook $+'."
1428          . out($outtxt) . ":elink.";
1429    }
1430    return link_url($link) . out($outtxt) . ":elink." if $link;
1431    return undef;
1432}
1433
1434sub format_funcall {
1435  my ($pre, $call, $func) = (@_);
1436  ( $func =~ /^($auto_link_both)$/o )
1437    ? "${pre}C<L<$func>()>"
1438    : "${pre}C<$call>"
1439}
1440
1441sub auto_beautify {
1442    my $para = $_[0];
1443    # We start with links to make as many of them as we can:
1444    $para =~ s/(^|[^<:\$@%])\b($auto_link)\b(?=$|[^>:]|:[^:])/$1L<$2>/go
1445      if $auto_link;
1446    # perl(1) Tix(n)
1447    $para =~
1448      s/ (^|[^<]) \b ( [\w:]+ \b \([\dn]\) ) (?=$|[^>]) /$1 . maybe_link($2)/gxe;
1449    # words in "SEE ALSO"
1450    # In fact, now there are many non-words in X<FOO>; so take only those which start and end with \w
1451    $para =~ s/ (^|[^<:|>()\w]) \b (?=\w) ( $auto_link_hard ) \b (?=$|[^\w|>:<)]) /$1L<$2>/gox
1452        if $hl and $section_head[$hl] eq "SEE ALSO" and $auto_link_hard;
1453    # Link highlighted "maybe-references"
1454    $para =~ s/([CBI])<($auto_link_both)>/$1<L<$2>>/go if $auto_link_both;
1455    # Link highlighted "pseudo-references" to function names
1456    $para =~ s/([CBI])<($auto_link_hard)(?=\()/$1<L<$2>/go if $auto_link_hard;
1457    $para =~ s/C<-([^\W\d])>/C<L<-$1>>/g;
1458    $para =~ s/ ^ ( $auto_link_hard ) $  /L<$1>/ox
1459      if $in_item_header and $auto_link_hard;
1460    # URLs inside F<>
1461    $para =~ s, F< ((http|file|ftp|mailto|news|newsrc|gopher):// [^\s<>]* ) >
1462              ,L<$1>,xg ;
1463    # free-standing URLs.
1464    $para =~ s% ( \s | ^ )
1465                ( (?:http|file|ftp|mailto|news|newsrc|gopher)
1466                  ://
1467                  [^\s<>]*
1468                  [^\s.,:;!?\"\'\)] # Strip trailing punctuation.
1469                )
1470                ( [.,:;!?\"\'\)]* ( \s | $ ) | $ )
1471              %$1L<$2>$3%xg ;
1472    # <> below is to avoid BOLDing of C in C<>
1473    $para =~ s/(^|[^<:\$@%])\b($make_bold)\b(?=$|[^<>:]|:[^:])/$1B<$2>/go
1474      if $make_bold;
1475    $para =~ s/(^|[^<:\$@%])\b($make_code)\b(?=$|[^>:]|:[^:])/$1C<$2>/go
1476      if $make_code;
1477    $para =~ s/ (\s+ | ^) ( [\$%\@] [\w:]+ \b) (?=$|[^>]) /$1C<$2>/gx; # $var
1478#    $para =~ s/([CBI])<($auto_link_both)>/$1<L<$2>>/go if $auto_link_both;
1479    $para =~ s{ (^|[^<]) \b ( ([\w:]+) \b \(\) ) (?=$|[^>]) }
1480              { format_funcall($1, $2, $3) }gex;                # func()
1481#    if ($para =~ /\bL<(::|\W)>/) {
1482#      print STDERR "auto-b: ``$para''\n";
1483#    }
1484    $para;
1485}
1486
1487my @tag_array;
1488BEGIN { @tag_array = qr{([<>]|(?!\n)$)} }       # ;-) ;-)
1489
1490sub fill_tag_array {            # Handle L<<<<  >>>>
1491  my $upto = shift;             # no. of > plus 1
1492  while (@tag_array <= $upto) {
1493    my $repeat = @tag_array + 1;
1494    push @tag_array, qr{(<|\s+>{$repeat}|(?!\n)$)};
1495  }
1496}
1497
1498sub find_matching {
1499  my $kets = 1 + pop;
1500  my $off = pop;
1501   $_[0] = $off
1502}
1503
1504sub out {
1505    return if ($pass == 1);
1506
1507    my $para = shift;
1508    my $markup = shift;
1509    my $beautify = $markup && ! shift;
1510    my $stop_at_ket = shift;    # Not finished: @stack?    arg=3 or 4
1511    my $cpos = shift || 0;      # scanned up to
1512    my @stack = ();
1513    my @lenstack = $stop_at_ket || 0;
1514    my $output = "";
1515    my ($c, $opos);             # opos: output done up to
1516    my $c_deep = 0;
1517    my @pos_stack;
1518
1519    $para = auto_beautify($para) if $beautify;
1520
1521    pos $para = $opos = $cpos;
1522    TAG: while ( $para =~ m{$tag_array[$lenstack[-1]]}g ) {
1523        $cpos = pos $para;
1524        $c = $1 || '';          # May hit the end of string
1525
1526        if ($c eq '<' && $cpos < 2) {
1527            $output .= escape(substr($para, $opos, $cpos - $opos));
1528        } elsif ($c eq '<') {
1529            $output .= escape(substr($para, $opos, $cpos - $opos - 2))
1530              if $cpos - $opos > 2;
1531
1532            $c = substr($para, $cpos - 2, 1);
1533            if ($c !~ /[A-Z]/) {
1534              $output .= escape(($cpos - $opos > 1 ? $c : '') . '<');
1535                pos($para) = $opos = $cpos;
1536                next TAG;
1537            }
1538
1539            # Look for L<<< X >>>
1540            my $extra = 0;
1541            pos $para = $cpos;
1542            $cpos = pos $para, $extra = length $1 if $para =~ /\G(<+)\s+/g;
1543            push @lenstack, $extra;
1544            fill_tag_array($extra);
1545
1546            if ($c eq 'B') {
1547              if (grep {$_ eq 'I'} @stack) {
1548                $output .= ':hp3.' if $markup;
1549                push (@stack, 'BI');
1550              } else {
1551                $output .= ':hp2.' if $markup;
1552                push (@stack, $c);
1553              }
1554            } elsif ($c eq 'F') {
1555                $output .= ':hp6.' if $markup;
1556                push (@stack, $c);
1557            } elsif ($c eq 'S') {
1558                # $output .= ':hp2.' if $markup; # XXXX Should not!
1559                push (@stack, $c);
1560            } elsif ($c eq 'I') {
1561              if (grep {$_ eq 'B'} @stack) {
1562                $output .= ':hp3.' if $markup;
1563                push (@stack, 'BI');
1564              } else {
1565                $output .= ':hp1.' if $markup;
1566                push (@stack, $c);
1567              }
1568            } elsif ($c eq 'C') {
1569                $output .= $to_C if $c_deep++ == 0 and $markup;
1570                push (@stack, $c);
1571            } elsif ($c eq 'L') {
1572                # Allow one level of included modifiers:
1573                push (@stack, $skip_embedded_links ? 'L' : 'LL'); # Treat as ordinary text
1574                pos($para) = $opos = $cpos;
1575                unless ($skip_embedded_links) {
1576                  push @pos_stack, $cpos;
1577                  push @out_stack, length $output;
1578                }
1579                next TAG;
1580            } elsif ($c eq 'E') {
1581                pos ($para) = $cpos;
1582                if ($para =~ m{$tag_array[$lenstack[-1]]}g) {
1583                    my $esc;
1584                    my $ocpos = $cpos;
1585                    $cpos = pos $para;
1586                    my $tag = substr $para, $ocpos, $cpos - $ocpos - length $1;
1587
1588                    if ($tag =~ m/^(([A-Za-z]+)|\d+)$/) {
1589                      if (defined $2) {
1590                        if (exists $HTML_Escapes{$1}) {
1591                          $escaped = 0;
1592                          $esc = $HTML_Escapes{$1};
1593                        } else {
1594                          $esc = exists $HTML_EscapesLit{$1}
1595                            ? "&$HTML_EscapesLit{$1}." : "E<$1>";
1596                          $escaped = 1;
1597                        }
1598                      } else {
1599                        $esc = chr $1;
1600                        $escaped = 1;
1601                      }
1602                      $output .= ($escaped ? $esc : escape($esc));
1603                    } else {
1604                      warn "$fname: unknown E<> in `" . (substr $para, $cpos-2, 10) . "'???\n";
1605                    }
1606                } else {
1607                    warn "$fname: unknown E<> in `" . (substr $para, $cpos-2, 10) . "'???\n";
1608                }
1609            } elsif ($c eq 'X') {
1610                pos ($para) = $cpos;
1611                # Here we match only '>'s, not '<'s
1612                if ($para =~ m{(?!<)$tag_array[$lenstack[-1]]}g) {
1613                    my $esc;
1614                    my $ocpos = $cpos;
1615                    $cpos = pos $para;
1616                    my $tag = substr $para, $ocpos, $cpos - $ocpos - length $1;
1617                    #$output .= escape($1);
1618                    push @index, $tag if $print_index;
1619                } else {
1620                    warn "$fname: error parsing X<...> ??? `" . (substr $para, $cpos-2, 160) . "', lenstack=`@lenstack', tag_array=`@tag_array'\n";
1621                }
1622            } elsif ($c eq 'Z') {
1623                pos ($para) = $cpos;
1624                if ($para =~ m/\G>/g) {
1625                    $cpos = pos $para;
1626                } else {
1627                    warn "funny: Z<...> ???\n";
1628                }
1629            } else {
1630                warn "$fname: what to do with $c<> ?\n";
1631            }
1632        } elsif ($#stack >= 0) {
1633            my ($l, $e) = length $c;
1634
1635            $output .= escape($e = substr($para, $opos, $cpos - $opos - $l));
1636            $c = pop(@stack);
1637            # XXXX This warning should better be skipped if we process truncated long headings...
1638            printf STDERR "     Unfinished tag: %s< Remains: %s\n", $c, $e
1639              unless $l;
1640            if ($c eq 'B') {
1641                $output .= ':ehp2.' if $markup;
1642            } elsif ($c eq 'F') {
1643                $output .= ':ehp6.' if $markup;
1644            } elsif ($c eq 'S') {
1645                # $output .= ':ehp2.' if $markup;
1646            } elsif ($c eq 'I') {
1647                $output .= ':ehp1.' if $markup;
1648            } elsif ($c eq 'BI') {
1649                $output .= ':ehp3.' if $markup;
1650            } elsif ($c eq 'C') {
1651                $output .= $from_C if --$c_deep == 0 and $markup;
1652            } elsif ($c eq 'L') {
1653                # end "unprocessed" link
1654            } elsif ($c eq 'LL') {
1655              # finish processing of the link
1656
1657              # First, ignore what was added
1658              substr($output, pop @out_stack) = '';
1659              # Avoid warning 208: a link inside a link could be
1660              # created during auto_beautify() above.
1661              local $skip_embedded_links = 1;
1662
1663              # Get the string inside L<< >>
1664              my $b = pop @pos_stack;
1665              my $link = substr $para, $b, $cpos - $l - $b;
1666              my $linktxt = $link;
1667
1668              # XXX Use heuristics to find | and /:
1669              my $haveliteral = 0;
1670              $haveliteral = 1, $linktxt = $1
1671                if $link =~ s!^(([A-Z]<[^<>]*>|(?>[^>|/]+))+)\|!!;
1672              $foundlink = findref($link);
1673              if (defined $links{$foundlink}) {
1674                my $blink = $linktxt;
1675                unless ($haveliteral) {
1676                  $blink =~ s|^"(.+)"$|$1|sm or
1677                    $blink =~ s|^([-\w:]+)/"(.+)"$|$1: $2|sm;
1678                }
1679                $output .= ":link reftype=hd refid=$links{$foundlink}."
1680                  if $markup;
1681                $output .= out($blink, 1, 1);
1682                $output .= ":elink." if $markup;
1683              } elsif ($foundlink = try_external_link($link,$linktxt)) {
1684                $output .= $markup ? $foundlink : out($linktxt) ;
1685              } else {
1686                warn "   unresolved link: $link\n";
1687                $output .= out($linktxt, 1, 1);
1688              }
1689              pos $para = $opos = $cpos;
1690            } else {
1691              $output .= escape('>'); # XXX Why?
1692            }
1693            pop @lenstack;
1694        } elsif (!length $c) {  # Hit the end, and stack is empty
1695            last TAG;           # Hitting the end fixes some of Warning 208
1696        } elsif (defined $stop_at_ket) {
1697            $output .= escape(substr($para, $opos, $cpos - $opos - length $c));
1698            $opos = $cpos;
1699            last TAG;
1700        } else {
1701            $output .= escape(substr($para, $opos, $cpos - $opos));
1702        }
1703        pos($para) = $opos = $cpos;
1704    }
1705    $output .= escape(substr($para, $opos, length($para) - $opos));
1706    if (!$markup) { # for toc/index/...
1707        $output =~ s/\n\s*/ /g;
1708        if (length $output > 140) {
1709          $output = substr($output, 0, 140); # strip too long stuff
1710          $output =~ s/&\w*$//;         # remove uncomplete escapes: Warning 203
1711        }
1712    }
1713    # Do not split inside "something" unless absolutely necessary
1714    # Try harder: e.g. perljp contains massive unbreakable stuff:
1715    1 while $output =~
1716      s/^(?=.{250})(.{80}([^\n \t]{0,169}(?=[ \t])|[^\n \t]{160}))[ \t]*/$1\n/gm; # Warning 206
1717    $output =~ s/^\./&per./mg;  # period.  Warning 204
1718    return $output;
1719}
1720
1721sub insert_back {               # Args: head_level and num of finished section,
1722  return unless $pass == 2;
1723  my $parent = find_parent($_[0]);
1724  return if $parent == $_[0];
1725  return if $parent <= $first_node;
1726  insert_nl;
1727  print " :link reftype=hd refid=$parent.:font facename=Courier size=8x6.Go Up:font facename=default size=0x0.:elink.\n";
1728  $was_nl = 1;
1729}
1730
1731# Find the latest node before $i at level < $level
1732sub find_parent {
1733    my $level = $headlevel[$_[0]];
1734    my $i = $_[0] - 1;
1735
1736    while ($i > $first_node && $headlevel[$i] >= $level) { $i--; }
1737
1738    return $i;
1739}
1740
1741sub contents {
1742    my $no = $_[0];
1743    my ($i, $cl, $toplevel);
1744    local $print_index = 0;
1745
1746    $isempty{$no}++;
1747    if ($pass == 1) {
1748        $wingroup[$no] = $groups{links};
1749        return ;
1750    }
1751
1752    #$i = find_parent($level,$no);
1753    $i = $no;
1754
1755    $toplevel = $headlevel[$i];
1756    return if $toplevel <= 0;
1757
1758    print ":p." . out($head[$i], 1) . "\n";
1759    $was_nl = 1;
1760    $i++;
1761    $cl = $toplevel;
1762    local $skip_embedded_links = 1;
1763    for (; $i <= $#head && $headlevel[$i] > $toplevel; $i++) {
1764        if ($headlevel[$i] > $cl) {
1765            print STDERR "     bad nesting: $toplevel, $headlevel[$i], $cl, $i, `$head[$i]`\n" if $headlevel[$i] != $cl + 1;
1766            print ":ul compact.\n";
1767            $was_nl = 1;
1768            $cl++;
1769        } elsif ($cl > $headlevel[$i]) {
1770            while ($cl > $headlevel[$i]) {
1771                print ":eul.\n";
1772                $was_nl = 1;
1773                $cl--;
1774            }
1775        }
1776        if (exists $isempty{$i}) {
1777          print ":li.", out($head[$i], 1, 1), "\n";
1778        } elsif (exists $hl_eitems{$i}) {
1779          print ":li.:link reftype=hd " . winlink($i)
1780            . " refid=$i."
1781              . out($_, 1, 1) . ":elink.\n" for @{$hl_eitems{$i}};
1782        } else {
1783          print ":li.:link reftype=hd " . winlink($i)
1784            . " refid=$i."
1785              . out($head[$i], 1, 1) . ":elink.\n";
1786        }
1787        $was_nl = 1;
1788    }
1789
1790    while ($cl > $toplevel) {
1791        print ":eul.\n";
1792        $cl--;
1793        $was_nl = 1;
1794    }
1795}
1796
1797sub findrefid {
1798  my $in = shift;
1799  my $out = $links{findref($in)} || $x_index{$in};
1800  warn "No refid for `$in'\n" if $debug and not defined $out;
1801  ($out || 0);                  # XXXX misplaced link - special panel?
1802}
1803
1804sub findref_with_pages { # various heuristics to get a valid prefix for a link
1805    my $link = shift;
1806    my $links = shift;
1807
1808    if (!defined $links->{$link}) {
1809      if ($link =~ m|(.*?)\.pod/(.*)|s) {
1810        $link = "$1/$2";        # Remove .pod from page name
1811      } elsif ($link =~ m|(.*?)\.pod$| and defined $links->{$1}) {
1812        $link = $1;
1813      }
1814    }
1815    if (!defined $links->{$link}) { # try harder
1816        if (defined $links->{qq|$page/"$link"|}) {
1817            $link = qq|$page/"$link"|;
1818        } elsif ($link =~ /^\"/) {
1819            $link = "$page/$link";
1820        } elsif ($link =~ m|^/\"|) {
1821            $link = "$page$link";
1822        } elsif ($link =~ m|^/(.*)|s) {
1823            $link = qq|$page/"$1"|;
1824        } elsif ($link =~ m|^([^/ ]+)/([^\"]+)$|) { # A/B to A/"B"
1825            $link = qq|$1/"$2"|;
1826        } elsif (exists $alternative_name{$link}
1827                 and exists $links->{$alternative_name{$link}}) {
1828            $link = $alternative_name{$link};
1829        }
1830        # print STDERR "trans: $link\n" if $debug_xref;
1831    }
1832    return $link;
1833}
1834
1835sub warn_strip {
1836  my ($link,$works,$flink) = @_;
1837  my $b = auto_beautify($flink);
1838  return if -1 < index $b, $link;       # May be missing perlpod/ or ""
1839  print STDERR "     Strip conversion in link: `$link' vs `$flink'.\n";
1840}
1841
1842sub findref_with_variations { # various heuristics to get a valid link
1843    my $link = shift;
1844    my $flink = findref_with_pages($link, \%links);
1845    my $tlink = $link;
1846    my $t;
1847
1848    if (!defined $links{$flink}) { # try harder
1849      ($tlink = $link) =~ s/\s+/ /g;
1850      $t = findref_with_pages($tlink, \%links_nws);
1851      $flink = $links_nws{$t} if exists $links_nws{$t};
1852    }
1853    if (!defined $links{$flink}) { # try file operators
1854      if ($link =~ /^-[^\W\d]$/) {
1855        $tlink = qq|perlfunc/"-X"|;
1856        $t = findref_with_pages($tlink, \%links_nws);
1857        $flink = $t if exists $links{$t};
1858      }
1859    }
1860    return $flink if $_[0];
1861    if (!defined $links{$flink}) { # try harder
1862      $tlink = lc $tlink;
1863      $t = findref_with_pages($tlink, \%links_lc);
1864      if (exists $links_lc{$t}) {
1865        $flink = $links_lc{$t};
1866        print STDERR "     Case conversion in link: `$link' vs `$flink'.\n";
1867      }
1868    }
1869    if (!defined $links{$flink}) { # try another way
1870      $tlink = strip $link;
1871      $t = findref_with_pages($tlink, \%links_strip);
1872      $flink = $links_strip{$t} if exists $links_strip{$t};
1873      if (!defined $links{$flink}) { # try harder
1874        my $b = auto_beautify($tlink);
1875        $t = findref_with_pages($b, \%links_b);
1876        if (exists $links_b{$t}) {
1877          $flink = $links_b{$t};
1878          warn_strip($link,$t,$flink);
1879        }
1880      } else {
1881          warn_strip($link,$t,$flink);
1882      }
1883    }
1884    if (!defined $links{$flink}) { # try another way
1885      my $b = auto_beautify($link);
1886      $t = findref_with_pages($b, \%links_b);
1887      if (exists $links_b{$t}) {
1888        $flink = $links_b{$t} if exists $links_b{$t};
1889        warn "Strip conversion in link: `$link' vs `$flink'.\n";
1890      }
1891    }
1892    return $flink;
1893}
1894
1895sub findref { # various heuristics to get a valid link
1896    my $link = shift;
1897    my $flink = findref_with_variations($link, @_);
1898
1899    print STDERR "link: $link\n" if $debug_xref;
1900
1901    if (!defined $links{$flink}) { # try harder
1902        if ($link =~ m|\(\)>?$|) {
1903            my $t = $link;
1904            $t =~ s/\(\)(>?)$/$1/; # open() -> open, C<open()> => C<open>
1905            $t = findref_with_variations $t, @_;
1906            $flink = $t if defined $links{$t};
1907        } elsif ($link =~ /\([\dn]\)>?$/) { # perl(1)
1908            my $t = $link;
1909            $t =~ s/\([\dn]\)(>?)$/$1/; # f(2) -> f, C<f(2)> => C<f>
1910            $t = findref_with_variations $t, @_;
1911            if (defined $links{$t}) {
1912              $flink = $t;
1913            } else {
1914              $unknown_manpages{$link}++; # May be converted to view.exe later
1915            }
1916        }
1917    }
1918    print STDERR "trans: $link => $flink\n" if $debug_xref;
1919    $foundrefs++ if defined $links{$flink};
1920    return $flink;
1921}
1922
1923sub add_ref {
1924    my $page = $_[0];
1925    my $num = $_[1];
1926    my $check = $_[2];
1927
1928    return if $page =~ m,^perltoc/,;
1929    $page =~ s/\s*$//;
1930#warn "<<<adding ref $num to \"$page\"\n";
1931
1932    $links{$page} = $num unless $check and exists $links{$page};
1933    (my $p = $page) =~ s/\s+/ /g;
1934    $links_nws{$p} = $page unless $check and exists $links_nws{$p};
1935    my $lc = lc $p;
1936    $links_lc{$lc} = $page unless $check and exists $links_lc{$lc};
1937    my $s = strip $page;
1938    $links_strip{$s} = $page unless $check and exists $links_strip{$s};
1939    my $b = auto_beautify($s);
1940    $links_b{$b} = $page unless $b eq $page or exists $links_b{$b};
1941    my $bb = auto_beautify($page);
1942    $links_b{$bb} = $page unless $bb eq $page or $bb eq $b;
1943}
1944
1945sub addsection {
1946    my $section = $_[0];
1947    my $num = $_[1];
1948    my $level = $_[2];
1949
1950    $head[$num] = $section;
1951    $headlevel[$num] = $level;
1952}
1953
1954sub escape {
1955    my $l = $_[0];
1956
1957    $l =~ s/\&/\&amp./g;
1958    $l =~ s/\:/\&colon./g;
1959    return $l;
1960}
1961
1962sub remove_colon {
1963    my $in = shift;
1964    $in =~ s/\&colon\./:/g;
1965    $in;
1966}
1967
1968sub escape_with_url {
1969    my $l = escape(shift);
1970
1971    $l =~ s% ( \s | ^ )
1972             (
1973              (?:http|file|ftp|mailto|news|newsrc|gopher)
1974              \&colon\.//
1975              [^\s<>]*
1976              [^\s.,:;!?\"\'\)] # Strip trailing punctuation.
1977             )
1978             ( [.,:;!?\"\'\)]* ( \s | $ ) | $ )
1979           % "$1" . link_url(remove_colon($2)) . "$2:elink.$3"
1980           %xeg ;
1981
1982    return $l;
1983}
1984
1985BEGIN {
1986    %HTML_Escapes =             # We provide a _practical_ list.
1987        (
1988         'amp'  =>      '&',    #   ampersand
1989         'lt'   =>      '<',    #   left chevron, less-than
1990         'gt'   =>      '>',    #   right chevron, greater-than
1991         'quot' =>      '"',    #   double quote
1992         'sol'  =>      '/',    #   slash=solidus
1993         'verbar' =>    '|',    #   vertical bar
1994         39     =>      "'",    #   single quote
1995        );
1996    %HTML_EscapesLit =          # We provide a _practical_ list.
1997        (
1998         # Stolen from pod2latex
1999         "Aacute"        =>     "aa", #   capital A, acute accent
2000         "aacute"        =>     "aa", #   small a, acute accent
2001         "Acirc"         =>     "ac", #   capital A, circumflex accent
2002         "acirc"         =>     "ac", #   small a, circumflex accent
2003         "AElig"         =>     'Aelig', #   capital AE diphthong (ligature)
2004         "aelig"         =>     'aelig', #   small ae diphthong (ligature)
2005         "Agrave"        =>     "ag", #   capital A, grave accent
2006         "agrave"        =>     "ag", #   small a, grave accent
2007         "Aring"         =>     'Ao', #   capital A, ring
2008         "aring"         =>     'ao', #   small a, ring
2009         #    "Atilde"   =>     '\\~{A}',       #   capital A, tilde
2010         #    "atilde"   =>     '\\~{a}',       #   small a, tilde
2011         "Auml"          =>     'Ae',   #   capital A, dieresis or umlaut mark
2012         "auml"          =>     'ae',   #   small a, dieresis or umlaut mark
2013         #    "Ccedil"   =>     '\\c{C}',       #   capital C, cedilla
2014         #    "ccedil"   =>     '\\c{c}',       #   small c, cedilla
2015         "Eacute"        =>     "Ea", #   capital E, acute accent
2016         "eacute"        =>     "ea", #   small e, acute accent
2017         "Ecirc"         =>     "ec", #   capital E, circumflex accent
2018         "ecirc"         =>     "ec", #   small e, circumflex accent
2019         "Egrave"        =>     "eg", #   capital E, grave accent
2020         "egrave"        =>     "eg", #   small e, grave accent
2021         #    "ETH"      =>     '\\OE',         #   capital Eth, Icelandic
2022         #    "eth"      =>     '\\oe',         #   small eth, Icelandic
2023         #    "Euml"     =>     '\\"{E}',       #   capital E, dieresis or umlaut mark
2024         #    "euml"     =>     '\\"{e}',       #   small e, dieresis or umlaut mark
2025         "Iacute"        =>     "ia", #   capital I, acute accent
2026         "iacute"        =>     "ia", #   small i, acute accent
2027         "Icirc"         =>     "ic", #   capital I, circumflex accent
2028         "icirc"         =>     "ic", #   small i, circumflex accent
2029         "Igrave"        =>     "ig", #   capital I, grave accent
2030         "igrave"        =>     "ig", #   small i, grave accent
2031         "Iuml"          =>     'Ie',   #   capital I, dieresis or umlaut mark
2032         "iuml"          =>     'ie',   #   small i, dieresis or umlaut mark
2033         "Ntilde"        =>     'Nt', #   capital N, tilde
2034         "ntilde"        =>     'nt', #   small n, tilde
2035         "Oacute"        =>     "oa", #   capital O, acute accent
2036         "oacute"        =>     "oa", #   small o, acute accent
2037         "Ocirc"         =>     "oc", #   capital O, circumflex accent
2038         "ocirc"         =>     "oc", #   small o, circumflex accent
2039         "Ograve"        =>     "og", #   capital O, grave accent
2040         "ograve"        =>     "og", #   small o, grave accent
2041         #    "Oslash"   =>     "\\O",          #   capital O, slash
2042         #    "oslash"   =>     "\\o",          #   small o, slash
2043         #    "Otilde"   =>     "\\~{O}",       #   capital O, tilde
2044         #    "otilde"   =>     "\\~{o}",       #   small o, tilde
2045         "Ouml"          =>     'Oe',   #   capital O, dieresis or umlaut mark
2046         "ouml"          =>     'oe',   #   small o, dieresis or umlaut mark
2047         #    "szlig"    =>     '\\ss{}',       #   small sharp s, German (sz ligature)
2048         #    "THORN"    =>     '\\L',          #   capital THORN, Icelandic
2049         #    "thorn"    =>     '\\l',,         #   small thorn, Icelandic
2050         "Uacute"        =>     "Ua", #   capital U, acute accent
2051         "uacute"        =>     "ua", #   small u, acute accent
2052         "Ucirc"         =>     "uc", #   capital U, circumflex accent
2053         "ucirc"         =>     "uc", #   small u, circumflex accent
2054         "Ugrave"        =>     "ug", #   capital U, grave accent
2055         "ugrave"        =>     "ug", #   small u, grave accent
2056         "Uuml"          =>     'Ue',   #   capital U, dieresis or umlaut mark
2057         "uuml"          =>     'ue',   #   small u, dieresis or umlaut mark
2058         #    "Yacute"   =>     "\\'{Y}",       #   capital Y, acute accent
2059         #    "yacute"   =>     "\\'{y}",       #   small y, acute accent
2060         "yuml"          =>     'ye',   #   small y, dieresis or umlaut mark
2061        );
2062}
2063
2064sub winhead {
2065    my $no = $_[0];
2066
2067    if ($multi_win) {
2068        if (defined $wingroup[$no]) {
2069            return "group=$groups{links} x=left width=$panelwidths{links}";
2070        }
2071    }
2072    return "";
2073}
2074
2075sub winlink {
2076    my $no = $_[0];
2077
2078    if ($multi_win) {
2079        if (defined $wingroup[$no]) {
2080            return "group=$groups{sublinks} vpx=2% vpcx=$panelwidths{sublinks}";
2081        } else {
2082            return "group=$groups{text} dependent vpx=right vpcx=$panelwidths{text}"
2083        }
2084    }
2085    return "";
2086}
2087
2088sub no_markup_len { # quick hack
2089    my $l = $_[0];
2090
2091    $l =~ s/\:.*?\.//g;
2092    $l =~ s/\&.*?\./x/g;
2093    return length $l;
2094}
2095
2096sub insert_nl {
2097  print "\n" if not $was_nl or shift;
2098  $was_nl = 1;
2099}
2100
2101sub do_libdir {
2102  local $_;
2103  $libdir = shift;
2104  chdir $libdir;
2105  debug("Looking in $libdir:");
2106  find (\&intern_modnamehash , '.');
2107  chdir $curdir;
2108}
2109
2110sub intern_modnamehash {
2111# File::Find is pretty screwy.
2112# I think we can't modify $_ or File::Find can screw up
2113
2114    my $shortpath;
2115
2116# this could be a problem - if we search $sitelibdir,
2117# its usually a subdir of $libdir, in which case we don't want it
2118# to think 'site_perl' is a class name.
2119
2120# site_perl and 5.00309 may be seen earlier than needed due to (unconvenient
2121# for reverse search) ordering of @INC.
2122  if ( defined $site_perl_prefix and
2123       $File::Find::name =~ m!/($site_perl_prefix|5\.(\d{3,5}|\d{1,2}\.\d{1,2}))/!o
2124       and $libdir !~ m!/($site_perl_prefix|5\.(\d{3,5}|\d{1,2}\.\d{1,2}))($|/)!o ) {
2125    return;
2126  }
2127
2128# site_perl/5.9.1 and siteperl may be both in @INC.
2129# One could also make site_perl/5.9.1-hide to avoid @INC
2130  if ( !defined $site_perl_prefix and
2131       $File::Find::name =~ m!/5\.(\d{3,5}|\d{1,2}\.\d{1,2})(-[-\w.]+)?/!
2132       and $libdir !~ m!/5\.(\d{3,5}|\d{1,2}\.\d{1,2})($|/)! ) {
2133    return;
2134  }
2135
2136# XXX - may be doing toplevel modules incorrectly in the above case
2137# is 'name' just the filename?  thats not good ....
2138    $shortpath = $_;
2139    local $_ = $File::Find::name;
2140
2141# kill leading './'
2142
2143    s{^[.]/}{};
2144    my $longname = "$libdir/$_";
2145    $longname =~ s{^[.]/}{};
2146
2147# XXX - take the current $libdir (/foo/bar)
2148# and see if the file were testing (/foo/bar/site_perl/Plugh/Blah.pm) is
2149# in any *other*, deeper subdir in @INC
2150# (/foo/bar/site_perl) - if so, skip this entry, cuz the deeper
2151# subdir will catch it properly (Plugh::Blah)
2152
2153# for other libraries that are proper subdirs of the current libdir
2154    foreach $otherlibrary (grep /^\Q$libdir\E.+/, @INC) {
2155
2156# if the other library is part of the current files path, skip it
2157# because it will be caught when the other library is used
2158
2159        if ($longname =~ /^\Q$otherlibrary\//) {
2160            print STDERR ".";
2161#           print "Skipping $_\n";
2162#           print "cuz $otherlibrary caught/will catch it\n";
2163            return;
2164        }
2165    }
2166
2167# exclude base pods - perlfoo.pod, but not perlfaqs
2168    /perl(?!faq).*[.]pod/ && $do_std && return;
2169
2170# for each file entry, kill trailing '.(pod|pm|cmd)'.  Skip other extentions
2171    (-f $shortpath) and
2172        s{^(.*)[.](pod|pm|plx?|cmd|bat)$ }{$1}xi
2173      or $shortpath !~ /[.]/ or return;
2174
2175# '.pod' files nonhierarchical - keep only last component as module name.
2176# well, hierarchical in Tk ... keep it hierarchical for now
2177
2178#    if ($2 eq 'pod') {$_ =~ s{.*/([^/]+)}{$1}; }
2179
2180# translate to module syntax
2181
2182    s{/}{::}g;
2183
2184# if its already in the hash, skip it.  We're following @INC order,
2185# which means if its found in a earlier @INC directory, it will
2186# be the one thats `use'd.  So rather than overwriting an earlier
2187# @INC entry with a newer one, we skip the newer one if the earlier
2188# one exists (or, we could do the foreach on (reverse @INC) instead
2189# of (@INC)).
2190
2191
2192    if (defined $seen{lc $_}) {
2193#       print "already found $_\n";
2194#       print "in $modnamehash{$_}\n";
2195        return
2196    };
2197
2198# If this is a .pm file, is there actually any documentation in it?
2199
2200# Under OS/2 perl utilites can have extension .cmd. To be safe, allow
2201# .bat as well. Since we look into $Config{bin}, we may allow files
2202# without extension as well, if they are text files.
2203
2204        if (($longname =~ /[.](pm|plx?|cmd|bat|pod)$/i
2205             or $shortpath !~ /[.]/) and -T $longname) {
2206            $good = 0;
2207            open(MODULE, $shortpath) or die "Cannot open `$shortpath': $!";
2208          line: while (defined ($theline = <MODULE>)) {
2209              $good = 1, last line if $theline =~ /^=head\d/;
2210            }
2211            $used_name = $_;
2212            if ($good and $theline =~ /^=head\d\s+NAME\b/ ) {
2213              my @alternative_names;
2214
2215              # Skip whitespace:
2216              $theline = "";
2217              $theline = <MODULE>
2218                while defined $theline and ($theline !~ /\S/ or $theline =~ /^X</);
2219              # Now have the name, find the description:
2220              if ($theline =~ /^((\S+)(,\s+\S+)*)\s*-\s*(.*)/ ) {
2221                my $desc = $4;
2222                my $podname = $1;
2223                my $have_more = length($2) != length($1);
2224
2225                if (exists $alias{$shortpath}) {
2226                  $used_name = $alias{$shortpath};
2227                } elsif ($believe_pod_name) {
2228                  $used_name = $podname;
2229                }
2230                my $skipNAME;   # safe to skip NAME section
2231                $name_from_pod = $2;
2232                { $name_from_pod =~ s/\.pm$//; }
2233                $name_from_pod = strip($name_from_pod);
2234#               if ( $name_from_pod =~ /^os2::/i
2235#                    and $libdir =~ m!/os2/?$! ) {
2236#                   (my $l = $libdir) =~ s,/os2/?$,,;
2237#                   return if $in_INC{$l};      # Will find it later...
2238#               }
2239                if ( $used_name =~ /^os2::/i and $libdir !~ m!/os2/?$! ) {
2240                   if ($seen_from_pod{$name_from_pod}) {
2241                     if ($in_INC{"$libdir/os2"}) {      # Already processed...
2242                        print STDERR "\n... $_: seen already: `$name_from_pod'\n";
2243                        return;
2244                     }
2245                     print STDERR "\n!!! $_: seen but $libdir/os2 not in \@INC: `$name_from_pod'???\n";
2246                   } else {
2247                        print STDERR "\n!!! $_: bad match for unseen module: `$name_from_pod'\n";
2248                   }
2249                   # may have backward-compatibility portable library in @INC,
2250                   # but not the (assumingly) version specific .../os2
2251                   my $rest = ($used_name =~ /^os2::(.*)/i);
2252                   return if lc $rest eq lc $name_from_pod
2253                                and $seen_from_pod{$name_from_pod};
2254                }
2255                if (lc($used_name) eq lc($name_from_pod)) {
2256                  # There is no sense to keep the NAME section due
2257                  # only to the long description, since the
2258                  # description is put *both* in the title of contents
2259                  # window, and at the top of contents window
2260                  $skipNAME = !$have_more; # && length(strip $theline) < 60;
2261                  # Prefer the name on the line over the file name:
2262                  $used_name = $name_from_pod;
2263                  # dumpValue(\%alternative_name);
2264                } elsif ($name_from_pod =~ /^OS2::(.*)/ and lc($used_name) eq lc($1)
2265                         and $libdir =~ m![\\/]os2([/\\])?$!) {
2266                     # Is not this obsolete?
2267                  $skipNAME = !$have_more && length(strip $theline) < 60;
2268                  $used_name = $name_from_pod;
2269                  # dumpValue(\%alternative_name);
2270                } else {
2271                  print STDERR "\n!!! Not matching: `$_' vs. `$name_from_pod'\n"
2272                    unless /perlfaq/;
2273                }
2274                $seen_from_pod{$name_from_pod}++;
2275                # Now process additional names this manpage may
2276                # appear under (first from the first line only):
2277                @alternative_names = ($podname =~ /([\w:.]*[\w:])/g);
2278                # Second from additional lines
2279                while (defined ($theline = <MODULE>)
2280                       and not $theline =~ /^=/) {
2281                  if ($theline =~ /^((\S+)(,\s+\S+)*)\s*-\s*(.*)/) {
2282                    push @alternative_names, ($1 =~ /([\w:.]*[\w:])/g);
2283                    $skipNAME = 0;
2284                  } elsif ($theline =~ /\S/) {
2285                    $skipNAME = 0;
2286                  }
2287                }
2288                my $f = $_;
2289                unshift @alternative_names, $f
2290                  unless $f eq $used_name or grep $_ eq $f, @alternative_names;
2291                @alternative_name{@alternative_names} = ($used_name) x @alternative_names;
2292                print STDERR "Auto-aliases `@alternative_names' for `$used_name'.\n"
2293                  if $debug or @alternative_names > 1;
2294                $moddesc{$used_name} = $desc;
2295                if ($skipNAME and 0) { # Do not skip if NAME is the only section
2296                  $theline = <MODULE>
2297                    while defined ($theline) and not $theline =~ /^=(?!cut)/;
2298                  $skipNAME = 0 unless defined $theline;
2299                }
2300                $skip_sections{"$used_name/NAME"}++ if $skipNAME;
2301              } else {
2302                print STDERR "\n!!! $_: bad NAME: `$theline'\n";
2303              }
2304            } elsif ($good) {
2305              print STDERR "\n!!! $_: no NAME\n";
2306            }
2307            add_file($used_name, $longname) if $good;
2308        }
2309
2310    echopod($_) if $modnamehash{$_};
2311}
2312
2313sub add_file {
2314  my ($used_name, $longname) = @_;
2315  $seen{lc $used_name}++;
2316  $modnamehash{$used_name} = $longname;
2317  $alternative_name{$used_name} = $used_name;
2318}
2319
2320sub debug {
2321  print STDERR "\n", '=' x 79, "\n$_[0]\n", '=' x 79 , "\n";
2322}
2323
2324sub echopod {
2325
2326    $savenew = $_[0];
2327    $oldpod ||= "";
2328
2329# if neither has a ::, same line
2330
2331    if ($oldpod !~ /::/ && $_[0] !~ /::/) {
2332
2333# if old one has a ::, different lines
2334
2335    } elsif ($oldpod =~ /::/ && $_[0] !~ /::/) {
2336
2337        print STDERR "\n";
2338
2339    } elsif ($oldpod !~ /::/ && $_[0] =~ /::/) {
2340
2341# if its the new one that has ::, start a header line
2342
2343        ($new) = ($_[0] =~ /^(.+?)::((?s:.*))/);
2344        print STDERR "\n${new} modules: ";
2345        $_[0] = $2;
2346
2347    } else {
2348
2349# if both have ::, if stuff before first :: is different, newline
2350# if stuff before is the same, trim it before printing (same line)
2351
2352        ($old) = ($oldpod =~ /^([^:]+)::/);
2353        ($new) = ($_[0] =~ /^([^:]+)::((?s:.*))/);
2354        if ($old eq $new) {
2355            # kill leading stuff
2356            $_[0] = $2;
2357        } else {
2358            print STDERR "\n${new} modules: ";
2359            $_[0] = $2;
2360        }
2361    }
2362
2363    $oldpod = $savenew;
2364
2365    print STDERR $_[0], " ";
2366
2367}
2368
2369sub hash_diff {
2370  my ($old, $new) = @_;
2371  my @keys = grep {not exists $old->{$_}} keys %$new;
2372  my %diff;
2373  @diff{@keys} = $new->{@keys};
2374  %diff;
2375}
2376
2377# Retval: hash: keys: toplevel nodes, values: '' or refs to lower-level-hashes.
2378# Keys have :: prepended.
2379sub create_tree {
2380  my $in = shift;
2381  my %branch;
2382  my (%ret, $leaf, $branch, $subbranch);
2383
2384  # If $leaf is undef, it means ''. The rest has implicit :: prepended.
2385  foreach $leaf (@$in) {
2386    $ret{''} = '', next unless  defined $leaf;
2387    if ($leaf =~ /^((?s:.*?))::((?s:.*))/) {
2388      push @{$branch{$1}}, $2;
2389    } else {
2390      push @{$branch{$leaf}}, undef; # Cooky to denote a leaf
2391    }
2392  }
2393  if (exists $ret{''} or keys %branch > 1) { # Need this level!
2394    foreach $branch (keys %branch) {
2395      $subbranch = create_tree($branch{$branch});
2396      if (keys %$subbranch > 1) {
2397        $ret{"::$branch"} = $subbranch;
2398      } else {
2399        $ret{"::$branch" . (keys %$subbranch)[0]} = '';
2400      }
2401    }
2402  } elsif (%branch) {           # This level is not needed, just copy sublevel.
2403    my $key = (keys %branch)[0];
2404    $subbranch = create_tree($branch{(keys %branch)[0]});
2405    foreach $leaf (keys %$subbranch) {
2406      $ret{"::$key$leaf"} = $subbranch->{$leaf};
2407    }
2408  }
2409  \%ret;
2410}
2411
2412sub format_args {
2413  return "with no command-line arguments" unless @args;
2414  'with arguments C<"' . (join qq(">\nC<"), @args) . '">'
2415}
2416
2417__END__
2418
2419=head1 NAME
2420
2421pod2ipf - translator from POD format to IBM's F<.INF> format.
2422
2423=head1 SYNOPSYS
2424
2425  cd \perllib\lib\pod
2426  pod2ipf > perl.ipf
2427  ipfc /inf perl.ipf
2428
2429  pod2ipf my.pod > my.ipf
2430
2431  pod2ipf my1.pod my2.pod > my.ipf
2432
2433  pod2ipf --by-files "--title=My first book" \
2434          chapter1.pod chapter2.pod > mybook.ipf
2435
2436  pod2ipf --by-dirs "--title=Book for /this/dir" /this/dir > book.ipf
2437
2438  pod2ipf --by-dirs "--title=Book with chapters" \
2439          "--section-name=General topics" --dir=gen1 --dir=gen2 \
2440          "--section-name=Specific topics" --dir=spe1
2441          --dir=spe2 --dir spe3      >   longbook.ipf
2442
2443=head1 DESCRIPTION
2444
2445By default, if no command-line options: processes all the
2446standard Perl pods in the current directory, as well as all the Perl
2447libraries and all the Perl utilities it can find using F<Config.pm>,
2448
2449The result should be converted to .INF via F<ipfc.exe>, with C</inf> switch.
2450
2451Both steps may produce warnings, mostly because of malformed
2452C<POD>s.  [Currently, the only false warnings are some of C<Strip conversion>
2453warnings.]
2454
2455Recognized command-line switches (with defaults);
2456
2457  --title               Title of the INF file
2458  --(no)burst           Print Logo and About pages      (y)
2459  --(no)about           Print About page                (y)
2460  --(no)mods            Scan through @INC               (y)
2461  --(no)std             Scan ./ for standard Perl PODs  (y)
2462  --(no)bin             Scan through $Config{bin}       (y)
2463  --(no)tree            Output modules tree             (y)
2464  --(no)faqs            Output faqs                     (y)
2465  --file                If present, do these files too (multiple OK)
2466  --dir                 Which addnl directories to scan (multiple OK)
2467  --(no)dump-xref       Dump them to STDERR             (n)
2468  --(no)dump-contents   Dump it to STDERR               (n)
2469  --(no)dump-manpages   Dump unknown manpages to STDERR (y)
2470  --(no)debug           Print an additional debug info  (n)
2471  --head-off            Offset of .IPF headings wrt POD (2|0)
2472  --to-bold             If present, words to auto-make bold (multiple OK)
2473                         (EMX RSX WPS Object-REXX HPFS HTML WWW GNU Perl C
2474                          XFree86 OS/2 CRT PM DOS VIO CPAN IBM URL);
2475  --to-code             If present, words to auto-make code-like (multiple OK)
2476                         (VCPI DPMI groff awk gawk STDIN STDOUT STDERR Emacs
2477                          EPM CMD 4os2 sh pdksh zip unzip pkunzip man gcc
2478                          link386 tr PATH LIBPATH)
2479  --section-name        Groups next --dir/--file's into a section (multiple OK)
2480  --bin-dir             If present, search for binaries here too (multiple OK)
2481  --by-files            Interpret extra args as file names (n if options seen)
2482  --by-dirs             Interpret extra args as dir names (n)
2483  --www                 Which browser to use. (%IPFWWW%||lynx||netscape)
2484  --(no)believe-pod-name Take names from NAME sections (n)
2485  --alias               Assign name to the preceding file (multiple OK)
2486
2487Depending on the value of C<head_off>, the toplevel sections of the generated
2488book are formed basing on:
2489
2490=over 4
2491
2492=item 0
2493
2494C<=head1>-entries of the POD document(s);
2495
2496=item 1
2497
2498processed POD documents;
2499
2500=item 2
2501
2502processed groups of POD documents (sections).
2503
2504=back
2505
2506Options C<--by-files> and C<--by-dirs> reset the values to
2507
2508 --nodump-manpages --noburst --nobin --nomods --nostd --notree --nofaqs
2509
2510and interpret the unprocessed command-line parameters as names of
2511files or directories to process.
2512
2513If the first argument is not an option, an implicit C<--by-files> is
2514assumed.  If the only argument is not an option, an implicit
2515C<--head-off=0> is assumed.
2516
2517=head2 URL
2518
2519Found URLs are made into links.  Each link starts a browser; the browser
2520to start is configured at conversion time by the C<--www> option.  Multiple
2521browsers may be specified, then they are started one-by-one until one of
2522them succeeds.  Use C<||> to separate browsers.  The first C<@@@> in
2523the browser command is replaced by the URL.  If no C<@@@> is present,
2524C<@@@> is assumed at the end.
2525
2526Since the default uses C<%IPFWWW%> as the first of the browsers, the user of
2527the generated files may specify his own browser by setting the
2528environment variable C<IPFWWW>.
2529
2530=head1 PREREQUISITES
2531
2532Developer 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.
2533
2534=head1 AUTHOR
2535
2536C<Marko.Macek@snet.fri.uni-lj.si>, C<mark@hermes.si>,
2537Ilya Zakharevich C<ilya@math.ohio-state.edu>.
2538
2539=head1 SEE ALSO
2540
2541L<perlpod>, L<perl>, L<pod2man>, L<perldoc>, L<pod2html>, L<pod2latex>,  L<pod2texi>, L<pod2text>.
2542
2543=cut
2544
2545No docs:  L<pod2html>, L<pod2latex>,  L<pod2texi>, L<pod2text>,