1#!/usr/bin/perl -w 2 3use strict; 4use File::Find; 5 6=head1 NAME 7 8Porting/pod_lib.pl - functions for building and installing POD 9 10=head1 SYNOPSIS 11 12 require './Porting/pod_lib.pl'; 13 14=cut 15 16=head1 DESCRIPTION 17 18This program, when C<require>d into other programs in the Perl 5 core 19distribution, provides functions useful during building and, secondarily, 20testing. 21 22As of this writing, the functions in this program are used in these other 23programs: 24 25 installman 26 installperl 27 pod/buildtoc 28 pod/perl.pod 29 Porting/new-perldelta.pl 30 Porting/pod_rules.pl 31 32Note: Since these functions are used during the Perl build process, they must 33work with F<miniperl>. That necessarily implies that these functions must not 34rely on XS modules, either directly or indirectly (e.g., C<autodie>). 35 36=head1 SUBROUTINES 37 38=head2 C<my_die()> 39 40=over 4 41 42=item * Purpose 43 44Exit from a process with an error code and a message. 45 46=item * Arguments 47 48List of arguments to be passed with the error message. Example: 49 50 close $fh or my_die("close 'utils.lst': $!"); 51 52=item * Return Value 53 54Exit code C<255>. 55 56=item * Comment 57 58Prints C<ABORTED> to STDERR. 59 60=back 61 62=cut 63 64# In some situations, eg cross-compiling, we get run with miniperl, so we can't use Digest::MD5 65my $has_md5; 66BEGIN { 67 use Carp; 68 $has_md5 = eval { require Digest::MD5; Digest::MD5->import('md5'); 1; }; 69} 70 71 72# make it clearer when we haven't run to completion, as we can be quite 73# noisy when things are working ok 74 75sub my_die { 76 print STDERR "$0: ", @_; 77 print STDERR "\n" unless $_[-1] =~ /\n\z/; 78 print STDERR "ABORTED\n"; 79 exit 255; 80} 81 82=head2 C<open_or_die()> 83 84=over 4 85 86=item * Purpose 87 88Opens a file or fails if it cannot. 89 90=item * Arguments 91 92String holding filename to be opened. Example: 93 94 $fh = open_or_die('utils.lst'); 95 96=item * Return Value 97 98Handle to opened file. 99 100=back 101 102=cut 103 104sub open_or_die { 105 my $filename = shift; 106 open my $fh, '<', $filename or my_die "Can't open $filename: $!"; 107 return $fh; 108} 109 110=head2 C<slurp_or_die()> 111 112=over 4 113 114=item * Purpose 115 116Read the contents of a file into memory as a single string. 117 118=item * Arguments 119 120String holding name of file to be read into memory. 121 122 $olddelta = slurp_or_die('pod/perldelta.pod'); 123 124=item * Return Value 125 126String holding contents of file. 127 128=back 129 130=cut 131 132sub slurp_or_die { 133 my $filename = shift; 134 my $fh = open_or_die($filename); 135 binmode $fh; 136 local $/; 137 my $contents = <$fh>; 138 die "Can't read $filename: $!" unless defined $contents and close $fh; 139 return $contents; 140} 141 142=head2 C<write_or_die()> 143 144=over 4 145 146=item * Purpose 147 148Write out a string to a file. 149 150=item * Arguments 151 152List of two arguments: (i) String holding name of file to be written to; (ii) 153String holding contents to be written. 154 155 write_or_die($olddeltaname, $olddelta); 156 157=item * Return Value 158 159Implicitly returns true value upon success. 160 161=back 162 163=cut 164 165sub write_or_die { 166 my ($filename, $contents) = @_; 167 open my $fh, '>', $filename or die "Can't open $filename for writing: $!"; 168 binmode $fh; 169 print $fh $contents or die "Can't write to $filename: $!"; 170 close $fh or die "Can't close $filename: $!"; 171} 172 173=head2 C<verify_contiguous()> 174 175=over 4 176 177=item * Purpose 178 179Verify that a makefile or makefile constructor contains exactly one contiguous 180run of lines which matches a given pattern. C<croak()>s if the pattern is not 181found, or found in more than one place. 182 183By "makefile or makefile constructor" we mean a file which is one of the 184right-hand values in this list of key-value pairs: 185 186 manifest => 'MANIFEST', 187 vms => 'vms/descrip_mms.template', 188 nmake => 'win32/Makefile', 189 gmake => 'win32/GNUmakefile', 190 podmak => 'win32/pod.mak', 191 unix => 'Makefile.SH', 192 193(Currently found in C<%Targets> in F<Porting/pod_rules.pl>.) 194 195=item * Arguments 196 197=over 4 198 199=item * Name of target 200 201String holding the key of one element in C<%Targets> in F<Porting/pod_rules.pl>. 202 203=item * Contents of file 204 205String holding slurped contents of the file named in the value of the element 206in C<%Targets> in F<Porting/pod_rules.pl> named in the first argument. 207 208=item * Pattern of interest 209 210Compiled regular expression pertinent to a particular makefile constructor. 211 212=item * Name to report on error 213 214String holding description. 215 216=back 217 218=item * Return Value 219 220The contents of the file, with C<qr/\0+/> substituted for the pattern. 221 222=item * Example (drawn from F<Porting/pod_rules.pl> C<do_unix()>): 223 224 my $makefile_SH = slurp_or_die('./Makefile.SH'); 225 my $re = qr/some\s+pattern/; 226 my $makefile_SH_out = 227 verify_contiguous('unix', $makefile_SH, $re, 'copy rules'); 228 229=back 230 231=cut 232 233sub verify_contiguous { 234 my ($name, $content, $re, $what) = @_; 235 require Carp; 236 $content =~ s/$re/\0/g; 237 my $sections = () = $content =~ m/\0+/g; 238 Carp::croak("$0: $name contains no $what") if $sections < 1; 239 Carp::croak("$0: $name contains discontiguous $what") if $sections > 1; 240 return $content; 241} 242 243=head2 C<process()> 244 245=over 4 246 247=item * Purpose 248 249Read a file from disk, pass the contents to the callback, and either update 250the file on disk (if changed) or generate TAP output to confirm that the 251version on disk is up to date. C<die>s if the file contains any C<NUL> bytes. 252This permits the callback routine to use C<NUL> bytes as placeholders while 253manipulating the file's contents. 254 255=item * Arguments 256 257=over 4 258 259=item * Description for use in error messages 260 261=item * Name of file 262 263=item * Callback 264 265Passed description and file contents, should return updated file contents. 266 267=item * Test number 268 269If defined, generate TAP output to C<STDOUT>. If defined and false, generate 270an unnumbered test. Otherwise this is the test number in the I<ok> line. 271 272=item * Verbose flag 273 274If true, generate verbose output. 275 276=back 277 278=item * Return Value 279 280Does not return anything. 281 282=back 283 284=cut 285 286sub process { 287 my ($desc, $filename, $callback, $test, $verbose) = @_; 288 289 print "Now processing $filename\n" if $verbose; 290 my $orig = slurp_or_die($filename); 291 my_die "$filename contains NUL bytes" if $orig =~ /\0/; 292 293 my $new = $callback->($desc, $orig); 294 295 if (defined $test) { 296 printf "%s%s # $filename is up to date\n", 297 ($new eq $orig ? 'ok' : 'not ok'), ($test ? " $test" : ''); 298 return; 299 } elsif ($new eq $orig) { 300 print "Was not modified\n" 301 if $verbose; 302 return; 303 } 304 305 my $mode = (stat $filename)[2]; 306 my_die "Can't stat $filename: $!" 307 unless defined $mode; 308 rename $filename, "$filename.old" 309 or my_die "Can't rename $filename to $filename.old: $!"; 310 311 write_or_die($filename, $new); 312 chmod $mode & 0777, $filename or my_die "can't chmod $mode $filename: $!"; 313} 314 315=head2 C<pods_to_install()> 316 317=over 4 318 319=item * Purpose 320 321Create a lookup table holding information about PODs to be installed. 322 323=item * Arguments 324 325None. 326 327=item * Return Value 328 329Reference to a hash with a structure like this: 330 331 $found = { 332 'MODULE' => { 333 'CPAN::Bundle' => 'lib/CPAN/Bundle.pm', 334 'Locale::Codes::Script_Retired' => 335 'lib/Locale/Codes/Script_Retired.pm', 336 'Pod::Simple::DumpAsText' => 337 'lib/Pod/Simple/DumpAsText.pm', 338 # ... 339 'Locale::Codes::LangVar' => 340 'lib/Locale/Codes/LangVar.pod' 341 }, 342 'PRAGMA' => { 343 'fields' => 'lib/fields.pm', 344 'subs' => 'lib/subs.pm', 345 # ... 346 }, 347 348=item * Comment 349 350Broadly speaking, the function assembles a list of all F<.pm> and F<.pod> 351files in the distribution and then excludes certain files from installation. 352 353=back 354 355=cut 356 357sub pods_to_install { 358 # manpages not to be installed 359 my %do_not_install = map { ($_ => 1) } 360 qw(Pod::Functions XS::APItest XS::Typemap); 361 $do_not_install{"ExtUtils::XSSymSet"} = 1 362 unless $^O eq "VMS"; 363 364 my (%done, %found); 365 366 File::Find::find({no_chdir=>1, 367 wanted => sub { 368 if (m!/t\z!) { 369 ++$File::Find::prune; 370 return; 371 } 372 373 # $_ is $File::Find::name when using no_chdir 374 return unless m!\.p(?:m|od)\z! && -f $_; 375 return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-) 376 # Skip .pm files that have corresponding .pod files 377 return if s!\.pm\z!.pod! && -e $_; 378 s!\.pod\z!!; 379 s!\Alib/!!; 380 s!/!::!g; 381 382 my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'") 383 if exists $done{$_}; 384 $done{$_} = $File::Find::name; 385 386 return if $do_not_install{$_}; 387 return if is_duplicate_pod($File::Find::name); 388 $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_} 389 = $File::Find::name; 390 }}, 'lib'); 391 return \%found; 392} 393 394my %state = ( 395 # Don't copy these top level READMEs 396 ignore => { 397 # vms => 1, 398 }, 399 ); 400 401{ 402 my (%Lengths, %MD5s); 403 404 sub is_duplicate_pod { 405 my $file = shift; 406 local $_; 407 408 return if !$has_md5; 409 410 # Initialise the list of possible source files on the first call. 411 unless (%Lengths) { 412 __prime_state() unless $state{master}; 413 foreach (@{$state{master}}) { 414 next unless $_->[2]{dual}; 415 # This is a dual-life perl*.pod file, which will have be copied 416 # to lib/ by the build process, and hence also found there. 417 # These are the only pod files that might become duplicated. 418 ++$Lengths{-s $_->[1]}; 419 ++$MD5s{md5(slurp_or_die($_->[1]))}; 420 } 421 } 422 423 # We are a file in lib. Are we a duplicate? 424 # Don't bother calculating the MD5 if there's no interesting file of 425 # this length. 426 return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))}; 427 } 428} 429 430sub __prime_state { 431 my $source = 'perldelta.pod'; 432 my $filename = "pod/$source"; 433 my $contents = slurp_or_die($filename); 434 my @want = 435 $contents =~ /perldelta - what is new for perl v(\d+)\.(\d+)\.(\d+)\r?\n/; 436 die "Can't extract version from $filename" unless @want; 437 my $delta_leaf = join '', 'perl', @want, 'delta'; 438 $state{delta_target} = "$delta_leaf.pod"; 439 $state{delta_version} = \@want; 440 441 # This way round so that keys can act as a MANIFEST skip list 442 # Targets will always be in the pod directory. Currently we can only cope 443 # with sources being in the same directory. 444 $state{copies}{$state{delta_target}} = $source; 445 446 # The default flags if none explicitly set for the current file. 447 my $current_flags = ''; 448 my (%flag_set, @paths); 449 450 my $master = open_or_die('pod/perl.pod'); 451 452 while (<$master>) { 453 last if /^=begin buildtoc$/; 454 } 455 die "Can't find '=begin buildtoc':" if eof $master; 456 457 while (<$master>) { 458 next if /^$/ or /^#/; 459 last if /^=end buildtoc/; 460 my ($command, @args) = split ' '; 461 if ($command eq 'flag') { 462 # For the named pods, use these flags, instead of $current_flags 463 my $flags = shift @args; 464 my_die("Malformed flag $flags") 465 unless $flags =~ /\A=([a-z]*)\z/; 466 $flag_set{$_} = $1 foreach @args; 467 } elsif ($command eq 'path') { 468 # If the pod's name matches the regex, prepend the given path. 469 my_die("Malformed path for /$args[0]/") 470 unless @args == 2; 471 push @paths, [qr/\A$args[0]\z/, $args[1]]; 472 } elsif ($command eq 'aux') { 473 # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section 474 $state{aux} = [sort @args]; 475 } else { 476 my_die("Unknown buildtoc command '$command'"); 477 } 478 } 479 480 foreach (<$master>) { 481 next if /^$/ or /^#/; 482 next if /^=head2/; 483 last if /^=for buildtoc __END__$/; 484 485 if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) { 486 if ($action eq '+') { 487 $current_flags .= $flags; 488 } else { 489 my_die("Attempt to unset [$flags] failed - flags are '$current_flags") 490 unless $current_flags =~ s/[\Q$flags\E]//g; 491 } 492 } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) { 493 my $podname = $leafname; 494 my $filename = "pod/$podname.pod"; 495 foreach (@paths) { 496 my ($re, $path) = @$_; 497 if ($leafname =~ $re) { 498 $podname = $path . $leafname; 499 $filename = "$podname.pod"; 500 last; 501 } 502 } 503 504 # Keep this compatible with pre-5.10 505 my $flags = delete $flag_set{$leafname}; 506 $flags = $current_flags unless defined $flags; 507 508 my %flags; 509 $flags{toc_omit} = 1 if $flags =~ tr/o//d; 510 $flags{dual} = $podname ne $leafname; 511 512 $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d; 513 514 if ($flags =~ tr/r//d) { 515 my $readme = $podname; 516 $readme =~ s/^perl//; 517 $state{readmes}{$readme} = $desc; 518 $flags{readme} = 1; 519 } else { 520 $state{pods}{$podname} = $desc; 521 } 522 my_die "Unknown flag found in section line: $_" if length $flags; 523 524 push @{$state{master}}, 525 [$leafname, $filename, \%flags]; 526 527 if ($podname eq 'perldelta') { 528 local $" = '.'; 529 push @{$state{master}}, 530 [$delta_leaf, "pod/$state{delta_target}"]; 531 $state{pods}{$delta_leaf} = "Perl changes in version @want"; 532 } 533 534 } else { 535 my_die("Malformed line: $_"); 536 } 537 } 538 close $master or my_die("close pod/perl.pod: $!"); 539 540 my_die("perl.pod sets flags for unknown pods: " 541 . join ' ', sort keys %flag_set) 542 if keys %flag_set; 543} 544 545=head2 C<get_pod_metadata()> 546 547=over 4 548 549=item * Purpose 550 551Create a data structure holding information about files containing text in POD format. 552 553=item * Arguments 554 555List of one or more arguments. 556 557=over 4 558 559=item * Boolean true or false 560 561=item * Reference to a subroutine. 562 563=item * Various other arguments. 564 565=back 566 567Example: 568 569 $state = get_pod_metadata( 570 0, sub { warn @_ if @_ }, 'pod/perltoc.pod'); 571 572 get_pod_metadata( 573 1, sub { warn @_ if @_ }, values %Build); 574 575=item * Return Value 576 577Hash reference; each element provides either a list or a lookup table for 578information about various types of POD files. 579 580 'aux' => [ # utility programs like 581 'h2xs' and 'perldoc' ] 582 'generated' => { # lookup table for generated POD files 583 like 'perlapi.pod' } 584 'ignore' => { # lookup table for files to be ignored } 585 'pods' => { # lookup table in "name" => 586 "short description" format } 587 'readmes' => { # lookup table for OS-specific 588 and other READMEs } 589 'delta_version' => [ # major version number, minor no., 590 patch no. ] 591 'delta_target' => 'perl<Mmmpp>delta.pod', 592 'master' => [ # list holding entries for files callable 593 by 'perldoc' ] 594 'copies' => { # patch version perldelta => 595 minor version perldelta } 596 597=item * Comment 598 599Instances where this subroutine is used may be found in these files: 600 601 pod/buildtoc 602 Porting/new-perldelta.pl 603 Porting/pod_rules.pl 604 605=back 606 607=cut 608 609sub get_pod_metadata { 610 # Do we expect to find generated pods on disk? 611 my $permit_missing_generated = shift; 612 # Do they want a consistency report? 613 my $callback = shift; 614 local $_; 615 616 __prime_state() unless $state{master}; 617 return \%state unless $callback; 618 619 my %BuildFiles; 620 621 foreach my $path (@_) { 622 $path =~ m!([^/]+)$!; 623 ++$BuildFiles{$1}; 624 } 625 626 # Sanity cross check 627 628 my (%disk_pods, %manipods, %manireadmes); 629 my (%cpanpods, %cpanpods_leaf); 630 my (%our_pods); 631 632 # There are files that we don't want to list in perl.pod. 633 # Maybe the various stub manpages should be listed there. 634 my %ignoredpods = map { ( "$_.pod" => 1 ) } qw( ); 635 636 # Convert these to a list of filenames. 637 ++$our_pods{"$_.pod"} foreach keys %{$state{pods}}; 638 foreach (@{$state{master}}) { 639 ++$our_pods{"$_->[0].pod"} 640 if $_->[2]{readme}; 641 } 642 643 opendir my $dh, 'pod'; 644 while (defined ($_ = readdir $dh)) { 645 next unless /\.pod\z/; 646 ++$disk_pods{$_}; 647 } 648 649 # Things we copy from won't be in perl.pod 650 # Things we copy to won't be in MANIFEST 651 652 my $mani = open_or_die('MANIFEST'); 653 while (<$mani>) { 654 chomp; 655 s/\s+.*$//; 656 if (m!^pod/([^.]+\.pod)!i) { 657 ++$manipods{$1}; 658 } elsif (m!^README\.(\S+)!i) { 659 next if $state{ignore}{$1}; 660 ++$manireadmes{"perl$1.pod"}; 661 } elsif (exists $our_pods{$_}) { 662 ++$cpanpods{$_}; 663 m!([^/]+)$!; 664 ++$cpanpods_leaf{$1}; 665 $disk_pods{$_}++ 666 if -e $_; 667 } 668 } 669 close $mani or my_die "close MANIFEST: $!\n"; 670 671 # Are we running before known generated files have been generated? 672 # (eg in a clean checkout) 673 my %not_yet_there; 674 if ($permit_missing_generated) { 675 # If so, don't complain if these files aren't yet in place 676 %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}}) 677 } 678 679 my @inconsistent; 680 foreach my $i (sort keys %disk_pods) { 681 push @inconsistent, "$0: $i exists but is unknown by buildtoc\n" 682 unless $our_pods{$i} || $ignoredpods{$i}; 683 push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n" 684 if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST 685 && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i} 686 && !$state{generated}{$i} && !$cpanpods{$i}; 687 } 688 foreach my $i (sort keys %our_pods) { 689 push @inconsistent, "$0: $i is known by buildtoc but does not exist\n" 690 unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i}; 691 } 692 unless ($BuildFiles{'MANIFEST'}) { 693 # Again, ignore these if we're about to rebuild MANIFEST 694 foreach my $i (sort keys %manipods) { 695 push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n" 696 unless $disk_pods{$i}; 697 push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n" 698 if $state{generated}{$i}; 699 } 700 } 701 &$callback(@inconsistent); 702 return \%state; 703} 704 7051; 706 707# ex: set ts=8 sts=4 sw=4 et: 708