Apache::UploadSvr - A Lightweight Publishing System for Apache

  PerlSetVar Auth_DBI_data_source dbi:mSQL:authen
  PerlSetVar Auth_DBI_pwd_table   usertable
  PerlSetVar Auth_DBI_grp_table   grouptable
  PerlSetVar Auth_DBI_uid_field   user
  PerlSetVar Auth_DBI_grp_field   group
  PerlSetVar Auth_DBI_pwd_field   password
  PerlSetVar stageuri /STAGE
  PerlSetVar Apache_UploadSvr_Usermgr "Apache::UploadSvr::User"
  PerlSetVar Apache_UploadSvr_myuri /perl/user/up
  PerlSetVar Apache_UploadSvr_transdir /usr/local/apache/trans
  PerlSetVar Apache_UploadSvr_trashdir /usr/local/apache/trash




  <Files "...">
    PerlSetVar DirCache .dircache
    SetHandler perl-script
    PerlHandler Apache::UploadSvr::Directory
    AuthName stadtplandienst
    AuthType Basic
    PerlAuthenHandler Apache::AuthenDBI
    require valid-user
  </Files>

  <Location /perl/user/up>
    PerlHandler Apache::UploadSvr
  </Location>

#!/usr/local/bin/perl

package Apache::UploadSvr;

use Apache::Constants qw(DECLINED OK SERVER_ERROR);
use CGI;
warn sprintf "%s", $INC{"CGI.pm"};
use Cwd;
use DirHandle;
use ExtUtils::Manifest;
use File::Basename qw(basename dirname);
use File::Find;
use File::Path ();
use HTML::FormatText ();
use HTML::Parse 'parse_html';
use HTTP::Date;
use IO::File;
use Mail::Send;
use URI::URL;
use Apache::UploadSvr::Dictionary;

use strict;
use vars qw( @Legalactions %Legalactions $VERSION);

$VERSION = sprintf "%d.%03d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/;

@Legalactions = qw/publish unzip lowercase linkcheck delete/;
%Legalactions = (
		 'delete'    => "D002",
		 'publish'   => "D003",
		 'unzip'     => "D004",
		 'lowercase' => "D005",
		 'linkcheck' => "D006",
		);

sub time {
  my($self) = @_;
  $self->{TIME} ||= sprintf "%010d", time;
}

sub new {
  my($class,%arg) = @_;
  bless {%arg}, $class;
}

sub dict {
  my($self,$code,@arg) = @_;
  my $lang = $self->language;
  Apache::UploadSvr::Dictionary->fetch($lang,$code,@arg);
}

sub language {
  my($self) = @_;
  return $self->{LANGUAGE} if exists $self->{LANGUAGE};

  my(%lang_wanted,$lang_match);
  my($default_weight) = 1;
  foreach my $e ( split /,/, $self->{R}->header_in('Accept-Language') ) { # de-DE,en,de,ja,hr 
    my($l,$v) = $e =~ / ^ \s* ([\w\-]+) \s* (.*) /x;
    my($q) = $v =~ / ^ ; \s* q \s* = \s* ([\d\.]+) /x;
    $q ||= $default_weight;
    $default_weight -= 0.0001;
    $lang_wanted{$l} = $q;
  }
  for my $l (sort {$lang_wanted{$b} <=> $lang_wanted{$a}}
	     keys %lang_wanted){
    if (Apache::UploadSvr::Dictionary->exists($l)) {
      $lang_match = $l;
    } elsif (Apache::UploadSvr::Dictionary->exists(substr($l,0,2))) {
      $lang_match = substr($l,0,2);
    } else {
      next;
    }
    last;
  }
  $lang_match ||= "de";
  $self->{LANGUAGE} = $lang_match;
}

sub handler {
  my($r) = @_;
  # local($/) = "\n";
  my $cgi = CGI->new;
  my $self = __PACKAGE__->new( 
			      CGI => $cgi,
			      R => $r,
			      USERCLASS => $r->dir_config("Apache_UploadSvr_Usermgr") || "Apache::UploadSvr::User"
			     );
  $self->dispatch;
}

