view release on metacpan or  search on metacpan

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

    $error = $self->dict("D053",$f);
  }
  return($sectrans,$error);
}

sub lowercase {
  my($self,$f) = @_;
  my $stagedir = $self->{STAGEDIR};
  my $done;
  my $lc = lc $f;
  if ($lc eq $f) {
    $done = $self->dict("D054", $f);
  } else {
    my $targetfile = "$stagedir$lc";
    my $targetdir = dirname("$targetfile");
    File::Path::mkpath($targetdir);
    my $absfile = "$stagedir$f";
    my $ok = $self->dict(rename($absfile, $targetfile) ? "D055" : "D056");
    $done = $self->dict("D057", $f, $lc, $ok);
  }
  return $done;
}

sub delete {
  my($self,$f) = @_;
  my $stagedir = $self->{STAGEDIR};
  my $absfile = "$stagedir$f";
  my $ok = $self->dict(unlink($absfile) ? "D055" : "D056");
  return "<B>delete</B> $absfile [$ok]<BR>";
}

sub linkcheck { # no dictionary used in this subroutine
  my($self,$f,$files) = @_;
  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 {