File Coverage

blib/lib/WWW/Link/Reporter/HTML.pm

Criterion	Covered	Total	%
statement	24	139	17.2
branch	0	24	0.0
condition			n/a
subroutine	8	26	30.7
pod	9	13	69.2
total	41	202	20.3

=head1 NAME

WWW::Link::Reporter::HTML - Report on status of links in HTML

=head1 SYNOPSIS

    use WWW::Link;
    use WWW::Link::Reporter::HTML;

    $link=new WWW::Link;
    #over time do things to the link ......

    $::reporter=new WWW::Link::Reporter::HTML;
    $::reporter->examine($link)

or see WWW::Link::Selector for a way to recurse through all of the links.

=head1 DESCRIPTION

This class will output information about any link that it is given.

If it's constructor is given an index (CDB_File::BiIndex or BiIndex) then it
can use that to generate lists of urls containing links being reported
on.

=cut

package WWW::Link::Reporter::HTML;
$REVISION=q$Revision: 1.7 $ ; $VERSION = sprintf ( "%d.%02d", $REVISION =~ /(\d+).(\d+)/ );

use WWW::Link;
use HTML::Stream;
use WWW::Link::Reporter;
@ISA=qw(WWW::Link::Reporter);
use warnings;
use strict;

=head1 new

This

=cut

sub new ($$;$){
  my ($class,$stream, $index)=@_;
  my $self=WWW::Link::Reporter::new($class, $index);
  $self->{"hstr"} = new HTML::Stream::LinkReport $stream;
  $self->{"docurl"} = "http://localhost/linkcontroler/docs/";
  return $self;
}

sub heading ($) {
  my $self=shift;
  $self->{"hstr"}->Heading;
}

sub footer ($) {
  my $self=shift;
  $self->{"hstr"}->Footer;
}

sub not_found  {
  my $self=shift;
  my $url=shift;
  $self->{"hstr"}-> P
                 -> t("Sorry, the link $url is not in the database.\n")
		 -> _P;
}

sub broken  {
  my ($self, $link, $redir)=@_;

  my $url=$link->url();
  my $hstr=$self->{"hstr"};

  $hstr-> P;

  $hstr -> STRONG -> nl
        ->Link_Heading($url, "Link found BROKEN")
	-> _STRONG -> nl;

  $redir && $self->redirections($link);
  $self->suggestions($link);

  if ($self->{"index"}) {
    $hstr->page_list( $self->{"index"}->lookup_second($url) );
  }

  $hstr-> _P;
}

sub okay  {
  my ($self, $link, $redir)=@_;

  my $url=$link->url();
  my $hstr=$self->{"hstr"};

  $hstr -> P;

  $hstr->Link_Heading($url, "Link tested okay");

  $redir && $self->redirections($link);
  $self->suggestions($link);

  if ($self->{"index"}) {
    $hstr->page_list( $self->{"index"}->lookup_second($url) );
  }

  $hstr -> _P;
}

sub damaged  {
  my ($self, $link, $redir)=@_;

  my $url=$link->url();
  my $hstr=$self->{"hstr"};

  $hstr -> P;

  $hstr->Link_Heading($url, "Link may be broken");

  $redir && $self->redirections($link);
  $self->suggestions($link);

  if ($self->{"index"}) {
    $hstr->page_list( $self->{"index"}->lookup_second($url) );
  }

  $hstr -> _P;
}

sub not_checked  {
  my ($self, $link )=@_;

  my $url=$link->url();
  my $hstr=$self->{"hstr"};

  $hstr -> P;

  $hstr->Link_Heading($url, "Link not yet checked");

  $self->suggestions($link);

  if ($self->{"index"}) {
    $hstr->page_list( $self->{"index"}->lookup_second($url) );
  }

  $hstr -> _P;
}

sub disallowed  {
  my ($self, $link)=@_;

  my $url=$link->url();
  my $hstr=$self->{"hstr"};

  $hstr -> P;

  $hstr->Link_Heading($url, "Link checking not allowed");

  $self->suggestions($link);

  if ($self->{"index"}) {
    $hstr->page_list( $self->{"index"}->lookup_second($url) );
  }

  $hstr -> _P;
}

sub unsupported  {
  my ($self, $link)=@_;

  my $url=$link->url();
  my $hstr=$self->{"hstr"};

  $hstr -> P;

  $hstr->Link_Heading($url, "Link uses unsupported protocol");

  $self->suggestions($link);

  if ($self->{"index"}) {
    $hstr->page_list( $self->{"index"}->lookup_second($url) );
  }

  $hstr -> _P;
}

sub unknown  {
  my ($self, $link)=@_;

  my $url=$link->url();
  my $hstr=$self->{"hstr"};

  $hstr -> P;

  $hstr->Link_Heading($url, "Link status unknown; error?");

  $self->suggestions($link);

  if ($self->{"index"}) {
    $hstr->page_list( $self->{"index"}->lookup_second($url) );
  }

  $hstr -> _P;
}

#we should separately deal with temporary redirections (generally
#ignored) and long term redirections (should generally be applied)

sub redirections  {
  my ($self, $link)=@_;

  my $hstr=$self->{"hstr"};

  my @redirects=$link->redirect_urls();
  if (@redirects) {
    $hstr -> DL;
    foreach my $redir ( @redirects ) {
       $hstr -> DT -> t("redirected to") -> _DT
             -> DD -> Link($redir) -> _DD -> nl;
    }
    $hstr -> _DL;
  }
}

sub suggestions  {
  my ($self, $link)=@_;
  my $hstr=$self->{"hstr"};

  $hstr -> DL;

  my $suggest;
  my $suggestions=$link->fix_suggestions();
  if ($suggestions) {
    foreach $suggest ( @{$suggestions} ) {
      $hstr -> DT -> t("suggest:") -> _DT
            -> DD -> Link($suggest) -> _DD -> nl;
    }
  }
  $hstr -> _DL;

}

package HTML::Stream::LinkReport;

our @ISA;
@ISA=qw(HTML::Stream);

use warnings;
use strict;

use HTML::Stream;

sub Heading {
  my $self=shift;
  $self->HTML
       ->HEAD
       ->TITLE ->t("Link Controller Report.") -> _TITLE
       ->_HEAD
       ->BODY
       ->H1 ->t("Report Contents") -> _H1;
  return $self;
}

sub Footer {
  my $self=shift;
  $self->_BODY
       ->_HTML;
  return $self;
}

=head2 Link_heading

This function simply prints a heading for a link with the url and text
given as arguments.

=cut

sub Link_Heading ($$$) {
  my ($self, $url, $text) = @_;
  $self -> nl->H2 -> t($text . " ")
	-> Link($url)-> _H2->nl;
}

=head2 page_list

This takes a list of urls as an argument and generates a unnumbered
html list consisting of those urls inside links to those urls.  It is
for use for refering to pages on which urls occur.

Obviously, if the URLs are file urls, then the machine they are being
read on must be the same as the one the file urls refer to.

=cut

sub page_list {
  my $self=shift;
  my $array=shift;
  $self->UL;
  foreach (@$array) {
    $self -> LI
      -> Link($_)
	-> _LI -> nl;
  }
  $self->_UL;
  return $self;
}

=head2 $LR->Link()

This method puts out a url inside a link refering to that url.  I
don't want to encourage this for general use: it's much better to use
a description generally.  This program, however, deals directly with
links so it suits us here.

=cut

sub Link {
  my $self=shift;
  my $url=shift;
  $self -> A(HREF=>$url)
	-> t($url)
	-> _A  ;
  return $self;
}