#!/usr/bin/perl -w
# Copyright 2010, 2011 Kevin Ryde
# This file is part of PodLinkCheck.
# PodLinkCheck is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# PodLinkCheck is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with PodLinkCheck. If not, see <http://www.gnu.org/licenses/>.
use 5.006;
use strict;
use warnings;
use FindBin;
my $progfile = "$FindBin::Bin/$FindBin::Script";
print $progfile,"\n";
# uncomment this to run the ### lines
use Smart::Comments;
{
my $plc = App::PodLinkCheck->new;
$plc->command_line;
exit 0;
}
{
my $plc = App::PodLinkCheck->new;
$plc->check_file ($progfile);
exit 0;
}
{
my $parser = App::PodLinkCheck::SectionParser->new;
$parser->parse_from_file ($progfile);
# $parser->parse_from_file ('/usr/share/perl/5.10/pod/perlsyn.pod');
my $sections = $parser->{'sections'};
require Data::Dumper;
print Data::Dumper->new([$sections],['args'])->Sortkeys(1)->Dump;
exit 0;
}
#------------------------------------------------------------------------------
{
package App::PodLinkCheck;
use strict;
use warnings;
sub new {
my ($class, @options) = @_;
return bless { verbose => 0,
module_path => \@INC,
executable_path => [ split /:/, $ENV{'PATH'} ],
@options }, $class;
}
sub command_line {
my ($self) = @_;
my @files = @ARGV;
while (@files) {
my $filename = shift @files;
if (-d $filename) {
### recurse dir: $filename
my @morefiles;
require File::Find;
File::Find::find ({ wanted => sub {
#### file: $_
if (! -d && /\.p(m|od)$/) {
push @morefiles, $_;
}
},
follow_fast => 1,
no_chdir => 1,
},
$filename);
unshift @files, @morefiles;
} else {
print "$filename:\n";
$self->check_file ($filename);
}
}
}
sub check_file {
my ($self, $filename) = @_;
my $parser = App::PodLinkCheck::LinkParser->new
(verbose => $self->{'verbose'});
$parser->parse_from_file ($filename);
}
}
#------------------------------------------------------------------------------
{
package App::PodLinkCheck::LinkParser;
use strict;
use warnings;
use File::Spec;
use List::Util;
BEGIN { our @ISA = ('App::PodLinkCheck::SectionParser'); }
sub new {
my $class = shift;
return $class->SUPER::new (@_,
pending_links => []);
}
# sub command {
# my ($self, $command, $text, $linenum, $paraobj) = @_;
# ### command: $command
# ### $text
# if ($command =~ /^(head|item)/) {
# $text = $self->interpolate ($text, $linenum);
# $text =~ tr/\n//d;
# ### text interpolated: $text
# $self->{'sections'}->{$text} = 1;
#
# # like Pod::Checker take the first word as a section name too, which is
# # much used for cross-references to perlfunc
# if ($text =~ s/\s.*//) {
# ### text one word: $text
# $self->{'sections'}->{$text} = 1;
# }
# }
# return '';
# }
# sub verbatim {
# return '';
# }
sub textblock {
my ($self, $text, $linenum, $paraobj) = @_;
### LinkParser textblock
return $self->interpolate ($text, $linenum);
}
sub interior_sequence {
my ($self, $command, $arg, $seq_obj) = @_;
### LinkParser interior: $command
### $arg
### seq raw_text: $seq_obj->raw_text
# ### $seq_obj
if ($command eq 'L') {
$self->check_L ($seq_obj->raw_text, $seq_obj);
}
return shift->SUPER::interior_sequence (@_);
}
sub check_L {
my ($self, $arg, $seq_obj) = @_;
require Pod::ParseLink;
my ($text, $inferred, $name, $section, $type)
= Pod::ParseLink::parselink ($arg);
### parselink: $text, $inferred, $name, $section, $type
my $linenum = ($seq_obj->file_line)[1];
if (defined $name) {
$name = $self->interpolate ($name, $linenum);
}
if ($type eq 'man') {
if (! _manpage_is_known($name)) {
$self->link_error ($seq_obj,
"unknown man page \"$name\"");
}
return;
}
($type eq 'pod') or return;
if (! defined $name) {
if (defined $section) {
push @{$self->{'pending_links'}}, [ $section, $seq_obj ];
}
return;
}
my $podfile = ($self->_module_to_podfile($name)
|| $self->_find_executable($name));
if (! defined $podfile) {
if (! _manpage_is_known($name)) {
$self->link_error ($seq_obj,
"unknown module/program/pod \"$name\"");
}
return;
}
(defined $section) or return;
$section = $self->interpolate ($section, ($seq_obj->file_line)[1]);
### interpolated section: $section
my $sections = _filename_to_sections ($podfile);
if (! exists $sections->{$section}) {
$self->link_error
($seq_obj,
"unknown section \"$section\" in \"$name\" (file $podfile)");
}
}
sub end_pod {
my ($self) = @_;
my $sections = $self->{'sections'};
foreach my $pending (@{$self->{'pending_links'}}) {
my ($section, $seq_obj) = @$pending;
if (! exists $sections->{$section}) {
$self->link_error ($seq_obj, "unknown section \"$section\"");
}
}
return '';
}
sub link_error {
my ($self, $seq_obj, $msg) = @_;
my ($filename, $linenum) = $seq_obj->file_line();
print "$filename:$linenum: $msg\n";
}
sub _module_to_podfile {
my ($self, $module) = @_;
my @moduleparts = split /::/, $module;
foreach my $suffix ('.pod', '.pm') {
foreach my $dir (@{$self->{'module_path'}}) {
foreach my $poddir ([], ['pod']) {
my $filename = (File::Spec->catfile($dir,@$poddir,@moduleparts)
. $suffix);
#### $filename
if (-e $filename) {
return $filename;
}
}
}
}
return undef;
}
sub _find_executable {
my ($self, $name) = @_;
foreach my $dir (@{$self->{'executable_path'}}) {
my $filename = File::Spec->catfile($dir,$name);
#### $filename
if (-e $filename) {
return $filename;
}
}
return undef;
}
my %sections_cache;
sub _filename_to_sections {
my ($filename) = @_;
return ($sections_cache{$filename} ||= do {
my $parser = App::PodLinkCheck::SectionParser->new;
$parser->parse_from_file ($filename);
### file sections: $parser->sections_hashref
$parser->sections_hashref;
});
}
my %manpage_is_known;
sub _manpage_is_known {
my ($name) = @_;
if (! exists $manpage_is_known{$name}) {
my $path;
require IPC::Run;
IPC::Run::run (['man', '--location', $name],
\undef, # stdin
\$path, # stdout
sub{}); # stderr
$manpage_is_known{$name} = ($path ne '');
}
return $manpage_is_known{$name};
}
}
#------------------------------------------------------------------------------
{
package App::PodLinkCheck::SectionParser;
use strict;
use warnings;
use Pod::Escapes;
use base 'Pod::Parser';
sub new {
my $class = shift;
my $self = $class->SUPER::new (@_,
sections => {});
$self->errorsub ('error_handler'); # method name
return $self;
}
sub error_handler {
my ($self, $errmsg) = @_;
return 1; # error handled
}
sub parse_from_string {
my ($self, $str) = @_;
require IO::String;
my $fh = IO::String->new ($str);
$self->parse_from_filehandle ($fh);
}
sub sections_hashref {
my ($self) = @_;
return $self->{'sections'};
}
sub command {
my ($self, $command, $text, $linenum, $paraobj) = @_;
### SectionParser command: $command
### $text
if ($command =~ /^(head|item)/) {
$text = $self->interpolate ($text, $linenum);
$text =~ tr/\n//d;
### text interpolated: $text
$text =~ s/^\s+//;
$text =~ s/\s+$//;
$self->{'sections'}->{$text} = 1;
# like Pod::Checker take the first word as a section name too, which is
# much used for cross-references to perlfunc
if ($text =~ s/\s.*//) {
### text one word: $text
$self->{'sections'}->{$text} = 1;
}
}
return '';
}
sub verbatim {
return '';
}
sub textblock {
return '';
}
BEGIN {
my %empty_interior = (L => 1,
X => 1);
sub interior_sequence {
my ($self, $command, $arg, $seq_obj) = @_;
### SectionParser interior_sequence: $command
if ($command eq 'E') {
return Pod::Escapes::e2char($arg);
}
if ($empty_interior{$command}) {
### empty
return '';
}
### return arg: $arg
return $arg;
}
}
}
# =over 4
#
# L<coE<sol>de>
#
# =cut
# =item PERL_HASH_SEED
# X<PERL_HASH_SEED>
#
# =item E<gt>
#
# =item blah Z<>
#
# =item C<code>
#
# L</C<code>>
#
# L</blah>
#
# L</no such target>
#
# L</PERL_HASH_SEED>
#
# L<AutoLoader/foo>
#
# L<AutoLoader/"foo bar">
#
# =back
#
# Pod::Man