view release on metacpan or  search on metacpan

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

#
# Perl implementation of a WebDAV server running under apache.
#

package Apache::WebDAV;

use strict;
use warnings;

our $VERSION = '0.01';

use Apache;
use Apache::Constants qw(:response :http);
use Apache::Util qw(unescape_uri escape_uri);
use Data::Dumper;
use Encode;
use File::Spec;
use File::Find::Rule::Filesys::Virtual;
use URI;
use URI::Escape;
use XML::Simple qw(:strict);
use XML::LibXML;

#
# This module implements an abstract WebDAV server layer.  Like
# Net::DAV::Server, which it was sort of modelled after, this module interacts
# with instances of Filesys::Virtual child classes.
#
# Wherever possible, I have used the response constants from Apache::Constants,
# but sometimes there isn't one, and the code has been used directly.
#

# A list of implemented methods.
my %implemented = (
    copy     => 1,
    delete   => 1,
    get      => 1,
    head     => 1,
    mkcol    => 1,
    move     => 1,
    options  => 1,
    propfind => 1,
    put      => 1,
    #proppatch => 1,
    #post     => 1,
    #trace    => 1,
    #lock     => 1,
    #unlock   => 1,
);

#
# Constructor.  Does nothing.
#
sub new
{
    my $class = shift;

    bless {}, $class;
}

#
# Specify which modules will handle which paths.
#
sub register_handlers
{
    my ($self, @handlers) = @_;

    $self->{'handlers'} = \@handlers;
}

#
# Process the request.  The $r is the apache object passed in from the mod_perl
# handler.
#

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

    my $multistat = $doc->createElement('D:multistatus');

    $multistat->setAttribute('xmlns:D', 'DAV:');
    $doc->setDocumentElement($multistat);

    foreach my $file (@$files)
    {
        my $response = $doc->createElement('D:response');

        $response->appendTextChild('D:href'   => $file);
        $response->appendTextChild('D:status' => 'HTTP/1.1 403 Forbidden');

        $multistat->addChild($response);
    }

    $r->status(207);
    $r->content_type('text/xml; charset="utf-8"');
    $r->send_http_header();

    if(!$r->header_only())
    {
        $r->print($doc->toString(1));
    }

    return OK;
}

#
# Build up a WebDAV flavored XML document containing a list of files in a
# directory.  Most of this was copied from Net::DAV::Server, but I took out
# all the stuff specific to HTTP::Daemon, HTTP::Request and HTTP::Response
# (so it would be compatible with apache/mod_perl).
#
# @arg $r apache object
# @arg $files arrayref of files [{path => $path, stat => $info}, {etc...}]
#
# @ret 200 OK
#
sub list_response
{
    my ($self, $r, $files) = @_;

    my $doc = new XML::LibXML::Document('1.0', 'utf-8');
    my $multistat = $doc->createElement('D:multistatus');

    $multistat->setAttribute('xmlns:D', 'DAV:');
    $doc->setDocumentElement($multistat);

    foreach my $file (@$files)
    {
        my $path = $file->{'path'};
        my $stat = $file->{'stat'};
        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);

        my $okprops = $doc->createElement('D:prop');

        foreach my $wanted_prop (keys %$stat)
        {
            # We set these down there automatically (we are faking quota
            # support to keep webdrive happy).
            next if $wanted_prop eq 'quota';
            next if $wanted_prop eq 'quotaused';
            next if $wanted_prop eq 'quota-available-bytes';
            next if $wanted_prop eq 'quota-used-bytes';
            next if $wanted_prop eq 'quota-assigned-bytes';

            my $prop = $doc->createElement("D:$wanted_prop");

            if($wanted_prop eq 'resourcetype')
            {
                if($stat->{$wanted_prop} eq 'collection')
                {
                    my $collection = $doc->createElement('D:collection');

                    $prop->addChild($collection);
                }
            }
            else
            {
                if(defined($stat->{$wanted_prop}))
                {
                    $prop->appendText($stat->{$wanted_prop});
                }
                else
                {
                    $prop->appendText('');
                }
            }

            $okprops->addChild($prop);
        }

        # Add quota information.  This doesn't appear to be in the WebDAV
        # spec, but if it's not here, WebDrive won't allow any uploads.
        #
        # Update: I found it in a proposal here:
        #
        # http://www.greenbytes.de/tech/webdav/draft-ietf-webdav-quota-07.html
        # 
        # But it doesn't say anything about quota, quotaused, or
        # quota-assigned-bytes - I found out that webdrive was looking for those
        # from its log file.
        my $quota                 = $doc->createElement('D:quota');
        my $quota_used            = $doc->createElement('D:quotaused');
        my $quota_available_bytes = $doc->createElement('D:quota-available-bytes');
        my $quota_used_bytes      = $doc->createElement('D:quota-used-bytes');
        my $quota_assigned_bytes  = $doc->createElement('D:quota-assigned-bytes');

        $quota->appendText('2000000000');