view release on metacpan or  search on metacpan

lib/App/FuguWeb/Check.pm  view on Meta::CPAN

	my ($title) = $html =~ m{<title>([^<]*)</title>};
	push @problems, "$page: has no title"
	    unless defined $title && length $title;

	for my $entry ( $self->{config}->nav ) {
		my $href = $entry->{href};

		# The chrome escapes an attribute on its way out, so the
		# search has to escape it the same way. A page below the
		# root also carries the step back, so the search reads
		# the same form that App::FuguWeb::Page writes.
		my $written = App::FuguWeb::escape_attr($href);
		$written = _base_of($page) . $written
		    unless $href =~ m{\A(?:[A-Za-z][A-Za-z0-9.+-]*:|/|\#)};

		push @problems,
		    "$page: does not carry the navigation" . " entry $href"
		    unless index( $html, qq{href="$written"} ) >= 0;
	}

	push @problems, $self->_check_references( $page, $html );

	return @problems;
}

# $self->_check_references($page, $html):
#	Every href and src of one page.
sub _check_references ( $self, $page, $html )
{
	my @problems;

	for my $ref ( map { _unescape($_) }
		$html =~ m{(?:href|src)="([^"]+)"}g )
	{

		# The host may serve the site from a path below the
		# root, where a leading slash leaves the site entirely.
		if ( $ref =~ m{^/} ) {
			push @problems, "$page: $ref is root-absolute";
			next;
		}
		if ( $ref =~ m{^file:}i ) {
			push @problems, "$page: $ref is a file: URL";
			next;
		}
		if ( $ref =~ m{^https?://} ) {
			$self->{external}{$ref} = 1;
			next;
		}
		next if $ref =~ m{^(?:mailto|news|ftp):}i;

		# A browser reads a relative URL whose first segment
		# holds a colon as a scheme, so a page named
		# Fugu::Daemon.3p.html needs its './'.
		if ( $ref =~ /^[A-Za-z][A-Za-z0-9.+-]*:/ ) {
			push @problems, "$page: $ref reads as a URL scheme;"
			    . ' a local link needs its ./';
			next;
		}

		my ( $path, $fragment ) = split /#/, $ref, 2;
		if ( defined $path && length $path ) {
			$path = _resolve( $page, $path );
			unless ( defined $path ) {
				push @problems,
				    "$page: $ref names no page of the site";
				next;
			}
		}
		else {
			$path = $page;
		}

		unless ( -e $self->{out} . "/$path" ) {
			push @problems, "$page: $ref leads nowhere";
			next;
		}
		next unless defined $fragment && length $fragment;

		my $target = Fugu::File->read( $self->{out} . "/$path" ) // '';
		push @problems, "$page: $ref has no such anchor"
		    unless $target =~ /\bid="\Q$fragment\E"/;
	}

	return @problems;
}

# _base_of($page):
#	The step back from a page to the site root. It is the empty
#	string for a page of the root, and one '../' for each
#	directory below it. App::FuguWeb::Page writes the same step in
#	front of every relative link of the chrome.
sub _base_of ($page)
{
	my $depth = () = $page =~ m{/}g;

	return '../' x $depth;
}

# _resolve($page, $ref):
#	One relative reference of a page, as a path below the output
#	directory. A site is one flat directory, so most references
#	resolve to themselves. The key directory sits below the root,
#	and a reference there is relative to its own page.
sub _resolve ( $page, $ref )
{
	my @parts = split m{/}, $page;
	pop @parts;

	for my $step ( split m{/}, $ref, -1 ) {
		next if $step eq '' || $step eq '.';
		if ( $step eq '..' ) {

			# A step above the site root names no file of
			# the output. A pop of an empty list does
			# nothing, so the reference would clamp to the
			# root and read like a link that resolves.
			return unless @parts;
			pop @parts;
			next;
		}
		push @parts, $step;
	}

	# A reference of './' names the directory of its own page, and
	# a directory is no page of a site. An empty answer also reads
	# as false in the walk of the reachability check. The walk
	# would then stop at the first page that holds one.
	return unless @parts;

	return join '/', @parts;
}

# _unescape($text):
#	Turn the four attribute entities back into their characters. A
#	reference is compared against a file name, and the file holds
#	the character and not the entity.
sub _unescape ($text)
{
	my $plain = $text;
	$plain =~ s/&lt;/</g;
	$plain =~ s/&gt;/>/g;