[Catalyst-commits] r6394 - trunk/Catalyst-Action-DAV/lib/Net/DAV
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Sat May 12 18:08:46 GMT 2007
Author: matthewt
Date: 2007-05-12 18:08:46 +0100 (Sat, 12 May 2007)
New Revision: 6394
Modified:
trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm
Log:
changes to Net/DAV/Server.pm
Modified: trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm
===================================================================
--- trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm 2007-05-12 17:07:45 UTC (rev 6393)
+++ trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm 2007-05-12 17:08:46 UTC (rev 6394)
@@ -13,7 +13,7 @@
use URI::Escape;
use XML::LibXML;
use base 'Class::Accessor::Fast';
-__PACKAGE__->mk_accessors(qw(filesys));
+__PACKAGE__->mk_accessors(qw(filesys base_uri));
our $VERSION = '1.29';
our %implemented = (
@@ -33,12 +33,32 @@
);
sub new {
- my ($class) = @_;
- my $self = {};
+ my ($class, @args) = @_;
+ my %args = (ref $args[0] eq 'HASH' ? %{$args[0]} : @args);
+ my $self = { base_uri => URI->new('http:///'), %args};
bless $self, $class;
return $self;
}
+sub path_for {
+ my ($self, $for) = @_;
+ my $uri;
+ if ($for->can('uri')) {
+ $uri = $for->uri;
+ } elsif (!ref $for) {
+ $uri = URI->new($for);
+ } else { # fallthrough: assume it's something URI-ish
+ $uri = $for;
+ }
+ return decode_utf8 uri_unescape $uri->rel($self->base_uri)->abs('/')->path;
+}
+
+sub href_for {
+ my ($self, $for) = @_;
+ $for =~ s/^\///;
+ return URI->new_abs($for, $self->base_uri)->path;
+}
+
sub handle_apache {
my ($self, $r) = @_;
@@ -79,14 +99,18 @@
}
sub handle_connection {
- my ($self, $c) = @_;
+ my ($self, $c, $get_request_arg) = @_;
+ unless (defined $get_request_arg) {
+ $get_request_arg = 1;
+ }
+
# NOTE: passing '1' to get_request only reads headers so we
# can avoid slurping then entire request body into memory
# for PUT. You can only do this if you pass the connection
# object as well
# - also, only one-shot for now
- while (my $request = $c->get_request(1)) {
+ while (my $request = $c->get_request($get_request_arg)) {
my $response = $self->run($request, undef, $c);
$c->send_response ($response);
$c->close();
@@ -99,7 +123,6 @@
my $fs = $self->filesys || die 'Boom';
my $method = $request->method;
- my $path = decode_utf8 uri_unescape $request->uri->path;
if (!defined $response) {
$response = HTTP::Response->new;
@@ -117,7 +140,7 @@
# Saying it isn't implemented is better than crashing!
warn "$method not implemented\n";
- $response->code(501);
+ $response->code(405);
$response->message('Not Implemented');
}
return $response;
@@ -126,7 +149,8 @@
sub options {
my ($self, $request, $response) = @_;
$response->header('DAV' => '1,2,<http://apache.org/dav/propset/fs/1>')
- ; # Nautilus freaks out
+ ; # Nautilus freaks out
+ # XXX shouldn't be 1,2, until LOCK and UNLOCK work
$response->header('MS-Author-Via' => 'DAV'); # Nautilus freaks out
$response->header('Allow' => join(',', map { uc } keys %implemented));
$response->header('Content-Type' => 'httpd/unix-directory');
@@ -136,7 +160,7 @@
sub head {
my ($self, $request, $response) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
if ($fs->test("f", $path) && $fs->test("r", $path)) {
@@ -165,7 +189,7 @@
sub get {
my ($self, $request, $response, $connection) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
if ($fs->test('f', $path) && $fs->test('r', $path)) {
@@ -215,7 +239,7 @@
sub put {
my ($self, $request, $response, $connection) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
$response = HTTP::Response->new(201, "CREATED", $response->headers);
@@ -251,17 +275,17 @@
}
sub _delete_xml {
- my ($dom, $path) = @_;
+ my ($self, $dom, $path) = @_;
my $response = $dom->createElement("d:response");
- $response->appendTextChild("d:href" => $path);
+ $response->appendTextChild("d:href" => $self->href_for($path));
$response->appendTextChild("d:status" => "HTTP/1.1 401 Permission Denied")
; # *** FIXME ***
}
sub delete {
my ($self, $request, $response) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
if ($request->uri->fragment) {
@@ -285,10 +309,10 @@
next unless $fs->test("e", $part);
if ($fs->test("f", $part)) {
- push @error, _delete_xml($dom, $part)
+ push @error, $self->_delete_xml($dom, $part)
unless $fs->delete($part);
} elsif ($fs->test("d", $part)) {
- push @error, _delete_xml($dom, $part)
+ push @error, $self->_delete_xml($dom, $part)
unless $fs->rmdir($part);
}
}
@@ -309,11 +333,11 @@
sub copy {
my ($self, $request, $response) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
my $destination = $request->header('Destination');
- $destination = URI->new($destination)->path;
+ $destination = $self->path_for($destination);
my $depth = $request->header('Depth') || 0;
my $overwrite = $request->header('Overwrite') || 'F';
@@ -371,11 +395,11 @@
sub copy_file {
my ($self, $request, $response) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
my $destination = $request->header('Destination');
- $destination = URI->new($destination)->path;
+ $destination = $self->path_for($destination);
my $depth = $request->header('Depth');
my $overwrite = $request->header('Overwrite');
@@ -416,7 +440,7 @@
my ($self, $request, $response) = @_;
my $destination = $request->header('Destination');
- $destination = URI->new($destination)->path;
+ $destination = $self->path_for($destination);
my $destexists = $self->filesys->test("e", $destination);
$response = $self->copy($request, $response);
@@ -430,27 +454,33 @@
sub lock {
my ($self, $request, $response) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
- my $fs = $self->filesys;
+ #my $path = $self->path_for($request);
+ #my $fs = $self->filesys;
- $fs->lock($path);
+ #$fs->lock($path);
+ $response->code(500);
+ $response->message('Lock error');
+
return $response;
}
sub unlock {
my ($self, $request, $response) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
- my $fs = $self->filesys;
+ #my $path = $self->path_for($request);
+ #my $fs = $self->filesys;
- $fs->unlock($path);
+ #$fs->unlock($path);
+ $response->code(500);
+ $response->message('Lock error');
+
return $response;
}
sub mkcol {
my ($self, $request, $response) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
if ($request->header('Content-Length')) {
@@ -475,7 +505,7 @@
sub propfind {
my ($self, $request, $response, $connection) = @_;
- my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $path = $self->path_for($request);
my $fs = $self->filesys;
my $depth = $request->header('Depth');
@@ -563,8 +593,10 @@
$multistat->addChild($resp);
my $href = $doc->createElement('D:href');
$href->appendText(
- File::Spec->catdir(
- map { uri_escape encode_utf8 $_} File::Spec->splitdir($path)
+ $self->href_for(
+ File::Spec->catdir(
+ map { uri_escape encode_utf8 $_} File::Spec->splitdir($path)
+ )
)
);
$resp->addChild($href);
@@ -668,7 +700,8 @@
$prop->addChild($lock);
}
$okprops->addChild($prop);
- };
+ } if 0; # XXX re-add this segment when locks actually work
+ # XXX this wasn't in propname or single-prop select anyway
$prop = $doc->createElement('D:resourcetype');
if ($fs->test('d', $path)) {
my $col = $doc->createElement('D:collection');
More information about the Catalyst-commits
mailing list