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>, |
---|