view release on metacpan or  search on metacpan

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

    my $file = $self->{'file'};
    my $basedir = $self->{'basedir'};
    my $dir = $file;
    my $user = $self->{'user'};
    my $prevdir;

    while (($dir = File::Basename::dirname($dir))
	   and  (!$prevdir  or  ($dir ne $prevdir))) {
	if ($basedir eq $dir) {
	    my $userdir;
	    $userdir = File::Basename::basename($prevdir) if $prevdir;
	    if (!$prevdir  or  $userdir ne $user) {
		$self->{'status'} = Apache::Constants::FORBIDDEN();
		die "Access to $file not permitted for user $user";
	    }
	    return;
	}
	$prevdir = $dir;
    }
    $self->{'status'} = Apache::Constants::FORBIDDEN();
    die "Access to $file not permitted for user $user";
}


=pod

=head2 GET, PUT, MOVE, DELETE

  $ar_req->GET();
  $ar_req->PUT();
  $ar_req->MOVE();
  $ar_req->DELETE();

(Instance Methods) These methods are called finally for performing the
real action. With the exception of GET, they call I<Success> finally
for reporting Ok.

Alternative method names are possible, depending on the name of the
requested file. For example, if you request the file I<liprefs> via
GET, then it is checked whether your sublass has a method I<GET_liprefs>.
If so, this method is called rather than the default method I<GET>.
The alternative method names are obtained by removing all non-alpha-
numeric characters from the files base name. That is, if you request
a file I<pab.na2>, then the alternative name is I<pabna2>. Note, these
method names are case sensitive!

=cut

sub GET {
    my $self = shift;
    my $file = $self->{'file'};
    my $r = $self->{'request'};

    if (! -f $file) {
	$self->{'status'} = Apache::Constants::NOT_FOUND();
	die "No such file: $file";
    }
#    return Apache::DECLINED();
    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime) = stat _;
    my $fh = Symbol::gensym();
    if (!open($fh, "<$file")  ||  !binmode($fh)) {
  	die "Failed to open file $file: $!";
    }
    $r->set_last_modified($mtime);
    $r->content_type('text/plain');
    $r->no_cache(1);
    $r->header_out('content_length', $size);
    $r->send_http_header();
    if (!$r->header_only()) {
  	$r->send_fd($fh) or die $!;
    }
    return Apache::OK();
}


sub PUT {
    my $self = shift;
    my $file = $self->{'file'};
    my $r = $self->{'request'};

    $self->MkDir($file);

    my $fh = Symbol::gensym();

    open($fh, ">$file")
	or die "Failed to open $file: $!";
    binmode($fh)
	or die "Failed to request binmode for $file: $!";

    my $size = $r->header_in('Content-length');
    $r->hard_timeout("Apache->read");
    while ($size > 0) {
	my $buf = '';
	my $rdn = $r->read_client_block($buf, ($size < 1024) ? $size : 1024);
	if (!defined($rdn)) {
	    die "Error while reading $file from client: $!";
	}
	print $fh ($buf)
	    or die "Error while writing to client: $!";
	$size -= $rdn;
    }
    $r->kill_timeout();
    close($fh);
    $self->Success(201, 'URI created');
}


sub DELETE {
    my $self = shift;
    my $file = $self->{'file'};
    if (-f $file  and  !unlink $file) {
	$self->{'status'} = Apache::Constants::NOT_FOUND();
	die "Error while unlinking $file: $!";
    }
    $self->Success(201, 'URI deleted');
}


sub MOVE {
    my $self = shift;
    my $file = $self->{'file'};
    my $dir = File::Basename::dirname($file);
    my $r = $self->{'request'};
    my $uri = $r->uri();
    my $new_uri = $r->header_in('New-uri');

    unless ($new_uri) {
	$self->{'status'} = Apache::Constants::BAD_REQUEST();
	die "Missing header: New-uri";
    }
    if ($uri !~ /(.*)\//) {
	$self->{'status'} = Apache::Constants::BAD_REQUEST();
	die "URI $uri doesn't contain a '/'";
    }
    $uri = $1;
    if ($new_uri !~ /(.*)\/([^\/]+)/) {
	$self->{'status'} = Apache::Constants::BAD_REQUEST();
	die "New URI $new_uri doesn't contain a '/'";
    }
    $new_uri = $1;
    my $new_file = File::Spec->catfile($dir, $2);
    if ($uri ne $new_uri) {
	$self->{'status'} = Apache::Constants::FORBIDDEN();
	die "New URI $new_uri refers to another directory than $uri";
    }

    rename $file, $new_file
	or die "Error while renaming $file to $new_file: $!";