view release on metacpan or  search on metacpan

lib/HTTP/DAV/Resource.pm  view on Meta::CPAN

    ####
    # Setup the headers for the lock request
    my $headers = new HTTP::Headers;
    $headers->header("Depth",     $depth);
    $headers->header("Overwrite", $overwrite);

    # Destination Resource must have a URL
    my $dest_url = $dest_resource->get_uri;
    my $server_type
        = $self->{_comms}->get_server_type($dest_url->host_port());
    my $dest_str = $dest_url->as_string;

    # Apache, Bad Gateway workaround
    if ($server_type =~ /Apache/i && $server_type =~ /DAV\//i) {

        #my $dest_str = "http://" . $dest_url->host_port . $dest_url->path;
        $dest_str
            = $dest_url->scheme . "://"
            . $dest_url->host_port
            . $dest_url->path;

        if ($HTTP::DAV::DEBUG) {
            warn
                "*** INSTIGATING mod_dav WORKAROUND FOR DESTINATION HEADER BUG IN Resource::_move_copy\n";
            warn "*** Server type of "
                . $dest_url->host_port()
                . ": $server_type\n";
            warn "*** Adding port number :"
                . $dest_url->port
                . " to given url: $dest_url\n";
        }

    }

    # Apache2 mod_dav, Permenantly Moved workaround
    # If the src is a collection, then the dest must have a trailing
    # slash or mod_dav2 gives a strange "bad url" error in a
    # "Moved Permenantly" response.
    if ($self->is_collection || $self->get_uri =~ /\/$/) {
        $dest_str =~ s#/*$#/#;
    }

    $headers->header("Destination", $dest_str);

    # Join both the If headers together.
    $self->_setup_if_headers($headers, 1);
    my $if1 = $headers->header('If');
    $if1 ||= "";
    warn "COPY/MOVE If header for source: $if1\n" if $HTTP::DAV::DEBUG > 2;
    $dest_resource->_setup_if_headers($headers, 1);
    my $if2 = $headers->header('If');
    $if2 ||= "";
    warn "COPY/MOVE If header for dest  : $if2\n" if $HTTP::DAV::DEBUG > 2;
    $if1 = "$if1 $if2" if ($if1 || $if2);
    $headers->header('If', $if1) if $if1;

    # See from RFC 12.12.
    # Valid values for '$text':
    #
    #    <D:keepalive>*</D:keepalive>
    # or
    #    <D:keepalive>
    #       <D:href>...url1...</D:href>
    #       <D:href>...url2...</D:href>
    #    </D:keepalive>
    # or
    #    <D:omit/>
    #
    my $xml_request;
    if ($text) {
        $headers->header("Content-type", "text/xml; charset=\"utf-8\"");
        $xml_request = qq{<?xml version="1.0" encoding="utf-8"?>};
        $xml_request .= '<D:propertybehavior xmlns:D="DAV:">';
        $xml_request .= $text;
        $xml_request .= "</D:propertybehavior>";
    }

    ####
    # Put the copy request to the remote server
    my $resp = $self->{_comms}->do_http_request(
        -method  => $method,
        -url     => $self->{_uri},
        -headers => $headers,
        -content => $xml_request,
    );

    if ($resp->is_multistatus()) {
        my $parser = new XML::DOM::Parser;
        my $doc    = $parser->parse($resp->content);
        eval { $self->_XML_parse_multistatus($doc, $resp) };
        warn "XML error: " . $@ if $@;
        $doc->dispose;
    }

    # MOVE EATS SOURCE LOCKS
    if ($method eq "MOVE") {
        $self->_unset_my_locks();

        # Well... I'm baffled.
        # I previousy had this commented out because my
        # undestanding was that the dest lock stayed in tact.
        # But mod_dav seems to remove it after a move. So,
        # I'm going to fall in line, but if another server
        # implements this differently, then I'm going to have
        # to pipe up and get them to sort out their differences :)
        #$dest_resource->_unset_my_locks();
    }

    return $resp;
}

###########################################################################
# proppatch a resource/collection
sub proppatch {
    my ($self, @p) = @_;

    my ($namespace, $propname, $propvalue, $action, $use_nsabbr)
        = HTTP::DAV::Utils::rearrange(
        [ 'NAMESPACE', 'PROPNAME', 'PROPVALUE', 'ACTION', 'NSABBR' ], @p);

    $use_nsabbr ||= 'R';

    # Sanity check. If action ain't 'remove' then set it to 'set';
    $action = (defined $action && $action eq "remove") ? "remove" : "set";