sub as_string {
  my($self) = @_;
  require Data::Dumper;
  join "", "<PRE>", Data::Dumper::Dumper($self), "</PRE>\n";
}

sub dispatch {
  my($self) = @_;
  my $r = $self->{R};
  my $cgi = $self->{CGI};

  my($filename, $content,$stagedir,$stageuri,$what_we_did,
     $sectrans,$transdir);

  my $document_root = $self->document_root;
  my $time = $self->time;
  eval "require $self->{USERCLASS};"; # there are more efficient ways...
  no strict "refs";
  my $userref = $self->{USERCLASS}->new($self);
  $self->{USERREF} = $userref;
  return SERVER_ERROR unless exists $userref->{user};

  $stageuri = $r->dir_config("stageuri") || "/STAGE";
  $stagedir = "$document_root$stageuri";
  $stageuri .= "/$userref->{user}";
  $stagedir .= "/$userref->{user}";
  $self->{STAGEURI} = $stageuri;
  $self->{STAGEDIR} = $stagedir;

  $userref->{permitted} ||= [];

  if ($r->method eq "PUT") {
    my $uri = $r->uri;
    #  $uri =~ s|/STAGE||;
    # I have never tried if PUT works this way or not. Code is just a
    # placeholder
    $r->read($content, $r->header_in("Content-length"));
    $filename = $stagedir . $uri;
  } elsif ($r->method eq "POST" or $r->method eq "GET") {
    if ( $cgi->param('SUBMITup')) {
      my($handle,$targetdir);
      if ($handle = $cgi->param('HTTPUPLOAD')) {
	$targetdir = $cgi->param('TARGETDIR') || "/";
	no strict;
	local $/;
	$content = <$handle>;
	close $handle;
	$handle =~ s(.*\/)();      # no slash
	$handle =~ s(.*\\)();     # no backslash
	$handle =~ s(.*:)();      # no colon
	$filename = "$stagedir$targetdir/$handle";
	#      warn "filename[$filename]";
	$filename =~ s|/+|/|g;
      } else {
	$what_we_did = $self->dict('D007');
      }
    } elsif ($cgi->param('SUBMITaction')) {
      my $action = $cgi->param('ACTION');
      if ($action) {
	$what_we_did = "";
	my(@files,$allflag);
	my(@stagedfiles) = $cgi->param('STAGEDFILES');
	warn "stagedfiles[@stagedfiles]";
	for my $f (@stagedfiles) {
	  if ($f eq " ALL") {
	    $allflag++;
	    last;
	  }
	  push @files, $f;
	}
	if ($allflag) {
	  chdir $stagedir;
	  my $manifind = ExtUtils::Manifest::manifind();
	  @files = map { "/$_" } keys %$manifind;
	}
	if (@files) {
	  for my $f (@files) {
	    if (index($f,"../")>=0) {
	      $what_we_did .= $self->dict("D008",$f);
	      next;
	    }
	    unless (-f "$stagedir$f"){
	      $what_we_did .= $self->dict("D009",$f);
	      next;
	    }
	    if ($action eq "publish") {
	      my($done,$error) = $self->publish($f);
	      if ($done) {
		$sectrans .= $done;
	      } else {
		$what_we_did .= $error;
	      }
	    } elsif ($self->can($action)) {
	      if (exists $Legalactions{$action}) {
		$what_we_did .= $self->$action($f,\@files);
	      } else {
		$what_we_did .= $self->dict("D010",$action);
	      }
	    } else {
	      $what_we_did .= $self->dict("D058",$action);
	    }
	  } # for @files
	  $what_we_did = $self->secure_transaction($sectrans) if $sectrans;
	} else { # no files
	  $what_we_did = $self->dict("D011",$action);
	}
      } else { # no action
	$what_we_did = $self->dict("D012",$self->dict("D013"));
      }
    } elsif ($cgi->param("SUBMITtrans")) {
      $what_we_did = $self->transhandler();
    }
  }

  # warn "filename[$filename] content[$content]";
  if ($filename && $content) {
    my $tdir = dirname($filename);
    File::Path::mkpath($tdir);
    my $fh;
    $fh = IO::File->new or die "Could not open new filehandle: $!";
    unless ($fh->open(">$filename")) {
      $r->log_error("Couldn't open >$filename: $!");
      return SERVER_ERROR;
    }
    $fh->print($content);
    $fh->close;
    #  $filename =~ s|.*?/STAGE/[^/]+(.*)|/STAGE$1|;
    my $basename = basename($filename);
    my $dirname = substr(dirname($filename),length($document_root));
    $what_we_did = $self->dict("D014",$dirname,$basename,$basename,$dirname);
  }

  my($file_listing,$manifind);
  if (
      chdir $stagedir and
      $manifind = ExtUtils::Manifest::manifind() and
      %$manifind
     ) {
    my(%legalactions);
    while (my($k,$v) = each %Legalactions) {
      $legalactions{$k} = $self->dict($v);
    }
    my $actions = $cgi->
	scrolling_list(
		       -name    => 'ACTION', 
		       'values' => [@Legalactions],
		       default  => [],
		       size     => 5,
		       labels   => \%legalactions,
		      );

    my $submit = $cgi->submit(
			      -name=>'SUBMITaction',
			      value=> $self->dict("D013")
			     );

    my(@m);
    push @m, $self->dict("D015", $self->dict("D013")), $actions, $submit;
    push @m, qq{<BR> <TABLE BORDER=1 CELLPADDING=8 };
    push @m, qq{CELLSPACING=2> <TR VALIGN=BOTTOM> <TH>};
    push @m, $self->dict("D016");
    push @m, qq{</TH><TH>};
    push @m, $self->dict("D017");
    push @m, qq{</TH> <TH> </TH> <TH>};
    push @m, $self->dict("D018");
    push @m, qq{</TH><TH>};
    push @m, $self->dict("D019");
    push @m, qq{</TH> </TR>};

    my(@rows);
    for my $f (sort keys %$manifind) {
      my @stat = stat $f;
      push @rows, [
		   qq{/$f},
		   qq{$userref->{user}},
		   qq{$stat[7]},
		   time2str($stat[9]),
		  ];
    }
    unshift @rows, [" ALL"];
    my(%dirlisting,@dirlisting);
    @dirlisting = map {$_->[0]} @rows;
    @dirlisting{@dirlisting} = (" ") x @dirlisting;
    my(@chkbox) = split /<BR>/, $cgi->checkbox_group(
						     -name => 'STAGEDFILES',
						     'values' => \@dirlisting,
						     linebreak=>'true',
						     labels=> \%dirlisting
				    );

    for my $e (0..$#rows) {
      push @m, "<TR>";
      my @l = @{$rows[$e]};
      if ($l[0] eq " ALL") {
	push @m, sprintf(
			 "<TD ALIGN=RIGHT>%s</TD><TD COLSPAN=4>%s</TD>",
			 $chkbox[$e],
			 "perform above selected action on all files below"
			);
      } else {
	push @m, sprintf(
			 qq{<TD ALIGN=RIGHT>%s</TD><TD> %s </TD><TD><A HREF="/STAGE/%s%s">view</A></TD><TD ALIGN=RIGHT> %d </TD><TD> %s </TD>},
			 $chkbox[$e],
			 @l[0,1,0,2,3]
			);
      }
      push @m, qq{</TR>};
    }
  push @m, "</TABLE>";

  $file_listing = join "", @m;
} else {
  $file_listing = $self->dict("D020");
  }
    
  File::Find::finddepth( sub {
			   return unless -d $_;
			   rmdir $_; # may fail
			 }, $stagedir);

    
$r->content_type("text/html");
  $r->send_http_header;
    
  my(@m);
push @m, $cgi->start_html(
			    -title => $self->dict("D021"),
			    author => 'andreas.koenig@kulturbox.de'
			   );
if ($time - $userref->{lastlogin} > 7200) {
    push @m, $self->hello;
  }
  $userref->{lastlogin} = $time;
  if ($what_we_did) {
    unless (  $what_we_did =~ /^<TABLE/ ) {
      $what_we_did =~ s/^/<TABLE BORDER=2><TR><TD>/;
      $what_we_did =~ s|$|</TD></TR></TABLE>|;
    }
  } else {
    $what_we_did = "<HR>";
  }
  push @m, $what_we_did;
  push @m, $self->upload_form;
  push @m, qq{<HR><H4>Delete, Unzip, Publish, etc.</H4>};
  push @m, $file_listing;
  push @m, "<HR>";
  # push @m, $self->as_string;
  push @m, $cgi->endform;
  push @m, $cgi->end_html;
  $cgi->print(@m);
}

