| 1 | extproc perl -wS
|
|---|
| 2 | #!perl -w
|
|---|
| 3 | use strict qw(refs subs);
|
|---|
| 4 | use File::Find;
|
|---|
| 5 | use File::Copy 'copy';
|
|---|
| 6 | use Cwd;
|
|---|
| 7 | use Config '%Config';
|
|---|
| 8 | use Getopt::Long 'GetOptions';
|
|---|
| 9 | use vars qw{%do_file_hash %do_dirs_hash %bin_hash %faqs_hash %pragmas_hash
|
|---|
| 10 | %mods_hash %pod_hash %add_mods_hash @add_dir @add_files %tree_hash
|
|---|
| 11 | $skip_embedded_links};
|
|---|
| 12 | # use Fatal qw(open close); # would not work: interprets filehandles as barewords.
|
|---|
| 13 | sub intern_modnamehash;
|
|---|
| 14 | sub do_libdir;
|
|---|
| 15 | sub output_file;
|
|---|
| 16 | sub hash_diff;
|
|---|
| 17 | sub auto_beautify;
|
|---|
| 18 | sub create_tree;
|
|---|
| 19 | sub format_args;
|
|---|
| 20 | sub output_index;
|
|---|
| 21 | sub count_index;
|
|---|
| 22 | sub untabify;
|
|---|
| 23 | sub untabify_after;
|
|---|
| 24 | sub strip;
|
|---|
| 25 | sub find_parent;
|
|---|
| 26 | sub insert_back;
|
|---|
| 27 |
|
|---|
| 28 | require 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 = ();
|
|---|
| 264 | my @args = @ARGV;
|
|---|
| 265 | my $foundrefs = 0;
|
|---|
| 266 | my %i1ids;
|
|---|
| 267 | my %index_seen;
|
|---|
| 268 | my %index_output;
|
|---|
| 269 | my $www = '%IPFWWW%||lynx||netscape';
|
|---|
| 270 | #my $to_C = ':font facename=Courier size=18x10.';
|
|---|
| 271 | #my $to_C = ':font facename=Courier size=14x8.';
|
|---|
| 272 | my $to_C = ':font facename=Courier size=11x6.'; # Tolerable on 72/96dpi.
|
|---|
| 273 | my $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);
|
|---|
| 279 | my %in_INC;
|
|---|
| 280 | @in_INC{@INC} = @INC;
|
|---|
| 281 |
|
|---|
| 282 | sub by_dirs { by_files(); $by_files = 0; $by_dirs = 1; }
|
|---|
| 283 | sub 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 |
|
|---|
| 308 | sub 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 |
|
|---|
| 325 | sub 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 |
|
|---|
| 331 | if (@ARGV >= 1 and $ARGV[0] !~ /^-/) {
|
|---|
| 332 | unshift @ARGV, '--by-files';
|
|---|
| 333 | unshift @ARGV, '--head-off=0' if @ARGV == 2;
|
|---|
| 334 | }
|
|---|
| 335 |
|
|---|
| 336 | GetOptions(
|
|---|
| 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 | );
|
|---|
| 364 | if ($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;
|
|---|
| 374 | my $unknownPod_prefix = $do_std ? undef : "File ";
|
|---|
| 375 |
|
|---|
| 376 | sub 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 |
|
|---|
| 390 | my @www;
|
|---|
| 391 |
|
|---|
| 392 | $www =~ s/^\s+//;
|
|---|
| 393 | $www =~ s/\s+$//;
|
|---|
| 394 | if ($www =~ /\|\||\s|\@\@\@/) {
|
|---|
| 395 | @www = map { /\@\@\@/ ? $_ : $_ . ' "@@@"' } split /\s*\|\|\s*/, $www;
|
|---|
| 396 | } elsif (! $www =~ /\./) {
|
|---|
| 397 | $www .= '.exe'
|
|---|
| 398 | }
|
|---|
| 399 |
|
|---|
| 400 | add_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 |
|
|---|
| 408 | debug("Module pod/pm discovery");
|
|---|
| 409 |
|
|---|
| 410 | $curdir = cwd;
|
|---|
| 411 | my $site_perl_prefix;
|
|---|
| 412 | my $libdir;
|
|---|
| 413 |
|
|---|
| 414 | if ((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 |
|
|---|
| 420 | if (@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 |
|
|---|
| 432 | sub 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 |
|
|---|
| 465 | if ($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 |
|
|---|
| 479 | foreach $libdir ( $do_bin ? ($Config{bin}, @bin_dirs) : () ) {
|
|---|
| 480 | do_libdir $libdir;
|
|---|
| 481 | }
|
|---|
| 482 | unless (@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 |
|
|---|
| 493 | print STDERR "\nFound `@modnames'.\n";
|
|---|
| 494 |
|
|---|
| 495 | # %modnamehash now maps module name -> file name.
|
|---|
| 496 | # %moddesc now maps module name -> description.
|
|---|
| 497 |
|
|---|
| 498 | @files = ();
|
|---|
| 499 |
|
|---|
| 500 | if ($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 |
|
|---|
| 553 | perlos2delta - a POD copy of \$builddir/os2/Changes.
|
|---|
| 554 |
|
|---|
| 555 | \=head1 DESCRIPTION
|
|---|
| 556 |
|
|---|
| 557 | EOP
|
|---|
| 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 |
|
|---|
| 572 | if ($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 |
|
|---|
| 605 | my @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));
|
|---|
| 608 | print 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 |
|
|---|
| 619 | for $pod (@files) {
|
|---|
| 620 | $doing_pod{$pod->[0] . ".pod"}++;
|
|---|
| 621 | }
|
|---|
| 622 |
|
|---|
| 623 | for $pod (qw(perlovl.pod)) {
|
|---|
| 624 | $obsolete{$pod}++;
|
|---|
| 625 | }
|
|---|
| 626 |
|
|---|
| 627 | for $pod (<*.pod>) {
|
|---|
| 628 | $not_doing_pod{$pod}++
|
|---|
| 629 | unless $doing_pod{$pod} or $obsolete{$pod} or $pod =~ /perlfaq/;
|
|---|
| 630 | }
|
|---|
| 631 |
|
|---|
| 632 | for $pod (keys %not_doing_pod) {
|
|---|
| 633 | print STDERR "\n!!! Unknown POD: `$pod'\n" if $do_std;
|
|---|
| 634 | }
|
|---|
| 635 |
|
|---|
| 636 | for $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 |
|
|---|
| 693 | sub out;
|
|---|
| 694 | sub contents;
|
|---|
| 695 | sub escape;
|
|---|
| 696 | sub add_ref;
|
|---|
| 697 | sub findref;
|
|---|
| 698 | sub winhead;
|
|---|
| 699 | sub winlink;
|
|---|
| 700 | sub no_markup_len;
|
|---|
| 701 | sub insert_nl;
|
|---|
| 702 |
|
|---|
| 703 | $/ = "";
|
|---|
| 704 |
|
|---|
| 705 | foreach $sc (@split_sections) { $as_head{$sc} = 1; }
|
|---|
| 706 |
|
|---|
| 707 | foreach $sc (@index_sections) { $fine_index{$sc} = 1; }
|
|---|
| 708 |
|
|---|
| 709 | if (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
|
|---|
| 717 | my $first_node = 30;
|
|---|
| 718 |
|
|---|
| 719 | for ($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
|
|---|
| 734 | EOI
|
|---|
| 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'.
|
|---|
| 784 | Do not forget that you can alway click on :hp9.Contents:ehp9., :hp9.Search:ehp9., and :hp9.Index:ehp9. buttons (or use :hp8.Alt-t:ehp8., :hp8.Alt-s:ehp8., :hp8.Alt-i:ehp8. correspondingly).
|
|---|
| 785 | :font facename=Courier size=7x5. The use of a camel image in conjunction with Perl is a trademark of
|
|---|
| 786 | O'Reilly &. Associates, Inc.:font facename=default size=0x0.
|
|---|
| 787 |
|
|---|
| 788 | EOI
|
|---|
| 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
|
|---|
| 793 | EOI
|
|---|
| 794 | print out(<<EOI, 1);
|
|---|
| 795 | Generated on @{[scalar localtime]}, by L<perl> version $],
|
|---|
| 796 | L<pod2ipf> version $VERSION @{[format_args]} in directory F<@{[cwd]}>.
|
|---|
| 797 | EOI
|
|---|
| 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 |
|
|---|
| 806 | EOP
|
|---|
| 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 |
|
|---|
| 832 | print "\n:euserdoc.\n";
|
|---|
| 833 |
|
|---|
| 834 | if ($dump_xref) {
|
|---|
| 835 | foreach (keys %links) {
|
|---|
| 836 | print STDERR $_ . "->" . $links{$_} . "\n";
|
|---|
| 837 | }
|
|---|
| 838 | }
|
|---|
| 839 | if ($dump_contents) {
|
|---|
| 840 | for($i = 0; $i <= $#head; $i++) {
|
|---|
| 841 | print STDERR " " x $headlevel[$i], $head[$i], "\n";
|
|---|
| 842 | }
|
|---|
| 843 | }
|
|---|
| 844 | if ($dump_manpages) {
|
|---|
| 845 | my @arr = sort keys %unknown_manpages;
|
|---|
| 846 | print STDERR "Unknown manpages: @arr.\n";
|
|---|
| 847 | }
|
|---|
| 848 | print STDERR "Found $foundrefs crosslinks.\n";
|
|---|
| 849 |
|
|---|
| 850 | sub 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 |
|
|---|
| 857 | EOP
|
|---|
| 858 | }
|
|---|
| 859 |
|
|---|
| 860 | sub 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 |
|
|---|
| 876 | my $last_hl = 123; # Very big
|
|---|
| 877 | sub 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 |
|
|---|
| 888 | sub non_empty ($) {
|
|---|
| 889 | my $p = shift;
|
|---|
| 890 | (length $p) ? $p : '=' x 40;
|
|---|
| 891 | }
|
|---|
| 892 |
|
|---|
| 893 | sub 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 |
|
|---|
| 1287 | sub 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 |
|
|---|
| 1301 | EOP
|
|---|
| 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 |
|
|---|
| 1309 | EOP
|
|---|
| 1310 | }
|
|---|
| 1311 | }
|
|---|
| 1312 | }
|
|---|
| 1313 |
|
|---|
| 1314 | sub 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 |
|
|---|
| 1323 | sub 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 |
|
|---|
| 1346 | sub 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 |
|
|---|
| 1358 | sub 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 |
|
|---|
| 1381 | sub count_index { $index_seen{trunc_heading shift}++ }
|
|---|
| 1382 |
|
|---|
| 1383 | sub 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 |
|
|---|
| 1391 | sub 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 |
|
|---|
| 1400 | sub 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 |
|
|---|
| 1410 | sub 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 |
|
|---|
| 1434 | sub format_funcall {
|
|---|
| 1435 | my ($pre, $call, $func) = (@_);
|
|---|
| 1436 | ( $func =~ /^($auto_link_both)$/o )
|
|---|
| 1437 | ? "${pre}C<L<$func>()>"
|
|---|
| 1438 | : "${pre}C<$call>"
|
|---|
| 1439 | }
|
|---|
| 1440 |
|
|---|
| 1441 | sub 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 |
|
|---|
| 1487 | my @tag_array;
|
|---|
| 1488 | BEGIN { @tag_array = qr{([<>]|(?!\n)$)} } # ;-) ;-)
|
|---|
| 1489 |
|
|---|
| 1490 | sub 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 |
|
|---|
| 1498 | sub find_matching {
|
|---|
| 1499 | my $kets = 1 + pop;
|
|---|
| 1500 | my $off = pop;
|
|---|
| 1501 | $_[0] = $off
|
|---|
| 1502 | }
|
|---|
| 1503 |
|
|---|
| 1504 | sub 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 |
|
|---|
| 1721 | sub 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
|
|---|
| 1732 | sub 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 |
|
|---|
| 1741 | sub 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 |
|
|---|
| 1797 | sub 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 |
|
|---|
| 1804 | sub 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 |
|
|---|
| 1835 | sub 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 |
|
|---|
| 1842 | sub 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 |
|
|---|
| 1895 | sub 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 |
|
|---|
| 1923 | sub 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 |
|
|---|
| 1945 | sub addsection {
|
|---|
| 1946 | my $section = $_[0];
|
|---|
| 1947 | my $num = $_[1];
|
|---|
| 1948 | my $level = $_[2];
|
|---|
| 1949 |
|
|---|
| 1950 | $head[$num] = $section;
|
|---|
| 1951 | $headlevel[$num] = $level;
|
|---|
| 1952 | }
|
|---|
| 1953 |
|
|---|
| 1954 | sub escape {
|
|---|
| 1955 | my $l = $_[0];
|
|---|
| 1956 |
|
|---|
| 1957 | $l =~ s/\&/\&./g;
|
|---|
| 1958 | $l =~ s/\:/\&colon./g;
|
|---|
| 1959 | return $l;
|
|---|
| 1960 | }
|
|---|
| 1961 |
|
|---|
| 1962 | sub remove_colon {
|
|---|
| 1963 | my $in = shift;
|
|---|
| 1964 | $in =~ s/\&colon\./:/g;
|
|---|
| 1965 | $in;
|
|---|
| 1966 | }
|
|---|
| 1967 |
|
|---|
| 1968 | sub 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 |
|
|---|
| 1985 | BEGIN {
|
|---|
| 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 |
|
|---|
| 2064 | sub 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 |
|
|---|
| 2075 | sub 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 |
|
|---|
| 2088 | sub 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 |
|
|---|
| 2096 | sub insert_nl {
|
|---|
| 2097 | print "\n" if not $was_nl or shift;
|
|---|
| 2098 | $was_nl = 1;
|
|---|
| 2099 | }
|
|---|
| 2100 |
|
|---|
| 2101 | sub do_libdir {
|
|---|
| 2102 | local $_;
|
|---|
| 2103 | $libdir = shift;
|
|---|
| 2104 | chdir $libdir;
|
|---|
| 2105 | debug("Looking in $libdir:");
|
|---|
| 2106 | find (\&intern_modnamehash , '.');
|
|---|
| 2107 | chdir $curdir;
|
|---|
| 2108 | }
|
|---|
| 2109 |
|
|---|
| 2110 | sub 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 |
|
|---|
| 2313 | sub 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 |
|
|---|
| 2320 | sub debug {
|
|---|
| 2321 | print STDERR "\n", '=' x 79, "\n$_[0]\n", '=' x 79 , "\n";
|
|---|
| 2322 | }
|
|---|
| 2323 |
|
|---|
| 2324 | sub 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 |
|
|---|
| 2369 | sub 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.
|
|---|
| 2379 | sub 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 |
|
|---|
| 2412 | sub 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 |
|
|---|
| 2421 | pod2ipf - 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 |
|
|---|
| 2445 | By default, if no command-line options: processes all the
|
|---|
| 2446 | standard Perl pods in the current directory, as well as all the Perl
|
|---|
| 2447 | libraries and all the Perl utilities it can find using F<Config.pm>,
|
|---|
| 2448 |
|
|---|
| 2449 | The result should be converted to .INF via F<ipfc.exe>, with C</inf> switch.
|
|---|
| 2450 |
|
|---|
| 2451 | Both steps may produce warnings, mostly because of malformed
|
|---|
| 2452 | C<POD>s. [Currently, the only false warnings are some of C<Strip conversion>
|
|---|
| 2453 | warnings.]
|
|---|
| 2454 |
|
|---|
| 2455 | Recognized 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 |
|
|---|
| 2487 | Depending on the value of C<head_off>, the toplevel sections of the generated
|
|---|
| 2488 | book are formed basing on:
|
|---|
| 2489 |
|
|---|
| 2490 | =over 4
|
|---|
| 2491 |
|
|---|
| 2492 | =item 0
|
|---|
| 2493 |
|
|---|
| 2494 | C<=head1>-entries of the POD document(s);
|
|---|
| 2495 |
|
|---|
| 2496 | =item 1
|
|---|
| 2497 |
|
|---|
| 2498 | processed POD documents;
|
|---|
| 2499 |
|
|---|
| 2500 | =item 2
|
|---|
| 2501 |
|
|---|
| 2502 | processed groups of POD documents (sections).
|
|---|
| 2503 |
|
|---|
| 2504 | =back
|
|---|
| 2505 |
|
|---|
| 2506 | Options C<--by-files> and C<--by-dirs> reset the values to
|
|---|
| 2507 |
|
|---|
| 2508 | --nodump-manpages --noburst --nobin --nomods --nostd --notree --nofaqs
|
|---|
| 2509 |
|
|---|
| 2510 | and interpret the unprocessed command-line parameters as names of
|
|---|
| 2511 | files or directories to process.
|
|---|
| 2512 |
|
|---|
| 2513 | If the first argument is not an option, an implicit C<--by-files> is
|
|---|
| 2514 | assumed. If the only argument is not an option, an implicit
|
|---|
| 2515 | C<--head-off=0> is assumed.
|
|---|
| 2516 |
|
|---|
| 2517 | =head2 URL
|
|---|
| 2518 |
|
|---|
| 2519 | Found URLs are made into links. Each link starts a browser; the browser
|
|---|
| 2520 | to start is configured at conversion time by the C<--www> option. Multiple
|
|---|
| 2521 | browsers may be specified, then they are started one-by-one until one of
|
|---|
| 2522 | them succeeds. Use C<||> to separate browsers. The first C<@@@> in
|
|---|
| 2523 | the browser command is replaced by the URL. If no C<@@@> is present,
|
|---|
| 2524 | C<@@@> is assumed at the end.
|
|---|
| 2525 |
|
|---|
| 2526 | Since the default uses C<%IPFWWW%> as the first of the browsers, the user of
|
|---|
| 2527 | the generated files may specify his own browser by setting the
|
|---|
| 2528 | environment variable C<IPFWWW>.
|
|---|
| 2529 |
|
|---|
| 2530 | =head1 PREREQUISITES
|
|---|
| 2531 |
|
|---|
| 2532 | Developer toolkit for OS/2 is required (for C<ifpc>). It is reported that C<ipfc> is also on DDK which is freely available from IBM site.
|
|---|
| 2533 |
|
|---|
| 2534 | =head1 AUTHOR
|
|---|
| 2535 |
|
|---|
| 2536 | C<Marko.Macek@snet.fri.uni-lj.si>, C<mark@hermes.si>,
|
|---|
| 2537 | Ilya Zakharevich C<ilya@math.ohio-state.edu>.
|
|---|
| 2538 |
|
|---|
| 2539 | =head1 SEE ALSO
|
|---|
| 2540 |
|
|---|
| 2541 | L<perlpod>, L<perl>, L<pod2man>, L<perldoc>, L<pod2html>, L<pod2latex>, L<pod2texi>, L<pod2text>.
|
|---|
| 2542 |
|
|---|
| 2543 | =cut
|
|---|
| 2544 |
|
|---|
| 2545 | No docs: L<pod2html>, L<pod2latex>, L<pod2texi>, L<pod2text>,
|
|---|
