This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
msgrcv: properly downgrade the receive buffer
[perl5.git] / autodoc.pl
1 #!/usr/bin/perl -w
2
3 use Text::Tabs;
4 #
5 # Unconditionally regenerate:
6 #
7 #    pod/perlintern.pod
8 #    pod/perlapi.pod
9 #
10 # from information stored in
11 #
12 #    embed.fnc
13 #    plus all the core .c, .h, and .pod files listed in MANIFEST
14 #
15 # Has an optional arg, which is the directory to chdir to before reading
16 # MANIFEST and the files
17 #
18 # This script is invoked as part of 'make all'
19 #
20 # The generated pod consists of sections of related elements, functions,
21 # macros, and variables.  The keys of %valid_sections give the current legal
22 # ones.  Just add a new key to add a section.
23 #
24 # Throughout the files read by this script are lines like
25 #
26 # =for apidoc_section Section Name
27 # =for apidoc_section $section_name_variable
28 #
29 # "Section Name" (after having been stripped of leading space) must be one of
30 # the legal section names, or an error is thrown.  $section_name_variable must
31 # be one of the legal section name variables defined below; these expand to
32 # legal section names.  This form is used so that minor wording changes in
33 # these titles can be confied to this file.  All the names of the variables
34 # end in '_scn'; this suffix is optional in the apidoc_section lines.
35 #
36 # All API elements defined between this line and the next 'apidoc_section'
37 # line will go into the section "Section Name" (or $section_name_variable),
38 # sorted by dictionary order within it.  perlintern and perlapi are parallel
39 # documents, each potentially with a section "Section Name".  Each element is
40 # marked as to which document it goes into.  If there are none for a
41 # particular section in perlapi, that section is omitted.
42 #
43 # Also, in .[ch] files, there may be
44 #
45 # =head1 Section Name
46 #
47 # lines in comments.  These are also used by this program to switch to section
48 # "Section Name".  The difference is that if there are any lines after the
49 # =head1, inside the same comment, and before any =for apidoc-ish lines, they
50 # are used as a heading for section "Section Name" (in both perlintern and
51 # perlapi).  This includes any =head[2-5].  If more than one '=head1 Section
52 # Name' line has content, they appear in the generated pod in an undefined
53 # order.  Note that you can't use a $section_name_variable in =head1 lines
54 #
55 # The next =head1, =for apidoc_section, or file end terminates what goes into
56 # the current section
57 #
58 # The %valid_sections hash below also can have header content, which will
59 # appear before any =head1 content.  The hash can also have footer content
60 # content, which will appear at the end of the section, after all the
61 # elements.
62 #
63 # The lines that define the actual functions, etc are documented in embed.fnc,
64 # because they have flags which must be kept in sync with that file.
65
66 use strict;
67 use warnings;
68
69 # 80 column terminal - 1 for pager adding a column; -7 for nroff
70 # indent;
71 my $max_width = 80 - 1 - 7;
72
73 if (@ARGV) {
74     my $workdir = shift;
75     chdir $workdir
76         or die "Couldn't chdir to '$workdir': $!";
77 }
78 require './regen/regen_lib.pl';
79 require './regen/embed_lib.pl';
80
81 my %described_elsewhere;
82
83 #
84 # See database of global and static function prototypes in embed.fnc
85 # This is used to generate prototype headers under various configurations,
86 # export symbols lists for different platforms, and macros to provide an
87 # implicit interpreter context argument.
88 #
89
90 my %docs;
91 my %seen;
92 my %funcflags;
93 my %missing;
94 my %missing_macros;
95
96 my $link_text = "Described in";
97
98 my $description_indent = 4;
99 my $usage_indent = 3;   # + initial blank yields 4 total
100
101 my $AV_scn = 'AV Handling';
102 my $callback_scn = 'Callback Functions';
103 my $casting_scn = 'Casting';
104 my $casing_scn = 'Character case changing';
105 my $classification_scn = 'Character classification';
106 my $names_scn = 'Character names';
107 my $scope_scn = 'Compile-time scope hooks';
108 my $compiler_scn = 'Compiler and Preprocessor information';
109 my $directives_scn = 'Compiler directives';
110 my $concurrency_scn = 'Concurrency';
111 my $COP_scn = 'COP Hint Hashes';
112 my $CV_scn = 'CV Handling';
113 my $custom_scn = 'Custom Operators';
114 my $debugging_scn = 'Debugging';
115 my $display_scn = 'Display functions';
116 my $embedding_scn = 'Embedding and Interpreter Cloning';
117 my $errno_scn = 'Errno';
118 my $exceptions_scn = 'Exception Handling (simple) Macros';
119 my $filesystem_scn = 'Filesystem configuration values';
120 my $floating_scn = 'Floating point configuration values';
121 my $formats_scn = 'Formats';
122 my $genconfig_scn = 'General Configuration';
123 my $globals_scn = 'Global Variables';
124 my $GV_scn = 'GV Handling';
125 my $hook_scn = 'Hook manipulation';
126 my $HV_scn = 'HV Handling';
127 my $io_scn = 'Input/Output';
128 my $integer_scn = 'Integer configuration values';
129 my $lexer_scn = 'Lexer interface';
130 my $locale_scn = 'Locales';
131 my $magic_scn = 'Magic';
132 my $memory_scn = 'Memory Management';
133 my $MRO_scn = 'MRO';
134 my $multicall_scn = 'Multicall Functions';
135 my $numeric_scn = 'Numeric Functions';
136 my $optree_construction_scn = 'Optree construction';
137 my $optree_manipulation_scn = 'Optree Manipulation Functions';
138 my $pack_scn = 'Pack and Unpack';
139 my $pad_scn = 'Pad Data Structures';
140 my $password_scn = 'Password and Group access';
141 my $paths_scn = 'Paths to system commands';
142 my $intrpvar_scn = 'Per-Interpreter Variables';
143 my $prototypes_scn = 'Prototype information';
144 my $regexp_scn = 'REGEXP Functions';
145 my $signals_scn = 'Signals';
146 my $site_scn = 'Site configuration';
147 my $sockets_scn = 'Sockets configuration values';
148 my $filters_scn = 'Source Filters';
149 my $stack_scn = 'Stack Manipulation Macros';
150 my $string_scn = 'String Handling';
151 my $SV_flags_scn = 'SV Flags';
152 my $SV_scn = 'SV Handling';
153 my $time_scn = 'Time';
154 my $typedefs_scn = 'Typedef names';
155 my $unicode_scn = 'Unicode Support';
156 my $utility_scn = 'Utility Functions';
157 my $versioning_scn = 'Versioning';
158 my $warning_scn = 'Warning and Dieing';
159 my $XS_scn = 'XS';
160
161 # Kept separate at end
162 my $undocumented_scn = 'Undocumented elements';
163
164 my %valid_sections = (
165     $AV_scn => {},
166     $callback_scn => {},
167     $casting_scn => {},
168     $casing_scn => {},
169     $classification_scn => {},
170     $scope_scn => {},
171     $compiler_scn => {},
172     $directives_scn => {},
173     $concurrency_scn => {},
174     $COP_scn => {},
175     $CV_scn => {
176         header => <<~'EOT',
177             This section documents functions to manipulate CVs which are
178             code-values, meaning subroutines.  For more information, see
179             L<perlguts>.
180             EOT
181     },
182
183     $custom_scn => {},
184     $debugging_scn => {},
185     $display_scn => {},
186     $embedding_scn => {},
187     $errno_scn => {},
188     $exceptions_scn => {},
189     $filesystem_scn => {
190         header => <<~'EOT',
191             Also see L</List of capability HAS_foo symbols>.
192             EOT
193         },
194     $floating_scn => {
195         header => <<~'EOT',
196             Also L</List of capability HAS_foo symbols> lists capabilities
197             that arent in this section.  For example C<HAS_ASINH>, for the
198             hyperbolic sine function.
199             EOT
200         },
201     $formats_scn => {
202         header => <<~'EOT',
203             These are used for formatting the corresponding type For example,
204             instead of saying
205
206              Perl_newSVpvf(pTHX_ "Create an SV with a %d in it\n", iv);
207
208             use
209
210              Perl_newSVpvf(pTHX_ "Create an SV with a " IVdf " in it\n", iv);
211
212             This keeps you from having to know if, say an IV, needs to be
213             printed as C<%d>, C<%ld>, or something else.
214             EOT
215       },
216     $genconfig_scn => {
217         header => <<~'EOT',
218             This section contains configuration information not otherwise
219             found in the more specialized sections of this document.  At the
220             end is a list of C<#defines> whose name should be enough to tell
221             you what they do, and a list of #defines which tell you if you
222             need to C<#include> files to get the corresponding functionality.
223             EOT
224
225         footer => <<~'EOT',
226
227             =head2 List of capability C<HAS_I<foo>> symbols
228
229             This is a list of those symbols that dont appear elsewhere in ths
230             document that indicate if the current platform has a certain
231             capability.  Their names all begin with C<HAS_>.  Only those
232             symbols whose capability is directly derived from the name are
233             listed here.  All others have their meaning expanded out elsewhere
234             in this document.  This (relatively) compact list is because we
235             think that the expansion would add little or no value and take up
236             a lot of space (because there are so many).  If you think certain
237             ones should be expanded, send email to
238             L<perl5-porters@perl.org|mailto:perl5-porters@perl.org>.
239
240             Each symbol here will be C<#define>d if and only if the platform
241             has the capability.  If you need more detail, see the
242             corresponding entry in F<config.h>.  For convenience, the list is
243             split so that the ones that indicate there is a reentrant version
244             of a capability are listed separately
245
246             __HAS_LIST__
247
248             And, the reentrant capabilities:
249
250             __HAS_R_LIST__
251
252             Example usage:
253
254             =over
255
256              #ifdef HAS_STRNLEN
257                use strnlen()
258              #else
259                use an alternative implementation
260              #endif
261
262             =back
263
264             =head2 List of C<#include> needed symbols
265
266             This list contains symbols that indicate if certain C<#include>
267             files are present on the platform.  If your code accesses the
268             functionality that one of these is for, you will need to
269             C<#include> it if the symbol on this list is C<#define>d.  For
270             more detail, see the corresponding entry in F<config.h>.
271
272             __INCLUDE_LIST__
273
274             Example usage:
275
276             =over
277
278              #ifdef I_WCHAR
279                #include <wchar.h>
280              #endif
281
282             =back
283             EOT
284       },
285     $globals_scn => {},
286     $GV_scn => {},
287     $hook_scn => {},
288     $HV_scn => {},
289     $io_scn => {},
290     $integer_scn => {},
291     $lexer_scn => {},
292     $locale_scn => {},
293     $magic_scn => {},
294     $memory_scn => {},
295     $MRO_scn => {},
296     $multicall_scn => {},
297     $numeric_scn => {},
298     $optree_construction_scn => {},
299     $optree_manipulation_scn => {},
300     $pack_scn => {},
301     $pad_scn => {},
302     $password_scn => {},
303     $paths_scn => {},
304     $intrpvar_scn => {},
305     $prototypes_scn => {},
306     $regexp_scn => {},
307     $signals_scn => {},
308     $site_scn => {
309         header => <<~'EOT',
310             These variables give details as to where various libraries,
311             installation destinations, I<etc.>, go, as well as what various
312             installation options were selected
313             EOT
314       },
315     $sockets_scn => {},
316     $filters_scn => {},
317     $stack_scn => {},
318     $string_scn => {
319         header => <<~EOT,
320             See also C<L</$unicode_scn>>.
321             EOT
322       },
323     $SV_flags_scn => {},
324     $SV_scn => {},
325     $time_scn => {},
326     $typedefs_scn => {},
327     $unicode_scn => {
328         header => <<~EOT,
329             L<perlguts/Unicode Support> has an introduction to this API.
330
331             See also C<L</$classification_scn>>,
332             C<L</$casing_scn>>,
333             and C<L</$string_scn>>.
334             Various functions outside this section also work specially with
335             Unicode.  Search for the string "utf8" in this document.
336             EOT
337       },
338     $utility_scn => {},
339     $versioning_scn => {},
340     $warning_scn => {},
341     $XS_scn => {},
342 );
343
344 # Somewhat loose match for an apidoc line so we can catch minor typos.
345 # Parentheses are used to capture portions so that below we verify
346 # that things are the actual correct syntax.
347 my $apidoc_re = qr/ ^ (\s*)            # $1
348                       (=?)             # $2
349                       (\s*)            # $3
350                       for (\s*)        # $4
351                       apidoc (_item)?  # $5
352                       (\s*)            # $6
353                       (.*?)            # $7
354                       \s* \n /x;
355 # Only certain flags, dealing with display, are acceptable for apidoc_item
356 my $display_flags = "fFnDopsT";
357
358 sub check_api_doc_line ($$) {
359     my ($file, $in) = @_;
360
361     return unless $in =~ $apidoc_re;
362
363     my $is_item = defined $5;
364     my $is_in_proper_form = length $1 == 0
365                          && length $2 > 0
366                          && length $3 == 0
367                          && length $4 > 0
368                          && length $6 > 0
369                          && length $7 > 0;
370     my $proto_in_file = $7;
371     my $proto = $proto_in_file;
372     $proto = "||$proto" if $proto !~ /\|/;
373     my ($flags, $ret_type, $name, @args) = split /\s*\|\s*/, $proto;
374
375     $name && $is_in_proper_form or die <<EOS;
376 Bad apidoc at $file line $.:
377   $in
378 Expected:
379   =for apidoc flags|returntype|name|arg|arg|...
380   =for apidoc flags|returntype|name
381   =for apidoc name
382 (or 'apidoc_item')
383 EOS
384
385     die "Only [$display_flags] allowed in apidoc_item:\n$in"
386                             if $is_item && $flags =~ /[^$display_flags]/;
387
388     return ($name, $flags, $ret_type, $is_item, $proto_in_file, @args);
389 }
390
391 sub embed_override($) {
392     my ($element_name) = shift;
393
394     # If the entry is also in embed.fnc, it should be defined
395     # completely there, but not here
396     my $embed_docref = delete $funcflags{$element_name};
397
398     return unless $embed_docref and %$embed_docref;
399
400     my $flags = $embed_docref->{'flags'};
401     warn "embed.fnc entry '$element_name' missing 'd' flag"
402                                             unless $flags =~ /d/;
403
404     return ($flags, $embed_docref->{'ret_type'}, $embed_docref->{args}->@*);
405 }
406
407 # The section that is in effect at the beginning of the given file.  If not
408 # listed here, an apidoc_section line must precede any apidoc lines.
409 # This allows the files listed here that generally are single-purpose, to not
410 # have to worry about the autodoc section
411 my %initial_file_section = (
412                             'av.c' => $AV_scn,
413                             'av.h' => $AV_scn,
414                             'cv.h' => $CV_scn,
415                             'doio.c' => $io_scn,
416                             'gv.c' => $GV_scn,
417                             'gv.h' => $GV_scn,
418                             'hv.h' => $HV_scn,
419                             'locale.c' => $locale_scn,
420                             'malloc.c' => $memory_scn,
421                             'numeric.c' => $numeric_scn,
422                             'opnames.h' => $optree_construction_scn,
423                             'pad.h'=> $pad_scn,
424                             'patchlevel.h' => $versioning_scn,
425                             'perlio.h' => $io_scn,
426                             'pod/perlapio.pod' => $io_scn,
427                             'pod/perlcall.pod' => $callback_scn,
428                             'pod/perlembed.pod' => $embedding_scn,
429                             'pod/perlfilter.pod' => $filters_scn,
430                             'pod/perliol.pod' => $io_scn,
431                             'pod/perlmroapi.pod' => $MRO_scn,
432                             'pod/perlreguts.pod' => $regexp_scn,
433                             'pp_pack.c' => $pack_scn,
434                             'pp_sort.c' => $SV_scn,
435                             'regcomp.c' => $regexp_scn,
436                             'regexp.h' => $regexp_scn,
437                             'unicode_constants.h' => $unicode_scn,
438                             'utf8.c' => $unicode_scn,
439                             'utf8.h' => $unicode_scn,
440                             'vutil.c' => $versioning_scn,
441                            );
442
443 sub autodoc ($$) { # parse a file and extract documentation info
444     my($fh,$file) = @_;
445     my($in, $line_num, $header, $section);
446
447     $section = $initial_file_section{$file}
448                                     if defined $initial_file_section{$file};
449
450     my $file_is_C = $file =~ / \. [ch] $ /x;
451
452     # Count lines easier
453     my $get_next_line = sub { $line_num++; return <$fh> };
454
455     # Read the file
456     while ($in = $get_next_line->()) {
457         last unless defined $in;
458
459         next unless (    $in =~ / ^ =for [ ]+ apidoc /x
460                                       # =head1 lines only have effect in C files
461                      || ($file_is_C && $in =~ /^=head1/));
462
463         # Here, the line introduces a portion of the input that we care about.
464         # Either it is for an API element, or heading text which we expect
465         # will be used for elements later in the file
466
467         my ($text, $element_name, $flags, $ret_type, $is_item, $proto_in_file);
468         my (@args, @items);
469
470         # If the line starts a new section ...
471         if ($in=~ /^ = (?: for [ ]+ apidoc_section | head1 ) [ ]+ (.*) /x) {
472
473             $section = $1;
474             if ($section =~ / ^ \$ /x) {
475                 $section .= '_scn' unless $section =~ / _scn $ /;
476                 $section = eval "$section";
477                 die "Unknown \$section variable '$section' in $file: $@" if $@;
478             }
479             die "Unknown section name '$section' in $file near line $.\n"
480                                     unless defined $valid_sections{$section};
481
482         }
483         elsif ($in=~ /^ =for [ ]+ apidoc \B /x) {   # Otherwise better be a
484                                                     # plain apidoc line
485             die "Unkown apidoc-type line '$in'" unless $in=~ /^=for apidoc_item/;
486             die "apidoc_item doesn't immediately follow an apidoc entry: '$in'";
487         }
488         else {  # Plain apidoc
489
490             ($element_name, $flags, $ret_type, $is_item, $proto_in_file, @args)
491                                                 = check_api_doc_line($file, $in);
492             # Override this line with any info in embed.fnc
493             my ($embed_flags, $embed_ret_type, @embed_args)
494                                                 = embed_override($element_name);
495             if ($embed_ret_type) {
496                 warn "embed.fnc entry overrides redundant information in"
497                     . " '$proto_in_file' in $file"
498                                                if $flags || $ret_type || @args;
499                 $flags = $embed_flags;
500                 $ret_type = $embed_ret_type;
501                 @args = @embed_args;
502             }
503             elsif ($flags !~ /[my]/)  { # Not in embed.fnc, is missing if not
504                                         # a macro or typedef
505                 $missing{$element_name} = $file;
506             }
507
508             die "flag '$1' is not legal (for function $element_name (from $file))"
509                         if $flags =~ / ( [^AabCDdEeFfhiMmNnTOoPpRrSsUuWXxy] ) /x;
510
511             die "'u' flag must also have 'm' or 'y' flags' for $element_name"
512                                             if $flags =~ /u/ && $flags !~ /[my]/;
513             warn ("'$element_name' not \\w+ in '$proto_in_file' in $file")
514                         if $flags !~ /N/ && $element_name !~ / ^ [_[:alpha:]] \w* $ /x;
515
516             if (exists $seen{$element_name} && $flags !~ /h/) {
517                 die ("'$element_name' in $file was already documented in $seen{$element_name}");
518             }
519             else {
520                 $seen{$element_name} = $file;
521             }
522         }
523
524         # Here we have processed the initial line in the heading text or API
525         # element, and have saved the important information from it into the
526         # corresponding variables.  Now accumulate the text that applies to it
527         # up to a terminating line, which is one of:
528         # 1) =cut
529         # 2) =head (in a C file only =head1)
530         # 3) an end comment line in a C file: m:^\s*\*/:
531         # 4) =for apidoc... (except apidoc_item lines)
532         $text = "";
533         my $head_ender_num = ($file_is_C) ? 1 : "";
534         while (defined($in = $get_next_line->())) {
535
536             last if $in =~ /^=cut/x;
537             last if $in =~ /^=head$head_ender_num/;
538
539             if ($file_is_C && $in =~ m: ^ \s* \* / $ :x) {
540
541                 # End of comment line in C files is a fall-back terminator,
542                 # but warn only if there actually is some accumulated text
543                 warn "=cut missing? $file:$line_num:$in" if $text =~ /\S/;
544                 last;
545             }
546
547             if ($in !~ / ^ =for [ ]+ apidoc /x) {
548                 $text .= $in;
549                 next;
550             }
551
552             # Here, the line is an apidoc line.  All but apidoc_item terminate
553             # the text being accumulated.
554             last if $in =~ / ^ =for [ ]+ apidoc_section /x;
555
556             my ($item_name, $item_flags, $item_ret_type, $is_item,
557                     $item_proto, @item_args) = check_api_doc_line($file, $in);
558             last unless $is_item;
559
560             # Here, is an apidoc_item_line; They can only come within apidoc
561             # paragraphs.
562             die "Unexpected api_doc_item line '$item_proto'"
563                                                         unless $element_name;
564
565             # We accept blank lines between these, but nothing else;
566             die "apidoc_item lines must immediately follow apidoc lines for "
567               . " '$element_name' in $file"
568                                                             if $text =~ /\S/;
569             # Override this line with any info in embed.fnc
570             my ($embed_flags, $embed_ret_type, @embed_args)
571                                                 = embed_override($item_name);
572             if ($embed_ret_type) {
573                 warn "embed.fnc entry overrides redundant information in"
574                     . " '$item_proto' in $file"
575                                 if $item_flags || $item_ret_type || @item_args;
576
577                 $item_flags = $embed_flags;
578                 $item_ret_type = $embed_ret_type;
579                 @item_args = @embed_args;
580             }
581
582             # Use the base entry flags if none for this item; otherwise add in
583             # any non-display base entry flags.
584             if ($item_flags) {
585                 $item_flags .= $flags =~ s/[$display_flags]//rg;
586             }
587             else {
588                 $item_flags = $flags;
589             }
590             $item_ret_type = $ret_type unless $item_ret_type;
591             @item_args = @args unless @item_args;
592             push @items, { name     => $item_name,
593                            ret_type => $item_ret_type,
594                            flags    => $item_flags,
595                            args     => [ @item_args ],
596                          };
597
598             # This line shows that this element is documented.
599             delete $funcflags{$item_name};
600         }
601
602         # Here, are done accumulating the text for this item.  Trim it
603         $text =~ s/ ^ \s* //x;
604         $text =~ s/ \s* $ //x;
605         $text .= "\n" if $text ne "";
606
607         # And treat all-spaces as nothing at all
608         undef $text unless $text =~ /\S/;
609
610         if ($element_name) {
611
612             # Here, we have accumulated into $text, the pod for $element_name
613             my $where = $flags =~ /A/ ? 'api' : 'guts';
614
615             $section = "Functions in file $file" unless defined $section;
616             die "No =for apidoc_section nor =head1 in $file for '$element_name'\n"
617                                                     unless defined $section;
618             if (exists $docs{$where}{$section}{$element_name}) {
619                 warn "$0: duplicate API entry for '$element_name' in"
620                     . " $where/$section\n";
621                 next;
622             }
623
624             # Override the text with just a link if the flags call for that
625             my $is_link_only = ($flags =~ /h/);
626             if ($is_link_only) {
627                 if ($file_is_C) {
628                     die "Can't currently handle link with items to it:\n$in" if @items;
629                     redo;    # Don't put anything if C source
630                 }
631
632                 # Here, is an 'h' flag in pod.  We add a reference to the pod (and
633                 # nothing else) to perlapi/intern.  (It would be better to add a
634                 # reference to the correct =item,=header, but something that makes
635                 # it harder is that it that might be a duplicate, like '=item *';
636                 # so that is a future enhancement XXX.  Another complication is
637                 # there might be more than one deserving candidates.)
638                 my $podname = $file =~ s!.*/!!r;    # Rmv directory name(s)
639                 $podname =~ s/\.pod//;
640                 $text = "Described in L<$podname>.\n";
641
642                 # Don't output a usage example for linked to documentation if
643                 # it is trivial (has no arguments) and we aren't to add a
644                 # semicolon
645                 $flags .= 'U' if $flags =~ /n/ && $flags !~ /[Us]/;
646
647                 # Keep track of all the pod files that we refer to.
648                 push $described_elsewhere{$podname}->@*, $podname;
649             }
650
651             $docs{$where}{$section}{$element_name}{flags} = $flags;
652             $docs{$where}{$section}{$element_name}{pod} = $text;
653             $docs{$where}{$section}{$element_name}{file} = $file;
654             $docs{$where}{$section}{$element_name}{ret_type} = $ret_type;
655             push $docs{$where}{$section}{$element_name}{args}->@*, @args;
656             push $docs{$where}{$section}{$element_name}{items}->@*, @items;
657         }
658         elsif ($text) {
659             $valid_sections{$section}{header} = "" unless
660                                     defined $valid_sections{$section}{header};
661             $valid_sections{$section}{header} .= "\n$text";
662         }
663
664         # We already have the first line of what's to come in $in
665         redo;
666
667     } # End of loop through input
668 }
669
670 my %configs;
671 my @has_defs;
672 my @has_r_defs;     # Reentrant symbols
673 my @include_defs;
674
675 sub parse_config_h {
676     use re '/aa';   # Everthing is ASCII in this file
677
678     # Process config.h
679     my $config_h = 'config.h';
680     $config_h = 'win32/config.h' unless -e $config_h;
681     die "Can't find $config_h" unless -e $config_h;
682     open my $fh, '<', $config_h or die "Can't open $config_h: $!";
683     while (<$fh>) {
684
685         # Look for lines like /* FOO_BAR:
686         # By convention all config.h descriptions begin like that
687         if (m[ ^ /\* [ ] ( [[:alpha:]] \w+ ) : \s* $ ]ax) {
688             my $name = $1;
689
690             # Here we are starting the description for $name in config.h.  We
691             # accumulate the entire description for it into @description.
692             # Flowing text from one input line to another is appended into the
693             # same array element to make a single flowing line element, but
694             # verbatim lines are kept as separate elements in @description.
695             # This will facilitate later doing pattern matching without regard
696             # to line boundaries on non-verbatim text.
697
698             die "Multiple config.h entries for '$name'"
699                                         if defined $configs{$name}{description};
700
701             # Get first line of description
702             $_ = <$fh>;
703
704             # Each line in the description begins with blanks followed by '/*'
705             # and some spaces.
706             die "Unexpected config.h initial line for $name: '$_'"
707                                             unless s/ ^ ( \s* \* \s* ) //x;
708             my $initial_text = $1;
709
710             # Initialize the description with this first line (after having
711             # stripped the prefix text)
712             my @description = $_;
713
714             # The first line is used as a template for how much indentation
715             # each normal succeeding line has.  Lines indented further
716             # will be considered as intended to be verbatim.  But, empty lines
717             # likely won't have trailing blanks, so just strip the whole thing
718             # for them.
719             my $strip_initial_qr = qr!   \s* \* \s* $
720                                     | \Q$initial_text\E
721                                     !x;
722             $configs{$name}{verbatim} = 0;
723
724             # Read in the remainder of the description
725             while (<$fh>) {
726                 last if s| ^ \s* \* / ||x;  # A '*/' ends it
727
728                 die "Unexpected config.h description line for $name: '$_'"
729                                                 unless s/$strip_initial_qr//;
730
731                 # Fix up the few flawed lines in config.h wherein a new
732                 # sentence begins with a tab (and maybe a space after that).
733                 # Although none of them currently do, let it recognize
734                 # something like
735                 #
736                 #   "... text").  The next sentence ...
737                 #
738                 s/ ( \w "? \)? \. ) \t \s* ( [[:alpha:]] ) /$1  $2/xg;
739
740                 # If this line has extra indentation or looks to have columns,
741                 # it should be treated as verbatim.  Columns are indicated by
742                 # use of interior: tabs, 3 spaces in a row, or even 2 spaces
743                 # not preceded by punctuation.
744                 if ($_ !~ m/  ^ \s
745                               | \S (?:                    \t
746                                     |                     \s{3}
747                                     |  (*nlb:[[:punct:]]) \s{2}
748                                    )
749                            /x)
750                 {
751                     # But here, is not a verbatim line.  Add an empty line if
752                     # this is the first non-verbatim after a run of verbatims
753                     if ($description[-1] =~ /^\s/) {
754                         push @description, "\n", $_;
755                     }
756                     else {  # Otherwise, append this flowing line to the
757                             # current flowing line
758                         $description[-1] .= $_;
759                     }
760                 }
761                 else {
762                     $configs{$name}{verbatim} = 1;
763
764                     # The first verbatim line in a run of them is separated by an
765                     # empty line from the flowing lines above it
766                     push @description, "\n" if $description[-1] =~ /^\S/;
767
768                     $_ = Text::Tabs::expand($_);
769
770                     # Only a single space so less likely to wrap
771                     s/ ^ \s* / /x;
772
773                     push @description, $_;
774                 }
775             }
776
777             push $configs{$name}{description}->@*, @description
778
779         }   # Not a description; see if it is a macro definition.
780         elsif (m! ^
781                   (?: / \* )?                   # Optional commented-out
782                                                 # indication
783                       \# \s* define \s+ ( \w+ ) # $1 is the name
784                   (   \s* )                     # $2 indicates if args or not
785                   (   .*? )                     # $3 is any definition
786                   (?: / \s* \* \* / )?          # Optional trailing /**/ or / **/
787                   $
788                 !x)
789         {
790             my $name = $1;
791
792             # There can be multiple definitions for a name.  We want to know
793             # if any of them has arguments, and if any has a body.
794             $configs{$name}{has_args} //= $2 eq "";
795             $configs{$name}{has_args} ||= $2 eq "";
796             $configs{$name}{has_defn} //= $3 ne "";
797             $configs{$name}{has_defn} ||= $3 ne "";
798         }
799     }
800
801     # We now have stored the description and information about every #define
802     # in the file.  The description is in a form convenient to operate on to
803     # convert to pod.  Do that now.
804     foreach my $name (keys %configs) {
805         next unless defined $configs{$name}{description};
806
807         # All adjacent non-verbatim lines of the description are appended
808         # together in a single element in the array.  This allows the patterns
809         # to work across input line boundaries.
810
811         my $pod = "";
812         while (defined ($_ = shift $configs{$name}{description}->@*)) {
813             chomp;
814
815             if (/ ^ \S /x) {  # Don't edit verbatim lines
816
817                 # Enclose known file/path names not already so enclosed
818                 # with <...>.  (Some entries in config.h are already
819                 # '<path/to/file>')
820                 my $file_name_qr = qr! [ \w / ]+ \.
821                                     (?: c | h | xs | p [lm] | pmc | PL
822                                         | sh | SH | exe ) \b
823                                     !xx;
824                 my $path_name_qr = qr! (?: / \w+ )+ !x;
825                 for my $re ($file_name_qr, $path_name_qr) {
826                     s! (*nlb:[ < \w / ]) ( $re ) !<$1>!gxx;
827                 }
828
829                 # Enclose <... file/path names with F<...> (but no double
830                 # angle brackets)
831                 for my $re ($file_name_qr, $path_name_qr) {
832                     s! < ( $re ) > !F<$1>!gxx;
833                 }
834
835                 # Explain metaconfig units
836                 s/ ( \w+ \. U \b ) /$1 (part of metaconfig)/gx;
837
838                 # Convert "See foo" to "See C<L</foo>>" if foo is described in
839                 # this file.  Also create a link to the known file INSTALL.
840                 # And, to be more general, handle "See also foo and bar", and
841                 # "See also foo, bar, and baz"
842                 while (m/ \b [Ss]ee \s+
843                          (?: also \s+ )?    ( \w+ )
844                          (?: ,  \s+         ( \w+ ) )?
845                          (?: ,? \s+ and \s+ ( \w+ ) )? /xg) {
846                     my @links = $1;
847                     push @links, $2 if defined $2;
848                     push @links, $3 if defined $3;
849                     foreach my $link (@links) {
850                         if ($link eq 'INSTALL') {
851                             s/ \b INSTALL \b /C<L<INSTALL>>/xg;
852                         }
853                         elsif (grep { $link =~ / \b $_ \b /x } keys %configs) {
854                             s| \b $link \b |C<L</$link>>|xg;
855                             $configs{$link}{linked} = 1;
856                             $configs{$name}{linked} = 1;
857                         }
858                     }
859                 }
860
861                 # Enclose what we think are symbols with C<...>.
862                 no warnings 'experimental::vlb';
863                 s/ (*nlb:<)
864                    (
865                         # Any word followed immediately with parens or
866                         # brackets
867                         \b \w+ (?: \( [^)]* \)    # parameter list
868                                  | \[ [^]]* \]    # or array reference
869                                )
870                     | (*plb: ^ | \s ) -D \w+    # Also -Dsymbols.
871                     | \b (?: struct | union ) \s \w+
872
873                         # Words that contain underscores (which are
874                         # definitely not text) or three uppercase letters in
875                         # a row.  Length two ones, like IV, aren't enclosed,
876                         # because they often don't look as nice.
877                     | \b \w* (?: _ | [[:upper:]]{3,} ) \w* \b
878                    )
879                     (*nla:>)
880                  /C<$1>/xg;
881
882                 # These include foo when the name is HAS_foo.  This is a
883                 # heuristic which works in most cases.
884                 if ($name =~ / ^ HAS_ (.*) /x) {
885                     my $symbol = lc $1;
886
887                     # Don't include path components, nor things already in
888                     # <>, or with trailing '(', '['
889                     s! \b (*nlb:[/<]) $symbol (*nla:[[/>(]) \b !C<$symbol>!xg;
890                 }
891             }
892
893             $pod .=  "$_\n";
894         }
895         delete $configs{$name}{description};
896
897         $configs{$name}{pod} = $pod;
898     }
899
900     # Now have converted the description to pod.  We also now have enough
901     # information that we can do cross checking to find definitions without
902     # corresponding pod, and see if they are mentioned in some description;
903     # otherwise they aren't documented.
904   NAME:
905     foreach my $name (keys %configs) {
906
907         # A definition without pod
908         if (! defined $configs{$name}{pod}) {
909
910             # Leading/trailing underscore means internal to config.h, e.g.,
911             # _GNU_SOURCE
912             next if $name =~ / ^ _ /x;
913             next if $name =~ / _ $ /x;
914
915             # MiXeD case names are internal to config.h; the first 4
916             # characters are sufficient to determine this
917             next if $name =~ / ^ [[:upper:]] [[:lower:]]
918                                  [[:upper:]] [[:lower:]]
919                             /x;
920
921             # Here, not internal to config.h.  Look to see if this symbol is
922             # mentioned in the pod of some other.  If so, assume it is
923             # documented.
924             foreach my $check_name (keys %configs) {
925                 my $this_element = $configs{$check_name};
926                 my $this_pod = $this_element->{pod};
927                 if (defined $this_pod) {
928                     next NAME if $this_pod =~ / \b $name \b /x;
929                 }
930             }
931
932             warn "$name has no documentation\n";
933             $missing_macros{$name} = 'config.h';
934
935             next;
936         }
937
938         my $has_defn = $configs{$name}{has_defn};
939         my $has_args = $configs{$name}{has_args};
940
941         # Check if any section already has an entry for this element.
942         # If so, it better be a placeholder, in which case we replace it
943         # with this entry.
944         foreach my $section (keys $docs{'api'}->%*) {
945             if (exists $docs{'api'}{$section}{$name}) {
946                 my $was = $docs{'api'}{$section}{$name}->{pod};
947                 $was = "" unless $was;
948                 chomp $was;
949                 if ($was ne "" && $was !~ m/$link_text/) {
950                     die "Multiple descriptions for $name\n"
951                         . "$section contained '$was'";
952                 }
953                 $docs{'api'}{$section}{$name}->{pod} = $configs{$name}{pod};
954                 $configs{$name}{section} = $section;
955                 last;
956             }
957         }
958
959         my $handled = 0;    # Haven't handled this yet
960
961         if (defined $configs{$name}{'section'}) {
962             # This has been taken care of elsewhere.
963             $handled = 1;
964         }
965         else {
966             my $flags = "";
967             if ($has_defn && ! $has_args) {
968                 $configs{$name}{args} = 1;
969             }
970
971             # Symbols of the form I_FOO are for #include files.  They have
972             # special usage information
973             if ($name =~ / ^ I_ ( .* ) /x) {
974                 my $file = lc $1 . '.h';
975                 $configs{$name}{usage} = <<~"EOT";
976                     #ifdef $name
977                         #include <$file>
978                     #endif
979                     EOT
980             }
981
982             # Compute what section this variable should go into.  This
983             # heuristic was determined by manually inspecting the current
984             # things in config.h, and should be adjusted as necessary as
985             # deficiencies are found.
986             #
987             # This is the default section for macros with a definiton but
988             # no arguments, meaning it is replaced unconditionally
989             #
990             my $sb = qr/ _ | \b /x; # segment boundary
991             my $dash_or_spaces = qr/ - | \s+ /x;
992             my $pod = $configs{$name}{pod};
993             if ($name =~ / ^ USE_ /x) {
994                 $configs{$name}{'section'} = $site_scn;
995             }
996             elsif ($name =~ / SLEEP | (*nlb:SYS_) TIME | TZ | $sb TM $sb /x)
997             {
998                 $configs{$name}{'section'} = $time_scn;
999             }
1000             elsif (   $name =~ / ^ [[:alpha:]]+ f $ /x
1001                    && $configs{$name}{pod} =~ m/ \b format \b /ix)
1002             {
1003                 $configs{$name}{'section'} = $formats_scn;
1004             }
1005             elsif ($name =~ /  DOUBLE | FLOAT | LONGDBL | LDBL | ^ NV
1006                             | $sb CASTFLAGS $sb
1007                             | QUADMATH
1008                             | $sb (?: IS )? NAN
1009                             | $sb (?: IS )? FINITE
1010                             /x)
1011             {
1012                 $configs{$name}{'section'} =
1013                                     $floating_scn;
1014             }
1015             elsif ($name =~ / (?: POS | OFF | DIR ) 64 /x) {
1016                 $configs{$name}{'section'} = $filesystem_scn;
1017             }
1018             elsif (   $name =~ / $sb (?: BUILTIN | CPP ) $sb | ^ CPP /x
1019                    || $configs{$name}{pod} =~ m/ \b align /x)
1020             {
1021                 $configs{$name}{'section'} = $compiler_scn;
1022             }
1023             elsif ($name =~ / ^ [IU] [ \d V ]
1024                             | ^ INT | SHORT | LONG | QUAD | 64 | 32 /xx)
1025             {
1026                 $configs{$name}{'section'} = $integer_scn;
1027             }
1028             elsif ($name =~ / $sb t $sb /x) {
1029                 $configs{$name}{'section'} = $typedefs_scn;
1030                 $flags .= 'y';
1031             }
1032             elsif (   $name =~ / ^ PERL_ ( PRI | SCN ) | $sb FORMAT $sb /x
1033                     && $configs{$name}{pod} =~ m/ \b format \b /ix)
1034             {
1035                 $configs{$name}{'section'} = $formats_scn;
1036             }
1037             elsif ($name =~ / BACKTRACE /x) {
1038                 $configs{$name}{'section'} = $debugging_scn;
1039             }
1040             elsif ($name =~ / ALLOC $sb /x) {
1041                 $configs{$name}{'section'} = $memory_scn;
1042             }
1043             elsif (   $name =~ /   STDIO | FCNTL | EOF | FFLUSH
1044                                 | $sb FILE $sb
1045                                 | $sb DIR $sb
1046                                 | $sb LSEEK
1047                                 | $sb INO $sb
1048                                 | $sb OPEN
1049                                 | $sb CLOSE
1050                                 | ^ DIR
1051                                 | ^ INO $sb
1052                                 | DIR $
1053                                 | FILENAMES
1054                                 /x
1055                     || $configs{$name}{pod} =~ m!  I/O | stdio
1056                                                 | file \s+ descriptor
1057                                                 | file \s* system
1058                                                 | statfs
1059                                                 !x)
1060             {
1061                 $configs{$name}{'section'} = $filesystem_scn;
1062             }
1063             elsif ($name =~ / ^ SIG | SIGINFO | signal /ix) {
1064                 $configs{$name}{'section'} = $signals_scn;
1065             }
1066             elsif ($name =~ / $sb ( PROTO (?: TYPE)? S? ) $sb /x) {
1067                 $configs{$name}{'section'} = $prototypes_scn;
1068             }
1069             elsif (   $name =~ / ^ LOC_ /x
1070                     || $configs{$name}{pod} =~ /full path/i)
1071             {
1072                 $configs{$name}{'section'} = $paths_scn;
1073             }
1074             elsif ($name =~ / $sb LC_ | LOCALE | langinfo /xi) {
1075                 $configs{$name}{'section'} = $locale_scn;
1076             }
1077             elsif ($configs{$name}{pod} =~ /  GCC | C99 | C\+\+ /xi) {
1078                 $configs{$name}{'section'} = $compiler_scn;
1079             }
1080             elsif ($name =~ / PASSW (OR)? D | ^ PW | ( PW | GR ) ENT /x)
1081             {
1082                 $configs{$name}{'section'} = $password_scn;
1083             }
1084             elsif ($name =~ /  SOCKET | $sb SOCK /x) {
1085                 $configs{$name}{'section'} = $sockets_scn;
1086             }
1087             elsif (   $name =~ / THREAD | MULTIPLICITY /x
1088                     || $configs{$name}{pod} =~ m/ \b pthread /ix)
1089             {
1090                 $configs{$name}{'section'} = $concurrency_scn;
1091             }
1092             elsif ($name =~ /  PERL | ^ PRIV | SITE | ARCH | BIN
1093                                 | VENDOR | ^ USE
1094                             /x)
1095             {
1096                 $configs{$name}{'section'} = $site_scn;
1097             }
1098             elsif (   $pod =~ / \b floating $dash_or_spaces point \b /ix
1099                    || $pod =~ / \b (double | single) $dash_or_spaces precision \b /ix
1100                    || $pod =~ / \b doubles \b /ix
1101                    || $pod =~ / \b (?: a | the | long ) \s+ (?: double | NV ) \b /ix)
1102             {
1103                 $configs{$name}{'section'} =
1104                                     $floating_scn;
1105             }
1106             else {
1107                 # Above are the specific sections.  The rest go into a
1108                 # grab-bag of general configuration values.  However, we put
1109                 # two classes of them into lists of their names, without their
1110                 # descriptions, when we think that the description doesn't add
1111                 # any real value.  One list contains the #include variables:
1112                 # the description is basically boiler plate for each of these.
1113                 # The other list contains the very many things that are of the
1114                 # form HAS_foo, and \bfoo\b is contained in its description,
1115                 # and there is no verbatim text in the pod or links to/from it
1116                 # (which would add value).  That means that it is likely the
1117                 # intent of the variable can be gleaned from just its name,
1118                 # and unlikely the description adds signficant value, so just
1119                 # listing them suffices.  Giving their descriptions would
1120                 # expand this pod significantly with little added value.
1121                 if (   ! $has_defn
1122                     && ! $configs{$name}{verbatim}
1123                     && ! $configs{$name}{linked})
1124                 {
1125                     if ($name =~ / ^ I_ ( .* ) /x) {
1126                         push @include_defs, $name;
1127                         next;
1128                     }
1129                     elsif ($name =~ / ^ HAS_ ( .* ) /x) {
1130                         my $canonical_name = $1;
1131                         $canonical_name =~ s/_//g;
1132
1133                         my $canonical_pod = $configs{$name}{pod};
1134                         $canonical_pod =~ s/_//g;
1135
1136                         if ($canonical_pod =~ / \b $canonical_name \b /xi) {
1137                             if ($name =~ / $sb R $sb /x) {
1138                                 push @has_r_defs, $name;
1139                             }
1140                             else {
1141                                 push @has_defs, $name;
1142                             }
1143                             next;
1144                         }
1145                     }
1146                 }
1147
1148                 $configs{$name}{'section'} = $genconfig_scn;
1149             }
1150
1151             my $section = $configs{$name}{'section'};
1152             die "Internal error: '$section' not in \%valid_sections"
1153                             unless grep { $_ eq $section } keys %valid_sections;
1154             $flags .= 'AdmnT';
1155             $flags .= 'U' unless defined $configs{$name}{usage};
1156
1157             # All the information has been gathered; save it
1158             $docs{'api'}{$section}{$name}{flags} = $flags;
1159             $docs{'api'}{$section}{$name}{pod} = $configs{$name}{pod};
1160             $docs{'api'}{$section}{$name}{ret_type} = "";
1161             $docs{'api'}{$section}{$name}{file} = 'config.h';
1162             $docs{'api'}{$section}{$name}{usage}
1163                 = $configs{$name}{usage} if defined $configs{$name}{usage};
1164             push $docs{'api'}{$section}{$name}{args}->@*, ();
1165             push $docs{'api'}{$section}{$name}{items}->@*, ();
1166         }
1167     }
1168 }
1169
1170 sub format_pod_indexes($) {
1171     my $entries_ref = shift;
1172
1173     # Output the X<> references to the names, packed since they don't get
1174     # displayed, but not too many per line so that when someone is editing the
1175     # file, it doesn't run on
1176
1177     my $text ="";
1178     my $line_length = 0;
1179     for my $name (sort dictionary_order $entries_ref->@*) {
1180         my $entry = "X<$name>";
1181         my $entry_length = length $entry;
1182
1183         # Don't loop forever if we have a verrry long name, and don't go too
1184         # far to the right.
1185         if ($line_length > 0 && $line_length + $entry_length > $max_width) {
1186             $text .= "\n";
1187             $line_length = 0;
1188         }
1189
1190         $text .= $entry;
1191         $line_length += $entry_length;
1192     }
1193
1194     return $text;
1195 }
1196
1197 sub docout ($$$) { # output the docs for one function
1198     my($fh, $element_name, $docref) = @_;
1199
1200     # Trim trailing space
1201     $element_name =~ s/\s*$//;
1202
1203     my $flags = $docref->{flags};
1204     my $pod = $docref->{pod} // "";
1205     my $file = $docref->{file};
1206
1207     my @items = $docref->{items}->@*;
1208
1209     # Make the main element the first of the items.  This allows uniform
1210     # treatment below
1211     unshift @items, {   name => $element_name,
1212                         flags => $flags,
1213                         ret_type => $docref->{ret_type},
1214                         args => [ $docref->{args}->@* ],
1215                     };
1216
1217     warn("Empty pod for $element_name (from $file)") unless $pod =~ /\S/;
1218
1219     print $fh "\n=over $description_indent\n";
1220     print $fh "\n=item C<$_->{name}>\n" for @items;
1221
1222     # If we're printing only a link to an element, this isn't the major entry,
1223     # so no X<> here.
1224     if ($flags !~ /h/) {
1225         print $fh "X<$_->{name}>" for @items;
1226         print $fh "\n";
1227     }
1228
1229     for my $item (@items) {
1230         if ($item->{flags} =~ /D/) {
1231             print $fh <<~"EOT";
1232
1233                 C<B<DEPRECATED!>>  It is planned to remove C<$item->{name}> from a
1234                 future release of Perl.  Do not use it for new code; remove it from
1235                 existing code.
1236                 EOT
1237         }
1238         elsif ($item->{flags} =~ /x/) {
1239             print $fh <<~"EOT";
1240
1241                 NOTE: C<$item->{name}> is B<experimental> and may change or be
1242                 removed without notice.
1243                 EOT
1244         }
1245     }
1246
1247     chomp $pod;     # Make sure prints pod with a single trailing \n
1248     print $fh "\n", $pod, "\n";
1249
1250     for my $item (@items) {
1251         my $item_flags = $item->{flags};
1252         my $item_name = $item->{name};
1253
1254         print $fh "\nNOTE: the C<perl_$item_name()> form is B<deprecated>.\n"
1255                                                     if $item_flags =~ /O/;
1256         # Is Perl_, but no #define foo # Perl_foo
1257         if (($item_flags =~ /p/ && $item_flags =~ /o/ && $item_flags !~ /M/)
1258
1259              # Can't handle threaded varargs
1260          || ($item_flags =~ /f/ && $item_flags !~ /T/))
1261         {
1262             $item->{name} = "Perl_$item_name";
1263             print $fh <<~"EOT";
1264
1265                 NOTE: C<$item_name> must be explicitly called as
1266                 C<$item->{name}>
1267                 EOT
1268             print $fh "with an C<aTHX_> parameter" if $item_flags !~ /T/;
1269             print $fh ".\n";
1270         }
1271     }
1272
1273     if ($flags =~ /[Uy]/) { # no usage; typedefs are considered simple enough
1274                             # to never warrant a usage line
1275         warn("U and s flags are incompatible")
1276                                             if $flags =~ /U/ && $flags =~ /s/;
1277         # nothing
1278     } else {
1279
1280         print $fh "\n=over $usage_indent\n";
1281
1282         if (defined $docref->{usage}) {     # An override of the usage section
1283             print $fh "\n", ($docref->{usage} =~ s/^/ /mrg), "\n";
1284         }
1285         else {
1286
1287             # Add the thread context formal parameter on expanded-out names
1288             for my $item (@items) {
1289                 unshift $item->{args}->@*, (($item->{args}->@*)
1290                                             ? "pTHX_"
1291                                             : "pTHX")
1292                                                    if $item->{flags} !~ /T/
1293                                                    && $item->{name} =~ /^Perl_/;
1294             }
1295
1296             # Look through all the items in this entry.  If all have the same
1297             # return type and arguments, only the main entry is displayed.
1298             # Also, find the longest return type and longest name so that if
1299             # multiple ones are shown, they can be vertically aligned nicely
1300             my $need_individual_usage = 0;
1301             my $longest_name_length = length $items[0]->{name};
1302             my $base_ret_type = $items[0]->{ret_type};
1303             my $longest_ret = length $base_ret_type;
1304             my @base_args = $items[0]->{args}->@*;
1305             for (my $i = 1; $i < @items; $i++) {
1306                 no warnings 'experimental::smartmatch';
1307                 my $item = $items[$i];
1308                 $need_individual_usage = 1
1309                                     if    $item->{ret_type} ne $base_ret_type
1310                                     || ! ($item->{args}->@* ~~ @base_args);
1311                 my $ret_length = length $item->{ret_type};
1312                 $longest_ret = $ret_length if $ret_length > $longest_ret;
1313                 my $name_length = length $item->{name};
1314                 $longest_name_length = $name_length
1315                                         if $name_length > $longest_name_length;
1316             }
1317
1318             # If we're only showing one entry, only its length matters.
1319             $longest_name_length = length($items[0]->{name})
1320                                                 unless $need_individual_usage;
1321             print $fh "\n";
1322
1323             my $indent = 1;     # 1 is sufficient for verbatim; =over is used
1324                                 # for more
1325             my $ret_name_sep_length = 2; # spaces between return type and name
1326             my $name_indent = $indent + $longest_ret;
1327             $name_indent += $ret_name_sep_length if $longest_ret;
1328
1329             my $this_max_width =
1330                                $max_width - $description_indent - $usage_indent;
1331
1332             for my $item (@items) {
1333                 my $ret_type = $item->{ret_type};
1334                 my @args = $item->{args}->@*;
1335                 my $name = $item->{name};
1336                 my $item_flags = $item->{flags};
1337
1338                 # The return type
1339                 print $fh (" " x $indent), $ret_type;
1340
1341                 print $fh " " x (  $ret_name_sep_length
1342                                  + $longest_ret - length $ret_type);
1343                 print $fh $name;
1344
1345                 if ($item_flags =~ /n/) { # no args
1346                     warn("$file: $element_name: n flag without m")
1347                                                     unless $item_flags =~ /m/;
1348                     warn("$file: $name: n flag but apparently has args")
1349                                                                     if @args;
1350                 }
1351                 else {
1352                     # +1 for the '('
1353                     my $arg_indent = $name_indent + $longest_name_length + 1;
1354
1355                     # Align the argument lists of the items
1356                     print $fh " " x ($longest_name_length - length($name));
1357                     print $fh "(";
1358
1359                     # Display as many of the arguments on the same line as
1360                     # will fit.
1361                     my $total_length = $arg_indent;
1362                     my $first_line = 1;
1363                     for (my $i = 0; $i < @args; $i++) {
1364                         my $arg = $args[$i];
1365                         my $arg_length = length($arg);
1366
1367                         # All but the first arg are preceded by a blank
1368                         my $use_blank = $i > 0;
1369
1370                         # +1 here and below because either the argument has a
1371                         # trailing comma or trailing ')'
1372                         $total_length += $arg_length + $use_blank + 1;
1373
1374                         # We want none of the arguments to be positioned so
1375                         # they extend too far to the right.  Ideally, they
1376                         # should all start in the same column as the arguments
1377                         # on the first line of the function display do.  But, if
1378                         # necessary, outdent them so that they all start in
1379                         # another column, with the longest ending at the right
1380                         # margin, like so:
1381                         #                   void  function_name(pTHX_ short1,
1382                         #                                    short2,
1383                         #                                    very_long_argument,
1384                         #                                    short3)
1385                         if ($total_length > $this_max_width) {
1386
1387                             # If this is the first continuation line,
1388                             # calculate the longest argument; this will be the
1389                             # one we may have to outdent for.
1390                             if ($first_line) {
1391                                 $first_line = 0;
1392
1393                                 # We will need at least as much as the current
1394                                 # argument
1395                                 my $longest_arg_length = $arg_length
1396                                                        + $use_blank + 1;
1397
1398                                 # Look through the rest of the args to see if
1399                                 # any are longer than this one.
1400                                 for (my $j = $i + 1; $j < @args; $j++) {
1401
1402                                     # Include the trailing ',' or ')' in the
1403                                     # length.  No need to concern ourselves
1404                                     # with a leading blank, as the argument
1405                                     # would be positioned first on the next
1406                                     # line
1407                                     my $peek_arg_length = length ($args[$j])
1408                                                         + 1;
1409                                     $longest_arg_length = $peek_arg_length
1410                                       if $peek_arg_length > $longest_arg_length;
1411                                 }
1412
1413                                 # Calculate the new indent if necessary.
1414                                 $arg_indent =
1415                                         $this_max_width - $longest_arg_length
1416                                         if $arg_indent + $longest_arg_length
1417                                                             > $this_max_width;
1418                             }
1419
1420                             print $fh "\n", (" " x $arg_indent);
1421                             $total_length = $arg_indent + $arg_length + 1;
1422                             $use_blank = 0;
1423                         }
1424
1425                         # Display this argument
1426                         print $fh " " if $use_blank;
1427                         print $fh $arg;
1428                         print $fh "," if $i < @args - 1 && $args[$i] ne 'pTHX_';
1429
1430                     } # End of loop through args
1431
1432                     print $fh ")";
1433                 }
1434
1435                 print $fh ";" if $item_flags =~ /s/; # semicolon: "dTHR;"
1436                 print $fh "\n";
1437
1438                 # Only the first entry is normally displayed
1439                 last unless $need_individual_usage;
1440             }
1441         }
1442
1443         print $fh "\n=back\n";
1444     }
1445
1446     print $fh "\n=back\n";
1447     print $fh "\n=for hackers\nFound in file $file\n";
1448 }
1449
1450 sub construct_missings_section {
1451     my ($pod_name, $missings_ref) = @_;
1452     my $text = "";
1453
1454     return $text unless $missings_ref->@*;
1455
1456     $text .= <<~EOT;
1457
1458         =head1 $undocumented_scn
1459
1460         EOT
1461     if ($pod_name eq 'perlapi') {
1462         $text .= <<~'EOT';
1463             The following functions have been flagged as part of the public
1464             API, but are currently undocumented.  Use them at your own risk,
1465             as the interfaces are subject to change.  Functions that are not
1466             listed in this document are not intended for public use, and
1467             should NOT be used under any circumstances.
1468
1469             If you feel you need to use one of these functions, first send
1470             email to L<perl5-porters@perl.org|mailto:perl5-porters@perl.org>.
1471             It may be that there is a good reason for the function not being
1472             documented, and it should be removed from this list; or it may
1473             just be that no one has gotten around to documenting it.  In the
1474             latter case, you will be asked to submit a patch to document the
1475             function.  Once your patch is accepted, it will indicate that the
1476             interface is stable (unless it is explicitly marked otherwise) and
1477             usable by you.
1478             EOT
1479     }
1480     else {
1481         $text .= <<~'EOT';
1482             The following functions are currently undocumented.  If you use
1483             one of them, you may wish to consider creating and submitting
1484             documentation for it.
1485             EOT
1486     }
1487
1488     $text .= "\n" . format_pod_indexes($missings_ref);
1489
1490     # Sort the elements.
1491     my @missings = sort dictionary_order $missings_ref->@*;
1492
1493
1494     $text .= "\n";
1495
1496     use integer;
1497
1498     # Look through all the elements in the list and see how many columns we
1499     # could place them in the output what will fit in the available width.
1500     my $min_spacer = 2;     # Need this much space between columns
1501     my $columns;
1502     my $rows;
1503     my @col_widths;
1504
1505   COLUMN:
1506     # We start with more columns, and work down until we find a number that
1507     # can accommodate all the data.  This algorithm doesn't require the
1508     # resulting columns to all have the same width.  This can allow for
1509     # as tight of packing as the data will possibly allow.
1510     for ($columns = 7; $columns > 1; $columns--) {
1511
1512         # For this many columns, we will need this many rows (final row might
1513         # not be completely filled)
1514         $rows = (@missings + $columns - 1) / $columns;
1515
1516         my $row_width = 0;
1517         my $i = 0;  # Which missing element
1518
1519         # For each column ...
1520         for my $col (0 .. $columns - 1) {
1521
1522             # Calculate how wide the column needs to be, which is based on the
1523             # widest element in it
1524             $col_widths[$col] = 0;
1525
1526             # Look through all the rows to find the widest element
1527             for my $row (0 .. $rows - 1) {
1528
1529                 # Skip if this row doesn't have an entry for this column
1530                 last if $i >= @missings;
1531
1532                 # This entry occupies this many bytes.
1533                 my $this_width = length $missings[$i];
1534
1535                 # All but the final column need a spacer between it and the
1536                 # next column over.
1537                 $this_width += $min_spacer if $col < $columns - 1;
1538
1539
1540                 # This column will need to have enough width to accommodate
1541                 # this element
1542                 if ($this_width > $col_widths[$col]) {
1543
1544                     # We can't have this many columns if the total width
1545                     # exceeds the available; bail now and try fewer columns
1546                     next COLUMN if $row_width + $this_width > $max_width;
1547
1548                     $col_widths[$col] = $this_width;
1549                 }
1550
1551                 $i++;   # The next row will contain the next item
1552             }
1553
1554             $row_width += $col_widths[$col];
1555             next COLUMN if $row_width > $max_width;
1556         }
1557
1558         # If we get this far, this many columns works
1559         last;
1560     }
1561
1562     # Here, have calculated the number of rows ($rows) and columns ($columns)
1563     # required to list the elements.  @col_widths contains the width of each
1564     # column.
1565
1566     $text .= "\n\n=over $description_indent\n\n";
1567
1568     # Assemble the output
1569     for my $row (0 .. $rows - 1) {
1570         for my $col (0 .. $columns - 1) {
1571             $text .= " " if $col == 0;  # Indent one to mark as verbatim
1572
1573             my $index = $row + $rows * $col;  # Convert 2 dimensions to 1
1574
1575             # Skip if this row doesn't have an entry for this column
1576             next if $index >= @missings;
1577
1578             my $element = $missings[$index];
1579             $text .= $element;
1580
1581             # Add alignment spaces for all but final column
1582             $text .= " " x ($col_widths[$col] - length $element)
1583                                                         if $col < $columns - 1;
1584         }
1585
1586         $text .= "\n";  # End of row
1587     }
1588
1589     $text .= "\n=back\n";
1590
1591     return $text;
1592 }
1593
1594 sub dictionary_order {
1595     # Do a case-insensitive dictionary sort, with only alphabetics
1596     # significant, falling back to using everything for determinancy
1597     return (uc($a =~ s/[[:^alpha:]]//r) cmp uc($b =~ s/[[:^alpha:]]//r))
1598            || uc($a) cmp uc($b)
1599            || $a cmp $b;
1600 }
1601
1602 sub output {
1603     my ($podname, $header, $dochash, $missings_ref, $footer) = @_;
1604     #
1605     # strip leading '|' from each line which had been used to hide
1606     # pod from pod checkers.
1607     s/^\|//gm for $header, $footer;
1608
1609     my $fh = open_new("pod/$podname.pod", undef,
1610                       {by => "$0 extracting documentation",
1611                        from => 'the C source files'}, 1);
1612
1613     print $fh $header, "\n";
1614
1615     for my $section_name (sort dictionary_order keys %valid_sections) {
1616         my $section_info = $dochash->{$section_name};
1617
1618         # We allow empty sections in perlintern.
1619         if (! $section_info && $podname eq 'perlapi') {
1620             warn "Empty section '$section_name'; skipped";
1621             next;
1622         }
1623
1624         print $fh "\n=head1 $section_name\n";
1625
1626         if ($podname eq 'perlapi') {
1627             print $fh "\n", $valid_sections{$section_name}{header}, "\n"
1628                                 if defined $valid_sections{$section_name}{header};
1629
1630             # Output any heading-level documentation and delete so won't get in
1631             # the way later
1632             if (exists $section_info->{""}) {
1633                 print $fh "\n", $section_info->{""}, "\n";
1634                 delete $section_info->{""};
1635             }
1636         }
1637
1638         if ($section_info && keys $section_info->%*) {
1639             for my $function_name (sort dictionary_order keys %$section_info) {
1640                 docout($fh, $function_name, $section_info->{$function_name});
1641             }
1642         }
1643         else {
1644             print $fh "\nThere are only public API items currently in $section_name\n";
1645         }
1646
1647         print $fh "\n", $valid_sections{$section_name}{footer}, "\n"
1648                             if $podname eq 'perlapi'
1649                             && defined $valid_sections{$section_name}{footer};
1650     }
1651
1652     print $fh construct_missings_section($podname, $missings_ref);
1653
1654     print $fh "\n$footer\n=cut\n";
1655
1656     read_only_bottom_close_and_rename($fh);
1657 }
1658
1659 foreach (@{(setup_embed())[0]}) {
1660     next if @$_ < 2;
1661     my ($flags, $ret_type, $func, @args) = @$_;
1662     s/\b(?:NN|NULLOK)\b\s+//g for @args;
1663
1664     $funcflags{$func} = {
1665                          flags => $flags,
1666                          ret_type => $ret_type,
1667                          args => \@args,
1668                         };
1669 }
1670
1671 # glob() picks up docs from extra .c or .h files that may be in unclean
1672 # development trees.
1673 open my $fh, '<', 'MANIFEST'
1674     or die "Can't open MANIFEST: $!";
1675 while (my $line = <$fh>) {
1676     next unless my ($file) = $line =~ /^(\S+\.(?:[ch]|pod))\t/;
1677
1678     # Don't pick up pods from these.  (We may pick up generated stuff from
1679     # /lib though)
1680     next if $file =~ m! ^ ( cpan | dist | ext ) / !x;
1681
1682     open F, '<', $file or die "Cannot open $file for docs: $!\n";
1683     autodoc(\*F,$file);
1684     close F or die "Error closing $file: $!\n";
1685 }
1686 close $fh or die "Error whilst reading MANIFEST: $!";
1687
1688 parse_config_h();
1689
1690 for (sort keys %funcflags) {
1691     next unless $funcflags{$_}{flags} =~ /d/;
1692     next if $funcflags{$_}{flags} =~ /h/;
1693     warn "no docs for $_\n";
1694 }
1695
1696 foreach (sort keys %missing) {
1697     warn "Function '$_', documented in $missing{$_}, not listed in embed.fnc";
1698 }
1699
1700 # List of funcs in the public API that aren't also marked as core-only,
1701 # experimental nor deprecated.
1702 my @missing_api = grep $funcflags{$_}{flags} =~ /A/
1703                     && $funcflags{$_}{flags} !~ /[xD]/
1704                     && !$docs{api}{$_}, keys %funcflags;
1705 push @missing_api, keys %missing_macros;
1706
1707 my @other_places = ( qw(perlclib perlxs), keys %described_elsewhere );
1708 my $places_other_than_intern = join ", ",
1709             map { "L<$_>" } sort dictionary_order 'perlapi', @other_places;
1710 my $places_other_than_api = join ", ",
1711             map { "L<$_>" } sort dictionary_order 'perlintern', @other_places;
1712
1713 # The S< > makes things less densely packed, hence more readable
1714 my $has_defs_text .= join ",S< > ", map { "C<$_>" } sort dictionary_order @has_defs;
1715 my $has_r_defs_text .= join ",S< > ", map { "C<$_>" } sort dictionary_order @has_r_defs;
1716 $valid_sections{$genconfig_scn}{footer} =~ s/__HAS_LIST__/$has_defs_text/;
1717 $valid_sections{$genconfig_scn}{footer} =~ s/__HAS_R_LIST__/$has_r_defs_text/;
1718
1719 my $include_defs_text .= join ",S< > ", map { "C<$_>" } sort dictionary_order @include_defs;
1720 $valid_sections{$genconfig_scn}{footer} =~ s/__INCLUDE_LIST__/$include_defs_text/;
1721
1722 my $section_list = join "\n\n", map { "=item L</$_>" }
1723                                 sort(dictionary_order keys %valid_sections),
1724                                 $undocumented_scn;  # Keep last
1725
1726 output('perlapi', <<"_EOB_", $docs{api}, \@missing_api, <<"_EOE_");
1727 |=encoding UTF-8
1728 |
1729 |=head1 NAME
1730 |
1731 |perlapi - autogenerated documentation for the perl public API
1732 |
1733 |=head1 DESCRIPTION
1734 |X<Perl API> X<API> X<api>
1735 |
1736 |This file contains most of the documentation of the perl public API, as
1737 |generated by F<embed.pl>.  Specifically, it is a listing of functions,
1738 |macros, flags, and variables that may be used by extension writers.  Besides
1739 |L<perlintern> and F<config.h>, some items are listed here as being actually
1740 |documented in another pod.
1741 |
1742 |L<At the end|/$undocumented_scn> is a list of functions which have yet
1743 |to be documented.  Patches welcome!  The interfaces of these are subject to
1744 |change without notice.
1745 |
1746 |Some of the functions documented here are consolidated so that a single entry
1747 |serves for multiple functions which all do basically the same thing, but have
1748 |some slight differences.  For example, one form might process magic, while
1749 |another doesn't.  The name of each variation is listed at the top of the
1750 |single entry.  But if all have the same signature (arguments and return type)
1751 |except for their names, only the usage for the base form is shown.  If any
1752 |one of the forms has a different signature (such as returning C<const> or
1753 |not) every function's signature is explicitly displayed.
1754 |
1755 |Anything not listed here or in the other mentioned pods is not part of the
1756 |public API, and should not be used by extension writers at all.  For these
1757 |reasons, blindly using functions listed in F<proto.h> is to be avoided when
1758 |writing extensions.
1759 |
1760 |In Perl, unlike C, a string of characters may generally contain embedded
1761 |C<NUL> characters.  Sometimes in the documentation a Perl string is referred
1762 |to as a "buffer" to distinguish it from a C string, but sometimes they are
1763 |both just referred to as strings.
1764 |
1765 |Note that all Perl API global variables must be referenced with the C<PL_>
1766 |prefix.  Again, those not listed here are not to be used by extension writers,
1767 |and can be changed or removed without notice; same with macros.
1768 |Some macros are provided for compatibility with the older,
1769 |unadorned names, but this support may be disabled in a future release.
1770 |
1771 |Perl was originally written to handle US-ASCII only (that is characters
1772 |whose ordinal numbers are in the range 0 - 127).
1773 |And documentation and comments may still use the term ASCII, when
1774 |sometimes in fact the entire range from 0 - 255 is meant.
1775 |
1776 |The non-ASCII characters below 256 can have various meanings, depending on
1777 |various things.  (See, most notably, L<perllocale>.)  But usually the whole
1778 |range can be referred to as ISO-8859-1.  Often, the term "Latin-1" (or
1779 |"Latin1") is used as an equivalent for ISO-8859-1.  But some people treat
1780 |"Latin1" as referring just to the characters in the range 128 through 255, or
1781 |sometimes from 160 through 255.
1782 |This documentation uses "Latin1" and "Latin-1" to refer to all 256 characters.
1783 |
1784 |Note that Perl can be compiled and run under either ASCII or EBCDIC (See
1785 |L<perlebcdic>).  Most of the documentation (and even comments in the code)
1786 |ignore the EBCDIC possibility.
1787 |For almost all purposes the differences are transparent.
1788 |As an example, under EBCDIC,
1789 |instead of UTF-8, UTF-EBCDIC is used to encode Unicode strings, and so
1790 |whenever this documentation refers to C<utf8>
1791 |(and variants of that name, including in function names),
1792 |it also (essentially transparently) means C<UTF-EBCDIC>.
1793 |But the ordinals of characters differ between ASCII, EBCDIC, and
1794 |the UTF- encodings, and a string encoded in UTF-EBCDIC may occupy a different
1795 |number of bytes than in UTF-8.
1796 |
1797 |The organization of this document is tentative and subject to change.
1798 |Suggestions and patches welcome
1799 |L<perl5-porters\@perl.org|mailto:perl5-porters\@perl.org>.
1800 |
1801 |The sections in this document currently are
1802 |
1803 |=over
1804
1805 |$section_list
1806 |
1807 |=back
1808 |
1809 |The listing below is alphabetical, case insensitive.
1810 _EOB_
1811 |=head1 AUTHORS
1812 |
1813 |Until May 1997, this document was maintained by Jeff Okamoto
1814 |<okamoto\@corp.hp.com>.  It is now maintained as part of Perl itself.
1815 |
1816 |With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
1817 |Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
1818 |Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
1819 |Stephen McCamant, and Gurusamy Sarathy.
1820 |
1821 |API Listing originally by Dean Roehrich <roehrich\@cray.com>.
1822 |
1823 |Updated to be autogenerated from comments in the source by Benjamin Stuhl.
1824 |
1825 |=head1 SEE ALSO
1826 |
1827 |F<config.h>, $places_other_than_api
1828 _EOE_
1829
1830 # List of non-static internal functions
1831 my @missing_guts =
1832  grep $funcflags{$_}{flags} !~ /[AS]/ && !$docs{guts}{$_}, keys %funcflags;
1833
1834 output('perlintern', <<'_EOB_', $docs{guts}, \@missing_guts, <<"_EOE_");
1835 |=head1 NAME
1836 |
1837 |perlintern - autogenerated documentation of purely B<internal>
1838 |Perl functions
1839 |
1840 |=head1 DESCRIPTION
1841 |X<internal Perl functions> X<interpreter functions>
1842 |
1843 |This file is the autogenerated documentation of functions in the
1844 |Perl interpreter that are documented using Perl's internal documentation
1845 |format but are not marked as part of the Perl API.  In other words,
1846 |B<they are not for use in extensions>!
1847
1848 |It has the same sections as L<perlapi>, though some may be empty.
1849 |
1850 _EOB_
1851 |
1852 |=head1 AUTHORS
1853 |
1854 |The autodocumentation system was originally added to the Perl core by
1855 |Benjamin Stuhl.  Documentation is by whoever was kind enough to
1856 |document their functions.
1857 |
1858 |=head1 SEE ALSO
1859 |
1860 |F<config.h>, $places_other_than_intern
1861 _EOE_