view release on metacpan or  search on metacpan

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

package Apache::UploadSvr::Directory;

use Apache::Constants qw(OK DECLINED AUTH_REQUIRED SERVER_ERROR);
use Apache::UploadSvr;
use CGI;
use Data::Dumper;
use DirHandle;
use File::Basename qw(basename dirname);
use File::Path;
use Image::Magick;
use IO::File;
use strict;
use vars qw( $VERSION @ISA );

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

@ISA = qw(Apache::UploadSvr); # secure_transaction, dict

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

sub handler {
  my $r = shift;
  my $cgi = CGI->new;
  # Directory not really suited well for the stage area
  my $userclass = $r->dir_config("Apache_UploadSvr_Usermgr")
      || "Apache::UploadSvr::User";
  eval "require $userclass;";
  no strict "refs";
  my $self = __PACKAGE__->new( CGI => $cgi, R => $r );
  $self->{USERREF} = $userclass->new($self);
  $self->dispatch;
}

sub dispatch {
  my($self) = @_;
  my $cgi = $self->{CGI};
  my $r = $self->{R};
  my(@m,$w,$cache,$has_changed);
  my $DirCache = $r->dir_config("DirCache") || ".dirchache";
  my $document_root = $r->document_root;
  my $directory = dirname($r->filename);
  my $stage = $r->dir_config("apache_stage_regex") ||
      q{ ^ (/STAGE/[^/]*) (.*) $ };
  return DECLINED if $r->uri =~ m| $stage |ox;
  if (basename($directory) eq $DirCache) {
    # warn "directory[$directory]DirCache[$DirCache]";
    return DECLINED;
  }
  my $userref = $self->{USERREF};
  # warn "userref[$userref]";
  return AUTH_REQUIRED unless exists $userref->{user};

  my $dir_uri = substr($directory,length($document_root)) || "";
  $dir_uri =~ s|/*$|/|;
  my $write_perm = $self->has_perms($dir_uri);
  # warn "write_perm[$write_perm]user[$userref->{user}]";
  $write_perm++ if $userref->{user} eq "admin";
  return DECLINED unless $write_perm;

  my $dh = DirHandle->new($directory);
  my $expect_missings;
  if (-f "$directory/$DirCache/$DirCache" && -r _) {
    my $fh = IO::File->new;

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

	      $scalemax = 31;
	      if ($imgx > $scalemax && $imgx > $imgy) {
		$scalex = $scalemax;
		$scaley = int($imgy*$scalemax/$imgx+.5) || 1;
	      } elsif ($imgy > $scalemax) {
		$scaley = $scalemax;
		$scalex = int($imgx*$scalemax/$imgy+.5) || 1;
	      } else {
		$scalex = $imgx;
		$scaley = $imgy;
	      }
	      my $incode = "$directory/$dirent";
	      if (-r $incode){
		my $orig = $imq->Read($incode);
		$imq->Sample(width=>$scalex,height=>$scaley);
		my $err = $imq->Write(filename=>"$directory/$thsrc");
		if ($err) {
		  warn "Could not write [$err]: $!";
		  $thsrc = "/icons/unknown.gif";
		  $scalex = 20;
		  $scaley = 22;
		}
	      } else {
		warn "Could not open input [$incode]: $!";
		return SERVER_ERROR;
	      }
	    }
	  }
	  $pic = qq{<A HREF="$href"><IMG SRC="$thsrc" BORDER=0 WIDTH="$scalex" HEIGHT="$scaley"></A>};
	}
      }
      $has_changed=1;
      $line = [
	       qq{<TD>$pic</TD>},
	       qq{<TD>$imgsize</TD>},
	       qq{<TD><A HREF="$href">$display_as</A></TD>},
	       $size eq "-" ?
	       "<TD></TD>" :
	       "checkbox",
	       qq{<TD ALIGN=CENTER>$size</TD>},
	       qq{<TD ALIGN=CENTER>$localtime</TD>}
	      ];

      $cache->{$dirent}{mtime} = $mtime;
      $cache->{$dirent}{line}  = $line;
    }
    push @rows, $line;
  }
  $dh->close;
  foreach my $olddirent (keys %$cache) {
    if (exists $cache->{$olddirent}{seen}) {
      delete $cache->{$olddirent}{seen};
    } else {
      delete $cache->{$olddirent};
      $has_changed = 1;
    }
  }
  if ($has_changed) {
    my $fh = IO::File->new;
    if ($fh->open(">$directory/$DirCache/$DirCache")) {
      $fh->print(Data::Dumper->new([$cache],["cache"])->Dump);
    } else {
      warn "Could not write >$directory/$DirCache/$DirCache: $!";
    }
  }
  my(@chkbox,$columns,$red);
  if ($write_perm) {
    $columns = 6;
  } else {
    $columns = 5;
  }
  if ($write_perm) {
    @dirlisting{@dirlisting} = (" ") x @dirlisting;
    @chkbox = split /<BR>/, $cgi->checkbox_group(-name => "delete",
						 'values' => \@dirlisting,
						 'linebreak'=>'true',
						 labels => \%dirlisting
						);
    $red = "#fa8888";
    push @m, "<TR><TD colspan=3></TD>";
    push @m, qq{<TD bgcolor="$red">};
    push @m, $cgi->submit(-name => 'Delete');
    push @m, qq{</TR>};
    for my $e (0..$#rows) {
      my $l = $rows[$e];
      $l->[3] = qq{<TD ALIGN=CENTER BGCOLOR=$red>$chkbox[$e]</TD>} if
	  "$l->[3]" eq "checkbox";
    }
  } else {
    for my $e (0..$#rows) {
      my $l = $rows[$e];
      splice @$l, 3, 1;
    }
  }

  for my $e (0..$#rows) {
    my $l = $rows[$e];
    push @m, "<TR>";
    for my $c (@$l) {
      push @m, $c;
    }
    push @m, "</TR>";
  }

  push @m, "</FORM></TABLE></BODY></HTML>";

  $r->content_type("text/html");
  $r->send_http_header;

  print @m;
  OK;
}

1;