view release on metacpan or  search on metacpan

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

}

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++;