view release on metacpan or  search on metacpan

lib/Apache/UploadSvr.pm  view on Meta::CPAN

  my $stageuri = $self->{STAGEURI};
  my($r) = $self->{R};
  my $display_method = (@$files > 1) ? "as_line" : "as_table";
  my $document_root = $self->document_root;
  my(@done,%seen);
  my($cntf,$cntn,$cnta,$try);
  my $servername = $r->server->server_hostname,
  $display_method ||= "";
  $try = "view";
  require HTML::LinkExtor;
  my $p = HTML::LinkExtor->new;
  $p->parse_file("$document_root$stageuri$f");
  my $s_uri = URI::URL->new("http://$servername$stageuri$f");
  my $b_uri = URI::URL->new("http://$servername$f");
  for my $link ($p->links) {
    my($rlink, $slink, @comment);
    my $tag = shift @$link;
    my %attr = @$link;
    my($k,$v,@attr);
    while (($k,$v) = each %attr) {
      my $x = qq{$k="$v"};
      while ($x =~ s/(.{1,35}\b)//) {
	push @attr, $1;
      }
      push @attr, $x;
    }
    my $href;
    if ($href = $attr{href} || $attr{src} || $attr{background}) {
      if ($seen{$href}++) {
	$rlink = $slink = "-";
	push @comment, "see above";
      } else {
	my $t_uri = URI::URL->new($href);
	my $found = 0;
	my $rbase = $t_uri->abs($b_uri);
	my $sbase = $t_uri->abs($s_uri);
	if ($rbase->path =~ m|^/../|) {
	  $rlink = $slink = "bad path";
	} elsif ($rbase->scheme ne "http") {
	  my $scheme = $rbase->scheme;
	  $rlink = qq{<a href="$href">$try</A>};
	  $slink = "-";
	  push @comment, qq{protocol $scheme not tested};
	  $found++;
	  $cntn++;
	} elsif ($rbase->host ne $servername) {
	  $rlink = qq{<a href="$href">$try</A>};
	  $slink = qq{-};
	  push @comment, qq{remote host not tested};
	  $found++;
	  $cntn++;
	} else {
	  # real link, stage link
	  $rlink = $slink = "needs work";
	  my $path = $rbase->path;
	  my $subr = $r->lookup_uri($path);
	  my $file = $subr->filename;
	  stat $file;
	  if (-f _ || -d _) {
	    $found++;
	    if ($rbase->frag) {
	      my $abs = $rbase->path ."#". $rbase->frag;
	      $rlink = qq{<a href="$abs">$try</A>};
	      if ($rbase->path eq $f) {
		# anchortesten?
	      }
	      $cnta++;
	      push @comment, "Real Link anchor not tested";
	    } else {
	      my $abs = $rbase->as_string;
	      $rlink = qq{<a href="$abs">$try</A>};
	      push @comment, "Real Link OK";
	    }
	  } else {
	    # could really run a subrequest
	    my $abs = $rbase->as_string;
	    $rlink = qq{file not found, try to <a href="$abs">$try</A>};
	  }
	  $path = $sbase->path;
	  stat "$document_root$path";
	  if (-f _ || -d _) {
	    $found++;
	    if ($sbase->frag) {
	      my $abs = $sbase->path ."#". $sbase->frag;
	      $slink = qq{<a href="$abs">$try</A>};
	      $cnta++;
	      push @comment, "Stage Link anchor not tested";
	    } else {
	      my $abs = $sbase->as_string;
	      $slink = qq{<a href="$abs">$try</A>};
	      push @comment, "Stage OK";
	    }
	  } else {
	    $slink = "not found";
	  }
	}
	unless ($found) {
	  $rlink = "<B>$rlink</B>";
	  $slink = "<B>$slink</B>";
	  $cntf++;
	}
      }
    } else {
      $rlink  = $slink = "no href, no src, not tested";
    }
    my $attr = join " ", @attr;
    my $comment = join ", ", @comment;
    $attr =~ s/\"/&quot;/g;
    push @done, sprintf(<<EOS,
<TR><TD>%s %s</TD><TD ALIGN=CENTER>%s</TD><TD
ALIGN=CENTER>%s</TD><TD>%s</TD></TR>
EOS
			$tag, $attr, $rlink, $slink, $comment);
  }
  if (@done) {
    unshift(@done, <<EOS);
<TABLE><TR>
<TH>Ref</TH>
<TH><I>Real</I> Link</TH>
<TH><I>Stage</I> Link</TH>
<TH>Comment</TH></TR>
EOS
    push @done, "</TABLE>\n";
  }
  my $vreport = sprintf "%d Error", $cntf;
  $vreport .= sprintf ", %d Links not tested", $cntn if $cntn;
  $vreport .= sprintf ", %d Anchor not tested", $cnta if $cnta;
  unshift(
	  @done,
	  sprintf(
		  qq{<TABLE BORDER><TR><TH>File <A HREF="%s%s">%s%s</A> }.
		  qq{%s</TH></TR><TR><TD>},
		  $stageuri,
		  $f,
		  $stageuri,
		  $f,
		  $vreport
		 ));
  push @done, "</TABLE>\n";

  if ($display_method eq "as_line") {
    return sprintf(
		   qq{<A HREF="/perl/user/up?SUBMITaction=1&}.
		   qq{ACTION=linkcheck&STAGEDFILES=%s">%s%s</A> %s<BR>},