File Coverage

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

Criterion	Covered	Total	%
statement	17	95	17.8
branch	0	22	0.0
condition			n/a
subroutine	5	15	33.3
pod	8	11	72.7
total	30	143	20.9

=head1 NAME

WWW::Link::Reporter::Text - Report on status of links in plain text

=head1 SYNOPSIS

   use WWW::Link;
   use WWW::Link::Reporter::Text;

   $link=new WWW::Link;

   #over time do things to the link ......

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

=head1 DESCRIPTION

This is a very simple class derived from WWW::Link::Reporter which provides
a report on the status of links in text for easy reading.  Nothing
much can be done other than read it.

=cut

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

@ISA = qw(WWW::Link::Reporter);

use warnings;
use strict;

use WWW::Link::Reporter;
use Carp;

sub broken {
  my $self=shift;
  my $link=shift;
  my $redir=shift;
  my $url=$link->url();
  print "broken:-       $url\n";
  $redir && $self->redirections($link);
  $self->suggestions($link);
  if ($self->{"index"}) {
    my $page_array=$self->{"index"}->lookup_second($url);
    $self->page_list ( @$page_array );
  }
}

sub not_found {
  my $self=shift;
  my $url=shift;
  print "Sorry, the link $url is not in the database.\n";
}

sub okay {
  my $self=shift;
  my $link=shift;
  my $redir=shift;
  my $url=$link->url();
  print "tested okay:-  $url\n";
  $redir && $self->redirections($link);
  $self->suggestions($link);
  if ($self->{"index"}) {
    my $page_array=$self->{"index"}->lookup_second($url);
    $self->page_list ( @$page_array );
  }
  return 1;
}

sub damaged {
  my $self=shift;
  my $link=shift;
  my $redir=shift;
  my $url=$link->url();
  print "could be broken:- $url\n";
  $redir && $self->redirections($link);
  $self->suggestions($link);
  if ($self->{"index"}) {
    my $page_array=$self->{"index"}->lookup_second($url);
    $self->page_list ( @$page_array );
  }
  return 1;
}

sub not_checked {
  my $self=shift;
  my $link=shift;
  my $url=$link->url();
  print "not yet checked:-  $url\n";
  $self->suggestions($link);
  if ($self->{"index"}) {
    my $page_array=$self->{"index"}->lookup_second($url);
    $self->page_list ( @$page_array );
  }
}

sub disallowed {
  my $self=shift;
  my $link=shift;
  my $url=$link->url();
  print "checking disallowed:-  $url\n";
  $self->suggestions($link);
  if ($self->{"index"}) {
    my $page_array=$self->{"index"}->lookup_second($url);
    $self->page_list ( @$page_array );
  }
}

sub unsupported {
  my $self=shift;
  my $link=shift;
  my $url=$link->url();
  print "unsupported protocol:-  $url\n";
  $self->suggestions($link);
  if ($self->{"index"}) {
    my $page_array=$self->{"index"}->lookup_second($url);
    $self->page_list ( @$page_array );
  }
}

sub unknown {
  my $self=shift;
  my $link=shift;
  my $url=$link->url();
  print "unknown status (error?):-  $url";
  $self->suggestions($link);
  if ($self->{"index"}) {
    my $page_array=$self->{"index"}->lookup_second($url);
    $self->page_list ( @$page_array );
  }
}


sub redirections {
  my $self=shift;
  my $link=shift;
  my @redirects=$link->redirect_urls();
  foreach my $redir ( @redirects ) {
    print "redirected to\t$redir\n";
  }
}


sub suggestions {
  my $self=shift;
  my $link=shift;
  my $suggestions=$link->fix_suggestions();
  if ($suggestions) {
    foreach my $suggest ( @{$suggestions} ) {
      print "suggest	$suggest\n";
    }
  }
  return 1;
}


sub page_list {
  my $self=shift;
  foreach (@_) {
    print "	$_\n";
  }
}

1;