sub secure_transaction {
  my($self,$sectrans) = @_;
  my $r = $self->{R}; # attn: Directory.pm calls this with a different $self
  my($userref) = $self->{USERREF};

  my($what_we_did);
  my $script_name = $r->dir_config("Apache_UploadSvr_myuri");
  unless ($script_name) {
    # script_name may be different from this script_name
    $script_name = $r->path_info ?
	substr($r->uri, 0, length($r->uri)-length($r->path_info)) :
	    $r->uri;
  }
  my $me_url = URI::URL->new(
			     "http://" .
			     $r->server->server_hostname .
			     $script_name)->as_string;
  my $secret = 100000 + int rand 900000;
  my $secretfile;
  my $transdir = $r->dir_config('Apache_UploadSvr_transdir');
  unless ($transdir) {
    $r->log_error("No Apache_UploadSvr_transdir specified. Setting to /tmp");
    $transdir = "/tmp";
  }
  $secret++ while -f ($secretfile = "$transdir/$userref->{user}$secret");
  my $fh = IO::File->new(">$secretfile") or 
      die "Couldn't create secretfile $secretfile: $!";
  my $plural = split(/\n/, $sectrans) > 1;
  my $mailtext = join("\n",
		      $self->dict($plural ? "D025" : "D024"),
		      $sectrans,
		      $self->dict("D026"),
		      "  $me_url?SUBMITtrans=$secret",
		     );
  $fh->print($sectrans);
  $fh->close;
  my($msg) = Mail::Send
      ->new(
	    "Subject" => $self->dict("D027"),
	    "To" => qq{"$userref->{fullname}" <$userref->{email}>}
	   );
  my $from = $r->dir_config("Apache_UploadSvr_from");
  $msg->add("From",$from) if $from;
  my $sendh = $msg->open or $r->log_error("Could not open sendmail");
  $sendh->print($mailtext);
  $what_we_did = <<EOS;
<TABLE BORDER=2 CELLPADDING=5><TR><TD BGCOLOR="#ff8888">
EOS

  if ($sendh->close) {
    warn "Uploader sent mail to $userref->{email} and closed successfully";
    $what_we_did .= $self->dict("D028", $userref->{email});
  } else {
    warn "Uploader tried to send mail, but...: $!";
    $what_we_did .= $self->dict("D029", $!);
  }
  $what_we_did .= qq{</TD></TR></TABLE>};
  $what_we_did;
}

