HTTP::DAVServer::PROPFIND - Implements the PROPFIND method
Index
Code Index:
NAME
HTTP::DAVServer::PROPFIND - Implements the PROPFIND method
SUPPORT
For technical support please email to jlawrenc@cpan.org ...
for faster service please include "HTTP::DAVServer" and "help" in your subject line.
AUTHOR
Jay J. Lawrence - jlawrenc@cpan.org
Infonium Inc., Canada
http://www.infonium.ca/
COPYRIGHT
Copyright (c) 2003 Jay J. Lawrence, Infonium Inc. All rights reserved.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
ACKNOWLEDGEMENTS
Thank you to the authors of my prequisite modules. With out your help this code
would be much more difficult to write!
XML::Simple - Grant McLean
XML::SAX - Matt Sergeant
DateTime - Dave Rolsky
Also the authors of litmus, a very helpful tool indeed!
SEE ALSO
HTTP::DAV, HTTP::Webdav, http://www.webdav.org/, RFC 2518
package HTTP::DAVServer::PROPFIND;
our $VERSION=0.1;
use strict;
use warnings;
use File::stat qw(stat);
our %fileProps = (
creationdate => 1,
displayname => 1,
getcontentlanguage => 1,
getcontentlength => 1,
getetag => 1,
getlastmodified => 1,
getcontenttype => 1,
lockdiscovery => 1,
resourcetype => 1,
source => 1,
supportedlock => 1,
);
our %collProps = (
creationdate => 1,
displayname => 1,
resourcetype => 1,
supportedlock => 1,
);
sub handle {
my ($self, $r, $url, $responder, $req) = @_;
$responder->badRequest( $r, "PROPFINDVAGUE" ) unless exists $req->{'{DAV:}prop'}
|| exists $req->{'{DAV:}allprop'}
|| exists $req->{'{DAV:}propname'};
$url =~ s#/*$##;
my $depth=$r->http('Depth');
$depth="infinite" unless $depth =~ /^(0|1|infinite)$/;
my $root = $HTTP::DAVServer::ROOT;
my $host = $HTTP::DAVServer::HOST;
# Property names response
if ( exists $req->{'{DAV:}propname'} ) {
my $xml="<response>";
if ( $depth eq "0") {
$xml .= qq(<propstat>\n<href>http://$host$url</href>\n<prop>\n);
map { $xml .= qq(\t<$_/>\n) } keys %fileProps if -f "$root/$url";
map { $xml .= qq(\t<$_/>\n) } keys %collProps if -d "$root/$url";
if (-r "$root/$url") {
$xml .= qq(</prop>\n<status>HTTP/1.1 200 OK</status>\n</propstat>\n);
} else {
$xml .= qq(</prop>\n<status>HTTP/1.1 404 Not Found</status>\n</propstat>\n);
}
} else {
if ( -f "$root/$url" ) {
$xml .= qq(<propstat>\n<href>http://$host$url</href>\n<prop>\n);
map { $xml .= qq(\t<$_/>\n) } keys %fileProps;
$xml .= qq(</prop>\n<status>HTTP/1.1 200 OK</status>\n</propstat>\n);
}
if ( -d "$root/$url" ) {
$xml .= qq(<propstat>\n<href>http://$host$url</href>\n<prop>\n);
map { $xml .= qq(\t<$_/>\n) } keys %collProps;
$xml .= qq(</prop>\n<status>HTTP/1.1 200 OK</status>\n</propstat>\n);
opendir DIR, "$root/$url";
while ( my $file = readdir DIR ) {
if (-f "$root/$url/$file") {
$xml .= qq(</response>\n<response>\n);
$xml .= qq(<propstat>\n<href>http://$host$url/$file</href>\n<prop>\n);
map { $xml .= qq(\t<$_/>\n) } keys %fileProps;
$xml .= qq(</prop>\n<status>HTTP/1.1 200 OK</status>\n</propstat>\n);
last;
}
}
}
}
$xml .= "</response>\n";
$responder->multiStatus( $r, $xml );
}
my $reqProps=$req->{'{DAV:}prop'} || undef;
# Property values response
my $response=[];
fetchProps( $root, $url, "http://$host", $reqProps, $depth, $response );
my $xml = qq(<response>\n) . join ( qq(</response>\n<response>\n), @$response) . qq(</response>\n);
$responder->multiStatus( $r, $xml );
}
sub fetchProps {
my ($root, $url, $urlPrefix, $reqProps, $depth, $response) = @_;
$DB::single=1;
my $path="$root$url";
if ($depth eq "0") {
if (-d $path) {
return push @$response, collection( $path, $url, $urlPrefix, $reqProps );
} else {
return push @$response, file( $path, $url, $urlPrefix, $reqProps );
}
}
if ($depth eq "1") {
if (-d $path) {
fetchProps($root, $url, $urlPrefix, $reqProps, 0, $response);
opendir PATH, $path;
while (my $item = readdir PATH) {
next if $item =~ /^\.\.?$/;
fetchProps($root, "$url/$item", $urlPrefix, $reqProps, 0, $response);
}
closedir PATH;
} else {
fetchProps($root, $url, $urlPrefix, $reqProps, 0, $response);
}
}
if ($depth eq "infinite") {
if (-d $path) {
opendir PATH, $path;
while (my $item = readdir PATH) {
fetchProps($root, "$url/$item", $urlPrefix, $reqProps, $depth, $response);
}
closedir PATH;
} else {
fetchProps($root, $url, $urlPrefix, $reqProps, 0, $response);
}
}
}
sub collection {
my ($path, $url, $urlPrefix, $reqProps) = @_;
$reqProps ||= \%collProps;
my $stat=stat($path);
my $ret=qq(\t<href>$urlPrefix$url/</href>\n)
. qq(\t<propstat>)
. qq(<prop>\n);
foreach my $reqProp ( keys %{$reqProps} ) {
$reqProp =~ s/^{DAV:}//;
$ret .= qq(\t<$reqProp><collection/></$reqProp>\n) and next if $reqProp eq "resourcetype";
if ($reqProp eq "creationdate") {
$ret .= qq(\t<$reqProp>) . HTTP::DAVServer::dateEpoch( $stat->mtime ) . qq(</$reqProp>\n);
next;
}
if ($reqProp eq "displayname") {
$path =~ /([^\/]+\/)$/;
$ret .= qq(\t<$reqProp>$1</$reqProp>\n);
next;
}
warn "Collection property $reqProp not known\n" if $HTTP::DAVServer::WARN;
}
$ret .= qq(</prop>)
. qq(<status>HTTP/1.1 200 OK</status>)
. qq(</propstat>);
return $ret;
}
sub file {
my ($path, $url, $urlPrefix, $reqProps) = @_;
$reqProps ||= \%fileProps;
my $stat=stat($path);
my $ret=qq(\t<href>$urlPrefix$url</href>\n)
. qq(\t<propstat>)
. qq(<prop>\n);
foreach my $reqProp ( keys %{$reqProps} ) {
$reqProp =~ s/^{DAV:}//;
$ret .= qq(\t<$reqProp/>\n) and next if $reqProp eq "resourcetype";
if ($reqProp eq "creationdate") {
$ret .= qq(\t<$reqProp>) . HTTP::DAVServer::dateEpoch( $stat->mtime ) . qq(</$reqProp>\n);
next;
}
if ($reqProp eq "displayname") {
$path =~ /([^\/]+\/)$/;
$ret .= qq(\t<$reqProp>$1</$reqProp>\n);
next;
}
if ($reqProp eq "getcontentlength") {
$ret .= qq(\t<$reqProp>) . $stat->size . qq(</$reqProp>\n);
next;
}
warn "Collection property $reqProp not known\n" if $HTTP::DAVServer::WARN;
}
$ret .= qq(</prop>)
. qq(<status>HTTP/1.1 200 OK</status>)
. qq(</propstat>);
return $ret;
}
1;