view release on metacpan or  search on metacpan

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

# @arg $files arrayref of files that had errors
#
# @ret 200 OK
#
sub delete_response
{
    my ($self, $r, $files) = @_;

    # This is a bit screwed up.  WebDrive doesn't properly parse 207 multistatus
    # responses for deletes.  So if it's webdrive, just send a generic error
    # code.  I know this sucks but the majority of our users use webdrive so
    # we have to do it.
    #
    # Here is the response from their tech support:
    # 
    # webdrive is not parsing the 207 multistatus response to look for the
    # error code.  If the DELETE returns an HTTP error like 403 instead of
    # 207 then webdrive would recognize the error.  Webdrive should parse
    # the response but currently it doesn't for the DELETE command.
    # It's nothing you are doing wrong, it's just something that wasn't
    # fully implemented with webdrive and the delete command.
    #
    if($r->header_in('User-Agent') =~ /WebDrive/)
    {
        $r->status(FORBIDDEN);
        $r->send_http_header();
        return OK;
    }

    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 $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
            {