sub upload_form {
  my($self) = @_;
  my $cgi = $self->{CGI};
  my $r = $self->{R};
  my($userref) = $self->{USERREF};

  my(@m);
  push @m, $cgi->start_multipart_form(-action => $r->uri);
  push @m, "<H4>Upload</H4>\n";
  push @m, $self->dict("D030");
  push @m, "<BR>";
  push @m, $cgi->hidden('HIDDEN1',"VALUE1");
  push @m, $cgi->filefield(-name => "HTTPUPLOAD", size => 48);
  push @m, $cgi->hidden('HIDDEN2',"VALUE2"); 
  push @m, qq{<BR>\n};
  push @m, $self->dict("D031");
  push @m, join(", ", @{$userref->{permitted} || []});
  push @m, qq{ \)<BR>\n};
  push @m, $cgi->textfield(
			   -name => "TARGETDIR", 
			   size => 63,
			   maxlength => 63,
			   'default' => $userref->{permitted}[0],
			  );
  push @m, "\n<BR>";
  push @m, $cgi->submit(
			-name=>'SUBMITup',
			value=> $self->dict("D032")
		       );
  join "", @m;
}

sub hello {
  my($self) = @_;
  my($cgi) = $self->{CGI};
  my($userref) = $self->{USERREF};
  my(@m);
  my @hello = ("D033".."D037");
  my $time = $self->time;
  my @time = localtime($time);
  my $daytime = $time[2];
  if ($daytime >= 7 && $daytime < 10) {
    push @hello, "D038";
  } elsif ($daytime >= 19 || $daytime < 1) {
    push @hello, "D039";
  } elsif ($daytime >= 10) {
    push @hello, "D040";
    if ($daytime >=11 && $daytime < 14) {
      push @hello, "D042";
    }
  } else {
    push @hello, "D043";
  }

  my $hello = $self->dict($hello[rand @hello]);

  my(@m);
  push @m, qq{<H3>$hello $userref->{salut} $userref->{lastname},</H3>};
  push @m, $self->dict('D001');
  push @m, $self->dict("D044");
  push @m, qq{<P>\n};
  join "", @m;
}

