[Catalyst-commits] r6393 - in trunk: . Catalyst-Action-DAV
Catalyst-Action-DAV/lib Catalyst-Action-DAV/lib/Catalyst
Catalyst-Action-DAV/lib/Catalyst/Action
Catalyst-Action-DAV/lib/Net Catalyst-Action-DAV/lib/Net/DAV
Catalyst-Action-DAV/litmus_test Catalyst-Action-DAV/t
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Sat May 12 18:07:45 GMT 2007
Author: matthewt
Date: 2007-05-12 18:07:45 +0100 (Sat, 12 May 2007)
New Revision: 6393
Added:
trunk/Catalyst-Action-DAV/
trunk/Catalyst-Action-DAV/CHANGES
trunk/Catalyst-Action-DAV/Makefile.PL
trunk/Catalyst-Action-DAV/lib/
trunk/Catalyst-Action-DAV/lib/Catalyst/
trunk/Catalyst-Action-DAV/lib/Catalyst/Action/
trunk/Catalyst-Action-DAV/lib/Catalyst/Action/DAV.pm
trunk/Catalyst-Action-DAV/lib/Net/
trunk/Catalyst-Action-DAV/lib/Net/DAV/
trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm
trunk/Catalyst-Action-DAV/litmus_test/
trunk/Catalyst-Action-DAV/litmus_test/catlitmus.pl
trunk/Catalyst-Action-DAV/litmus_test/litmus.pl
trunk/Catalyst-Action-DAV/t/
trunk/Catalyst-Action-DAV/t/pod.t
Log:
initial import of Catalyst::Action::DAV with original Net::DAV::Server from http://svn.brong.net/netdavserver/trunk/ r84
Added: trunk/Catalyst-Action-DAV/CHANGES
===================================================================
--- trunk/Catalyst-Action-DAV/CHANGES (rev 0)
+++ trunk/Catalyst-Action-DAV/CHANGES 2007-05-12 17:07:45 UTC (rev 6393)
@@ -0,0 +1,57 @@
+CHANGES file for Net::DAV::Server
+
+1.29 Wed Jul 19 11:42:56 EST 2006
+ - Bugfix: RT#17077 - uninitialised variable.
+ -- Thanks to CLOTHO
+ - Bugfixes/interoperability:
+ * RT#20022 - add trailing slashes to directory names in listing.
+ * RT#20016 - remove upwards path from directory listing.
+ -- Both thanks to HACHI
+ - Test infrastructure (requires litmus installed) to ensure
+ new changes don't cause regressions.
+ - Add 'TODO' list to remind myself of other work I want to do.
+
+1.28 Sat Jul 9 00:08:24 EST 2005
+ - new maintainer: Bron Gondwana <brong at brong.net>
+ - fix DAV: namespace in propfind
+ - use ISO time format for DAV::creationdate property
+
+1.27 Wed Jun 8 10:33:44 BST 2005
+ - advertise that locking is available to get Windows DAV happier
+ (thanks to Stefan `Sec` Zehl)
+
+1.26 Tue Apr 26 22:03:33 BST 2005
+ - removed webdav.pl (spotted by CDOLAN)
+
+1.25 Sat Mar 26 07:06:03 CST 2005
+ - finished the support for parsing PROPFIND request bodies - for
+ retreiving property names, named properties, or all properties.
+ - tweaked some things to support publishing DAV using
+ POE::Component::Server::HTTP (bug #11821)
+ - a little more magic to make wide character file names work
+ - all above patches by Jack/ms419
+ - added POD test
+
+1.24 Tue Mar 8 18:58:05 EST 2005
+ - included big patch from Mark A. Hershberger, so that
+ Net::DAV::Server passes more litmus tests
+ - remove silly line that stopped cadaver from working
+ - return 201 if moving to a new directory
+ - return 409 if writing to a directory which does not exist
+
+1.23 Thu May 20 10:06:05 BST 2004
+ - implemented recursive copy, delete, move using
+ File::Find::Rule::Filesys::Virtual
+ - 403 on more things we don't support
+
+1.22 Wed May 19 14:04:47 BST 2004
+ - give a 404 on unknown error (thanks to Yair Lenga)
+ - add Last-Modified upon GETs (thanks to Yair Lenga)
+ - remove DateTime dependency (thanks to Yair Lenga)
+ - fix URI encoding problems
+ - give proper Server: header
+ - use XML::LibXML to generate proper XML
+ - refactoring
+
+1.21 Sun May 9 10:16:31 IST 2004
+ - first release
Added: trunk/Catalyst-Action-DAV/Makefile.PL
===================================================================
--- trunk/Catalyst-Action-DAV/Makefile.PL (rev 0)
+++ trunk/Catalyst-Action-DAV/Makefile.PL 2007-05-12 17:07:45 UTC (rev 6393)
@@ -0,0 +1,21 @@
+use strict;
+use warnings;
+use inc::Module::Install 0.65;
+
+name 'Catalyst-Action-DAV';
+license 'perl';
+all_from 'lib/Catalyst/Action/DAV.pm';
+
+requires 'Catalyst::Runtime' => '5.70';
+requires 'Class::Accessor::Fast' => 0;
+requires 'Encode' => 0;
+requires 'File::Slurp' => 0;
+requires 'File::Find::Rule::Filesys::Virtual' => 0;
+requires 'HTTP::Date' => 0;
+requires 'HTTP::Headers' => 0;
+requires 'HTTP::Response' => 0;
+requires 'HTTP::Request' => 0;
+requires 'Test::More' => 0;
+requires 'URI' => 0;
+requires 'URI::Escape' => 0;
+requires 'XML::LibXML' => 0;
Added: trunk/Catalyst-Action-DAV/lib/Catalyst/Action/DAV.pm
===================================================================
--- trunk/Catalyst-Action-DAV/lib/Catalyst/Action/DAV.pm (rev 0)
+++ trunk/Catalyst-Action-DAV/lib/Catalyst/Action/DAV.pm 2007-05-12 17:07:45 UTC (rev 6393)
@@ -0,0 +1,107 @@
+package Catalyst::Action::DAV;
+
+use strict;
+use warnings;
+use base qw/Catalyst::Action/;
+use Class::C3;
+
+use Net::DAV::Server;
+use HTTP::Request;
+use HTTP::Response;
+use PadWalker qw(peek_sub);
+
+sub execute {
+ my $self = shift;
+ my ($controller, $c) = @_;
+ my $ret = $self->next::method(@_);
+ $self->run_dav($c);
+ return $ret;
+}
+
+sub run_dav {
+ my ($self, $c) = @_;
+ my $dav = $self->mk_dav_object($c);
+ my $req = $self->mk_http_request_object($c);
+ my $method = lc($c->req->method);
+ if (my $handler = $self->can('handle_method_${method}')) {
+ $self->$handler($c, $dav, $req);
+ } else {
+ $self->handle_generic($c, $dav, $req);
+ }
+}
+
+sub mk_dav_object {
+ my ($self, $c) = @_;
+ return $self->dav_class($c)->new($self->dav_args($c));
+}
+
+sub dav_class { 'Net::DAV::Server' }
+
+sub dav_args {
+ my ($self, $c) = @_;
+ my $uri = $c->uri_for($self, $c->req->captures);
+ #warn $uri;
+ unless ($uri->path =~ /\/$/) {
+ $uri->path($uri->path.'/');
+ }
+ #warn $uri;
+ return (
+ filesys => $c->stash->{filesys},
+ base_uri => $uri,
+ );
+}
+
+sub mk_http_request_object {
+ my ($self, $c) = @_;
+ return $self->http_request_class($c)->new($self->http_request_args($c));
+}
+
+sub http_request_class { 'HTTP::Request' }
+
+sub http_request_args {
+ my ($self, $c) = @_;
+ return map { $c->req->$_ } qw/method uri headers/;
+}
+
+sub handle_method_put { shift->handle_stream_read_request(@_); }
+
+sub handle_method_propfind { shift->handle_stream_read_request(@_); }
+
+sub handle_stream_read_request {
+ my ($self, $c, $dav, $req) = @_;
+ my $res = $dav->run($req, undef, $c->req->body);
+ $self->populate_catalyst_response_from_http_response($c->res, $res);
+}
+
+sub handle_generic {
+ my ($self, $c, $dav, $req) = @_;
+ $self->populate_http_request_from_catalyst_request($req, $c->req);
+ my $res = $dav->run($req);
+ $self->populate_catalyst_response_from_http_response($c->res, $res);
+}
+
+sub populate_http_request_from_catalyst_request {
+ my ($self, $req, $catreq) = @_;
+ {
+ my $body = $catreq->body;
+ return unless $body;
+ local $/;
+ my $content = <$body>;
+ $req->content($content);
+ }
+}
+
+sub populate_catalyst_response_from_http_response {
+ my ($self, $catres, $res) = @_;
+ $catres->status($res->status_line);
+ if (ref $res->content eq 'CODE') {
+ my $info = peek_sub($res->content);
+ my $fh = ${$info->{'$fh'}};
+ $catres->body($fh);
+ } else {
+ $catres->body($res->content);
+ }
+ $catres->headers($res->headers);
+}
+
+1;
Added: trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm
===================================================================
--- trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm (rev 0)
+++ trunk/Catalyst-Action-DAV/lib/Net/DAV/Server.pm 2007-05-12 17:07:45 UTC (rev 6393)
@@ -0,0 +1,771 @@
+package Net::DAV::Server;
+use strict;
+use warnings;
+use File::Slurp;
+use Encode;
+use File::Find::Rule::Filesys::Virtual;
+use HTTP::Date qw(time2str time2isoz);
+use HTTP::Headers;
+use HTTP::Response;
+use HTTP::Request;
+use File::Spec;
+use URI;
+use URI::Escape;
+use XML::LibXML;
+use base 'Class::Accessor::Fast';
+__PACKAGE__->mk_accessors(qw(filesys));
+our $VERSION = '1.29';
+
+our %implemented = (
+ options => 1,
+ put => 1,
+ get => 1,
+ head => 1,
+ post => 1,
+ delete => 1,
+ trace => 1,
+ mkcol => 1,
+ propfind => 1,
+ copy => 1,
+ lock => 1,
+ unlock => 1,
+ move => 1
+);
+
+sub new {
+ my ($class) = @_;
+ my $self = {};
+ bless $self, $class;
+ return $self;
+}
+
+sub handle_apache {
+ my ($self, $r) = @_;
+
+ # set up the request
+ my @headers = $r->headers_in();
+ my $method = $r->method();
+ my $uri = $r->uri();
+ my $request = HTTP::Request->new($method, $uri, \@headers);
+
+ # run the request
+ my $response = $self->run($request, undef, $r);
+
+ my $code = $response->code();
+ my $message = $response->message();
+ my $status_line = $response->status_line();
+
+ # set up the response header
+ $r->status_line($response->status_line());
+ $response->scan(sub { $r->err_header_out(@_) });
+ $r->send_http_header();
+
+ # send the response content
+ my $content = $response->content();
+ if (ref($content)) {
+ # XXX - if Apache2, try to generate chunked encooding?
+ while (1) {
+ my $buf = $content->();
+ last if (not defined $buf or $buf eq '');
+ $r->print($buf);
+ }
+ }
+ else {
+ $r->print($content);
+ }
+
+ # return the correct code (or maybe just 200)
+ return 200;
+}
+
+sub handle_connection {
+ my ($self, $c) = @_;
+
+ # 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)) {
+ my $response = $self->run($request, undef, $c);
+ $c->send_response ($response);
+ $c->close();
+ }
+}
+
+sub run {
+ my ($self, $request, $response, $connection) = @_;
+
+ 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;
+ }
+
+ $method = lc $method;
+ if ($implemented{$method}) {
+ $response->code(200);
+ $response->message('OK');
+ $response = $self->$method($request, $response, $connection);
+ unless ($response->header('Content-Length')) {
+ $response->header('Content-Length' => length($response->content));
+ }
+ } else {
+
+ # Saying it isn't implemented is better than crashing!
+ warn "$method not implemented\n";
+ $response->code(501);
+ $response->message('Not Implemented');
+ }
+ return $response;
+}
+
+sub options {
+ my ($self, $request, $response) = @_;
+ $response->header('DAV' => '1,2,<http://apache.org/dav/propset/fs/1>')
+ ; # Nautilus freaks out
+ $response->header('MS-Author-Via' => 'DAV'); # Nautilus freaks out
+ $response->header('Allow' => join(',', map { uc } keys %implemented));
+ $response->header('Content-Type' => 'httpd/unix-directory');
+ $response->header('Keep-Alive' => 'timeout=15, max=96');
+ return $response;
+}
+
+sub head {
+ my ($self, $request, $response) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ if ($fs->test("f", $path) && $fs->test("r", $path)) {
+ $response->header('Content-Length' => $fs->size($path));
+ $response->last_modified($fs->modtime($path));
+ } elsif ($fs->test("d", $path)) {
+
+ # a web browser, then
+ my @files = $fs->list($path);
+ my $body;
+ foreach my $file (@files) {
+ if ($fs->test('d', $path . $file)) {
+ $body .= qq|<a href="$file/">$file/</a><br>\n|;
+ } else {
+ $file =~ s{/$}{};
+ $body .= qq|<a href="$file">$file</a><br>\n|;
+ }
+ }
+ $response->header('Content-Type' => 'text/html; charset="utf-8"');
+ $response->header('Content-Length' => length($body)); # would be this size
+ } else {
+ $response = HTTP::Response->new(404, "NOT FOUND", $response->headers);
+ }
+ return $response;
+}
+
+sub get {
+ my ($self, $request, $response, $connection) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ if ($fs->test('f', $path) && $fs->test('r', $path)) {
+ my $size = $fs->size($path);
+ $response->header('Content-Length' => $size);
+ $response->last_modified($fs->modtime($path));
+
+ # set up a closure to actually write the content later - can be chunked
+ # for nicer output.
+ my $copied = 0;
+ my $fh = $fs->open_read($path);
+ $response->content(sub {
+ my $buf;
+ if ($copied < $size) {
+ my $amount = 4096;
+ if ($copied + $amount > $size) {
+ $amount = $size - $copied;
+ }
+ my $bytes = $fh->read($buf, $amount);
+ $copied += $bytes;
+ return $buf;
+ }
+ $fs->close_read($fh);
+ return undef;
+ });
+ } elsif ($fs->test('d', $path)) {
+
+ # a web browser, then
+ my @files = $fs->list($path);
+ my $body;
+ foreach my $file (@files) {
+ if ($fs->test('d', $path . $file)) {
+ $body .= qq|<a href="$file/">$file/</a><br>\n|;
+ } else {
+ $file =~ s{/$}{};
+ $body .= qq|<a href="$file">$file</a><br>\n|;
+ }
+ }
+ $response->header('Content-Type' => 'text/html; charset="utf-8"');
+ $response->content($body);
+ } else {
+ $response->code(404);
+ $response->message('Not Found');
+ }
+ return $response;
+}
+
+sub put {
+ my ($self, $request, $response, $connection) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ $response = HTTP::Response->new(201, "CREATED", $response->headers);
+
+ my $fh = $fs->open_write($path);
+
+ # check that we have anything to write
+ my $length = $request->header('Content-Length');
+ if ($length > 0) {
+ # and if so, where from
+ if ($connection and length($request->content) == 0) {
+ # we're going to read it directly from the connection
+ my $copied = 0;
+ my $buf;
+ while ($copied < $length) {
+ my $amount = 4096;
+ if ($copied + $amount > $length) {
+ $amount = $length - $copied;
+ }
+ my $bytes = $connection->read($buf, $amount);
+ $fh->print($buf);
+ $copied += $bytes;
+ }
+ }
+ else {
+ # content already slurped into memory
+ $fh->print($request->content);
+ }
+ }
+ $fs->close_write($fh);
+
+ return $response;
+}
+
+sub _delete_xml {
+ my ($dom, $path) = @_;
+
+ my $response = $dom->createElement("d:response");
+ $response->appendTextChild("d:href" => $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 $fs = $self->filesys;
+
+ if ($request->uri->fragment) {
+ return HTTP::Response->new(404, "NOT FOUND", $response->headers);
+ }
+
+ unless ($fs->test("e", $path)) {
+ return HTTP::Response->new(404, "NOT FOUND", $response->headers);
+ }
+
+ my $dom = XML::LibXML::Document->new("1.0", "utf-8");
+ my @error;
+ foreach my $part (
+ grep { $_ !~ m{/\.\.?$} }
+ map { s{/+}{/}g; $_ }
+ File::Find::Rule::Filesys::Virtual->virtual($fs)->in($path),
+ $path
+ )
+ {
+
+ next unless $fs->test("e", $part);
+
+ if ($fs->test("f", $part)) {
+ push @error, _delete_xml($dom, $part)
+ unless $fs->delete($part);
+ } elsif ($fs->test("d", $part)) {
+ push @error, _delete_xml($dom, $part)
+ unless $fs->rmdir($part);
+ }
+ }
+
+ if (@error) {
+ my $multistatus = $dom->createElement("D:multistatus");
+ $multistatus->setAttribute("xmlns:D", "DAV:");
+
+ $multistatus->addChild($_) foreach @error;
+
+ $response = HTTP::Response->new(207 => "Multi-Status");
+ $response->header("Content-Type" => 'text/xml; charset="utf-8"');
+ } else {
+ $response = HTTP::Response->new(204 => "No Content");
+ }
+ return $response;
+}
+
+sub copy {
+ my ($self, $request, $response) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ my $destination = $request->header('Destination');
+ $destination = URI->new($destination)->path;
+ my $depth = $request->header('Depth') || 0;
+ my $overwrite = $request->header('Overwrite') || 'F';
+
+ if ($fs->test("f", $path)) {
+ return $self->copy_file($request, $response);
+ }
+
+ # it's a good approximation
+ $depth = 100 if defined $depth && $depth eq 'infinity';
+
+ my @files =
+ map { s{/+}{/}g; $_ }
+ File::Find::Rule::Filesys::Virtual->virtual($fs)->file->maxdepth($depth)
+ ->in($path);
+
+ my @dirs = reverse sort
+ grep { $_ !~ m{/\.\.?$} }
+ map { s{/+}{/}g; $_ }
+ File::Find::Rule::Filesys::Virtual->virtual($fs)
+ ->directory->maxdepth($depth)->in($path);
+
+ push @dirs, $path;
+ foreach my $dir (sort @dirs) {
+ my $destdir = $dir;
+ $destdir =~ s/^$path/$destination/;
+ if ($overwrite eq 'F' && $fs->test("e", $destdir)) {
+ return HTTP::Response->new(401, "ERROR", $response->headers);
+ }
+ $fs->mkdir($destdir);
+ }
+
+ foreach my $file (reverse sort @files) {
+ my $destfile = $file;
+ $destfile =~ s/^$path/$destination/;
+ my $fh = $fs->open_read($file);
+ my $file = join '', <$fh>;
+ $fs->close_read($fh);
+ if ($fs->test("e", $destfile)) {
+ if ($overwrite eq 'T') {
+ $fh = $fs->open_write($destfile);
+ print $fh $file;
+ $fs->close_write($fh);
+ } else {
+ }
+ } else {
+ $fh = $fs->open_write($destfile);
+ print $fh $file;
+ $fs->close_write($fh);
+ }
+ }
+
+ $response = HTTP::Response->new(200, "OK", $response->headers);
+ return $response;
+}
+
+sub copy_file {
+ my ($self, $request, $response) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ my $destination = $request->header('Destination');
+ $destination = URI->new($destination)->path;
+ my $depth = $request->header('Depth');
+ my $overwrite = $request->header('Overwrite');
+
+ if ($fs->test("d", $destination)) {
+ $response = HTTP::Response->new(204, "NO CONTENT", $response->headers);
+ } elsif ($fs->test("f", $path) && $fs->test("r", $path)) {
+ my $fh = $fs->open_read($path);
+ my $file = join '', <$fh>;
+ $fs->close_read($fh);
+ if ($fs->test("f", $destination)) {
+ if ($overwrite eq 'T') {
+ $fh = $fs->open_write($destination);
+ print $fh $file;
+ $fs->close_write($fh);
+ } else {
+ $response->code(412);
+ $response->message('Precondition Failed');
+ }
+ } else {
+ unless ($fh = $fs->open_write($destination)) {
+ $response->code(409);
+ $response->message('Conflict');
+ return $response;
+ }
+ print $fh $file;
+ $fs->close_write($fh);
+ $response->code(201);
+ $response->message('Created');
+ }
+ } else {
+ $response->code(404);
+ $response->message('Not Found');
+ }
+ return $response;
+}
+
+sub move {
+ my ($self, $request, $response) = @_;
+
+ my $destination = $request->header('Destination');
+ $destination = URI->new($destination)->path;
+ my $destexists = $self->filesys->test("e", $destination);
+
+ $response = $self->copy($request, $response);
+ $response = $self->delete($request, $response)
+ if $response->is_success;
+
+ $response->code(201) unless $destexists;
+
+ return $response;
+}
+
+sub lock {
+ my ($self, $request, $response) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ $fs->lock($path);
+
+ return $response;
+}
+
+sub unlock {
+ my ($self, $request, $response) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ $fs->unlock($path);
+
+ return $response;
+}
+
+sub mkcol {
+ my ($self, $request, $response) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+
+ if ($request->header('Content-Length')) {
+ $response->code(415);
+ $response->message('Unsupported Media Type');
+ } elsif (not $fs->test("e", $path)) {
+ $fs->mkdir($path);
+ if ($fs->test("d", $path)) {
+ $response->code(201);
+ $response->message('Created');
+ } else {
+ $response->code(409);
+ $response->message('Conflict');
+ }
+ } else {
+ $response->code(405);
+ $response->message('Method Not Allowed');
+ }
+
+ return $response;
+}
+
+sub propfind {
+ my ($self, $request, $response, $connection) = @_;
+ my $path = decode_utf8 uri_unescape $request->uri->path;
+ my $fs = $self->filesys;
+ my $depth = $request->header('Depth');
+
+ my $reqinfo = 'allprop';
+ my @reqprops;
+ if (my $length = $request->header('Content-Length')) {
+ my $content;
+ if ($connection and length($request->content()) == 0) {
+ my $bytes = $connection->read($content, $length);
+ # Check we got it all!
+ while ($bytes < $length) {
+ my $buf;
+ $bytes += $connection->read($buf, $length - $bytes);
+ $content .= $buf;
+ }
+ }
+ else {
+ $content = $request->content;
+ }
+ my $parser = XML::LibXML->new;
+ my $doc;
+ eval { $doc = $parser->parse_string($content); };
+ if ($@) {
+ $response->code(400);
+ $response->message('Bad Request');
+ return $response;
+ }
+
+ #$reqinfo = doc->find('/DAV:propfind/*')->localname;
+ $reqinfo = $doc->find('/*/*')->shift->localname;
+ if ($reqinfo eq 'prop') {
+
+ #for my $node ($doc->find('/DAV:propfind/DAV:prop/*')) {
+ for my $node ($doc->find('/*/*/*')->get_nodelist) {
+ push @reqprops, [ $node->namespaceURI, $node->localname ];
+ }
+ }
+ }
+
+ if (!$fs->test('e', $path)) {
+ $response->code(404);
+ $response->message('Not Found');
+ return $response;
+ }
+
+ $response->code(207);
+ $response->message('Multi-Status');
+ $response->header('Content-Type' => 'text/xml; charset="utf-8"');
+
+ my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
+ my $multistat = $doc->createElement('D:multistatus');
+ $multistat->setAttribute('xmlns:D', 'DAV:');
+ $doc->setDocumentElement($multistat);
+
+ my @paths;
+ if (defined $depth && $depth eq 1 and $fs->test('d', $path)) {
+ my $p = $path;
+ $p .= '/' unless $p =~ m{/$};
+ @paths = map { $p . $_ } File::Spec->no_upwards( $fs->list($path) );
+ push @paths, $path;
+ } else {
+ @paths = ($path);
+ }
+
+ for my $path (@paths) {
+ my (
+ $dev, $ino, $mode, $nlink, $uid, $gid, $rdev,
+ $size, $atime, $mtime, $ctime, $blksize, $blocks
+ )
+ = $fs->stat($path);
+
+ # modified time is stringified human readable HTTP::Date style
+ $mtime = time2str($mtime);
+
+ # created time is ISO format
+ # tidy up date format - isoz isn't exactly what we want, but
+ # it's easy to change.
+ $ctime = time2isoz($ctime);
+ $ctime =~ s/ /T/;
+ $ctime =~ s/Z//;
+
+ $size ||= '';
+
+ my $resp = $doc->createElement('D:response');
+ $multistat->addChild($resp);
+ my $href = $doc->createElement('D:href');
+ $href->appendText(
+ File::Spec->catdir(
+ map { uri_escape encode_utf8 $_} File::Spec->splitdir($path)
+ )
+ );
+ $resp->addChild($href);
+ $href->appendText( '/' ) if $fs->test('d', $path);
+ my $okprops = $doc->createElement('D:prop');
+ my $nfprops = $doc->createElement('D:prop');
+ my $prop;
+
+ if ($reqinfo eq 'prop') {
+ my %prefixes = ('DAV:' => 'D');
+ my $i = 0;
+
+ for my $reqprop (@reqprops) {
+ my ($ns, $name) = @$reqprop;
+ if ($ns eq 'DAV:' && $name eq 'creationdate') {
+ $prop = $doc->createElement('D:creationdate');
+ $prop->appendText($ctime);
+ $okprops->addChild($prop);
+ } elsif ($ns eq 'DAV:' && $name eq 'getcontentlength') {
+ $prop = $doc->createElement('D:getcontentlength');
+ $prop->appendText($size);
+ $okprops->addChild($prop);
+ } elsif ($ns eq 'DAV:' && $name eq 'getcontenttype') {
+ $prop = $doc->createElement('D:getcontenttype');
+ if ($fs->test('d', $path)) {
+ $prop->appendText('httpd/unix-directory');
+ } else {
+ $prop->appendText('httpd/unix-file');
+ }
+ $okprops->addChild($prop);
+ } elsif ($ns eq 'DAV:' && $name eq 'getlastmodified') {
+ $prop = $doc->createElement('D:getlastmodified');
+ $prop->appendText($mtime);
+ $okprops->addChild($prop);
+ } elsif ($ns eq 'DAV:' && $name eq 'resourcetype') {
+ $prop = $doc->createElement('D:resourcetype');
+ if ($fs->test('d', $path)) {
+ my $col = $doc->createElement('D:collection');
+ $prop->addChild($col);
+ }
+ $okprops->addChild($prop);
+ } else {
+ my $prefix = $prefixes{$ns};
+ if (!defined $prefix) {
+ $prefix = 'i' . $i++;
+
+ # mod_dav sets <response> 'xmlns' attribute - whatever
+ #$nfprops->setAttribute("xmlns:$prefix", $ns);
+ $resp->setAttribute("xmlns:$prefix", $ns);
+
+ $prefixes{$ns} = $prefix;
+ }
+
+ $prop = $doc->createElement("$prefix:$name");
+ $nfprops->addChild($prop);
+ }
+ }
+ } elsif ($reqinfo eq 'propname') {
+ $prop = $doc->createElement('D:creationdate');
+ $okprops->addChild($prop);
+ $prop = $doc->createElement('D:getcontentlength');
+ $okprops->addChild($prop);
+ $prop = $doc->createElement('D:getcontenttype');
+ $okprops->addChild($prop);
+ $prop = $doc->createElement('D:getlastmodified');
+ $okprops->addChild($prop);
+ $prop = $doc->createElement('D:resourcetype');
+ $okprops->addChild($prop);
+ } else {
+ $prop = $doc->createElement('D:creationdate');
+ $prop->appendText($ctime);
+ $okprops->addChild($prop);
+ $prop = $doc->createElement('D:getcontentlength');
+ $prop->appendText($size);
+ $okprops->addChild($prop);
+ $prop = $doc->createElement('D:getcontenttype');
+ if ($fs->test('d', $path)) {
+ $prop->appendText('httpd/unix-directory');
+ } else {
+ $prop->appendText('httpd/unix-file');
+ }
+ $okprops->addChild($prop);
+ $prop = $doc->createElement('D:getlastmodified');
+ $prop->appendText($mtime);
+ $okprops->addChild($prop);
+ do {
+ $prop = $doc->createElement('D:supportedlock');
+ for my $n (qw(exclusive shared)) {
+ my $lock = $doc->createElement('D:lockentry');
+
+ my $scope = $doc->createElement('D:lockscope');
+ my $attr = $doc->createElement('D:' . $n);
+ $scope->addChild($attr);
+ $lock->addChild($scope);
+
+ my $type = $doc->createElement('D:locktype');
+ $attr = $doc->createElement('D:write');
+ $type->addChild($attr);
+ $lock->addChild($type);
+
+ $prop->addChild($lock);
+ }
+ $okprops->addChild($prop);
+ };
+ $prop = $doc->createElement('D:resourcetype');
+ if ($fs->test('d', $path)) {
+ my $col = $doc->createElement('D:collection');
+ $prop->addChild($col);
+ }
+ $okprops->addChild($prop);
+ }
+
+ if ($okprops->hasChildNodes) {
+ my $propstat = $doc->createElement('D:propstat');
+ $propstat->addChild($okprops);
+ my $stat = $doc->createElement('D:status');
+ $stat->appendText('HTTP/1.1 200 OK');
+ $propstat->addChild($stat);
+ $resp->addChild($propstat);
+ }
+
+ if ($nfprops->hasChildNodes) {
+ my $propstat = $doc->createElement('D:propstat');
+ $propstat->addChild($nfprops);
+ my $stat = $doc->createElement('D:status');
+ $stat->appendText('HTTP/1.1 404 Not Found');
+ $propstat->addChild($stat);
+ $resp->addChild($propstat);
+ }
+ }
+
+ $response->content($doc->toString(1));
+
+ return $response;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::DAV::Server - Provide a DAV Server
+
+=head1 SYNOPSIS
+
+ my $filesys = Filesys::Virtual::Plain->new({root_path => $cwd});
+ my $webdav = Net::DAV::Server->new();
+ $webdav->filesys($filesys);
+
+ my $d = HTTP::Daemon->new(
+ LocalAddr => 'localhost',
+ LocalPort => 4242,
+ ReuseAddr => 1) || die;
+ print "Please contact me at: ", $d->url, "\n";
+ while (my $c = $d->accept) {
+ $webdav->handle_connection($c);
+ undef($c);
+ }
+
+=head1 DESCRIPTION
+
+This module provides a WebDAV server. WebDAV stands for "Web-based
+Distributed Authoring and Versioning". It is a set of extensions to
+the HTTP protocol which allows users to collaboratively edit and
+manage files on remote web servers.
+
+Net::DAV::Server provides a WebDAV server and exports a filesystem for
+you using the Filesys::Virtual suite of modules. If you simply want to
+export a local filesystem, use Filesys::Virtual::Plain as above.
+
+This module doesn't currently provide a full WebDAV
+implementation. However, I am working through the WebDAV server
+protocol compliance test suite (litmus, see
+http://www.webdav.org/neon/litmus/) and will provide more compliance
+in future. The important thing is that it supports cadaver and the Mac
+OS X Finder as clients.
+
+=head1 AUTHOR
+
+Leon Brocard <acme at astray.com>
+
+=head1 MAINTAINERS
+
+ Bron Gondwana <perlcode at brong.net> ( current maintainer )
+ Leon Brocard <acme at astray.com> ( original author )
+
+The latest copy of this package can be checked out using Subversion
+from http://svn.brong.net/netdavserver/release
+
+Development code at http://svn.brong.net/netdavserver/trunk
+
+
+=head1 COPYRIGHT
+
+
+Copyright (C) 2004, Leon Brocard
+
+This module is free software; you can redistribute it or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1
Added: trunk/Catalyst-Action-DAV/litmus_test/catlitmus.pl
===================================================================
--- trunk/Catalyst-Action-DAV/litmus_test/catlitmus.pl (rev 0)
+++ trunk/Catalyst-Action-DAV/litmus_test/catlitmus.pl 2007-05-12 17:07:45 UTC (rev 6393)
@@ -0,0 +1,58 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use File::Temp;
+use Filesys::Virtual::Plain;
+
+BEGIN {
+ package CatLitmus;
+
+ use Catalyst;
+
+ __PACKAGE__->mk_classdata('filesys');
+
+ use Catalyst::Action::DAV;
+
+ sub litmus_action :Path('') :ActionClass('DAV') {
+ my ($self, $c) = @_;
+ $c->stash(filesys => $self->filesys);
+ }
+
+}
+
+sub run_litmus_server {
+ my ($port, $path) = @_;
+ # Set up Filesystem
+ my $tempdir = File::Temp::tempdir(CLEANUP => 1);
+ my $filesys = Filesys::Virtual::Plain->new({root_path => $tempdir});
+
+ $ENV{CATALYST_ENGINE} ||= 'HTTP';
+
+ CatLitmus->config(
+ actions => { litmus_action => { Path => [ $path ] } }
+ );
+
+ CatLitmus->filesys($filesys);
+
+ CatLitmus->setup;
+
+ CatLitmus->run($port, 'localhost');
+}
+
+# main code
+
+my $port = $ENV{CL_PORT} || 3000;
+my $path = $ENV{CL_PATH} || '';
+
+my $uri = join('/', "http://localhost:${port}", $path, '');
+
+if (my $pid = fork()) {
+ sleep 5;
+ system("litmus", $uri);
+ kill 9, $pid;
+ exit 0;
+} else {
+ run_litmus_server($port, $path);
+}
Property changes on: trunk/Catalyst-Action-DAV/litmus_test/catlitmus.pl
___________________________________________________________________
Name: svn:mime-type
+ text/script
Added: trunk/Catalyst-Action-DAV/litmus_test/litmus.pl
===================================================================
--- trunk/Catalyst-Action-DAV/litmus_test/litmus.pl (rev 0)
+++ trunk/Catalyst-Action-DAV/litmus_test/litmus.pl 2007-05-12 17:07:45 UTC (rev 6393)
@@ -0,0 +1,34 @@
+#!/usr/bin/perl
+#
+# Usage: "perl -I./lib litmus.pl > litmus.new; diff litmus.out litmus.new
+#
+
+use File::Temp;
+use HTTP::Daemon;
+use Net::DAV::Server;
+use Filesys::Virtual::Plain;
+
+
+# Set up Filesystem
+my $tempdir = File::Temp::tempdir(CLEANUP => 1);
+my $filesys = Filesys::Virtual::Plain->new({root_path => $tempdir});
+my $webdav = Net::DAV::Server->new();
+$webdav->filesys($filesys);
+
+# Set up Server
+my $d = HTTP::Daemon->new() || die;
+
+# Run litmus against it
+if (my $pid = fork()) {
+ system("litmus", $d->url());
+ kill 9, $pid;
+ exit 0;
+}
+
+# and do the requests...
+else {
+ while (my $c = $d->accept) {
+ $webdav->handle_connection($c, 0);
+ undef($c);
+ }
+}
Added: trunk/Catalyst-Action-DAV/t/pod.t
===================================================================
--- trunk/Catalyst-Action-DAV/t/pod.t (rev 0)
+++ trunk/Catalyst-Action-DAV/t/pod.t 2007-05-12 17:07:45 UTC (rev 6393)
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD: $@" if $@;
+all_pod_files_ok();
More information about the Catalyst-commits
mailing list