view release on metacpan or  search on metacpan

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

    $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);