sub document_root {
  my($self) = @_;
  return $self->{DOCUMENT_ROOT} if exists $self->{DOCUMENT_ROOT};
  my $document_root = $self->{R}->document_root;
  $document_root =~ s|/+$||; # trailing slashes disturb processing here
  $self->{DOCUMENT_ROOT} = $document_root;
}

sub request { shift->{R} }

sub transhandler {
  my($self) = @_;
  my($userref) = $self->{USERREF};
  my($what_we_did);
  my($cgi) = $self->{CGI};
  my($r) = $self->{R};
  my $stagedir = $self->{STAGEDIR};
  my $secret = $cgi->param("SUBMITtrans");
  my $transdir = $r->dir_config('Apache_UploadSvr_transdir');
  unless ($transdir) {
    $r->log_error("No Apache_UploadSvr_transdir specified. Setting to /tmp");
    $transdir = "/tmp";
  }
  my $trashdir = $r->dir_config('Apache_UploadSvr_trashdir');
  unless ($trashdir) {
    $r->log_error("No Apache_UploadSvr_trashdir specified. Setting to /tmp");
    $trashdir = "/tmp";
  }
  File::Path::mkpath($trashdir);
  my $dh = DirHandle->new($trashdir) or die;
  my $time = $self->time;
  for my $d ($dh->read) {
    my $old =  "$trashdir/$d";
    stat $old;
    next unless -f _;
    next unless (stat _)[9] < $time - 7 * 86400;
    unlink $old;
  }
  my $dh = DirHandle->new($transdir) or die
      "Couldn't opendir $transdir directory: $!";
  for my $dirent ($dh->read) {
    my $file = "$transdir/$dirent";
    stat $file;
    if (-f _ && (-M _ > 3)) {
      unlink $file;
    }
  }
  my $efile = "$transdir/$userref->{user}$secret";
  my $document_root = $self->document_root;
  if (-r $efile) {
    my $fh = IO::File->new($efile) or die "Couldn't open $efile: $!";
    my($doit,@done);
    while ( defined($doit = <$fh>) ) {
      chomp $doit;
      my($command,@args) = split " ", $doit;
      if ($command =~ /^\s*\#/) {
	next;
      }
      if ($command eq "publish") {
	my $f = $args[0];
	my($targetdir,$absfile,$targetfile);
	$targetfile = "$document_root$f";
	$targetdir = dirname($targetfile);
	$absfile = "$stagedir$f";
	eval {
	  File::Path::mkpath($targetdir);
	  rename($absfile, $targetfile) or die $!;
	};
	push @done, $@ ? $self->dict("D022",$doit,$@)
	    : $self->dict("D023",$f,$f);
	$r->log_error("doit[$doit]ERR[$@]targetfile[$targetfile] targetdir[$targetdir] absfile[$absfile]");
      } elsif ($command eq "unpublish") {
	my $f = $args[0];
	my($rmfile, $trashfile);
	$rmfile = "$document_root$f";
	$trashfile = $trashdir . "/" . basename($f);
	if ($self->has_perms($f)) {
	  if (-f $rmfile) {
	    if (rename $rmfile, $trashfile) {
	      push @done, qq{<B>unpublish</B> $f<BR>};
	      my $rmf = $rmfile;
	      while () {
		my $rmd = File::Basename::dirname($rmf);
		my $d = File::Basename::dirname($f);
		my $dh = DirHandle->new($rmd) or die "Couldn't diropen $d: $!";
		my @dirent = $dh->read;
		if (@dirent == 3 && -d "$rmd/.dircache") {
		  File::Path::rmtree("$rmd/.dircache");
		  pop @dirent;
		}
		if (@dirent == 2) { # empty directory
		  if ( rmdir $rmd ) {
		    push @done, qq{  };
		    push @done, $self->dict("D045",$d);
		    $f = $d;
		    $rmf = $rmd;
		  } else {
		    last;
		  }
		} else {
		  last;
		}
	      }
	    } else {
	      push @done, $self->dict("D022",$doit,$!);
	    }
	  } else {
	    push @done, $self->dict("D046",$doit);
	    $r->log_error("DEBUG: rmfile[$rmfile]");
	  }
	} else {
	  push @done, $self->dict("D047",$doit);
	  $r->log_error(qq{DEBUG:rmfile[$rmfile]trashfile[$trashfile]user[$userref->{user}]});
	}
      }
    }
    $fh->close;
    unlink $efile or die "Couldn't unlink $efile";
    $what_we_did = join("\n",
			$self->dict("D048",$secret),
			@done
		       );
  } else {
    $what_we_did = $self->dict("D049", $secret);
  }
  warn scalar(localtime) . $what_we_did;
  $what_we_did;
}

