Apache-Roaming
1 match

 view release on metacpan or  search on metacpan

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

    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: $!";
    $self->Success(201, 'URI moved');
}


=pod

=head2 MkDir

  $ar_req->MkDir($file);

(Instance Method) Helper function of I<PUT>, creates the directory
where $file is located, if it doesn't yet exist. Works recursively,
if more than one directory must be created.

=cut

sub MkDir {
    my $self = shift;  my $file = shift;
    my $dir = File::Basename::dirname($file);
    return if -d $dir;
    $self->MkDir($dir);
    mkdir($dir, 0700)  or  die "Cannot create directory $dir: $!";
}


=pod

=head2 Success

  $ar_req->Success($status, $text);

(Instance Method) Creates an HTML document with status $status,
containing $text as success messages.

=cut

sub Success {
    my($self, $code, $text) = @_;
    my $r = $self->{'request'};
    $r->status($code);
    $r->content_type("text/html");
    $r->send_http_header;
	print <<EOM;
<HTML><HEAD><TITLE>Success</TITLE></HEAD>
<BODY>$text</BODY></HTML;
EOM
}


1;

__END__

=pod

=head1 AUTHOR AND COPYRIGHT

This module is



( run in 1.116 second using v1.01-cache-2.11-cpan-5b529ec07f3 )