"Fossies" - the Fresh Open Source Software Archive

Member "HTTP-DAV-0.49/lib/HTTP/DAV/Resource.pm" (28 Nov 2018, 57470 Bytes) of package /linux/www/HTTP-DAV-0.49.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Resource.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 0.48_vs_0.49.

    1 package HTTP::DAV::Resource;
    2 
    3 use strict;
    4 use vars qw($VERSION);
    5 
    6 $VERSION = '0.31';
    7 
    8 use HTTP::DAV;
    9 use HTTP::DAV::Utils;
   10 use HTTP::DAV::Lock;
   11 use HTTP::Date qw(str2time);
   12 use HTTP::DAV::ResourceList;
   13 use Scalar::Util ();
   14 use URI::Escape;
   15 
   16 ###########################################################################
   17 
   18 # Construct a new object and initialize it
   19 sub new {
   20     my $class = shift;
   21     my $self = bless {}, ref($class) || $class;
   22     $self->_init(@_);
   23     return $self;
   24 }
   25 
   26 sub _init {
   27     my ($self, @p) = @_;
   28 
   29     ####
   30     # This is the order of the arguments unless used as
   31     # named parameters
   32     my ($uri, $lockedresourcelist, $comms, $client)
   33         = HTTP::DAV::Utils::rearrange(
   34         [ 'URI', 'LOCKEDRESOURCELIST', 'COMMS', 'CLIENT' ], @p);
   35 
   36     # Optionally add a scheme.
   37     $uri =~ s/^\s*(.*?)\s*$/$1/g;    # Remove leading and trailing slashes
   38     $uri = "http://$uri" if ($uri ne "" && $uri !~ /^https?:\/\//);
   39 
   40     $self->{"_uri"}                = $uri                || "";
   41     $self->{"_lockedresourcelist"} = $lockedresourcelist || "";
   42     $self->{"_comms"}              = $comms              || "";
   43     $self->{"_dav_client"}         = $client             || "";
   44 
   45     # Avoid circular references between
   46     # - HTTP::DAV -> {_workingresource} and
   47     # - HTTP::DAV::Resource -> {_dav_client}
   48     Scalar::Util::weaken($self->{"_dav_client"});
   49 
   50     ####
   51     # Set the _uri
   52     $self->{_uri} = HTTP::DAV::Utils::make_uri($self->{_uri});
   53     die "HTTP URL required when creating a Resource object\n"
   54         if (!$self->{_uri}->scheme);
   55 
   56     ####
   57     # Check that the required objects exist
   58 
   59     die("Comms object required when creating a Resource object")
   60         unless (defined $self->{_comms}
   61         && $self->{_comms} =~ /HTTP::DAV::Comms/);
   62 
   63     die("Locked ResourceList object required when creating a Resource object")
   64         unless (defined $self->{_lockedresourcelist}
   65         && $self->{_lockedresourcelist} =~ /HTTP::DAV::ResourceList/);
   66 
   67     die("DAV Client required when creating a Resource object")
   68         unless (defined $self->{_dav_client}
   69         && $self->{_dav_client} =~ /HTTP::DAV/);
   70 }
   71 
   72 ###########################################################################
   73 
   74 # GET/SET
   75 #sub set_lockpolicy { cluck("Can't reset the lockpolicy on a Resource"); 0; }
   76 
   77 sub set_parent_resourcelist {
   78     my ($self, $resource_list) = @_;
   79 
   80     # Avoid circular references between the
   81     # parent resource list and this child resource
   82     Scalar::Util::weaken($self->{_parent_resourcelist} = $resource_list);
   83 }
   84 
   85 sub set_property { $_[0]->{_properties}{ $_[1] } = $_[2]; }
   86 
   87 sub set_uri { $_[0]->{_uri} = HTTP::DAV::Utils::make_uri($_[1]); }
   88 
   89 # PRIVATE SUBROUTINES
   90 sub _set_content    { $_[0]->{_content}    = $_[1]; }
   91 sub _set_options    { $_[0]->{_options}    = $_[1]; }
   92 sub _set_compliance { $_[0]->{_compliance} = $_[1]; }
   93 
   94 sub set_locks {
   95     my ($self, @locks) = @_;
   96 
   97     # Unset any existing locks because we're about to reset them
   98     # But keep their name temporarily because some of them
   99     # may be ours.
  100     my @old_lock_tokens = keys %{ $self->{_locks} } || ();
  101 
  102     #if (@locks && defined $self->{_locks}) {
  103     if (defined $self->{_locks}) {
  104         delete $self->{_locks};
  105     }
  106 
  107     foreach my $lock (@locks) {
  108         my $token = $lock->get_locktoken();
  109 
  110         #print "Adding $token\n";
  111 
  112         # If it exists, we'll set it to owned and reapply
  113         # it (it may have changed since we saw it last.
  114         # Like it might have timed out?
  115         if (grep($token, @old_lock_tokens)) {
  116             $lock->set_owned(1);
  117         }
  118         $self->{_locks}{$token} = $lock;
  119     }
  120 
  121     #print "Locks: " . join(' ',keys %{$self->{_locks}} )."\n";
  122 }
  123 
  124 sub is_option {
  125     my ($self, $option) = @_;
  126     $self->options if (!defined $self->{_options});
  127     return ($self->{_options} =~ /\b$option\b/i) ? 1 : 0;
  128 }
  129 
  130 sub is_dav_compliant {
  131     my $resp = $_[0]->options if (!defined $_[0]->{_options});
  132     $_[0]->{_compliance};
  133 }
  134 
  135 sub get_options { $_[0]->{_options}; }
  136 
  137 sub get_content     { $_[0]->{_content}; }
  138 sub get_content_ref { \$_[0]->{_content}; }
  139 
  140 sub get_username {
  141     my ($self) = @_;
  142     my $ra = $self->{_comms}->get_user_agent();
  143     my @userpass = $ra->get_basic_credentials(undef, $self->get_uri());
  144     return $userpass[0];
  145 }
  146 
  147 #sub get_lockpolicy { $_[0]->{_lockpolicy}; }
  148 sub get_client              { $_[0]->{_dav_client}; }
  149 sub get_resourcelist        { $_[0]->{_resource_list}; }
  150 sub get_lockedresourcelist  { $_[0]->{_lockedresourcelist}; }
  151 sub get_comms               { $_[0]->{_comms}; }
  152 sub get_property            { $_[0]->{_properties}{ $_[1] } || ""; }
  153 sub get_uri                 { $_[0]->{_uri}; }
  154 sub get_uristring           { $_[0]->{_uri}->as_string; }
  155 sub get_parent_resourcelist { $_[0]->{_parent_resourcelist}; }
  156 
  157 # $self->get_locks( -owned => [0|1] );
  158 #  '1'  = return any locks owned be me
  159 #  '0'   = return any locks NOT owned be me
  160 #  no value = return all locks
  161 #
  162 sub get_locks {
  163     my ($self, @p) = @_;
  164     my ($owned) = HTTP::DAV::Utils::rearrange(['OWNED'], @p);
  165     $owned = "" unless defined $owned;
  166 
  167     #print "owned=$owned,\@p=\"@p\"\n";
  168 
  169     my @return_locks = ();
  170 
  171     foreach my $token (sort keys %{ $self->{_locks} }) {
  172         my $lock = $self->{_locks}{$token};
  173         if ($owned eq "1" && $lock->is_owned) {
  174             push(@return_locks, $lock);
  175         }
  176         elsif ($owned eq "0" && !$lock->is_owned) {
  177             push(@return_locks, $lock);
  178         }
  179         elsif ($owned eq "") {
  180             push(@return_locks, $lock);
  181         }
  182     }
  183 
  184     return @return_locks;
  185 }
  186 
  187 sub get_lock {
  188     my ($self, $token) = @_;
  189     return $self->{_locks}{$token} if ($token);
  190 }
  191 
  192 # Just pass through to get_locks all of our parameters.
  193 # Then count how many we get back. >1 lock returns 1.
  194 sub is_locked {
  195     my ($self, @p) = @_;
  196     return scalar $self->get_locks(@p);
  197 }
  198 
  199 sub is_collection {
  200     my $type = $_[0]->get_property("resourcetype");
  201     return (defined $type && $type =~ /collection/) ? 1 : 0;
  202 }
  203 
  204 sub _unset_properties { $_[0]->{_properties} = (); }
  205 sub _unset_lock { delete $_[0]->{_locks}{ $_[1] } if $_[1]; }
  206 sub _unset_locks { $_[0]->{_locks} = (); }
  207 
  208 sub _unset_my_locks {
  209     my ($self) = @_;
  210     my @locks = $self->get_locks(-owned => 1);
  211     foreach my $lock (@locks) {
  212         $self->_unset_lock($lock->get_locktoken);
  213     }
  214     $self->get_lockedresourcelist->remove_resource($self);
  215 }
  216 
  217 ###########################################################################
  218 sub lock {
  219     my ($self, @p) = @_;
  220 
  221     my $lock = HTTP::DAV::Lock->new(-owned => 1);
  222 
  223     #my $existing_lock = $self->get_lockedresourcelist->get_member($self->uri);
  224 
  225     my ($owner, $depth, $timeout, $scope, $type, @other)
  226         = HTTP::DAV::Utils::rearrange(
  227         [ 'OWNER', 'DEPTH', 'TIMEOUT', 'SCOPE', 'TYPE' ], @p);
  228 
  229     ####
  230     # Set the defaults
  231 
  232     # 'owner' default is DAV.pm/v0.1 (ProcessId)
  233     $owner ||= "DAV.pm/v$HTTP::DAV::VERSION ($$)";
  234 
  235     # Sanity check. If it ain't 0, then make it infinity.
  236     $depth = (defined $depth && $depth eq "0") ? 0 : "infinity";
  237 
  238     # 'scope' default is exclusive
  239     $scope ||= "exclusive";
  240 
  241     # 'type' default is write
  242     $type ||= "write";
  243 
  244     ####
  245     # Setup the headers for the lock request
  246     my $headers = HTTP::DAV::Headers->new;
  247     $headers->header("Content-type", "text/xml; charset=\"utf-8\"");
  248     $headers->header("Depth",        $depth);
  249     my $timeoutval = $lock->timeout($timeout);
  250     $headers->header("Timeout", $timeoutval) if ($timeoutval);
  251 
  252     # Add any If headers required
  253     #$self->_setup_if_headers($headers);
  254 
  255     ####
  256     # Setup the XML content for the lock request
  257     my $xml_request = HTTP::DAV::Lock->make_lock_xml(
  258         -owner   => $owner,
  259         -timeout => $timeout,
  260         -scope   => $scope,
  261         -type    => $type,
  262     );
  263 
  264     #print "$xml_request\n";
  265 
  266     ####
  267     # Put the lock request to the remote server
  268     my $resp = $self->{_comms}->do_http_request(
  269         -method  => "LOCK",
  270         -url     => $self->{_uri},
  271         -headers => $headers,
  272         -content => $xml_request,
  273     );
  274 
  275     ###
  276     # Handle the lock response
  277 
  278     # Normal spec scenario
  279     if ($self->content_type_is_xml($resp)) {
  280 
  281         # use XML::DOM to parse the result.
  282         my $parser = new XML::DOM::Parser;
  283         my $doc    = $parser->parse($resp->content);
  284 
  285         ###
  286         # Multistatus response. Generally indicates a failure
  287         if ($resp->code == 207) {
  288 
  289             # We're only interested in the error codes that come
  290             # out of the multistatus $resp.
  291             eval { $self->_XML_parse_multistatus($doc, $resp) };
  292             print "XML error: " . $@ if $@;
  293         }
  294 
  295         ###
  296         # Lock succeeded
  297         # 1. I assume from RFC2518 that if it successsfully locks
  298         # then we will only get back the lockdiscover element
  299         # for MY lock. If not, I will warn the user.
  300         #
  301         # 2. I am fairly sure that my client should only ever be able to
  302         # take out one lock on a resource. As such this program assumes
  303         # that a resource can only have one lock held against it (locks
  304         # owned by other people do not get stored here).
  305         #
  306         elsif ($resp->is_success) {
  307             my $node_prop
  308                 = HTTP::DAV::Utils::get_only_element($doc, "D:prop");
  309             my $lock_discovery
  310                 = HTTP::DAV::Utils::get_only_element($node_prop,
  311                 "D:lockdiscovery");
  312             my @locks
  313                 = HTTP::DAV::Lock->XML_lockdiscovery_parse($lock_discovery);
  314 
  315             # Degenerate case for bad server mydocsonline.
  316             # Doesn't return a proper lockdiscovery.
  317             # Just use the Lock-Token in the header instead.
  318             if (!@locks && $resp->header('Lock-Token')) {
  319                 print
  320                     "Using degenerate case of getting Lock-Token from Header.\n"
  321                     if $HTTP::DAV::DEBUG > 2;
  322                 $locks[0] = HTTP::DAV::Lock->new(-owned => 1);
  323                 $locks[0]->set_locktoken($resp->header('Lock-Token'));
  324             }
  325 
  326             if ($#locks > 0) {
  327                 warn(
  328                     "Serious protocol error, expected 1 lock back from request "
  329                         . "but got more than one. Don't know which one is mine"
  330                 );
  331             }
  332             else {
  333                 $self->set_locks(@locks);
  334                 foreach my $lock (@locks) { $lock->set_owned(1); }
  335                 $self->{_lockedresourcelist}->add_resource($self);
  336 
  337                 #print $self->{_lockedresourcelist}->as_string;
  338             }
  339         }
  340 
  341         # Discard of XML doc safely.
  342         $doc->dispose;
  343     }
  344 
  345     return $resp;
  346 }
  347 
  348 ###########################################################################
  349 sub unlock {
  350     my ($self, @p) = @_;
  351     my ($opaquelocktoken) = HTTP::DAV::Utils::rearrange(['TOKEN'], @p);
  352     my $resp;
  353 
  354     my $uri = $self->get_uri();
  355 
  356     # If you passed no lock token then I'll try
  357     # and unlock with any tokens I own.
  358     if (!$opaquelocktoken) {
  359         my @locks = $self->get_locks(-owned => 1);
  360         my $num_locks = $#locks + 1;
  361         if ($num_locks == 0) {
  362 
  363             # Just use a dummy token. They're unique anyway.
  364             #$opaquelocktoken = "opaquelocktoken:dummytoken-82d32fa22932";
  365             $opaquelocktoken = "";
  366         }
  367         if ($num_locks == 1) {
  368             $opaquelocktoken = $locks[0]->get_locktoken;
  369         }
  370         else {
  371             foreach my $lock (@locks) {
  372                 $resp = $self->unlock(-token => $lock->get_locktoken);
  373                 return $resp if $resp->is_error();
  374             }
  375         }
  376     }
  377 
  378     my $headers = HTTP::DAV::Headers->new;
  379 
  380     #$headers->header("Lock-Token", "<${opaquelocktoken}>") if $opaquelocktoken;
  381     $headers->header("Lock-Token", "<${opaquelocktoken}>");
  382 
  383     if ($opaquelocktoken) {
  384         warn "UNLOCKING with '$opaquelocktoken'\n" if $HTTP::DAV::DEBUG > 2;
  385 
  386         # Put the unlock request to the remote server
  387         $resp = $self->{_comms}->do_http_request(
  388             -method  => "UNLOCK",
  389             -url     => $self->get_uri,
  390             -headers => $headers,
  391 
  392             #-content => no content required
  393         );
  394     }
  395     else {
  396 
  397         #print "START\n";
  398         $resp = HTTP::Response->new(500, "Client error. No lock held.");
  399         $resp = HTTP::DAV::Response->clone_http_resp($resp);
  400 
  401         #print $resp->as_string();
  402         #print "END\n";
  403     }
  404 
  405     if ($resp->is_success) {
  406         $self->_unset_lock($opaquelocktoken);
  407     }
  408 
  409     return $resp;
  410 }
  411 
  412 ###########################################################################
  413 sub forcefully_unlock_all {
  414     my ($self) = @_;
  415     my $resp;
  416 
  417     my $discovery_resp = $self->lockdiscovery;
  418     if ($discovery_resp->is_success) {
  419         my @locks = $self->get_locks();
  420         foreach my $lock (@locks) {
  421             my $token = $lock->get_locktoken;
  422             $resp = $self->unlock(-token => $token) if $token;
  423             return $resp if $resp->is_error;
  424         }
  425     }
  426 
  427     # In the event that there were no locks to steal,
  428     # then just send a dud request out and let the
  429     # server fail it.
  430     if (!$resp) {
  431         $resp = $self->unlock();
  432     }
  433 
  434     return $resp;
  435 }
  436 ###########################################################################
  437 sub steal_lock {
  438     my ($self) = @_;
  439 
  440     $self->forcefully_unlock_all;
  441     return $self->lock;
  442 }
  443 
  444 ###########################################################################
  445 sub lockdiscovery {
  446     my ($self, @p) = @_;
  447     my ($depth, @other) = HTTP::DAV::Utils::rearrange(['DEPTH'], @p);
  448 
  449     return $self->propfind(
  450         -depth => $depth,
  451         -text  => "<D:prop><D:lockdiscovery/></D:prop>"
  452     );
  453 }
  454 
  455 ###########################################################################
  456 sub propfind {
  457     my ($self, @p) = @_;
  458 
  459     my ($depth, $text, @other)
  460         = HTTP::DAV::Utils::rearrange([ 'DEPTH', 'TEXT' ], @p);
  461 
  462     # 'depth' default is 1
  463     $depth = 1 unless (defined $depth && $depth ne "");
  464 
  465     ####
  466     # Setup the headers for the request
  467     my $headers = new HTTP::Headers;
  468     $headers->header("Content-type", "text/xml; charset=\"utf-8\"");
  469     $headers->header("Depth",        $depth);
  470 
  471     # Create a new XML document
  472     #   <D:propfind xmlns:D="DAV:">
  473     #       <D:allprop/>
  474     #   </D:propfind>
  475     my $xml_request = qq{<?xml version="1.0" encoding="utf-8"?>};
  476     $xml_request .= '<D:propfind xmlns:D="DAV:">';
  477     $xml_request .= $text || "<D:allprop/>";
  478     $xml_request .= "</D:propfind>";
  479 
  480     ####
  481     # Put the propfind request to the remote server
  482     my $resp = $self->{_comms}->do_http_request(
  483         -method  => "PROPFIND",
  484         -url     => $self->{_uri},
  485         -headers => $headers,
  486         -content => $xml_request,
  487     );
  488 
  489     # Reset the resource list, in case of intermediate errors,
  490     # to keep object state consistent
  491     $self->{_resource_list} = undef;
  492 
  493     if (! $self->content_type_is_xml($resp)) {
  494         $resp->add_status_line(
  495             "HTTP/1.1 422 Unprocessable Entity, no XML body.",
  496             "", $self->{_uri}, $self->{_uri}
  497         );
  498         return $resp;
  499     }
  500 
  501     # use XML::DOM to parse the result.
  502     my $parser = XML::DOM::Parser->new();
  503     my $xml_resp = $resp->content;
  504     my $doc;
  505 
  506     if (! $xml_resp) {
  507         $resp->add_status_line(
  508             "HTTP/1.1 422 Unprocessable Entity, no XML body.",
  509             "", $self->{_uri}, $self->{_uri}
  510         );
  511         return $resp;
  512     }
  513 
  514     eval {
  515         $doc = $parser->parse($xml_resp);
  516     } or do {
  517         warn "Unparsable XML received from server (" . length($xml_resp) . " bytes)\n";
  518         warn "ERROR: $@\n";
  519         return $resp;
  520     };
  521 
  522     # Setup a ResourceList in which to pump all of the collection
  523     my $resource_list;
  524     eval {
  525         $resource_list = $self->_XML_parse_multistatus($doc, $resp)
  526     } or do {
  527         warn "Error parsing PROPFIND response XML: $@\n";
  528     };
  529 
  530     if ($resource_list && $resource_list->count_resources()) {
  531         $self->{_resource_list} = $resource_list;
  532     }
  533 
  534     $doc->dispose;
  535 
  536     return $resp;
  537 }
  538 
  539 ###########################################################################
  540 # get/GET the body contents
  541 sub get {
  542     my ($self, @p) = @_;
  543 
  544     my ($save_to, $progress_callback, $chunk)
  545         = HTTP::DAV::Utils::rearrange(
  546         [ 'SAVE_TO', 'PROGRESS_CALLBACK', 'CHUNK' ], @p);
  547 
  548     #$save_to = URI::Escape::uri_unescape($save_to);
  549     my $resp = $self->{_comms}->do_http_request(
  550         -method   => "GET",
  551         -uri      => $self->get_uri,
  552         -save_to  => $save_to,
  553         -callback => $progress_callback,
  554         -chunk    => $chunk
  555     );
  556 
  557     # What to do with all of the headers in the response. Put
  558     # them into this object? If so, which ones?
  559     if ($resp->is_success) {
  560         $self->_set_content($resp->content);
  561     }
  562 
  563     return $resp;
  564 }
  565 sub GET { shift->get(@_); }
  566 
  567 ###########################################################################
  568 # put/PUT the body contents
  569 
  570 sub put {
  571     my ($self, $content, $custom_headers) = @_;
  572     my $resp;
  573 
  574     # Setup the If: header if it is locked
  575     my $headers = HTTP::DAV::Headers->new();
  576 
  577     $self->_setup_if_headers($headers);
  578     $self->_setup_custom_headers($custom_headers);
  579 
  580     if (!defined $content) {
  581         $content = $self->get_content();
  582 
  583         # if ( ! $content ) {
  584         #    #$resp = HTTP::DAV::Response->new;
  585         #    #$resp->code("400"); ??
  586         #    return $resp;
  587         # }
  588     }
  589 
  590     $resp = $self->{_comms}->do_http_request(
  591         -method  => "PUT",
  592         -uri     => $self->get_uri,
  593         -headers => $headers,
  594         -content => $content,
  595     );
  596 
  597     #my $unlockresp = $self->unlock;
  598 
  599     # What to do with all of the headers in the response. Put
  600     # them into this object? If so, which ones?
  601     # $self->_set_content( $resp->content );
  602 
  603     return $resp;
  604 }
  605 sub PUT { my $self = shift; $self->put(@_); }
  606 
  607 ###########################################################################
  608 # Make a collection
  609 sub mkcol {
  610     my ($self) = @_;
  611 
  612     # Setup the If: header if it is locked
  613     my $headers = HTTP::DAV::Headers->new();
  614     $self->_setup_if_headers($headers);
  615 
  616     my $resp = $self->{_comms}->do_http_request(
  617         -method  => "MKCOL",
  618         -uri     => $self->get_uri,
  619         -headers => $headers,
  620     );
  621 
  622     # Handle a multistatus response
  623     if ($self->content_type_is_xml($resp) &&    # XML body
  624         $resp->is_multistatus()                 # Multistatus
  625         )
  626     {
  627 
  628         # use XML::DOM to parse the result.
  629         my $parser = new XML::DOM::Parser;
  630         my $doc    = $parser->parse($resp->content);
  631 
  632         # We're only interested in the error codes that come out of $resp.
  633         eval { $self->_XML_parse_multistatus($doc, $resp) };
  634         warn "XML error: " . $@ if $@;
  635         $doc->dispose;
  636     }
  637 
  638     return $resp;
  639 }
  640 
  641 ###########################################################################
  642 # Get OPTIONS available on a resource/collection
  643 sub options {
  644     my ($self, $entire_server) = @_;
  645 
  646     my $uri = $self->get_uri;
  647 
  648     # Doesn't work properly. Sets it as /*
  649     # How do we get LWP to send through just
  650     # OPTIONS * HTTP/1.1
  651     # ??
  652     #$uri->path("*") if $entire_server;
  653 
  654     my $resp = $self->{_comms}->do_http_request(
  655         -method => "OPTIONS",
  656         -uri    => $uri,
  657     );
  658 
  659     if ($resp->header("Allow")) {
  660 
  661         #print "Allow: ". $resp->header("Allow") . "\n";
  662         $self->_set_options($resp->header("Allow"));
  663     }
  664 
  665     # Get the "DAV" header and look for
  666     # either "DAV:1" or "DAV:1,2"
  667     my $compliance = 0;
  668     if ($resp->header("DAV")) {
  669 
  670         $compliance = $resp->header("DAV");
  671         if ($compliance =~ /^\s*1\s*,\s*2/) {
  672             $compliance = 2;
  673         }
  674 
  675         elsif ($compliance =~ /^\s*1/) {
  676             $compliance = 1;
  677         }
  678 
  679     }
  680     $self->_set_compliance($compliance);
  681 
  682     return $resp;
  683 }
  684 
  685 sub OPTIONS { my $self = shift; $self->options(@_); }
  686 
  687 ###########################################################################
  688 # Move or copy a resource/collection
  689 sub move { return shift->_move_copy("MOVE", @_); }
  690 sub copy { return shift->_move_copy("COPY", @_); }
  691 
  692 sub _move_copy {
  693     my ($self, $method, @p) = @_;
  694     my ($dest_resource, $overwrite, $depth, $text, @other)
  695         = HTTP::DAV::Utils::rearrange(
  696         [ 'DEST', 'OVERWRITE', 'DEPTH', 'TEXT' ], @p);
  697 
  698     # Sanity check. If depth ain't 0, then make it infinity.
  699     # Only infinity allowed for move.
  700     # 0 or infinity allowed for copy.
  701     if ($method eq "MOVE") {
  702         $depth = "infinity";
  703     }
  704     else {
  705         $depth = (defined $depth && $depth eq "0") ? 0 : "infinity";
  706     }
  707 
  708     # Sanity check. If overwrite ain't F or 0, then make it T
  709     $overwrite = "F" if (defined $overwrite && $overwrite eq "0");
  710     $overwrite = (defined $overwrite && $overwrite eq "F") ? "F" : "T";
  711 
  712     ####
  713     # Setup the headers for the lock request
  714     my $headers = new HTTP::Headers;
  715     $headers->header("Depth",     $depth);
  716     $headers->header("Overwrite", $overwrite);
  717 
  718     # Destination Resource must have a URL
  719     my $dest_url = $dest_resource->get_uri;
  720     my $server_type
  721         = $self->{_comms}->get_server_type($dest_url->host_port());
  722     my $dest_str = $dest_url->as_string;
  723 
  724     # Apache, Bad Gateway workaround
  725     if ($server_type =~ /Apache/i && $server_type =~ /DAV\//i) {
  726 
  727         #my $dest_str = "http://" . $dest_url->host_port . $dest_url->path;
  728         $dest_str
  729             = $dest_url->scheme . "://"
  730             . $dest_url->host_port
  731             . $dest_url->path;
  732 
  733         if ($HTTP::DAV::DEBUG) {
  734             warn
  735                 "*** INSTIGATING mod_dav WORKAROUND FOR DESTINATION HEADER BUG IN Resource::_move_copy\n";
  736             warn "*** Server type of "
  737                 . $dest_url->host_port()
  738                 . ": $server_type\n";
  739             warn "*** Adding port number :"
  740                 . $dest_url->port
  741                 . " to given url: $dest_url\n";
  742         }
  743 
  744     }
  745 
  746     # Apache2 mod_dav, Permenantly Moved workaround
  747     # If the src is a collection, then the dest must have a trailing
  748     # slash or mod_dav2 gives a strange "bad url" error in a
  749     # "Moved Permenantly" response.
  750     if ($self->is_collection || $self->get_uri =~ /\/$/) {
  751         $dest_str =~ s#/*$#/#;
  752     }
  753 
  754     $headers->header("Destination", $dest_str);
  755 
  756     # Join both the If headers together.
  757     $self->_setup_if_headers($headers, 1);
  758     my $if1 = $headers->header('If');
  759     $if1 ||= "";
  760     warn "COPY/MOVE If header for source: $if1\n" if $HTTP::DAV::DEBUG > 2;
  761     $dest_resource->_setup_if_headers($headers, 1);
  762     my $if2 = $headers->header('If');
  763     $if2 ||= "";
  764     warn "COPY/MOVE If header for dest  : $if2\n" if $HTTP::DAV::DEBUG > 2;
  765     $if1 = "$if1 $if2" if ($if1 || $if2);
  766     $headers->header('If', $if1) if $if1;
  767 
  768     # See from RFC 12.12.
  769     # Valid values for '$text':
  770     #
  771     #    <D:keepalive>*</D:keepalive>
  772     # or
  773     #    <D:keepalive>
  774     #       <D:href>...url1...</D:href>
  775     #       <D:href>...url2...</D:href>
  776     #    </D:keepalive>
  777     # or
  778     #    <D:omit/>
  779     #
  780     my $xml_request;
  781     if ($text) {
  782         $headers->header("Content-type", "text/xml; charset=\"utf-8\"");
  783         $xml_request = qq{<?xml version="1.0" encoding="utf-8"?>};
  784         $xml_request .= '<D:propertybehavior xmlns:D="DAV:">';
  785         $xml_request .= $text;
  786         $xml_request .= "</D:propertybehavior>";
  787     }
  788 
  789     ####
  790     # Put the copy request to the remote server
  791     my $resp = $self->{_comms}->do_http_request(
  792         -method  => $method,
  793         -url     => $self->{_uri},
  794         -headers => $headers,
  795         -content => $xml_request,
  796     );
  797 
  798     if ($resp->is_multistatus()) {
  799         my $parser = new XML::DOM::Parser;
  800         my $doc    = $parser->parse($resp->content);
  801         eval { $self->_XML_parse_multistatus($doc, $resp) };
  802         warn "XML error: " . $@ if $@;
  803         $doc->dispose;
  804     }
  805 
  806     # MOVE EATS SOURCE LOCKS
  807     if ($method eq "MOVE") {
  808         $self->_unset_my_locks();
  809 
  810         # Well... I'm baffled.
  811         # I previousy had this commented out because my
  812         # undestanding was that the dest lock stayed in tact.
  813         # But mod_dav seems to remove it after a move. So,
  814         # I'm going to fall in line, but if another server
  815         # implements this differently, then I'm going to have
  816         # to pipe up and get them to sort out their differences :)
  817         #$dest_resource->_unset_my_locks();
  818     }
  819 
  820     return $resp;
  821 }
  822 
  823 ###########################################################################
  824 # proppatch a resource/collection
  825 sub proppatch {
  826     my ($self, @p) = @_;
  827 
  828     my ($namespace, $propname, $propvalue, $action, $use_nsabbr)
  829         = HTTP::DAV::Utils::rearrange(
  830         [ 'NAMESPACE', 'PROPNAME', 'PROPVALUE', 'ACTION', 'NSABBR' ], @p);
  831 
  832     $use_nsabbr ||= 'R';
  833 
  834     # Sanity check. If action ain't 'remove' then set it to 'set';
  835     $action = (defined $action && $action eq "remove") ? "remove" : "set";
  836 
  837     ####
  838     # Setup the headers for the lock request
  839     my $headers = new HTTP::Headers;
  840     $headers->header("Content-type", "text/xml; charset=\"utf-8\"");
  841     $self->_setup_if_headers($headers);
  842 
  843     my $xml_request = qq{<?xml version="1.0" encoding="utf-8"?>};
  844 
  845     #   $xml_request .= "<D:propertyupdate xmlns:D=\"DAV:\">";
  846     #   $xml_request .= "<D:$action>";
  847 
  848     $xml_request .= "<D:propertyupdate xmlns:D=\"DAV:\"";
  849     $namespace ||= "";
  850     my $nsabbr = 'D';
  851 
  852     if ($namespace =~ /dav/i || $namespace eq "") {
  853 
  854         #     $xml_request .= "<D:prop>";
  855         #     if ($action eq "set" ) {
  856         #        $xml_request .= "<D:$propname>$propvalue</D:$propname>";
  857         #     } else {
  858         #        $xml_request .= "<D:$propname/>";
  859         #     }
  860         $xml_request .= ">";
  861     }
  862     else {
  863         $nsabbr = $use_nsabbr;
  864         $xml_request .= " xmlns:$nsabbr=\"$namespace\">";
  865     }
  866 
  867     #   else {
  868     #     $xml_request .= "<D:prop xmlns:R=\"".$namespace."\">";
  869     #     if ($action eq "set" ) {
  870     #        $xml_request .= "<R:$propname>$propvalue</R:$propname>";
  871     #     } else {
  872     #        $xml_request .= "<R:$propname/>";
  873     #     }
  874     $xml_request .= "<D:$action>";
  875     $xml_request .= "<D:prop>";
  876 
  877     if ($action eq "set") {
  878         $xml_request .= "<$nsabbr:$propname>$propvalue</$nsabbr:$propname>";
  879     }
  880     else {
  881         $xml_request .= "<$nsabbr:$propname/>";
  882     }
  883 
  884     $xml_request .= "</D:prop>";
  885     $xml_request .= "</D:$action>";
  886     $xml_request .= "</D:propertyupdate>";
  887 
  888     ####
  889     # Put the proppatch request to the remote server
  890     my $resp = $self->{_comms}->do_http_request(
  891         -method  => "PROPPATCH",
  892         -url     => $self->{_uri},
  893         -headers => $headers,
  894         -content => $xml_request,
  895     );
  896 
  897     if ($resp->is_multistatus) {
  898         my $parser = new XML::DOM::Parser;
  899         my $doc    = $parser->parse($resp->content);
  900         eval { $self->_XML_parse_multistatus($doc, $resp) };
  901         warn "XML error: " . $@ if $@;
  902         $doc->dispose;
  903     }
  904 
  905     return $resp;
  906 }
  907 
  908 ###########################################################################
  909 # Delete a resource/collection
  910 sub delete {
  911     my ($self) = @_;
  912 
  913     # Setup the If: header if it is locked
  914     my $headers = HTTP::DAV::Headers->new();
  915     $self->_setup_if_headers($headers);
  916 
  917     # Setup the Depth for the delete request
  918     # The only valid depth is infinity.
  919     #$headers->header("Depth", "infinity");
  920 
  921     my $resp = $self->{_comms}->do_http_request(
  922         -method  => "DELETE",
  923         -uri     => $self->get_uri,
  924         -headers => $headers,
  925     );
  926 
  927     # Handle a multistatus response
  928     if ($self->content_type_is_xml($resp) &&    # XML body
  929         $resp->is_multistatus()                 # Multistatus
  930     ) {
  931 
  932         # use XML::DOM to parse the result.
  933         my $parser = new XML::DOM::Parser;
  934         my $doc    = $parser->parse($resp->content);
  935 
  936         # We're only interested in the error codes that come out of $resp.
  937         eval { $self->_XML_parse_multistatus($doc, $resp) };
  938         warn "XML error: " . $@ if $@;
  939         $doc->dispose;
  940     }
  941 
  942     if ($resp->is_success) {
  943         $self->_unset_my_locks();
  944     }
  945 
  946     return $resp;
  947 }
  948 
  949 sub content_type_is_xml {
  950     my ($self, $resp) = @_;
  951 
  952     return unless $resp;
  953 
  954     my $type = $resp->content_type;
  955     return unless $type;
  956 
  957     if ($type =~ m{(?:application|text)/xml}) {
  958         return 1;
  959     }
  960 
  961     return;
  962 }
  963 
  964 ###########################################################################
  965 ###########################################################################
  966 # parses a <D:multistatus> element.
  967 # This is the root level element for a
  968 # PROPFIND body or a failed DELETE body.
  969 # For example. The following is the result of a DELETE operation
  970 # with a locked progeny (child).
  971 #
  972 # >> DELETE /test/dir/newdir/ HTTP/1.1
  973 # << HTTP/1.1 207 Multistatus
  974 # <?xml version="1.0" encoding="utf-8"?>
  975 # <D:multistatus xmlns:D="DAV:">
  976 #   <D:response>
  977 #      <D:href>/test/dir/newdir/locker/</D:href>
  978 #      <D:status>HTTP/1.1 423 Locked</D:status>
  979 #      <D:responsedescription>Twas locked baby</D:responsedescription>
  980 #   </D:response>
  981 #   <D:response>
  982 #      <D:href>/test/dir/newdir/</D:href>
  983 #      <D:propstat>
  984 #         <D:prop><D:lockdiscovery/></D:prop>
  985 #         <D:status>HTTP/1.1 424 Failed Dependency</D:status>
  986 #         <D:responsedescription>Locks here somewhere</D:status>
  987 #      </D:propstat>
  988 #      <D:responsedescription>Can't delete him. Lock here</D:responsedescription>
  989 #   </D:response>
  990 #   <D:responsedescription>Failed delete</D:responsedescription>
  991 # </D:multistatus>
  992 #
  993 sub _XML_parse_multistatus {
  994     my ($self, $doc, $resp) = @_;
  995     my $resource_list = HTTP::DAV::ResourceList->new;
  996 
  997     # <!ELEMENT multistatus (response+, responsedescription?) >
  998     # Parse     I            II         III
  999 
 1000     ###
 1001     # Parse I
 1002     my $node_multistatus
 1003         = HTTP::DAV::Utils::get_only_element($doc, "D:multistatus");
 1004 
 1005     ###
 1006     # Parse III
 1007     # Get the overarching responsedescription for the
 1008     # multistatus and set it into the DAV:Response object.
 1009     my $node_rd = HTTP::DAV::Utils::get_only_element($node_multistatus,
 1010         "D:responsedescription");
 1011     if ($node_rd) {
 1012         my $rd = $node_rd->getFirstChild->getNodeValue();
 1013         $resp->set_responsedescription($rd) if $rd;
 1014     }
 1015 
 1016     ###
 1017     # Parse II
 1018     # Get all the responses in the multistatus element
 1019     # <!ELEMENT multistatus (response+,responsedescription?) >
 1020     my @nodes_response
 1021         = HTTP::DAV::Utils::get_elements_by_tag_name($node_multistatus,
 1022         "D:response");
 1023 
 1024     # Process each response object
 1025     #<!ELEMENT  response (href, ((href*, status)|(propstat+)), responsedescription?) >
 1026     # Parse     1         2       2a     3        4            5
 1027 
 1028     ###
 1029     # Parse 1.
 1030     for my $node_response (@nodes_response) {
 1031 
 1032         ###
 1033         # Parse 2 and 2a (one or more hrefs)
 1034         my @nodes_href
 1035             = HTTP::DAV::Utils::get_elements_by_tag_name($node_response,
 1036             "D:href");
 1037 
 1038         # Get href <!ELEMENT href (#PCDATA) >
 1039         my ($href, $href_a, $resource);
 1040         foreach my $node_href (@nodes_href) {
 1041 
 1042             $href = $node_href->getFirstChild->getNodeValue();
 1043 
 1044             # The href may be relative. If so make it absolute.
 1045             # With the uri data "/mydir/myfile.txt"
 1046             # And the uri of "this" object, "http://site/dir",
 1047             # return "http://site/mydir/myfile.txt"
 1048             # See the rules of URI.pm
 1049             my $href_uri = HTTP::DAV::Utils::make_uri($href);
 1050             my $res_url  = $href_uri->abs($self->get_uri);
 1051 
 1052             # Just store the first one for later use
 1053             $href_a = $res_url unless defined $href_a;
 1054 
 1055             # Create a new Resource to put into the list
 1056             # Remove trailing slashes before comparing.
 1057             #warn "Am about to compare $res_url and ". $self->get_uri . "\n" ;
 1058             if (HTTP::DAV::Utils::compare_uris($res_url, $self->get_uri)) {
 1059                 $resource = $self;
 1060 
 1061                 #warn " Exists. $resource\n";
 1062             }
 1063             else {
 1064                 $resource = $self->get_client->new_resource(-uri => $res_url);
 1065                 $resource_list->add_resource($resource);
 1066 
 1067                 #warn " New. $resource\n";
 1068             }
 1069         }
 1070 
 1071         ###
 1072         # Parse 3 and 5
 1073         # Get the values out of each Response
 1074         # <!ELEMENT status (#PCDATA) >
 1075         # <!ELEMENT responsedescription (#PCDATA) >
 1076 
 1077         my ($response_status, $response_rd)
 1078             = $self->_XML_parse_status($node_response);
 1079 
 1080         if ($response_status) {
 1081             $resp->add_status_line(
 1082                 $response_status,
 1083                 $response_rd,
 1084                 "$href_a:response:$node_response",
 1085                 $href_a
 1086             );
 1087         }
 1088 
 1089         ###
 1090         # Parse 4.
 1091         # Get the propstat+ list to be processed below
 1092         # Process each propstat object within this response
 1093         #
 1094         # <!ELEMENT propstat (prop, status, responsedescription?) >
 1095         # Parse     a         b     c       d
 1096 
 1097         ###
 1098         # Parse a
 1099         my @nodes_propstat
 1100             = HTTP::DAV::Utils::get_elements_by_tag_name($node_response,
 1101             "D:propstat");
 1102 
 1103         # Unset any old properties
 1104         $resource->_unset_properties();
 1105 
 1106         foreach my $node_propstat (@nodes_propstat) {
 1107 
 1108             ###
 1109             # Parse b
 1110             my $node_prop = HTTP::DAV::Utils::get_only_element($node_propstat,
 1111                 "D:prop");
 1112             my $prop_hashref
 1113                 = $resource->_XML_parse_and_store_props($node_prop);
 1114 
 1115             ###
 1116             # Parse c and d
 1117             my ($propstat_status, $propstat_rd)
 1118                 = $self->_XML_parse_status($node_propstat);
 1119 
 1120             # If there is no rd for this propstat, then use the
 1121             # enclosing rd from the actual response.
 1122             $propstat_rd = $response_rd unless $propstat_rd;
 1123 
 1124             if ($propstat_status) {
 1125                 $resp->add_status_line(
 1126                     $propstat_status,
 1127                     $propstat_rd,
 1128                     "$href_a:propstat:$node_propstat",
 1129                     $href_a
 1130                 );
 1131             }
 1132 
 1133         }    # foreach propstat
 1134 
 1135     }    # foreach response
 1136 
 1137     #warn "\nEND MULTI:". $self->as_string . $resource_list->as_string;
 1138     return $resource_list;
 1139 }
 1140 
 1141 ###
 1142 # This routine takes an XML node and:
 1143 # Extracts the D:status and D:responsedescription elements.
 1144 # If either of these exists, sets messages into the passed HTTP::DAV::Response object.
 1145 # The handle should be unique.
 1146 sub _XML_parse_status {
 1147     my ($self, $node) = @_;
 1148 
 1149     # <!ELEMENT status (#PCDATA) >
 1150     # <!ELEMENT responsedescription (#PCDATA) >
 1151     my $node_status = HTTP::DAV::Utils::get_only_element($node, "D:status");
 1152     my $node_rd
 1153         = HTTP::DAV::Utils::get_only_element($node, "D:responsedescription");
 1154     my $status = $node_status->getFirstChild->getNodeValue()
 1155         if ($node_status);
 1156     my $rd = $node_rd->getFirstChild->getNodeValue() if ($node_rd);
 1157 
 1158     return ($status, $rd);
 1159 }
 1160 
 1161 ###
 1162 # Pass in the XML::DOM prop node Element and it will
 1163 # parse and store all of the properties. These ones
 1164 # are specifically dealt with:
 1165 # creationdate
 1166 # getcontenttype
 1167 # getcontentlength
 1168 # displayname
 1169 # getetag
 1170 # getlastmodified
 1171 # resourcetype
 1172 # supportedlock
 1173 # lockdiscovery
 1174 # source
 1175 
 1176 sub _XML_parse_and_store_props {
 1177     my ($self, $node) = @_;
 1178     my %return_props = ();
 1179 
 1180     return unless ($node && $node->hasChildNodes());
 1181 
 1182     # These elements will just get copied straight into our properties hash.
 1183     my @raw_copy = qw(
 1184         creationdate
 1185         getlastmodified
 1186         getetag
 1187         displayname
 1188         getcontentlength
 1189         getcontenttype
 1190     );
 1191 
 1192     my $props = $node->getChildNodes;
 1193     my $n     = $props->getLength;
 1194     for (my $i = 0; $i < $n; $i++) {
 1195 
 1196         my $prop = $props->item($i);
 1197 
 1198         # Ignore anything in the <prop> element which is
 1199         # not an Element. i.e. ignore comments, text, etc...
 1200         next if ($prop->getNodeTypeName() ne "ELEMENT_NODE");
 1201 
 1202         my $prop_name = $prop->getNodeName();
 1203 
 1204         $prop_name = HTTP::DAV::Utils::XML_remove_namespace($prop_name);
 1205 
 1206         if (grep (/^$prop_name$/i, @raw_copy)) {
 1207             my $cdata = HTTP::DAV::Utils::get_only_cdata($prop);
 1208             $self->set_property($prop_name, $cdata);
 1209         }
 1210 
 1211         elsif ($prop_name eq "lockdiscovery") {
 1212             my @locks = HTTP::DAV::Lock->XML_lockdiscovery_parse($prop);
 1213             $self->set_locks(@locks);
 1214         }
 1215 
 1216         elsif ($prop_name eq "supportedlock") {
 1217             my $supportedlock_hashref
 1218                 = HTTP::DAV::Lock::get_supportedlock_details($prop);
 1219             $self->set_property("supportedlocks", $supportedlock_hashref);
 1220         }
 1221 
 1222         # Work in progress
 1223         #      elsif ( $prop_name eq "source" ) {
 1224         #         my $links = $self->_XML_parse_source_links( $prop );
 1225         #         $self->set_property( "supportedlocks", $supportedlock_hashref );
 1226         #      }
 1227 
 1228         #resourcetype and others
 1229         else {
 1230             my $node_name = HTTP::DAV::Utils::XML_remove_namespace(
 1231                 $prop->getNodeName());
 1232             my $str   = "";
 1233             my @nodes = $prop->getChildNodes;
 1234             foreach my $node (@nodes) { $str .= $node->toString; }
 1235             $self->set_property($node_name, $str);
 1236         }
 1237     }
 1238 
 1239     ###
 1240     # Cleanup work
 1241 
 1242     # set collection based on resourcetype
 1243     #my $getcontenttype = $self->get_property("getcontenttype");
 1244     #($getcontenttype && $getcontenttype =~ /directory/i  ) ||
 1245     my $resourcetype = $self->get_property("resourcetype");
 1246     if (($resourcetype && $resourcetype =~ /collection/i)) {
 1247         $self->set_property("resourcetype", "collection");
 1248         my $uri = HTTP::DAV::Utils::make_trail_slash($self->get_uri);
 1249         $self->set_uri($uri);
 1250     }
 1251 
 1252     # Clean up the date work.
 1253     my $creationdate = $self->get_property("creationdate");
 1254     if ($creationdate) {
 1255         my ($epochgmt) = HTTP::Date::str2time($creationdate);
 1256         $self->set_property("creationepoch", $epochgmt);
 1257         $self->set_property("creationdate",  HTTP::Date::time2str($epochgmt));
 1258     }
 1259 
 1260     my $getlastmodified = $self->get_property("getlastmodified");
 1261     if ($getlastmodified) {
 1262         my ($epochgmt) = HTTP::Date::str2time($getlastmodified);
 1263         $self->set_property("lastmodifiedepoch", $epochgmt);
 1264         $self->set_property("lastmodifieddate",
 1265             HTTP::Date::time2str($epochgmt));
 1266     }
 1267 }
 1268 
 1269 sub _setup_custom_headers {
 1270     my ($self, $headers, $custom_headers) = @_;
 1271 
 1272     if ($custom_headers && ref $custom_headers eq 'HASH') {
 1273         for my $hdr_name (keys %{$custom_headers}) {
 1274             my $hdr_value = $custom_headers->{$hdr_name};
 1275             warn "Setting custom header $hdr_name to '$hdr_value'\n";
 1276             $headers->header($hdr_name => $hdr_value);
 1277         }
 1278     }
 1279 
 1280     return;
 1281 }
 1282 
 1283 ###########################################################################
 1284 # $self->_setup_if_headers( $headers_obj, [0|1] );
 1285 # used by at least PUT,MKCOL,DELETE,COPY/MOVE
 1286 sub _setup_if_headers {
 1287     my ($self, $headers, $tagged) = @_;
 1288 
 1289     # Setup the If: header if it is locked
 1290     my $tokens = $self->{_lockedresourcelist}
 1291         ->get_locktokens(-uri => $self->get_uri, -owned => 1);
 1292     $tagged = 1 unless defined $tagged;
 1293     my $if
 1294         = $self->{_lockedresourcelist}->tokens_to_if_header($tokens, $tagged);
 1295     $headers->header("If", $if) if $if;
 1296     warn "Setting if_header to \"If: $if\"\n" if $if && $HTTP::DAV::DEBUG;
 1297 }
 1298 
 1299 ###########################################################################
 1300 # Dump the objects contents as a string
 1301 sub as_string {
 1302     my ($self, $space, $depth) = @_;
 1303 
 1304     $depth = 1 if (!defined $depth || $depth eq "");
 1305     $space = "" unless $space;
 1306     my $return;
 1307 
 1308     # Do lock only
 1309     if ($depth == 2) {
 1310         $return = "${space}'Url': ";
 1311         $return .= $self->{_uri}->as_string . "\n";
 1312         foreach my $lock ($self->get_locks()) {
 1313             $return .= $lock->pretty_print("$space   ");
 1314         }
 1315         return $return;
 1316     }
 1317 
 1318     $return .= "${space}Resource\n";
 1319     $space  .= "   ";
 1320     $return .= "${space}'Url': ";
 1321     $return .= $self->{_uri}->as_string . "\n";
 1322 
 1323     $return .= "${space}'Options': " . $self->{_options} . "\n"
 1324         if $self->{_options};
 1325 
 1326     $return .= "${space}Properties\n";
 1327     foreach my $prop (sort keys %{ $self->{_properties} }) {
 1328         next if $prop =~ /_ls$/;
 1329         my $prop_val;
 1330         if ($prop eq "supportedlocks" && $depth > 1) {
 1331             use Data::Dumper;
 1332             $prop_val = $self->get_property($prop);
 1333             $prop_val = Data::Dumper->Dump([$prop_val], ['$prop_val']);
 1334         }
 1335         else {
 1336             $prop_val = $self->get_property($prop);
 1337             $prop_val =~ s/\n/\\n/g;
 1338         }
 1339         $return .= "${space}   '$prop': $prop_val\n";
 1340     }
 1341 
 1342     if (defined $self->{_content}) {
 1343         $return .= "${space}'Content':"
 1344             . substr($self->{_content}, 0, 50) . "...\n";
 1345     }
 1346 
 1347     # DEEP PRINT
 1348     if ($depth) {
 1349         $return .= "${space}'_locks':\n";
 1350         foreach my $lock ($self->get_locks()) {
 1351             $return .= $lock->as_string("$space   ");
 1352         }
 1353 
 1354         $return .= $self->{_resource_list}->as_string($space)
 1355             if $self->{_resource_list};
 1356     }
 1357 
 1358     # SHALLOW PRINT
 1359     else {
 1360         $return .= "${space}'_locks': ";
 1361         foreach my $lock ($self->get_locks()) {
 1362             my $locktoken = $lock->get_locktoken();
 1363             my $owned = ($lock->is_owned) ? "owned" : "not owned";
 1364             $return .= "${space}   $locktoken ($owned)\n";
 1365         }
 1366         $return
 1367             .= "${space}'_resource_list': " . $self->{_resource_list} . "\n";
 1368     }
 1369 
 1370     $return;
 1371 }
 1372 
 1373 ######################################################################
 1374 # Dump myself as an 'ls' might.
 1375 # Requires you to have already performed a propfind
 1376 sub build_ls {
 1377     my ($self, $parent_resource) = @_;
 1378 
 1379     # Build some local variables that have been sanitised.
 1380     my $exec           = $self->get_property("executable")        || "?";
 1381     my $contenttype    = $self->get_property("getcontenttype")    || "";
 1382     my $supportedlocks = $self->get_property("supportedlocks")    || ();
 1383     my $epoch          = $self->get_property("lastmodifiedepoch") || 0;
 1384     my $size           = $self->get_property("getcontentlength")  || "";
 1385     my $is_coll        = $self->is_collection()                   || "?";
 1386     my $is_lock        = $self->is_locked()                       || "?";
 1387 
 1388     # Construct a relative URI;
 1389     my $abs_uri = $self->get_uri();
 1390     my $rel_uri = $abs_uri->rel($parent_resource->get_uri());
 1391     $rel_uri = uri_unescape($rel_uri);
 1392 
 1393     ####
 1394     # Build up a long display name.
 1395 
 1396     # 1.
 1397     my $lls = "URL: $abs_uri\n";
 1398     foreach my $prop (sort keys %{ $self->{_properties} }) {
 1399         next
 1400             if ($prop eq "lastmodifiedepoch"
 1401             || $prop eq "creationepoch"
 1402             || $prop eq "supportedlocks");
 1403         $lls .= "$prop: ";
 1404         if ($prop =~ /Content-Length/) {
 1405             $lls .= $self->get_property($prop) . " bytes";
 1406         }
 1407         else {
 1408             $lls .= $self->get_property($prop);
 1409         }
 1410         $lls .= "\n";
 1411     }
 1412 
 1413     # 2. Build a supportedlocks string
 1414     if (defined $supportedlocks and ref($supportedlocks) eq "ARRAY") {
 1415         my @supported_locks = @{$supportedlocks};
 1416         $supportedlocks = "";
 1417         foreach my $lock_type_hash (@supported_locks) {
 1418             $supportedlocks .= $$lock_type_hash{'type'} . "/"
 1419                 . $$lock_type_hash{'scope'} . " ";
 1420         }
 1421     }
 1422     else {
 1423         $supportedlocks = '"No locking supported"';
 1424     }
 1425 
 1426     $lls .= "Locks supported: $supportedlocks\n";
 1427 
 1428     # 3. Print all of the locks.
 1429     my @my_locks     = $self->get_locks(-owned => 1);
 1430     my @not_my_locks = $self->get_locks(-owned => 0);
 1431     if ($is_lock) {
 1432         $lls .= "Locks: \n";
 1433         if (@my_locks) {
 1434             $lls .= "   My locks:\n";
 1435             foreach my $lock (@my_locks) {
 1436                 $lls .= $lock->pretty_print("      ") . "\n";
 1437             }
 1438         }
 1439         if (@not_my_locks) {
 1440             $lls .= "   Others' locks:\n";
 1441             foreach my $lock (@not_my_locks) {
 1442                 $lls .= $lock->pretty_print("      ") . "\n";
 1443             }
 1444         }
 1445 
 1446     }
 1447     else {
 1448         $lls .= "Locks: Not locked\n";
 1449     }
 1450 
 1451     ######################################################################
 1452     ####
 1453     # Build up a list of useful information
 1454 
 1455     $self->set_property('rel_uri', $rel_uri);
 1456 
 1457     my @props = ();
 1458     push(@props, "<exe>")    if ($exec    eq "T");
 1459     push(@props, "<dir>")    if ($is_coll eq "1");
 1460     push(@props, "<locked>") if ($is_lock eq "1");
 1461     $self->set_property('short_props', join(',', @props));
 1462 
 1463     # Build a (short) display date in either
 1464     # "Mmm dd  yyyy" or "Mmm dd HH:MM" format.
 1465 
 1466     my $display_date = "?";
 1467     if ($epoch > 1) {
 1468 
 1469         my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst)
 1470             = localtime($epoch);
 1471         my %mons = (
 1472             0 => 'Jan', 1 => 'Feb', 2  => 'Mar', 3  => 'Apr',
 1473             4 => 'May', 5 => 'Jun', 6  => 'Jul', 7  => 'Aug',
 1474             8 => 'Sep', 9 => 'Oct', 10 => 'Nov', 11 => 'Dec'
 1475         );
 1476         $year += 1900;
 1477         my $month = $mons{$mon};
 1478 
 1479         # If the last modified time is older than six months
 1480         # then display in "Mmm dd  yyyy" format.
 1481         # else display in "Mmm dd HH:MM" format.
 1482         if (time - $epoch > (3600 * 24 * 30 * 6)) {
 1483             $self->set_property(
 1484                 'display_date',
 1485                 sprintf(
 1486                     "%3s %0.2d  %4d",
 1487                     $month, $mday, $year
 1488                 )
 1489             );
 1490         }
 1491         else {
 1492             $self->set_property(
 1493                 'display_date',
 1494                 sprintf(
 1495                     "%3s %0.2d %0.2d:%0.2d",
 1496                     $month, $mday, $hour, $min
 1497                 )
 1498             );
 1499         }
 1500     }
 1501 
 1502     $self->set_property('long_ls', $lls);
 1503 
 1504     # Preset this, but it will be overwritten below
 1505     # if it is a collection
 1506     $self->set_property('short_ls', $lls);
 1507 
 1508     # Build the short listing if it is a collection
 1509     if ($self->is_collection) {
 1510         my $short = "";
 1511         $short .= "Listing of " . $self->get_uri() . "\n";
 1512 
 1513         my $child_resource_list = $self->get_resourcelist;
 1514         if (defined $child_resource_list) {
 1515             my @resources = $child_resource_list->get_resources;
 1516 
 1517             foreach my $child_res (@resources) {
 1518                 $child_res->build_ls($self);
 1519             }
 1520 
 1521             # Get the maximum uri length for pretty printing.
 1522             my $max_uri_length   = 0;
 1523             my $max_bytes_length = 0;
 1524             foreach my $r ($self, sort by_URI @resources) {
 1525                 my $l;
 1526                 $l = length($r->get_property('rel_uri'));
 1527                 $max_uri_length = $l if $l > $max_uri_length;
 1528 
 1529                 $l = length($r->get_property('getcontentlength'));
 1530                 $max_bytes_length = $l if $l > $max_bytes_length;
 1531             }
 1532 
 1533             # Print the listing
 1534             foreach my $r ($self, sort by_URI @resources) {
 1535                 $short .= sprintf(
 1536                     " %${max_uri_length}s  %${max_bytes_length}s  %12s  %s\n",
 1537                     $r->get_property('rel_uri'),
 1538                     $r->get_property('getcontentlength'),
 1539                     $r->get_property('display_date'),
 1540                     $r->get_property('short_props')
 1541                 );
 1542             }
 1543         }    # if defined resource_list
 1544 
 1545         $self->set_property('short_ls', $short);
 1546     }
 1547 
 1548     sub by_URI {
 1549         my $a_str = $a->get_uri;
 1550         my $b_str = $b->get_uri;
 1551         return $a_str cmp $b_str;
 1552     }
 1553 }
 1554 
 1555 1;
 1556 
 1557 __END__
 1558 
 1559 =head1 NAME
 1560 
 1561 HTTP::DAV::Resource - Represents and interfaces with WebDAV Resources
 1562 
 1563 =head1 SYNOPSIS
 1564 
 1565 Sample
 1566 
 1567 =head1 DESCRIPTION
 1568 
 1569 Description here
 1570 
 1571 =head1 CONSTRUCTORS
 1572 
 1573 =over 4
 1574 
 1575 =item B<new>
 1576 
 1577 Returns a new resource represented by the URI.
 1578 
 1579 $r = HTTP::DAV::Resource->new( 
 1580         -uri => $uri, 
 1581         -LockedResourceList => $locks, 
 1582         -Comms => $comms 
 1583         -Client => $dav_client 
 1584      );
 1585 
 1586 On creation a Resource object needs 2 other objects passed in:
 1587 
 1588 1. a C<ResourceList> Object. This list will be added to if you lock this Resource.
 1589 
 1590 2. a C<Comms> Object. This object will be used for HTTP communication.
 1591 
 1592 2. a C<HTTP::DAV> Object. This object is where all locks are stored
 1593 
 1594 =back
 1595 
 1596 =head1 METHODS
 1597 
 1598 =over 4 
 1599 
 1600 
 1601 =item B<get/GET>
 1602 
 1603 Performs an HTTP GET and returns a DAV::Response object.        
 1604 
 1605  $response = $resource->get;
 1606  print $resource->get_content if ($response->is_success);
 1607 
 1608 =item B<put/PUT>
 1609 
 1610 Performs an HTTP PUT and returns a DAV::Response object.        
 1611 
 1612 $response = $resource->put( $string );
 1613 
 1614 $string is be passed as the body.
 1615 
 1616  e.g.
 1617  $response = $resource->put($string);
 1618  print $resource->get_content if ($response->is_success);
 1619 
 1620 Will use a Lock header if this resource was previously locked.
 1621 
 1622 =item B<copy>
 1623 
 1624 Not implemented 
 1625 
 1626 =item B<move>
 1627 
 1628 Not implemented 
 1629 
 1630 =item B<delete>
 1631 
 1632 Performs an HTTP DELETE and returns a DAV::Response object.
 1633 
 1634  $response = $resource->delete;
 1635  print "Delete successful" if ($response->is_success);
 1636 
 1637 Will use a Lock header if this resource was previously locked.
 1638 
 1639 =item B<options>
 1640 
 1641 Performs an HTTP OPTIONS and returns a DAV::Response object.
 1642 
 1643  $response = $resource->options;
 1644  print "Yay for PUT!" if $resource->is_option("PUT");
 1645 
 1646 =item B<mkcol>
 1647 
 1648 Performs a WebDAV MKCOL request and returns a DAV::Response object.
 1649 
 1650  $response = $resource->mkcol;
 1651  print "MKCOL successful" if ($response->is_success);
 1652 
 1653 Will use a Lock header if this resource was previously locked.
 1654 
 1655 =item B<proppatch>
 1656 
 1657 xxx
 1658 
 1659 =item B<propfind>
 1660 
 1661 Performs a WebDAV PROPFIND request and returns a DAV::Response object.
 1662 
 1663  $response = $resource->propfind;
 1664  if ($response->is_success) {
 1665     print "PROPFIND successful\n";
 1666     print $resource->get_property("displayname") . "\n";
 1667  }
 1668 
 1669 A successful PROPFIND fills the object with much data about the Resource.  
 1670 Including:
 1671    displayname
 1672    ...
 1673    TODO
 1674 
 1675 
 1676 =item B<lock>
 1677 
 1678 Performs a WebDAV LOCK request and returns a DAV::Response object.
 1679 
 1680  $resource->lock(
 1681         -owner   => "Patrick Collins",
 1682         -depth   => "infinity"
 1683         -scope   => "exclusive",
 1684         -type    => "write" 
 1685         -timeout => TIMEOUT',
 1686      )
 1687 
 1688 lock takes the following arguments.
 1689 
 1690 
 1691 B<owner> - Indicates who locked this resource
 1692 
 1693 The default value is: 
 1694  DAV.pm/v$DAV::VERSION ($$)
 1695 
 1696  e.g. DAV.pm/v0.1 (123)
 1697 
 1698 If you use a URL as the owner, the module will
 1699 automatically indicate to the server that is is a 
 1700 URL (<D:href>http://...</D:href>)
 1701 
 1702 
 1703 B<depth> - Indicates the depth of the lock. 
 1704 
 1705 Legal values are 0 or infinity. (1 is not allowed).
 1706 
 1707 The default value is infinity.
 1708 
 1709 A lock value of 0 on a collection will lock just the collection but not it's members, whereas a lock value of infinity will lock the collection and all of it's members.
 1710 
 1711 
 1712 B<scope> - Indicates the scope of the lock.
 1713 
 1714 Legal DAV values are "exclusive" or "shared".
 1715 
 1716 The default value is exclusive. 
 1717 
 1718 See section 6.1 of RFC2518 for a description of shared vs. exclusive locks.
 1719 
 1720 
 1721 B<type> - Indicates the type of lock (read, write, etc)
 1722 
 1723 The only legal DAV value currently is "write".
 1724 
 1725 The default value is write.
 1726 
 1727 
 1728 B<timeout> - Indicates when the lock will timeout
 1729 
 1730 The timeout value may be one of, an Absolute Date, a Time Offset from now, or the word "infinity". 
 1731 
 1732 The default value is "infinity".
 1733 
 1734 The following are all valid timeout values:
 1735 
 1736 Time Offset:
 1737     30s          30 seconds from now
 1738     10m          ten minutes from now
 1739     1h           one hour from now
 1740     1d           tomorrow
 1741     3M           in three months
 1742     10y          in ten years time
 1743 
 1744 Absolute Date:
 1745 
 1746     timeout at the indicated time & date (UTC/GMT)
 1747        2000-02-31 00:40:33   
 1748 
 1749     timeout at the indicated date (UTC/GMT)
 1750        2000-02-31            
 1751 
 1752 You can use any of the Absolute Date formats specified in HTTP::Date (see perldoc HTTP::Date)
 1753 
 1754 Note: the DAV server may choose to ignore your specified timeout. 
 1755 
 1756 
 1757 =item B<unlock>
 1758 
 1759 Performs a WebDAV UNLOCK request and returns a DAV::Response object.
 1760 
 1761  $response = $resource->unlock()
 1762  $response = $resource->unlock( -force => 1 )
 1763  $response = $resource->unlock( 
 1764     -token => "opaquelocktoken:1342-21423-2323" )
 1765 
 1766 This method will automatically use the correct locktoken If: header if this resource was previously locked.
 1767 
 1768 B<force> - Synonymous to calling $resource->forcefully_unlock_all.
 1769 
 1770 =item B<forcefully_unlock_all>
 1771 
 1772 Remove all locks from a resource and return the last DAV::Response object. This method take no arguments.
 1773 
 1774 $response = $resource->forcefully_unlock_all;
 1775 
 1776 This method will perform a lockdiscovery against the resource to determine all of the current locks. Then it will UNLOCK them one by one. unlock( -token => locktoken ). 
 1777 
 1778 This unlock process is achievable because DAV does not enforce any security over locks.
 1779 
 1780 Note: this method returns the LAST unlock response (this is sufficient to indicate the success of the sequence of unlocks). If an unlock fails, it will bail and return that response.  For instance, In the event that there are 3 shared locks and the second unlock method fails, then you will get returned the unsuccessful second response. The 3rd unlock will not be attempted.
 1781 
 1782 Don't run with this knife, you could hurt someone (or yourself).
 1783 
 1784 =item B<steal_lock>
 1785 
 1786 Removes all locks from a resource, relocks it in your name and returns the DAV::Response object for the lock command. This method takes no arguments.
 1787 
 1788 $response = $resource->steal_lock;
 1789 
 1790 Synonymous to forcefully_unlock_all() and then lock().
 1791 
 1792 =item B<lockdiscovery>
 1793 
 1794 Discover the locks held against this resource and return a DAV::Response object. This method take no arguments.
 1795 
 1796  $response = $resource->lockdiscovery;
 1797  @locks = $resource->get_locks if $response->is_success;
 1798 
 1799 This method is in fact a simplified version of propfind().
 1800 
 1801 =item B<as_string>
 1802 
 1803 Returns a string representation of the object. Mainly useful for debugging purposes. It takes no arguments.
 1804 
 1805 print $resource->as_string
 1806 
 1807 =back
 1808 
 1809 =head1 ACCESSOR METHODS (get, set and is)
 1810 
 1811 =over 4 
 1812 
 1813 =item B<is_option>
 1814 
 1815 Returns a boolean indicating whether this resource supports the option passed in as a string. The option match is case insensitive so, PUT and Put are should both work.
 1816 
 1817  if ($resource->is_option( "PUT" ) ) {
 1818     $resource->put( ... ) 
 1819  }
 1820 
 1821 Note: this routine automatically calls the options() routine which makes the request to the server. Subsequent calls to is_option will use the cached option list. To force a rerequest to the server call options()
 1822 
 1823 =item B<is_locked>
 1824 
 1825 Returns a boolean indicating whether this resource is locked.
 1826 
 1827   @lock = $resource->is_locked( -owned=>[1|0] );
 1828 
 1829 B<owned> - this parameter is used to ask, is this resource locked by me?
 1830 
 1831 Note: You must have already called propfind() or lockdiscovery()
 1832 
 1833 e.g. 
 1834 Is the resource locked at all?
 1835  print "yes" if $resource->is_locked();
 1836 
 1837 Is the resource locked by me?
 1838  print "yes" if $resource->is_locked( -owned=>1 );
 1839 
 1840 Is the resource locked by someone other than me?
 1841  print "yes" if $resource->is_locked( -owned=>0 );
 1842 
 1843 =item B<is_collection>
 1844 
 1845 Returns a boolean indicating whether this resource is a collection. 
 1846 
 1847  print "Directory" if ( $resource->is_collection );
 1848 
 1849 You must first have performed a propfind.
 1850 
 1851 =item B<get_uri>
 1852 
 1853 Returns the URI object for this resource.
 1854 
 1855  print "URL is: " . $resource->get_uri()->as_string . "\n";
 1856 
 1857 See the URI manpage from the LWP libraries (perldoc URI)
 1858 
 1859 =item B<get_property>
 1860 
 1861 Returns a property value. Takes a string as an argument.
 1862 
 1863  print $resource->get_property( "displayname" );
 1864 
 1865 You must first have performed a propfind.
 1866 
 1867 =item B<get_options>
 1868 
 1869 Returns an array of options allowed on this resource.
 1870 Note: If $resource->options has not been called then it will return an empty array.
 1871 
 1872 @options = $resource->get_options
 1873 
 1874 =item B<get_content>
 1875 
 1876 Returns the resource's content/body as a string.
 1877 The content is typically the result of a GET. 
 1878 
 1879 $content = $resource->get_content
 1880 
 1881 =item B<get_content_ref>
 1882 
 1883 Returns the resource's content/body as a reference to a string.
 1884 This is useful and more efficient if the content is large.
 1885 
 1886 ${$resource->get_content_ref} =~ s/\bfoo\b/bar/g;
 1887 
 1888 Note: You must have already called get()
 1889 
 1890 =item B<get_lock>
 1891 
 1892 Returns the DAV::Lock object if it exists. Requires opaquelocktoken passed as a parameter.
 1893 
 1894  $lock = $resource->get_lock( "opaquelocktoken:234214--342-3444" );
 1895 
 1896 =item B<get_locks>
 1897 
 1898 Returns a list of any DAV::Lock objects held against the resource.
 1899 
 1900   @lock = $resource->get_locks( -owned=>[1|0] );
 1901 
 1902 B<owned> - this parameter indicates which locks you want.
 1903  - '1', requests any of my locks. (Locked by this DAV instance).
 1904  - '0' ,requests any locks not owned by us.
 1905  - any other value or no value, requests ALL locks.
 1906 
 1907 Note: You must have already called propfind() or lockdiscovery()
 1908 
 1909 e.g. 
 1910  Give me my locks
 1911   @lock = $resource->get_locks( -owned=>1 );
 1912 
 1913  Give me all locks
 1914   @lock = $resource->get_locks();
 1915 
 1916 =item B<get_lockedresourcelist>
 1917 
 1918 =item B<get_parentresourcelist>
 1919 
 1920 =item B<get_comms>
 1921 
 1922 =item B<set_parent_resourcelist>
 1923 
 1924 $resource->set_parent_resourcelist( $resourcelist )
 1925 
 1926 Sets the parent resource list (ask the question, which collection am I a member of?). See L<HTTP::DAV::ResourceList>.
 1927 
 1928 =back
 1929 
 1930 =cut
 1931