sub has_perms {
  my($self,$f) = @_;
  # warn "has_perms f[$f]";
  my $userref = $self->{USERREF};
  $userref->has_perms($f);
}

sub unzip {
  my($self,$f) = @_;
  my $stagedir = $self->{STAGEDIR};
  my $absfile = "$stagedir$f";
  my $done;
  my $fromdir = dirname($absfile);
  my $fromfile = basename($f);
  chdir $fromdir;
  my $system;
  if ($fromfile =~ /\.t(ar\.)?gz$/i){
    $system="tar xvzf $fromfile";
  } elsif ($fromfile =~ /\.zip$/i){
    $system="unzip -a $fromfile";
  } elsif ($fromfile =~ /\.gz$/i) {
    $system="gzip -dv $fromfile";
  }
  if ($system) {
    my $out = `$system 2>&1`;
    my $ret = $? >> 8;
    if ($ret == 0) {
      $done = $self->dict("D051",$system);
    } else {
      $done = join("",
		   $self->dict("D050",$system),
		   "<PRE>",
		   $out,
		   "</PRE>");
    }
  } else {
    $done = $self->dict("D052",$f);
  }
  $done;
}

sub publish {
  my($self,$f) = @_;
  my $sectrans = "";
  my $error = "";
  if ($self->has_perms($f)) {
    $sectrans = qq{  publish $f\n};
  } else {
    $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 {
	      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>},
		   $f,
		   $stageuri,
		   $f,
		   $vreport);
  }
  return join "\n", @done;
}

1;