HTTP-DAV-0.50/0000755000175000017500000000000014703666621012204 5ustar cosimocosimoHTTP-DAV-0.50/Makefile.PL0000644000175000017500000000155314703664713014162 0ustar cosimocosimouse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my @programs_to_install = qw(dave); WriteMakefile( 'NAME' => 'HTTP::DAV', 'VERSION_FROM' => 'lib/HTTP/DAV.pm', 'dist' => { COMPRESS => 'gzip -9f --best', SUFFIX => '.gz', #PREOP => 'bin/dist' }, 'EXE_FILES' => [ map {"bin/$_"} @programs_to_install ], 'PREREQ_PM' => { 'Cwd' => 0, 'File::Temp' => 0, 'LWP' => 5.48, 'Scalar::Util' => 0, 'Time::Local' => 0, 'URI' => 0, 'URI::Escape' => 0, 'XML::DOM' => 0, # bin/dave specific dependencies 'Getopt::Long' => 0, 'Term::ReadLine' => 0, 'Text::ParseWords' => 0, 'Pod::Usage' => 0, }, ); HTTP-DAV-0.50/META.yml0000664000175000017500000000127314703666621013462 0ustar cosimocosimo--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: HTTP-DAV no_index: directory: - t - inc requires: Cwd: '0' File::Temp: '0' Getopt::Long: '0' LWP: '5.48' Pod::Usage: '0' Scalar::Util: '0' Term::ReadLine: '0' Text::ParseWords: '0' Time::Local: '0' URI: '0' URI::Escape: '0' XML::DOM: '0' version: '0.50' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' HTTP-DAV-0.50/MANIFEST.SKIP0000644000175000017500000000011014703664237014073 0ustar cosimocosimopatches/.* pod2htm.* pm_to_blib$ blib.* \.git.* Makefile$ \.bak$ \.old$ HTTP-DAV-0.50/Changes0000644000175000017500000002413014703665637013505 0ustar cosimocosimoRevision history for HTTP::DAV v0.50 (released 2024/10/16): * bug fixes Fixed missing custom headers when calling PUT methods. Closes "RT#100756". Thanks Georg Acher for the patch and for patiently waiting a decade (!) for a fix. v0.49 (released 2018/11/28): * bug fixes Fixed perl shebang line in "dave" script, for ExtUtils::MakeMaker to correctly replace it. Closes "RT#127819". Fixed "propfind" response handling to also consider successful an HTTP 207 status code. Closes "RT#127591". Fixed clone() method to properly respect the class name. Closes "RT#123528". Thanks to Ricardo Signes for the patch. * documentation fixes Fixed various pod issues raised by Debian contributor "fsfs@debian.org". Closes "RT#119878". v0.48 (released 2015/03/26): * bug fixes "RT#103126", fixed faulty code to add trailing slash to URLs. v0.47 (released 2012/03/24): * bug fixes Improve propfind() resilience when server response contains broken, truncated or no XML at all. RT#75011. v0.46 (released 2012/01/11): * improvements HTTP::DAV should now be working with more WebDAV servers. We are more flexible in what content types we consider to be XML. Thanks Ron1 and Adam for the feedback and patches. v0.45 (released 2011/09/18): * bug fixes - Fixed RT #69439 (http://rt.cpan.org/Public/Bug/Display.html?id=69439), insecure /tmp files handling in dave client. * improvements - Added -tmpdir option to dave client. - Reorganized distribution layout to match usual CPAN practice - Removed remains of svn-era ($Id and such...) v0.44 (released 2011/06/19): * bug fixes - Fixed RT #68936 (http://rt.cpan.org/Public/Bug/Display.html?id=68936), Fixed errors() method that would bomb out when the "_errors" attribute wasn't initialized. Thanks to Michael Lackoff for reporting. v0.43 (released 2011/04/12): * bug fixes - Fixed RT #38677 (http://rt.cpan.org/Public/Bug/Display.html?id=38677), Intercept correctly 405 (Method now allowed) errors and report them to the clients. v0.42 (released 2010/11/07): * bug fixes - Fixed RT #60457 (http://rt.cpan.org/Public/Bug/Display.html?id=60457), Added and documented possibility to pass your own custom HTTP headers. - Fixed errors in the code examples in the synopsis. v0.41 (released 2010/07/24): * bug fixes - Fixed RT #59674 (http://rt.cpan.org/Public/Bug/Display.html?id=59674), When SSL support is needed but not installed, a more specific error messages is now displayed, instead of "not DAV enabled or not accessible". v0.40 (released 2010/01/27): * bug fixes - Fixed RT #47500 (http://rt.cpan.org/Public/Bug/Display.html?id=47500), HTTP::DAV::Comms->credentials() method erroneously autovivified basic authentication internal values, causing wrong or undefined credentials to be sent out, or credentials to be "forgot" by HTTP::DAV. v0.39 (released 2009/12/12): * bug fixes - Fixed RT #52665 (http://rt.cpan.org/Public/Bug/Display.html?id=52665), Using dave or propfind() on URLs containing escaped chars (%xx) could fail, due to upper/lower case differences. Thanks to cebjyre for the patch and the test case. v0.38 (released 2009/06/09): * bug fixes - Fixed RT #14506 (http://rt.cpan.org/Public/Bug/Display.html?id=14506), about the missing get_lastresponse() method. It was a documentation bug. - Fixed RT #29788 (http://rt.cpan.org/Public/Bug/Display.html?id=29788), avoid file corruptions on Win32 when calling HTTP::DAV::get() method. - Fixed RT #31014 (http://rt.cpan.org/Public/Bug/Display.html?id=31014), probably already in v0.34, since it seems related to propfind() "depth" bug. v0.37 (released 2009/03/24): * bug fixes - Fixed RT #44409 (http://rt.cpan.org/Public/Bug/Display.html?id=44409), Small bug in HTTP::DAV::put(). Passing a reference as local content resulted in the "SCALAR(0x12345678)" being logged instead of the real scalar. v0.36 (released 2009/02/25): * bug fixes - Fixed RT #19616 (http://rt.cpan.org/Public/Bug/Display.html?id=19616), LWP::UserAgent::redirect_ok() is not changed anymore. We're subclassing it from HTTP::DAV::UserAgent and overriding redirect_ok() there. - Fixed RT #42877 (http://rt.cpan.org/Public/Bug/Display.html?id=42877), HTTP::DAV::UserAgent::credentials() has been modified to behave like LWP::UserAgent::credentials(), otherwise basic authentication breakages can occur. - Fixed a problem with C<-depth> argument to C that could lead to massive performance degradation, especially when running C against large folders. C<-depth> was set to 1 even when passed as zero. v0.35 (released 2008/11/03): * bug fixes - Fixed RT #40318 (http://rt.cpan.org/Public/Bug/Display.html?id=40318), about getting single or multiple files directly to \*STDOUT. v0.34 (released 2008/09/11): * bug fixes - Fixed RT #39150 (http://rt.cpan.org/Public/Bug/Display.html?id=39150), about downloading multiple files in the same directory. v0.33 (released 2008/08/24): * documentation - Clearly state that opera software asa is now co-maintainer of http::dav - Fixed various inconsistencies in the v0.32 documentation v0.32 (released 2008/08/24): * incompatibilities - Now HTTP::DAV requires Perl 5.6.0+ and Scalar::Util (core in 5.8.x). * bug fixes - Now HTTP::DAV objects are correctly released from memory when they go out of scope. Now it should be possible to use multiple instances of HTTP::DAV even in long-running processes. Was caused by circular references between HTTP::DAV and HTTP::DAV::Resource. v0.31 (released 2002/04/13): * Apache 2 mod_dav support - Now works with mod_dav under Apache 2. * bug fixes - Fixed bug to correctly handle the put/get of filenames with spaces in them. - Fixed bug to allow the PUT of empty files. - put() now uses binmode so that it works under Windows. - HTTP redirect code added in the previous release was incorrectly returning a HTTP::Response instead of a HTTP::DAV::Response - Fixed bug to allow https for copy and move (http:// was hardcoded). - Fixed strange copy/move bug for Apache2.0's mod_dav. v0.29 (released 2001/10/31): * https https support as provided from the underlying LWP library has been tested against mod_dav and mod_ssl. Seems to work well. See INSTALLATION for more detail. * Digest authentication Requires MD5 to be installed. See INSTALLATION notes. * various bug fixes * more powerful callback support for get() Useful for giving progress indicators. * get() to filehandles and scalar references the get() routine now allows you to pass by reference a filehandle or scalar in which to save the contents of the GET request. * added namespace abbreviations in proppatch Thanks to Jeremy for this patch. * improved redirect handling in Comms.pm Thanks to Jeremy for this patch. v0.23 (released 2001/09/07): * file globbing for get and put HTTP::DAV::get() and HTTP::DAV::put() now supports file globs. This functionality also propagates to dave. This allows you to do the following: dav> put /tmp/index*.html dav> get index[12].htm? /tmp ?,* and sets ([]) are supported. See the docs for details. HTTP::DAV now requires the Perl module File::Glob which comes bundled with perl5.6 and later. * bug fix in -overwrite flag in HTTP::DAV::copy/move. v0.22 (released 2001/09/03) Complete overhaul of API, recursive get and put, addition of dave. * dave -- the new command line client I wrote dave (the DAV Explorer) because I needed an end-user application that allowed me to "feel" how well the HTTP::DAV API was performing. dave is quite similar to Joe Orton's C-based DAV client called cadaver (yes, imitation is the best form of flattery). * A new and simpler API This new API is accessed directly through the HTTP::DAV module and is based on the core API written in previous releases. * new methods The new API now supports, proppatch, recursive get and put. * A substantial core API overhaul Moving from v0.05 to v0.22 in one release might indicate the amount of work gone into this release. * A new interoperability test suite is now included in PerlDAV. The test suite is built on top of the standard Perl Test::Harness modules. Still in development, the test suite is highlighting interoperability problems with DAV-servers a lot quicker than before. See "the test suite & interoperability" section. v0.05 (released 2001/07/24) General bug fixes and addition of proppatch - added PROPPATCH method to HTTP::DAV::Resource, thanks to Sylvain Plancon. - fixed uninitialized warnings in test scripts. - fixed new lock bug in DAV::Lock, thanks to Ben Evans - fixed dumb mistake where PUT was calling get instead of put, thanks to Sylvain and Ben again. - fixed call to Utils::bad, thanks to Sylvain v0.04 (released 2000/04/25) Initial Release - supports PUT,GET,MLCOL,DELETE,OPTIONS,PROPFIND,LOCK,UNLOCK,steal_lock,lock_discovery ** This file was automatically generated from ** ** doc/Changes.pod. To edit it, see there. ** HTTP-DAV-0.50/MANIFEST0000644000175000017500000000204614703666621013337 0ustar cosimocosimobin/dave bin/dist Changes doc/html/Changes.html doc/html/dave.html doc/html/HTTP-DAV.html doc/html/index.html doc/html/TODO.html doc/README.pod doc/TODO.pod lib/HTTP/DAV.pm lib/HTTP/DAV/Changes.pod lib/HTTP/DAV/Comms.pm lib/HTTP/DAV/Lock.pm lib/HTTP/DAV/Resource.pm lib/HTTP/DAV/ResourceList.pm lib/HTTP/DAV/Response.pm lib/HTTP/DAV/Utils.pm Makefile.PL MANIFEST MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) README t/1_loadme.t t/1_utils.t t/2_options.t t/3_put_get_delete.t t/4_multistatus.t t/5_propfind.t t/5_proppatch.t t/6_dav_copy_move.t t/6_dav_get_callback.t t/6_dav_globs.t t/6_dav_lock.t t/6_dav_lock2.t t/6_dav_open_put_get.t t/6_dav_options.t t/9_RT_19616.t t/9_RT_38677.t t/9_RT_42877.t t/9_RT_47500.t t/9_RT_52665.t t/9_RT_59674.t t/9_RT_60457.t t/9_RT_68936.t t/9_RT_69439.t t/multistatus.xml t/test_data/file1 t/test_data/file2 t/test_data/file2.txt t/test_data/file3 t/test_data/file4.txt.gz t/test_data/subdir/test3.txt t/TestDetails.pm TODO META.json Module JSON meta-data (added by MakeMaker) HTTP-DAV-0.50/t/0000755000175000017500000000000014703666621012447 5ustar cosimocosimoHTTP-DAV-0.50/t/9_RT_47500.t0000644000175000017500000000166014703664237014154 0ustar cosimocosimo#!/usr/bin/env perl use strict; use Test::More tests => 7; use_ok('HTTP::DAV'); use_ok('HTTP::DAV::Comms'); #$HTTP::DAV::DEBUG = #$HTTP::DAV::DEBUG = 0; # Normalize netloc with port (:80) # or we might miss the hash key my $netloc = 'mylocation:80'; my $realm = 'myrealm'; my $user = 'randomuser'; my $pass = '12345'; my $ua = HTTP::DAV::UserAgent->new(); my $existing_credentials = $ua->credentials($netloc, $realm); ok ( ! exists $ua->{basic_authentication}->{$netloc}->{$realm}, "Shouldn't autovivify the $netloc/$realm hash key when accessing it" ); $ua->credentials($netloc, $realm, $user, $pass); is_deeply ( $ua->{basic_authentication}->{$netloc}->{$realm}, [ $user, $pass ], 'Credentials are correctly set', ); my @cred = $ua->credentials($netloc, $realm); is(scalar @cred, 2, 'credentials() has 2 elements'); is($cred[0], $user, 'credentials() stored correctly'); is($cred[1], $pass, 'credentials() stored correctly'); HTTP-DAV-0.50/t/9_RT_69439.t0000644000175000017500000000204114703664237014165 0ustar cosimocosimo#!/usr/bin/env perl # # RT #69439, insecure /tmp file handling # use strict; use warnings; use Test::More tests => 11; use File::Path (); use HTTP::DAV; # Dave uses HTTP::DAV::_tempfile() every time # it has to open a new temporary file my $tmpdir = ".http-dav-test-tmpdir.$$"; ok(File::Path::mkpath($tmpdir), "Created temp dir"); # Generate two temp files one immediately after the other my ($fh1, $filename1) = HTTP::DAV::_tempfile('dave', $tmpdir); my ($fh2, $filename2) = HTTP::DAV::_tempfile('dave', $tmpdir); ok($fh1); ok($fh2); ok($filename1); ok($filename2); # They have to have different filenames isnt($filename1, $filename2, "Different filenames should be generated"); isnt($fh1, $fh2, "They should be different filehandles too, just in case"); #diag("Generated temp file: $filename1"); #diag("Generated temp file: $filename2"); ok(index($filename1, "$tmpdir/dave") > -1); ok(index($filename2, "$tmpdir/dave") > -1); is(unlink($filename1, $filename2), 2, "Removed temp files"); ok(File::Path::rmtree($tmpdir), "Cleaned up temp dir"); HTTP-DAV-0.50/t/9_RT_19616.t0000644000175000017500000000037714703664237014167 0ustar cosimocosimo#!/usr/bin/env perl use strict; use Test::More (tests => 2); use_ok('HTTP::DAV::Comms'); ok ( defined &HTTP::DAV::UserAgent::redirect_ok && HTTP::DAV::UserAgent->can('redirect_ok'), 'redirect_ok() is overridden in HTTP::DAV::UserAgent' ); HTTP-DAV-0.50/t/TestDetails.pm0000644000175000017500000000637514703664237015246 0ustar cosimocosimo# $Id$ package TestDetails; use strict; use Test; use Exporter; use Cwd; use vars qw(@EXPORT @EXPORT_OK $VERSION @ISA); @ISA=qw(Exporter); @EXPORT=qw(do_test fail_tests test_callback $test_user $test_pass $test_url $test_cwd); # This package is designed to simplify testing. # It allows you to enter multiple URL's (and # credentials) for the different tests. # You need to manually edit the %details hash below. # A test script may tell us that it is about to do a propfind. # It would do this by calling TestDetails::method('PROPFIND'); # Then when the test script calls TestDetails::url() you will # get the URL specificed in the PROPFIND hash below. # But, if you haven't specified any details in the hash below # specific for PROPFIND it will use the DEFAULT entries instead. $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); # Configure these details: my %details = ( # 'default' => { # 'url'=> 'http://localhost/dav/', # 'user' => 'username', # 'pass' => 'pass', # }, ); # End of configuration section ###################################################################### my $method = ""; my $PERLDAV_TEST = 'default'; if (defined $ENV{'PERLDAV_TEST'}) { $PERLDAV_TEST = lc $ENV{'PERLDAV_TEST'} || 'default'; } our $test_user = user(); our $test_pass = pass(); our $test_url = url(); our $test_cwd = getcwd(); # If the user wants to remember where they started. ###################################################################### sub fail_tests { my ($num) = @_; print "You need to set a test url in the t/TestDetails.pm module.\n"; for(1..$num) { skip("no test server",1); } exit; } sub user { no warnings; $details{$PERLDAV_TEST}{'user'} || $details{'DEFAULT'}{'user'} || '' } sub pass { no warnings; $details{$PERLDAV_TEST}{'pass'} || $details{'DEFAULT'}{'pass'} || '' } sub url { no warnings; $details{$PERLDAV_TEST}{'url'} || $details{'DEFAULT'}{'url'} || '' } ###################################################################### # UTILITY FUNCTIONS: # do_test , , # It was getting tedious doing the error handling so # I built this little routine, Makes the test cases easier to read. sub do_test { my($dav,$result,$expected,$message,$resp) = @_; $expected = 1 if !defined $expected; my $ok; my $respobj =""; my $davmsg; if (ref($result) =~ /Response/ ) { $davmsg = $result->message . "REQUEST>>".$result->request()->as_string() . "RESPONS>>".$result->as_string; $result=$result->is_success; } else { my $resp = $dav->get_last_response; $davmsg = $dav->message;# . join("\n",@{$resp->messages()}); } if ($expected) { if ( $ok = ok($result,$expected) ) { print "TEST $message succeeded\n"; } else { print "TEST $message failed: $davmsg\n"; } } else { if ( $ok = ok($result,$expected) ) { print "TEST $message failed (as expected): \"$davmsg\"\n"; } else { print "TEST $message succeeded (unexpectedly): \"$davmsg\"\n"; } } return $ok; } sub test_callback { my($success,$mesg) = @_; if ($success) { print "$mesg\n" } else { print "Failed: $mesg\n" } } 1; HTTP-DAV-0.50/t/9_RT_42877.t0000644000175000017500000000152014703664237014163 0ustar cosimocosimo#!/usr/bin/env perl use strict; use Test::More tests => 7; use_ok('HTTP::DAV'); use_ok('HTTP::DAV::Comms'); $HTTP::DAV::DEBUG = $HTTP::DAV::DEBUG = 3; my $netloc = 'mylocation'; my $realm = 'myrealm'; my $user = 'randomuser'; my $pass = '12345'; my $ua = HTTP::DAV::UserAgent->new(); my $existing_credentials = $ua->credentials($netloc, $realm); is ($existing_credentials, undef, 'No credentials defined at start'); $ua->credentials($netloc, $realm, $user, $pass); $existing_credentials = $ua->credentials($netloc, $realm); is ($existing_credentials, "$user:$pass", 'credentials() called in scalar context'); my @cred = $ua->credentials($netloc, $realm); is(scalar @cred, 2, 'credentials() called in list context'); is($cred[0], $user, 'credentials() called in list context'); is($cred[1], $pass, 'credentials() called in list context'); HTTP-DAV-0.50/t/1_utils.t0000644000175000017500000000230214703664237014212 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; # Tests the DAV::Utils functions my $TESTS; BEGIN { $TESTS=6; plan tests => $TESTS; } #HTTP::DAV::DebugLevel(3); #ok($response->get_responsedescription(), 'There has been an access violation error.'); # Test get_leafname my @splits = ( ["http://server.com/", "http://server.com", "" ], ["http://server.com", "http://server.com" , "" ], ["http://server.com/index.html", "http://server.com", "index.html" ], ["http://server.com/test/index.html","http://server.com/test", "index.html" ], ["http://server.com/test/test2/", "http://server.com/test", "test2" ], ["/test/test2/", "/test", "test2" ], ); foreach my $arr ( @splits ) { my ($url,$left,$leaf) = @$arr; my ($pleft,$pleaf) = HTTP::DAV::Utils::split_leaf($url); my ($get_leaf) = HTTP::DAV::Utils::get_leafname($url); if ( ($pleft eq $left) && ($pleaf eq $leaf) && ($get_leaf eq $leaf) ) { ok(1); } else { print "BAD: $url-> $pleft, $pleaf (I thought: $left, $leaf)\n"; ok(0); } } HTTP-DAV-0.50/t/2_options.t0000644000175000017500000000152114703664237014550 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url do_test fail_tests test_callback); my $TESTS; $TESTS = 6; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $dav = HTTP::DAV->new; $dav->DebugLevel(3); $dav->credentials( $test_user, $test_pass, $test_url ); my $resource = $dav->new_resource( -uri => $test_url ); my $response = $resource->options(); if ( ! ok($response->is_success) ) { print $response->message() ."\n"; } print "DAV compliancy: ". $resource->is_dav_compliant(). "\n"; ok($resource->is_dav_compliant()); my $options = $resource->get_options || ""; print "$options\n"; ok($options,'/PROPFIND/'); ok($resource->is_option('PROPFIND'),1); ok($resource->is_option('JUNKOPTION'),0); ok($resource->get_username(),$test_user); HTTP-DAV-0.50/t/6_dav_globs.t0000644000175000017500000000420614703664237015024 0ustar cosimocosimo#!/usr/local/bin/perl -w ################################################################ # t/t_dav_globs.t # Tests globbing functionality: wildcards, like *, ? etc in URL's # # GLOB - Test plan # ------------------------- # We want to perform test functions against ... # # Test 1. # OPEN perldav_test_copy/subdir/ (should fail because no depth). use strict; use HTTP::DAV; use lib 't'; use TestDetails qw($test_user $test_pass $test_url do_test fail_tests test_callback); use Test; my $TESTS=11; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; HTTP::DAV::DebugLevel(3); my $targeturi = "perldav_test" .$$ . "_".time; my $shorturi = "perldav_test" .$$; my $targeturl = URI->new_abs($targeturi,$test_url); my $localdir = "/tmp/$targeturi"; print "targeturi: $targeturi\n"; print "targeturl: $targeturl\n"; my $dav1 = HTTP::DAV->new(); $dav1->credentials( $test_user, $test_pass, $test_url ); # SETUP # make URL/perldav_12341234/test_data/* do_test $dav1, $dav1->open ($test_url), 1,"OPEN $test_url"; do_test $dav1, $dav1->mkcol($targeturl), 1,"MKCOL $targeturl"; do_test $dav1, mkdir($localdir), 1, "system mkdir $localdir"; # TEST 1 # Test that working directory =~ /$shorturi/ do_test $dav1, $dav1->cwd("$shorturi*"), 1,"CWD $shorturi*"; do_test $dav1, $dav1->get_workingurl, "/$shorturi/", "CHECK WORKING DIRECTORY =~ /$shorturi/"; # TEST 2 do_test $dav1, $dav1->put(-local=>"t/test_data/file*", -callback=>\&test_callback), 1, "PUT t/test_data/file*"; # TEST 3 # Test for get xxxxxx* (should fail) do_test $dav1, $dav1->get(-url=>"xxxxx*", -to=>$localdir), 0, 'GET xxxxx*'; # TEST 4 # Test for get file[1_]* (should succeed) do_test $dav1, $dav1->get(-url=>"file[1_]*", -to=>$localdir,-callback=>\&test_callback), 1, 'GET file[1_]*'; # TEST 5 # Test for delete *.txt (should succeed) do_test $dav1, $dav1->delete(-url=>"*.txt",-callback=>\&test_callback), 1, 'DELETE *.txt'; # TEST 6 # Test for delete *.txt (should fail) do_test $dav1, $dav1->delete(-url=>"*.txt",-callback=>\&test_callback), 0, 'DELETE *.txt'; # CLEANUP do_test $dav1, $dav1->delete("$targeturl"), 1,"DELETE $targeturl"; system("/bin/rm -rf $localdir"); HTTP-DAV-0.50/t/6_dav_copy_move.t0000644000175000017500000001063014703664237015714 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url $test_cwd do_test fail_tests test_callback); # Tests basic copy and move functionality. my $TESTS; $TESTS=14; #$TESTS=18; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $user = $test_user; my $pass = $test_pass; my $url = $test_url; $url=~ s/\/$//g; # Remove trailing slash my $cwd = $test_cwd; # Remember where we started. HTTP::DAV::DebugLevel(3); =begin COPY - Test plan ------------------------- We want to perform test functions against proppatch. Setup. OPEN MKCOL perldav_test MKCOL perldav_test/subdir CWD perldav_test Test 1. COPY perldav_test perldav_test_copy OPEN perldav_test_copy/subdir/ Test 2. COPY perldav_test perldav_test_copy (no overwrite) Test 3. COPY perldav_test perldav_test_copy (with overwrite, depth 0) OPEN perldav_test_copy OPEN perldav_test_copy/subdir/ (should fail because no depth). MOVE - Test plan ------------------------- We want to perform test functions against proppatch. Setup. Test 1. TODO Cleanup DELETE perldav_test DELETE perldav_test_copy =cut # Setup # Make a directory with our process id after it # so that it is somewhat random my $sourceuri = "perldav_test" .$$ . "_".time; my $sourceurl = "$url/$sourceuri"; my $targeturi = ${sourceuri} . "_copy"; my $targeturl = "$url/$targeturi"; print "sourceuri: $sourceuri\n"; print "sourceurl: $sourceurl\n"; print "targeturi: $targeturi\n"; print "targeturl: $targeturl\n"; my $dav1 = HTTP::DAV->new(); $dav1->credentials( $user, $pass, $url ); do_test $dav1, $dav1->open ($url), 1,"OPEN $url"; do_test $dav1, $dav1->mkcol($sourceuri), 1,"MKCOL $sourceuri"; do_test $dav1, $dav1->mkcol("$sourceuri/subdir"), 1,"MKCOL $sourceuri/subdir"; do_test $dav1, $dav1->cwd ($sourceuri), 1,"CWD $sourceuri"; print "COPY\n" . "----\n"; my $resource1 = $dav1->get_workingresource(); my $resource2 = $dav1->new_resource( -uri => $targeturl ); my $resource3 = $dav1->new_resource( -uri =>"$targeturl/subdir" ); # Test 1 - COPY do_test $dav1, $resource1->copy( $resource2 ),1, "COPY $sourceuri to $targeturi"; do_test $dav1, $dav1->open( "$targeturl/subdir" ), 1, "OPEN $targeturi/subdir"; # Test 2 - COPY (no overwrite) do_test $dav1, $resource1->copy( -dest=>$resource2, -overwrite=>"F" ),0, "COPY $sourceuri to $targeturi (no overwrite)"; # Test 3 - COPY (overwrite, no depth) do_test $dav1, $resource1->copy( -dest=>$resource2, -overwrite=>"T", -depth=>0 ),1, "COPY $sourceuri to $targeturi (with overwrite, no depth)"; do_test $dav1, $dav1->open( "$targeturl" ), 1, "GET $targeturi"; do_test $dav1, $dav1->open( "$targeturl/subdir" ), 0, "GET $targeturi/subdir"; print "MOVE\n" . "----\n"; sub getlocks { my $r = $dav1->new_resource($url); $r->propfind(-depth=>1 ); my $rl = $r->get_lockedresourcelist; print "rl=$rl\n"; my $x = $rl->get_locktokens(); foreach my $i ( $rl->get_resources() ) { my @locks = $i->get_locks(); use Data::Dumper; print "All locks for " . $i->get_uri . ":\n"; print Data::Dumper->Dump( [@locks] , [ '@locks' ] ); } # use Data::Dumper; # print "All locks:\n"; # print Data::Dumper->Dump( [$rl] , [ '$rl' ] ); } # Re-setup do_test $dav1, $dav1->delete( "$sourceurl" ), 1, "DELETE $sourceuri"; do_test $dav1, $dav1->lock( "$targeturl" ), 1, "LOCK $targeturi"; do_test $dav1, $dav1->lock( "$sourceurl" ), 1, "LOCK $sourceuri"; &getlocks; # Test 4 - MOVE target(2) back to source(1) do_test $dav1, $dav1->move( -url=>$targeturl,-dest=>$sourceurl ),1, "MOVE $targeturi to $sourceuri"; # This unlock should fail because MOVE eats source locks # I can't seem to get these tests to work. # For some reason mod_dav has strange behaviour with trailing slashes if you move or copy null-locked files. # For some reason, it keeps shadowed versions of the null-lock #after deleting the directory. #do_test $dav1, $dav1->unlock( "$targeturl" ), 0, "UNLOCK $targeturl"; #do_test $dav1, $dav1->unlock( "$sourceurl" ), 1, "UNLOCK $sourceurl"; # Cleanup $dav1->cwd(".."); #do_test $dav1, $dav1->delete("$sourceurl"),1,"DELETE $sourceurl"; #do_test $dav1, $dav1->delete("$targeturl"),0,"DELETE $targeturl"; $dav1->unlock( "$targeturl" ); $dav1->unlock( "$sourceurl" ); $dav1->delete( "$targeturl" ); $dav1->delete( "$sourceurl" ); HTTP-DAV-0.50/t/9_RT_60457.t0000644000175000017500000000406614703664237014165 0ustar cosimocosimo#!/usr/bin/env perl # # RT #60457, add custom headers to HTTP::DAV::put() # use strict; use warnings; use Cwd (); use Data::Dumper; use Test::More tests => 8; use_ok('HTTP::DAV'); use_ok('HTTP::DAV::Comms'); #HTTP::DAV::DebugLevel(3); # # Test the set of headers in HTTP::DAV::Comms # my $comms = HTTP::DAV::Comms->new( -headers => {"X-HTTP-DAV-1" => "abc123"} ); ok($comms); my $headers = $comms->{_headers}; ok($headers, "Got a HTTP::DAV::Headers object"); is( $headers->header("X-HTTP-DAV-1") => "abc123", "Header passed at construction time" ); # # Test setting of headers from HTTP::DAV to Comms # my $dav = HTTP::DAV->new( -headers => { "X-HTTP-DAV-2" => "def456" } ); # XXX This currently does not work without test details, # so it's not tested my $result = $dav->put( -local => $0, -url => "$0.copy.$$", -headers => {"X-HTTP-DAV-3" => "ghi789"} ); # Inspect the internals to check if everything looks fine $comms = $dav->{_comms}; ok($comms, 'HTTP::DAV::Comms object is there'); $headers = $comms->{_headers}; ok($headers, "Got a HTTP::DAV::Headers object"); is( $headers->header("X-HTTP-DAV-2") => "def456", "Header passed in the HTTP::DAV constructor is passed along", ); __END__ SKIP: { use lib 't'; use TestDetails qw($test_user $test_pass $test_url do_test fail_tests test_callback); # if ($test_url !~ m{http}) { # skip("no test server", 4); # } use_ok('HTTP::DAV'); use_ok('HTTP::DAV::Comms'); my $dav = HTTP::DAV->new(); HTTP::DAV::DebugLevel(3); $dav->credentials($test_user,$test_pass,$test_url); my $collection = $test_url; $collection =~ s{/$}{}g; my $new_file = "$collection/dav_test_file.txt"; diag("File: $new_file"); my $resource = $dav->new_resource( -uri => $new_file ); my $response = $resource->put("DAV.pm test content ", {"X-DAV-Test" => "12345"}); if (! ok($response->is_success)) { diag($response->message()); } $response = $resource->get(); if (! ok($response->is_success) ) { diag($response->message()); } } HTTP-DAV-0.50/t/multistatus.xml0000644000175000017500000000701114703664237015567 0ustar cosimocosimo /test/cadaver-0.17.0.tar.gz 2001-08-07T14:10:00Z 377211 Tue, 07 Aug 2001 14:10:00 GMT "b15d1-5c17b-3b6ff6b8" F application/x-tar HTTP/1.1 200 OK /test/mod_dav/ 2001-08-06T11:24:17Z Mon, 06 Aug 2001 11:24:17 GMT "9790e-400-3b6e7e61" infinity DAV.pm/v0.05 (6370) Infinite opaquelocktoken:6d1d271a-1dd2-11b2-b3a8-efebe4918f22 httpd/unix-directory HTTP/1.1 200 OK /test/dual_href1 /test/dual_href2 HTTP/1.1 200 OK Looks good to me /test/testprops Box type A J.J. Johnson HTTP/1.1 200 OK HTTP/1.1 403 Forbidden The user does not have access to the DingALing property. There has been an access violation error. HTTP-DAV-0.50/t/9_RT_52665.t0000644000175000017500000000150214703664237014157 0ustar cosimocosimo#!/usr/bin/env perl use strict; use Test::More tests => 6; use_ok('HTTP::DAV'); use_ok('HTTP::DAV::Utils'); my $uc_uri = 'http://example.com/escaped_%5B/'; my $lc_uri = 'http://example.com//escaped_%5b/'; my $uri_missing_slash = 'http://example.com/escaped_%5b'; my $different_uri = 'http://example.com/ESCAPED_%5B/'; ok( HTTP::DAV::Utils::compare_uris($uc_uri, $lc_uri), 'Upper and lower case escaping is equivalent' ); ok( HTTP::DAV::Utils::compare_uris($uc_uri, $uri_missing_slash), 'Upper and lower case escaping is equivalent, even with missing final slash' ); ok( HTTP::DAV::Utils::compare_uris($lc_uri, $uri_missing_slash), 'Upper and lower case escaping is equivalent, even with missing final slash' ); ok( ! HTTP::DAV::Utils::compare_uris($uc_uri, $different_uri), 'General URI characters are case sensitive' ); HTTP-DAV-0.50/t/6_dav_open_put_get.t0000644000175000017500000001617214703664237016413 0ustar cosimocosimouse strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url $test_cwd do_test fail_tests test_callback); # Sends out a propfind request to the server # specified in "PROPFIND" in the TestDetails # module. my $TESTS; $TESTS=39; plan tests => $TESTS; my $user = $test_user; my $pass = $test_pass; my $url = $test_url; my $cwd = $test_cwd; fail_tests($TESTS) unless $test_url =~ /http/; HTTP::DAV::DebugLevel(2); my $dav; # Test get_workingurl on empty client $dav = HTTP::DAV->new( ); do_test $dav, $dav->get_workingurl(), "", "Empty get_workingurl"; # Test an empty open. Should fail. do_test $dav, $dav->open(), 0, "OPEN nothing"; $dav = HTTP::DAV->new(); # Set some creds and then open the URL $dav->credentials( $user, $pass, $url ); do_test $dav, $dav->open( $url ), 1, "OPEN $url"; do_test $dav, $dav->open( -url => $url ), 1, "OPEN $url"; # Try opening a non-collection. It should fail. #do_test $dav, $dav->open( -url => $geturl ), 0, "OPEN $geturl"; # Test various ways of getting the working url my $working_url1 = $dav->get_workingresource()->get_uri(); my $working_url2 = $dav->get_workingurl(); my $test_url = $url; ok($working_url1 eq $test_url); ok($working_url2 eq $test_url); ok($working_url1 eq $working_url2); print "AM STARTING THE OPERATIONS!!\n"; # Make a directory with our process id after it # so that it is somewhat random my $newdir = "perldav_test$$"; do_test $dav, $dav->mkcol($newdir), 1, "MKCOL $newdir"; # Try it again. This time it should fail. do_test $dav, $dav->mkcol($newdir), 0, "MKCOL $newdir"; # Try changing to it. It should work do_test $dav, $dav->cwd($newdir), 1, "CWD to $newdir"; # Make another in newdir. do_test $dav, $dav->mkcol("subdir"),1, 'MKCOL "subdir"'; # Go back again. cwd .. It should work. do_test $dav, $dav->cwd(".."), 1, "CWD to '..'"; ###################################################################### # PUT some files print "Doing PUT\n"; my $localdir = "/tmp/perldav"; # Test put with absolute paths do_test $dav, $dav->put("t/test_data","$newdir",\&test_callback), 1, "put t"; print scalar $dav->message() . "\n"; # Try putting the directory to a bogus location do_test $dav, $dav->put("t/test_data","/foobar/$newdir/",\&test_callback), 0, "put t"; if (!open(F,">/tmp/tmpfile.txt") ) { print "Couldn't open /tmp/tmpfile.txt"; } print F "I am content that came from a local file \n"; close F; my $some_content="I am content that came from a scalar\n"; do_test $dav, $dav->put("/tmp/tmpfile.txt","$newdir/file.txt"), 1, "put $newdir/file.txt"; print scalar $dav->message() . "\n"; do_test $dav, $dav->put(\$some_content,"$newdir/scalar_to_file.txt"), 1, 'put \$some_content'; print scalar $dav->message() . "\n"; print "Test put with relative paths\n"; do_test $dav, $dav->cwd($newdir), 1, "CWD to $newdir"; do_test $dav, $dav->put("/tmp/tmpfile.txt"), 1, "put /tmp/tmpfile.txt"; print scalar $dav->message() . "\n"; do_test $dav, $dav->put("/tmp/tmpfile.txt", "file2.txt"), 1, "put file2.txt"; print scalar $dav->message() . "\n"; do_test $dav, $dav->put("/tmp/tmpfile.txt", "subdir/file2.txt"), 1, "put subdir/file2.txt"; print scalar $dav->message() . "\n"; chdir "/tmp" || die "Couldn't change to /tmp\n"; do_test $dav, $dav->put("tmpfile.txt", "file3.txt"), 1, "put file3.txt"; print scalar $dav->message() . "\n"; do_test $dav, $dav->put("tmpfile.txt", "subdir/file3.txt"), 1, "put subdir/file3.txt"; print scalar $dav->message() . "\n"; do_test $dav, $dav->cwd('..'), 1, "CWD to .."; unlink("/tmp/tmpfile.txt") || print "Couldn't remove /tmp/tmpfile.txt\n"; #my $put_url = $dav->get_absolute_uri("$newdir/file.txt"); #my $put_res = $dav->new_resource($put_url); #my $put_resp; # #$put_resp = $put_res->get(); #if (ok $put_resp->is_success) { # print "GET succeded on file.txt. Contents:\n" . $put_resp->content . "\n"; #} else { # print "GET failed on $put_url. ". $put_resp->message . "\n"; #} ###################################################################### # GET some files # We're now at the base directory again but have two nested subdirectories with some files in there. # Let's start getting things !! # Create a local directory # No error checking required. Don't care if it fails. if (!mkdir $localdir ) { print "Local mkdir failed: $!\n" if $!; } # Get it the normal way do_test $dav, $dav->get($newdir, $localdir, \&test_callback ), 1, "GET of $newdir"; do_test $dav, -e ("$localdir/$newdir/file.txt"), 1, "ls of $localdir/$newdir/file.txt"; print scalar $dav->message() . "\n"; # Let's try getting the coll without passing a local # working directory. It should fail. do_test $dav, $dav->get($newdir), 0, "GET of $newdir"; # Let's try getting the coll and passing it '.' as the cwd. But first # let's try it when the local directory already exists (retrieved # above). chdir($localdir); do_test $dav, $dav->get($newdir,'.',\&test_callback), 0, "GET of $newdir"; # Let's try getting the coll and passing it '.'. But this time let's do # it properly, we'll remove the local directory first so we have a clean # slate. system("rm -rf $localdir/$newdir") if $localdir =~ /\w/; chdir("$localdir"); do_test $dav, $dav->get($newdir,'.',\&test_callback), 1, "GET of $newdir"; do_test $dav, -e ("$localdir/$newdir/file.txt"),1,"ls of $localdir/$newdir/file.txt"; print scalar $dav->message() . "\n"; # Now let's get file.txt (created earlier) rather than a coll. # Put it in $localdir and call it newfile.txt my $file = "$newdir/file.txt"; my $scal = "$newdir/scalar_to_file.txt"; chdir("$localdir/$newdir") || print "chdir to $localdir/$newdir failed\n"; do_test $dav, $dav->get($file,'../newfile.txt',\&test_callback), 1, "GET of $file to ../newfile.txt"; do_test $dav, -e ("$localdir/newfile.txt"), 1, "ls of $localdir/newfile.txt"; print scalar $dav->message() . "\n"; do_test $dav, $dav->get($file,"$localdir/$newdir/subdir/newfile.txt",\&test_callback), 1, "GET of $file to $localdir/$newdir/subdir/newfile.txt"; do_test $dav, -e ("$localdir/$newdir/subdir/newfile.txt"), 1, "ls of $localdir/$newdir/subdir/newfile.txt"; print scalar $dav->message() . "\n"; # Now let's get file.txt and file2.txt but don't save it # to disk. Expect it back as text my $string; $dav->get($file,\$string); do_test $dav, $string, '/from a local file/', "GET of $file to \$scalar"; $dav->get($scal,\$string); do_test $dav, $string, '/from a scalar/', "GET of $scal to \$scalar"; # Get a nonexistent file # Expect undef $file="$newdir/foobar"; do_test $dav, $dav->get($file), 0, "GET of $file to \$scalar"; ###################################################################### ###################################################################### # DELETE some files # Remove the directory (and it's subdirectory). It should succeed. END { if ( $url =~ /http/ ) { print "Cleaning up\n"; do_test $dav, $dav->delete(-url=>"$newdir/test_data/file*",-callback=>\&test_callback ),1,"DELETE $newdir/test_data/file*"; do_test $dav, $dav->delete($newdir), 1, "DELETE $newdir"; # Remove the directory again. It should fail do_test $dav, $dav->delete($newdir), 0, "DELETE $newdir"; chdir $cwd; system("rm -rf $localdir") if $localdir =~ /\w/; } } HTTP-DAV-0.50/t/4_multistatus.t0000644000175000017500000001110414703664237015453 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; # Tests Response.pm's ability to handle multistatus documents. # Prerequisite: Resource.pm's _XML_parse_multistatus works. my $TESTS; $TESTS=20; plan tests => $TESTS; my $dav = HTTP::DAV->new; HTTP::DAV::DebugLevel(3); my $resource = $dav->new_resource( -uri => 'http://testserver:8080/test/' ); # MAKE OURSELVES A DUMMY REQUEST my $request = HTTP::Request->new(PROPFIND => 'http://testserver:8080/test/' ); print "REQUEST>>: " . $request->as_string(); # MAKE OURSELVES A DUMMY RESPONSE # From perldoc HTTP::Response # $r = HTTP::Response->new($rc, [$msg, [$header, [$content]]]) # Constructs a new `HTTP::Response' object describing a # response with response code `$rc' and optional message # `$msg'. The message is a short human readable single # line string that explains the response code. my $headers = HTTP::Headers->new(); $headers->header('Date' => 'Thu, 03 Feb 2001 00:00:00 GMT'); $headers->header('Content-Type' => 'text/xml; charset="utf-8"'); # LOAD t/multistatus.xml AS OUR CONTENT open(F,"t/multistatus.xml") || die("Couldn't find multistatus.xml");; my $content; while() { $content.=$_ }; my $response = HTTP::DAV::Response->new("207","Multi-Status",$headers,$content); # Put the dummy request into teh dummy response. Not # really required but HTTP::Response dies when you # do an as_string if you don't do this first. $response->request($request); # Requires the response code to be reset # for older versions of LWP $response->set_message( $response->code ); # A 207 will return OK. But down # further it should fail because their will be # sub-status's that fail. if (! ok($response->is_success) ) { print $response->message() ."\n"; } # use XML::DOM to parse the result. my $resource_list; eval { my $parser = new XML::DOM::Parser; my $doc = $parser->parse($response->content); # We're only interested in the error codes that come out of $resp. $resource_list = $resource->_XML_parse_multistatus( $doc, $response ) }; if ($@) { print "XML error: " . $@; } else { ok(1); } print "RESPONSE>>: " . $response->as_string(); # Check that the response is a multistatus ok($response->is_multistatus()); # Check that the message returned is indeed 'Multistatus' ok($response->message(), 'Multistatus'); # Check that the response successfully says that it failed ok($response->is_success(),0); # Check an array of messages my @messages = $response->messages(); ok(scalar(@messages), 5); ok($messages[4], '/Forbidden/'); # Check that the URI in at least one of the resourcs is absolute. # Search for Parse 1 area in Resource.pm ok($response->url_bynum(0),'/http\:\/\//'); # Check that there are five errors in the multistatus. ok($response->response_count(),5-1); # Check that the desc for status 1 and status 3 are ok ok($response->description_bynum(0), undef); ok($response->description_bynum(2), "/Looks good to me/"); # Check that the code for status 5 is forbidden ok($response->code_bynum(4), '403'); # Check the overall response description ok($response->get_responsedescription(), 'There has been an access violation error.'); ###################################################################### # Check some of the resources etc. ok( $resource_list->count_resources(), 5); my @progeny = $resource_list->get_resources(); my @urls = $resource_list->get_urls(); print join("\n",@urls) . "\n"; # Test getting slighlt different URI's. $urls[1] =~ s/\/+$//g; # Remove the trailing slash from the collection # Now see if we get the same resource. my $resource1= $resource_list->get_member( $urls[1] ); print "Resource 1: " . $urls[1] . ": $resource1\n"; ok($progeny[1] eq $resource1 ); # Test removing the second last element (0,1,2,'3',4) my $resource3 = $resource_list->get_member( $urls[3] ); my $resource3a= $resource_list->remove_resource( $resource3 ); print "Is Removed resource <-> sames as \$urls[3]?\n"; if ($resource3->get_uri eq $resource3a->get_uri ) { ok 1; } #if ($resource3 && $resource3->get_uri eq $urls[3] ) { # ok 1; #} # Test that we now only have 4 resoruces my @urls2 = $resource_list->get_urls(); print join("\n",@urls2) . "\n"; ok ( scalar @urls2, 4 ); # Resource 1 has 2 locks types supported "exclusive:write" and "shared:write" my $supportedlocks_arr = $progeny[0]->get_property('supportedlocks'); ok ( scalar(@$supportedlocks_arr), 2 ); # Resource 3 should have no locks supported. $supportedlocks_arr = $progeny[2]->get_property('supportedlocks'); ok( ref($supportedlocks_arr) ne "ARRAY" ); print $progeny[4]->as_string(); ok($progeny[4]->get_property('author'),'/Johnson/'); HTTP-DAV-0.50/t/5_proppatch.t0000644000175000017500000001113314703664237015060 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use Cwd; use lib 't'; use TestDetails qw($test_user $test_pass $test_url $test_cwd do_test fail_tests test_callback); # Tests basic proppatch. my $TESTS; $TESTS=14; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $user = $test_user; my $pass = $test_pass; my $url = $test_url; my $cwd = $test_cwd; # Remember where we started HTTP::DAV::DebugLevel(3); # Make a directory with our process id after it # so that it is somewhat random my $newdir = "perldav_test$$"; =begin Proppatch - Test plan ------------------------- We want to perform test functions against proppatch. Setup. OPEN MKCOL perldav_test CWD perldav_test PUT perldav_test/file.txt #is option(perldav_test,PROPFIND) #is option(perldav_test/file.txt, PROPFIND) Test 1. We want to test a set prop sequence. if is_option(perldav_test,PROPFIND) { PROPPATCH(perldav_test, set patrick:test_prop=test_val) } if is_option(perldav_test/file.txt,PROPFIND) { PROPPATCH(perldav_test/file.txt, set patrick:test_prop=test_val) } Test 2. Then a remove prop sequence PROPPATCH perldav_test (remove patrick:test_prop) Test 3. Then lock perldav_test and do a proppatch. No namespace 3a. LOCK perldav_test 3a. PROPPATCH perldav_test (set test_prop=test_val) 3b. PROPPATCH perldav_test (remove DAV:test_prop) 3b. UNLOCK perldav_test =cut # Setup my $dav1 = HTTP::DAV->new(); $dav1->credentials( $user, $pass, $url ); do_test $dav1, $dav1->open ( $url ), 1,"OPEN $url"; # Determine server's willingness to proppatching and locking # IIS5 currently does not support pp on files or colls. my $options =$dav1->options(); my $coll_proppatch=( $options=~/\bPROPPATCH\b/)?1:0; my $coll_lock= ( $options=~/\bLOCK\b/ )?1:0; my $cps = ($coll_proppatch)?"supports":"does not support"; my $cls = ($coll_lock )?"supports":"does not support"; print "$options\n"; print "** Server $cps proppatch against collections ** \n"; print "** Server $cls locking against collections ** \n"; if (!$coll_proppatch) { skip_num($TESTS-1); # We've already done one test on the open exit; } ###################################################################### my $resource; do_test $dav1, $dav1->mkcol ($newdir), 1,"MKCOL $newdir"; do_test $dav1, $dav1->cwd ($newdir), 1,"CWD $newdir"; ## Test 1. do_test $dav1, $dav1->proppatch(-namespace=>'patrick', -propname=>'test_prop', -propvalue=>'test_val'), '/Resource/', "proppatch set test_prop"; $resource = $dav1->propfind(-depth=>0); if ($resource) { do_test $dav1, $resource->get_property('test_prop'), 'test_val', "propfind get_property test_prop"; } else { print "Couldn't perform propfind\n"; ok 0; } print $resource->as_string; ## Test 2 do_test $dav1, $dav1->proppatch(-namespace=>'patrick', -propname=>'test_prop', -action=>'remove'), '/Resource/', "proppatch remove test_prop"; $resource = $dav1->propfind(-depth=>0); if ($resource) { do_test $dav1, $resource->get_property('test_prop'), '', "propfind get_property test_prop"; } else { print "Couldn't perform propfind\n"; ok 0; } print $resource->as_string; ###################################################################### if ($coll_lock) { do_test $dav1, $dav1->lock(), 1,"LOCK"; # Test 3a do_test $dav1, $dav1->set_prop(-propname=>'test_prop',-propvalue=>'test_value2'), '/Resource/', "proppatch set DAV:test_prop"; $resource = $dav1->propfind(-depth=>0); if ($resource) { do_test $dav1, $resource->get_property('test_prop'), 'test_value2', "propset get_property DAV:test_prop"; } else { print "Couldn't perform propfind\n"; ok 0; } print $resource->as_string; # Test 3b do_test $dav1, $dav1->unset_prop(-propname=>'test_prop',-namespace=>'DAV'), '/Resource/', "unset_prop DAV:test_prop"; $resource = $dav1->propfind(-depth=>0); if ($resource) { do_test $dav1, $resource->get_property('test_prop'), '', "propfind get_property DAV:test_prop"; } else { print "Couldn't perform propfind\n"; ok 0; } print $resource->as_string; do_test $dav1, $dav1->unlock(), 1,"UNLOCK"; } # Cleanup if ( $test_url =~ /http/ ) { print "Cleaning up\n"; $dav1->cwd(".."); do_test $dav1, $dav1->delete($newdir), 1,"DELETE $newdir"; } HTTP-DAV-0.50/t/6_dav_lock2.t0000644000175000017500000000651714703664237014737 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url $test_cwd do_test fail_tests test_callback); # Tests advanced locking, like shared locks and steal locks my $TESTS; $TESTS=11; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $user = $test_user; my $pass = $test_pass; my $url = $test_url; my $cwd = $test_cwd; # Remember where we started. HTTP::DAV::DebugLevel(1); # Make a directory with our process id after it # so that it is somewhat random my $newdir = "perldav_test$$"; =begin Advanced Locking - Test plan ------------------------- We want to perform test functions against our locking mechanisms. This stretches the legs of: - the headers (depth, type, scope, owner) - shared locking - steal locks Setup. Client 1: OPEN Client 2: OPEN Client 1: MKCOL perldav_test Client 1: MKCOL perldav_test/subdir Test 1. Test timeout header Client 1: LOCK perldav_test with timeout=10m Client 1: UNLOCK perldav_test with timeout=10m Test 1. Test 2 shared locks Client 1: LOCK perldav_test with scope=shared Client 2: LOCK perldav_test with scope=shared =cut # Setup my $dav1 = HTTP::DAV->new(); my $dav2 = HTTP::DAV->new(); $dav1->credentials( $user, $pass, $url ); $dav2->credentials( $user, $pass, $url ); do_test $dav1, $dav1->open( $url ), 1, "dav1->OPEN $url"; do_test $dav2, $dav2->open( $url ), 1, "dav2->OPEN $url"; do_test $dav1, $dav1->mkcol ($newdir), 1,"dav1->MKCOL $newdir"; do_test $dav1, $dav1->mkcol ("$newdir/subdir"), 1,"dav1->MKCOL $newdir/subdir"; # Test 1 do_test $dav1, $dav1->lock(-url=>$newdir,-timeout=>"10m"), 1,"dav1->LOCK $newdir timeout=10mins"; my $u = $url; $u =~ s/\/$//g; my $r1 = $dav1->new_resource("$u/$newdir"); my $r2 = $dav2->new_resource("$u/$newdir"); print $r1->as_string; my @locks = $r1->get_locks(-owned=>1); my $lock = shift @locks; my $timeout = ($lock->get_timeout()||0) if ($lock); if ($timeout) { my $secstogo = ($timeout-time); print "Timesout in: $secstogo seconds\n"; if ( $secstogo <= 10*60 ) { print "Whoopee!! The server honored out timeout of 10 minutes. (but I'm not hanging around to watch it timeout :)\n"; } else { print "Hmmm... server did strange thing with my 10min lock. Maybe made it infinite?\n"; } } else { print "Server ignored my lock timeout. Oh well... c'est la vie.\n"; } do_test $dav1, $dav1->unlock($newdir), 1,"dav1->UNLOCK $newdir"; # Test 2 do_test $dav1, $dav1->lock(-url=>$newdir, -scope=>'shared', -owner=>'dav1' ), 1,"dav1->LOCK $newdir (scope=shared)"; do_test $dav2, $dav2->lock(-url=>$newdir, -scope=>'shared', -depth=>0, -owner=>'http://dav2' ), 1,"dav2->LOCK $newdir (scope=shared)"; $r1->propfind(); $r2->propfind(); print "DAV1:" . $r1->as_string; print "DAV2:" . $r2->as_string; do_test $dav1, $dav1->steal(-url=>$newdir), 1,"dav1->STEAL $newdir"; $r1->propfind(); print "DAV1:" . $r1->as_string; do_test $dav2, $dav2->unlock(-url=>$newdir), 0,"dav2->UNLOCK $newdir"; my $resp=$r2->propfind(); print "DAV2:" . $r2->as_string; #$r1->build_ls(); #$r1->get_property(short_ls); do_test $dav1, $dav1->delete(-url=>$newdir), 1,"dav1->DELETE $newdir"; HTTP-DAV-0.50/t/9_RT_68936.t0000644000175000017500000000055114703664237014172 0ustar cosimocosimo#!/usr/bin/env perl # # RT #68936, errors() throws an undefined reference exception # use strict; use warnings; use Test::More tests => 2; use HTTP::DAV; my $dav = HTTP::DAV->new(); ok($dav); my @errors; eval { @errors = $dav->errors(); ok(@errors == 0, "No errors to be returned"); } or do { ok(0, "errors() method failed miserably: $@"); }; HTTP-DAV-0.50/t/6_dav_options.t0000644000175000017500000000305714703664237015414 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url do_test fail_tests test_callback); # Tests dav options functionality. my $TESTS; $TESTS=6; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $user = $test_user; my $pass = $test_pass; my $url = $test_url; $url=~ s/\/$//g; # Remove trailing slash HTTP::DAV::DebugLevel(1); =begin DAV.pm::options() - Test plan ------------------------- We want to perform test functions against proppatch. OPEN MKCOL perldav OPTIONS (looking for PROPFIND) OPTIONS perldav (looking for PROPFIND) OPTIONS http://...perldav (looking for PROPFIND) =cut # Setup # Make a directory with our process id after it # so that it is somewhat random my $perldav_test_uri = "perldav_test" .$$; my $perldav_test_url = "$url/$perldav_test_uri/"; my $dav = HTTP::DAV->new(); $dav->credentials( $user, $pass, $url ); do_test $dav, $dav->open ($url), 1,"OPEN $url"; do_test $dav, $dav->mkcol($perldav_test_uri), 1,"MKCOL $perldav_test_uri"; print "OPTIONS\n" . "----\n"; do_test $dav, $dav->options( "$url" ), '/PROPFIND/', "OPTIONS $url (looking for PROPFIND)"; do_test $dav, $dav->options( "$perldav_test_uri" ), '/PROPFIND/', "OPTIONS $perldav_test_uri (looking for PROPFIND)"; do_test $dav, $dav->options( "$perldav_test_url" ), '/PROPFIND/', "OPTIONS $perldav_test_url (looking for PROPFIND)"; # Cleanup do_test $dav, $dav->delete("$perldav_test_url"),1,"DELETE $perldav_test_url"; HTTP-DAV-0.50/t/5_propfind.t0000644000175000017500000000316314703664237014705 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url do_test fail_tests test_callback); # Sends out a propfind request to the server # specified in "PROPFIND" in the TestDetails # module. my $TESTS; $TESTS=9; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $dav = HTTP::DAV->new; HTTP::DAV::DebugLevel(3); $dav->credentials( $test_user,$test_pass,$test_url ); my $response; my $resource = $dav->new_resource( -uri => $test_url ); ###################################################################### # RUN THE TESTS ok($resource->set_property('testing','123')); ok($resource->get_property('testing'),'123'); ok($resource->is_collection(),0); $response = $resource->propfind(); if (! ok($response->is_success) ) { print $response->message() ."\n"; } ok($resource->is_collection()); ok($resource->get_property('resourcetype')); $response = $resource->propfind( -depth=>0, ""); if (! ok($response->is_success) ) { print $response->message() ."\n"; } #use Data::Dumper; #print Data::Dumper->Dump( [$resource] , [ '$resource' ] ); #print $resource->as_string; $response = $resource->options(); if (! ok($response->is_success) ) { print $response->message() ."\n"; } #$resource->set_property('supportedlocks',[]); if ( $resource->is_dav_compliant() eq 2 && $resource->is_option('LOCK') ) { my $supportedlocks_arr = $resource->get_property('supportedlocks'); print "supportedlocks_arr: ". ref($supportedlocks_arr) ."\n"; ok(1) if ref($supportedlocks_arr) eq "ARRAY"; } else { skip 1,1; } HTTP-DAV-0.50/t/6_dav_get_callback.t0000644000175000017500000000763214703664237016317 0ustar cosimocosimouse strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url $test_cwd do_test fail_tests test_callback); # Sends out a propfind request to the server # specified in "PROPFIND" in the TestDetails # module. my $TESTS; $TESTS=19; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $user = $test_user; my $pass = $test_pass; my $url = $test_url; my $cwd = $test_cwd; HTTP::DAV::DebugLevel(0); my $dav; # Test get_workingurl on empty client $dav = HTTP::DAV->new( ); $dav->credentials( $user, $pass, $url ); do_test $dav, $dav->open( $url ), 1, "OPEN $url"; # Make a directory with our process id after it # so that it is somewhat random my $newdir = "perldav_test$$"; do_test $dav, $dav->mkcol($newdir), 1, "MKCOL $newdir"; do_test $dav, $dav->cwd($newdir), 1, "CWD to $newdir"; # Make a big temporary file print "CREATING temporary 1Mb file\n"; my $tmp_file = "perldav_$$.tmp"; open(TMP,">$tmp_file") ||die; my $bytes = 1000000; print TMP "X"x$bytes; close TMP; my $size = -s $tmp_file; do_test $dav, $dav->put($tmp_file), 1, "PUT $tmp_file ($size bytes)"; ###################################################################### # GET # Create a local directory # No error checking required. Don't care if it fails. # Get it the normal way do_test $dav, $dav->get($tmp_file, "${tmp_file}2"), 1, "GET of $tmp_file to ${tmp_file}2"; my $newsize = -s "${tmp_file}2"; sub remove_temps { no warnings; unlink ${tmp_file}; unlink "${tmp_file}2"; } print "SIZE of original file: $size\n"; print "SIZE of new file: $newsize\n"; do_test $dav,($size == $newsize),1,"SIZE compare of $tmp_file and ${tmp_file}2"; &remove_temps; print "\n"; do_test $dav, $dav->get(-url=>$tmp_file, -to=>"${tmp_file}2"), 1, "GET of $tmp_file to ${tmp_file}2"; do_test $dav,-e "${tmp_file}2",1,"SIZE compare of $tmp_file and ${tmp_file}2 with to"; &remove_temps; print "\n"; do_test $dav, $dav->get(-url=>"XXXX", -to=>"/tmp", -callback=>\&callback), 0, "GET of XXXXX with callback"; &remove_temps; print "\n"; do_test $dav, $dav->get(-url=>$tmp_file, -callback=>\&callback), 1, "GET of $tmp_file to ${tmp_file}2 with callback"; $newsize = -s "${tmp_file}2" || -1; do_test $dav,($size != $newsize),1,"SIZE compare of $tmp_file and ${tmp_file}2"; &remove_temps; do_test $dav, $dav->get(-url=>$tmp_file, -to=>"${tmp_file}2", -callback=>\&callback), 1, "GET of $tmp_file to ${tmp_file}2 with callback and to"; $newsize = -s "${tmp_file}2"; do_test $dav,($size == $newsize),1,"SIZE compare of $tmp_file and ${tmp_file}2"; &remove_temps; print "\n"; my $scalar; do_test $dav, $dav->get(-url=>$tmp_file, -to=>\$scalar, -callback=>\&callback), 1, "GET of $tmp_file to \$scalar with callback and scalar to"; do_test $dav,($size == length($scalar)),1,"SIZE compare of $tmp_file and \$scalar"; &remove_temps; print "\n"; do_test $dav, $dav->get(-url=>$tmp_file, -to=>\$scalar), 1, "GET of $tmp_file to \$scalar"; do_test $dav,($size == length($scalar)),1,"SIZE compare of $tmp_file and \$scalar"; &remove_temps; print "\n"; { my $in_transfer=0; sub callback { my($status,$mesg,$url,$so_far,$length,$data) = @_; $|=1; if ($status == 1) { print "Transfer complete.\n"; $in_transfer=0; } if ($status == 0) { print "Transfer failed: ($mesg)\n"; $in_transfer=0; } if ($status == -1) { if (!$in_transfer++) { print "Transferring $url ($length bytes):\n"; } my $width = 60; if ($length>0) { my $num = int($so_far/$length * $width); my $space = $width-$num; print "[" . "#"x$num . " "x$space . "]"; } print " $so_far bytes\r"; } } } ###################################################################### # CLEANUP END { if ( $test_url =~ /http/ ) { print "Cleaning up\n"; do_test $dav, $dav->cwd(".."), 1, "CWD .."; do_test $dav, $dav->delete("$newdir"), 1, "DELETE $newdir"; } &remove_temps; } HTTP-DAV-0.50/t/9_RT_38677.t0000644000175000017500000000141314703664237014167 0ustar cosimocosimo#!/usr/bin/env perl use strict; use Test::More tests => 5; use HTTP::Response; use_ok('HTTP::DAV'); my $server_msg = q{Method not allowed}; my $fake_405_response = HTTP::Response->new(405, $server_msg); my $dav = HTTP::DAV->new(); my $result = $dav->what_happened( 'https://fake.url.for.testing', # url undef, # resource $fake_405_response, # http::response ); ok(ref $result eq 'HASH', 'A hashref is expected'); is( $result->{success} => 0, 'Requests ending in 405s should be considered failed' ); is( $result->{error_type} => 'ERR_405', 'RT#38677: 405s are detected as such' ); like( $result->{error_msg} => qr{$server_msg}, 'Server message should be reported as error message' ); HTTP-DAV-0.50/t/9_RT_59674.t0000644000175000017500000000137314703664237014174 0ustar cosimocosimo#!/usr/bin/env perl use strict; use Test::More tests => 5; use HTTP::Response; use_ok('HTTP::DAV'); my $server_msg = q{Protocol scheme 'https' is not supported}; my $fake_501_response = HTTP::Response->new(501, $server_msg); my $dav = HTTP::DAV->new(); my $result = $dav->what_happened( 'https://fake.url.for.testing', # url undef, # resource $fake_501_response, # http::response ); ok(ref $result eq 'HASH', 'Has to return a hashref'); is($result->{success} => 0, 'Requests ending in 501s should be considered failed'); is($result->{error_type} => 'ERR_501', '501s are detected as such'); like($result->{error_msg} => qr{$server_msg}, 'Server message should be reported as error message'); HTTP-DAV-0.50/t/test_data/0000755000175000017500000000000014703666621014417 5ustar cosimocosimoHTTP-DAV-0.50/t/test_data/file30000644000175000017500000000042614703664237015347 0ustar cosimocosimo ##### ###### # # ###### # # # # # # # ##### # # ##### ##### # # # # # # # # # # # # # ###### ###### ##### HTTP-DAV-0.50/t/test_data/file4.txt.gz0000644000175000017500000000015314703664237016602 0ustar cosimocosimo‹ïj—;file4.txtOAÀ0ºó þÿÇe5Q™M;m‚@žG ÖÄ–ÏûnXM¼vtûl0£T°ÂlÒœ\¨”Þ³dgiP¿]ñqñFSUFUwi' 1; $SIG{__WARN__} = sub { ok(0); exit; } } # Check that we compile without warnings. use HTTP::DAV; ok(1); HTTP-DAV-0.50/t/6_dav_lock.t0000644000175000017500000000644414703664237014654 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url $test_cwd do_test fail_tests test_callback); # Tests basic LOCKing. my $TESTS; $TESTS=13; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $user = $test_user; my $pass = $test_pass; my $url = $test_url; my $cwd = $test_cwd; HTTP::DAV::DebugLevel(1); # Make a directory with our process id after it # so that it is somewhat random my $newdir = "perldav_test$$"; =begin Locking - Test plan ------------------------- We want to perform test functions against our locking mechanisms. This stretches the legs of: - delete/put/mkcol's use of the if headers - the locked resources state management and then secondly - the depth headers etc... Setup. Client 1: OPEN Client 2: OPEN Client 1: MKCOL perldav_test Client 1: MKCOL perldav_test/subdir Test 1. We want to test a lock/unlock sequence. Client 1: LOCK perldav_test Client 1: UNLOCK perldav_test Test 2. Then a lock/put sequence Client 1: LOCK perldav_test Client 1: PUT perldav_test/subdir/file.txt Test 3. Then a lock/mkcol sequence (and again with another client) Client 2: MKCOL perldav_test/subdir2 (should fail as we don't own the lock) Client 1: MKCOL perldav_test/subdir3 (fails badly on the subsequent delete. not sure why) Test 4. Then a lock/lock sequence (should fail) Client 1: LOCK perldav_test/subdir (should fail, can't nest locks) Test 5. Then a lock/delete sequence (should work) Client 1: DELETE perldav_test Test 6. Then a delete/unlock sequence (should fail resource was delete) Client 1: UNLOCK perldav_test (should fail in client as no locks held after the delete). =cut # Setup my $dav1 = HTTP::DAV->new(); my $dav2 = HTTP::DAV->new(); $dav1->credentials( $user, $pass, $url ); $dav2->credentials( $user, $pass, $url ); do_test $dav1, $dav1->open( $url ), 1, "dav1->OPEN $url"; do_test $dav2, $dav2->open( $url ), 1, "dav2->OPEN $url"; do_test $dav1, $dav1->mkcol ($newdir), 1,"dav1->MKCOL $newdir"; do_test $dav1, $dav1->mkcol ("$newdir/subdir"), 1,"dav1->MKCOL $newdir/subdir"; # Test 1 do_test $dav1, $dav1->lock ($newdir), 1,"dav1->LOCK $newdir"; do_test $dav1, $dav1->unlock($newdir), 1,"dav1->UNLOCK $newdir"; # Test 2 do_test $dav1, $dav1->lock ($newdir), 1,"dav1->LOCK $newdir"; do_test $dav1, $dav1->put(\"Testdata","$newdir/subdir/file.txt"),1,"dav1->PUT $newdir/subdir/file.txt"; # Test 3 # For some reason mydocsonline allows this test to succeed!? # I don't need a lock token to create the following directory. Weird. do_test $dav2, $dav2->mkcol ("$newdir/subdir2"),0,"dav2->MKCOL $newdir/subdir2"; # Contentious activity with mod_dav # For some reason, I just can't get this # to work with my mod_dav. Works with Greg's though??? # Very very annoyed spent hours tracking it. I'll give # you a porsche if you can find out why it bugs out. do_test $dav1, $dav1->mkcol ("$newdir/subdir3"),1,"dav1->MKCOL $newdir/subdir3"; # Test 4 do_test $dav1, $dav1->lock ("$newdir/subdir"), 0,"dav1->LOCK $newdir/subdir"; # Test 5 do_test $dav1, $dav1->delete($newdir), 1,"dav1->DELETE $newdir"; # Test 6 do_test $dav1, $dav1->unlock($newdir), 0,"dav1->UNLOCK $newdir"; HTTP-DAV-0.50/t/3_put_get_delete.t0000644000175000017500000000221214703664237016045 0ustar cosimocosimo#!/usr/local/bin/perl -w use strict; use HTTP::DAV; use Test; use lib 't'; use TestDetails qw($test_user $test_pass $test_url do_test fail_tests test_callback); my $TESTS; $TESTS = 6; plan tests => $TESTS; fail_tests($TESTS) unless $test_url =~ /http/; my $dav = HTTP::DAV->new; HTTP::DAV::DebugLevel(3); $dav->credentials( $test_user,$test_pass,$test_url ); my $collection = $test_url; $collection=~ s#/$##g; # Remove trailing slash. We'll put it on. my $new_file = "$collection/dav_test_file.txt"; print "File: $new_file\n"; my $resource = $dav->new_resource( -uri => $new_file ); my $response; $response = $resource->put("DAV.pm test content "); if (! ok($response->is_success) ) { print $response->message() ."\n"; } $response = $resource->get(); if (! ok($response->is_success) ) { print $response->message() ."\n"; } my $content1 = $resource->get_content(); my $content2 = $resource->get_content_ref(); ok( $content1, '/\w/'); ok( $$content2, '/\w/'); print $content1 ."\n"; print $$content2 ."\n"; ok( $content1 eq $$content2 ); $response = $resource->delete(); if (! ok($response->is_success) ) { print $response->message() ."\n"; } HTTP-DAV-0.50/README0000644000175000017500000001314314703665637013074 0ustar cosimocosimoPerlDAV -- A WebDAV client library for Perl5 PerlDAV is a Perl library for modifying content on webservers using the WebDAV protocol. Now you can LOCK, DELETE and PUT files and much more on a DAV-enabled webserver. The PerlDAV library consists of: * HTTP::DAV - an object-oriented Web-DAV client API. * dave - the DAV Explorer, an end-user Unix console program for interacting with WebDAV servers. dave looks and feels like a standard Unix ftp program. LATEST VERSION AND WHAT'S NEW See the included "Changes" file for the full changelog. INSTALLING HTTP::DAV The lazy way to install PerlDAV: $ cpan HTTP::DAV Or the normal way: Retrieve the latest copy from CPAN: https://metacpan.org/module/HTTP-DAV/ $ perl Makefile.PL # Creates the Makefile $ make # Runs the makefile $ make test # Optional (See Interopability below) $ make install # Installs dave and HTTP::DAV With this method you will first have to install the pre-requisites: LWP and XML::DOM, see "what are the prerequisites?". When you install PerlDAV, the HTTP::DAV library will be installed to your Perl library location (usually /usr/local/lib/perl5) "dave" will be installed to /usr/local/bin. This suits most people but you can modify this by using the INSTALLBIN flag: $ perl Makefile.PL INSTALLBIN="/home/user/bin" What Are The Prerequisites? * Perl 5.6.0+ * LWP (Have not tested lower than v5.48) * Scalar::Util (standard library from 5.8.0+) * XML::DOM (Have not tested lower than v1.26). Requires James Clark's expat library: * To access SSL urls you will need Crypt::SSLeay and/or IO::Socket::SSL. Optional Prerequisites. * Crypt::SSLeay if you'd like to use https. Crypt::SSLeay requires the openssl library as well. See Crypt::SSLeay's excellent install instructions for how to get https support into LWP (and hence HTTP::DAV). I've tested HTTP::DAV and Crypt::SSLeay against Apache/mod_dav with the mod_ssl plugin. Works seamlessly. * MD5 if you'd like to use LWP's Digest authentication. To get the latest versions of these prerequisite modules you can simply type this at the command prompt: $ then: $ perl -MCPAN -e shell cpan> install LWP cpan> install XML::DOM or if you just 'install HTTP::DAV' the lovely CPAN module should just magically install all of the prerequisites for you (you'll still need to manually instal expat though). What Systems Does It Work With? HTTP::DAV and dave are pure perl so only needs Perl 5.6.0 (or later). PerlDAV is known to run under Windows (although I haven't tried it myself) and should run under all Unix systems. WHERE ARE THE MANUALS? Once you've installed PerlDAV, you can type: $ perldoc HTTP::DAV $ man dave GETTING HELP The perldav mailing list There is a mailing list for PerlDAV for use by Developers and Users. Please see http://mailman.webdav.org/mailman/listinfo/perldav THE TEST SUITE & INTEROPERABILITY You will notice that the standard "make test" command invokes a large set of test procedures, but most will be skipped. This standard test is sufficient to give you a good indication that PerlDAV has installed properly. If you'd like to see how well PerlDAV performs against a particular DAV server then you should set the URL (and username,password) in the test suite t/TestDetails.pm. Then you can run "make test" again and watch the test suite perform as many operations as the server supports. Please note that the test suite will perofrm well over 200 HTTP requests to your server. I have tested PerlDAV against IIS5, mod_dav and the Xythos WFS. Out of the box, the test suite should NOT fail on any tests. The test suite is the best way to test interopability between PerlDAV and other servers. I'd really like help with testing PerlDAV's interoperability. So if one or more tests fail against your server please follow the following steps: * Determine which test is failing. * set DEBUG to on: edit the script and change HTTP::DAV::DebugLevel(0) to (3). * Delete previous server output: rm /tmp/perldav_debug.txt * Run that single test again: $make test TEST_FILES=t/thetest.t TEST_VERBOSE=1 > testoutput.log * Then gzip and mail me both testoutput.log and /tmp/perldav_debug.txt with details of the test environment. (My email is at the bottom) Alternatively, you could have a shot at solving the bug yourself :) BUGS and TODO Need to convert XML::DOM to a DOM Level 2 compliant parser like XML::Gdome. See TODO for what is left to be done. AUTHOR AND COPYRIGHT This module is Copyright (C) 2001 by Patrick Collins G03 Gloucester Place, Kensington Sydney, Australia mailto:pcollins@cpan.org Phone: +61 2 9663 4916 All rights reserved. MAINTAINER The current maintainer of HTTP-DAV is Cosimo Streppone for Kahoot!, and previously for Opera Software ASA. You can contact me at "cosimo@cpan.org". GITHUB REPOSITORY The official repository for HTTP-DAV is now on Github: https://github.com/cosimo/perl5-http-dav LICENSE You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. $Id$ ** This file was automatically generated from ** ** doc/Changes.pod. To edit it, see there. ** HTTP-DAV-0.50/TODO0000644000175000017500000000557214703665637012713 0ustar cosimocosimoTODO dave - globs on lock(),unlock(),steal(),options()?,move(),copy(),propfind(),proppatch() (and set/unset). - rework ls to use globs. - multistatus responses don't come through nicely. HTTP::DAV - Rework the file transfer code to avoid slurping complete files in memory and read through a fixed size buffer, to avoid memory hogs or crashes when transferring huge files. - LWP doesn't allow callback on upload, only download. This means we can't do progress indicators on "PUT". How to do it? Could patch LWP? Specialise LWP::UserAgent? Ugh. - doco globs in DAV.pm - fix get references - _put calls propfind on every call throughout a recursive _put(). need to adjust this so that it does it only once, in put(). After the first time, we should be able to KNOW whether it is a collection or not instead of having to propfind to find out becasue in theory WE were the ones who put the file there. - finish "source" property in DAV::Resource.pm - redo POD Resource.pm - setup_if_headers need to get just Rsource's locks not all RL's locks. - discovery still isn't resetting locks properly ???? - DAV.pm as_string needs working resource - finish lock (bug against mod_dav somewhere) - mod t/* for IIS 5 lock and proppatch deficiencies. - how to we handle degradation for incomplete servers in test suite (IIS)? - mod_dav has a very strange bug with lock-null resources. The following combination of commands makes it weird out: $ mkdir dir1 $ lock dir1 $ lock dir2 (this is a lock null) $ move dir1 dir2 Now, the spec says that dir2 should now be the copy of dir1 and it should be locked. However, mod_dav has an unlocked dir2. Even worse, if you delete dir2, there is a shadowed lock-null resource called dir2 sitting behind the scenes. Bad. Wishlist functions - testing against Zope - dave:implement netrc? - dave:tab completion? history? - dave:implement more advanced command-line interaction - dave:copy/move should allow the user to set 'depth' and 'overwrite' - redo auth as a callback? If so, needs 2 functions, get and success. Wishlist projects - Namespaces are not currently supported. I munge around them since they are not supported in DOM1 which is what XML::DOM uses. - Rework Response.pm now that LWP::Status supports the status codes. - support for LWPng which is fully HTTP/1.1 compliant. - DAV Bindings - DAV Redirects Reference - DAV Ordered collections - DAV DASL support - DAV Delta-V - DAV ACL's $Id$ ** This file was automatically generated from ** ** doc/TODO.pod. To edit it, see there. ** HTTP-DAV-0.50/bin/0000755000175000017500000000000014703666621012754 5ustar cosimocosimoHTTP-DAV-0.50/bin/dist0000755000175000017500000000257514703665632013657 0ustar cosimocosimo#!/bin/sh # $Id$ URL="http://www.webdav.org/perldav" HTML="doc/html" echo "Updating \"The latest version is: ...\" string in doc/README.pod" perl -pi -e 'BEGIN{require "./lib/HTTP/DAV.pm";}; s/(latest version is:\s*v).*/$1$HTTP::DAV::VERSION (released $HTTP::DAV::VERSION_DATE)/gi;' doc/README.pod echo "Making html docs" pod2html="pod2html --noindex --htmldir $HTML" $pod2html --infile=doc/TODO.pod --css=perldav.css --title="TODO" --outfile=$HTML/TODO.html $pod2html --infile=doc/README.pod --css=perldav.css --title="PerlDAV" --outfile=$HTML/index.html $pod2html --infile=lib/HTTP/DAV/Changes.pod --css=perldav.css --title="Changes" --outfile=$HTML/Changes.html $pod2html --infile=lib/HTTP/DAV.pm --css=perldav_plain.css --outfile=$HTML/HTTP-DAV.html $pod2html --infile=bin/dave --css=$URL/perldav_plain.css --outfile=$HTML/dave.html #$pod2html --infile=doc/HISTORY.pod --css=$URL/perldav.css --outfile=$HTML/HISTORY.html echo "Removing extraneous

's from HTML" perl -pi -e 's#^

$##; s#^

$##; ' $HTML/*.html echo "Making text docs" pod2text doc/README.pod > README pod2text doc/TODO.pod > TODO pod2text lib/HTTP/DAV/Changes.pod > Changes # Needs to copy in the empty version of the TestDetails.pm module #cp HTTP-DAV-... doc/html echo "Copying TestDetails.pm.empty to TestDetails.pm" cp t/TestDetails.pm t/TestDetails.pm.bak cp t/TestDetails.pm.empty t/TestDetails.pm HTTP-DAV-0.50/bin/dave0000755000175000017500000006661314703664237013636 0ustar cosimocosimo#!/usr/bin/perl =pod =head1 NAME dave - DAV Explorer =head1 SYNOPSIS dave [OPTIONS] URL e.g. $ dave -u pcollins -p mypass www.host.org/dav_dir/ ... dave> get file.txt Use C to get help on options. Use C for the whole manpage. =cut use strict; use vars '$AUTOLOAD'; use AutoLoader; use Cwd; use Getopt::Long; use HTTP::DAV; use Pod::Usage; use Term::ReadLine; use Text::ParseWords; use Time::Local; use URI::file; my $VERSION = "2.01"; my $TMP_DIR = "/tmp"; my $LOCK_OWNER = "dave/v$VERSION (pid $$)"; my $USER_AGENT = "dave/v$VERSION (perldav)"; ## Setup/parse options ## Parse options and print usage if there is a syntax error. ## Note pod2usage comes from Pod::Usage my $opt_h=0; my $opt_man=0; my $user=''; my $pass=''; my $debug=0; GetOptions( 'help|?' => \$opt_h, 'man|?' => \$opt_man, 'debug:i' => \$debug, 'u|username=s' => \$user, 'p|password=s' => \$pass, 'tmpdir:s' => \$TMP_DIR, ) or Pod::Usage::pod2usage(2); # Basic sanity check for /tmp dir if (! $TMP_DIR or ! -d $TMP_DIR or ! -w $TMP_DIR) { die "Can't write into temp dir '$TMP_DIR': $!\n"; } ## Setup the Terminal my $prompt = "dave> "; my $term = Term::ReadLine->new('DAV Terminal'); $term->ornaments(0); # Catch ^C my $OUT = $term->OUT || *STDOUT; $SIG{INT} = sub { print $OUT "\nType q, bye or quit\n$prompt"; }; ## Setup the HTTP::DAV client my $useragent = DAVE::UserAgent->new(); $useragent->agent($USER_AGENT); my $gdc = HTTP::DAV->new(-useragent=>$useragent); HTTP::DAV::DebugLevel($debug); ## Setup the help system my $help = Pod2HelpParser->new(); $help->parse_from_filehandle(\*DATA); ## Setup the valid commands and synonyms my @valid_commands = qw( cd cat copy delete edit get help lcd lls ls lpwd lock mkcol move open options propfind put pwd quit set sh showlocks steal unlock unset ); my %command_synonyms = qw( ! sh ? help q quit bye quit h help dir ls mkdir mkcol rmdir delete rm delete cp copy mv move ); # Make a full populated hash from those given above. # %commands = ( # quit => quit, # q => quit, # help => help, # ? => help, my %commands; foreach my $command (@valid_commands) { $commands{$command} = $command; } # Invert the command_synonyms for easy lookup. foreach my $synonym (keys %command_synonyms ) { $commands{$synonym} = $command_synonyms{$synonym}; } ########################################################################### # MAIN pod2usage(-verbose => 1) if ($opt_h); pod2usage(-verbose => 2) if ($opt_man); # Barf if more than one URL if (@ARGV > 1) { pod2usage( -message => "$0: You must only specify one URL.\n") } print $OUT <credentials( -user=>$user, -pass=>$pass, -url=>$url ); } &command_open($url) if ($url ); ###################################################################### # WHILE dave> command my $line; while ( defined ($line = $term->readline($prompt)) ) { # Hack. Put a space between the ! shellout command and the next arg $line =~ s/^([!])/$1 /g; # Parse the user's typed command and return a parsed list of words. my @args = &shellwords($line); # Remove empty elements from the list @args = grep( ! /^\s*$/,@args); # If the user has entered nothing then back to while # loop and throw another command prompt. next if ( ! @args ); # Get the first argument. It should be the command. my $command = shift @args; # Check the validity of the command in our lookup. if ( &is_valid_command($command) ) { # This is so we can do the ref'ed function call no strict 'refs'; $command = &get_command($command); print $OUT "Valid Command: \"$command\"\n" if $HTTP::DAV::DEBUG>2; # Call the command. e.g. &command_put(@args) my $function_name = "command_" . $command; my $return_code = &$function_name(@args); } else { print $OUT "Unrecognised command. Try 'help or h' for a list of commands.\n"; } } ###################################################################### # Command implementations # This is a simple "print message" (pm) routine. # Keeps things neat. sub pm { print $OUT "** $_[0] **\n"; } sub command_cd { $gdc->cwd (@_); pm($gdc->message()) } sub command_copy { $gdc->copy (@_); pm($gdc->message()) } sub command_delete { $gdc->delete(-url=> $_[0], -callback=>\&cb); pm($gdc->message()); } sub command_mkcol { $gdc->mkcol (@_); pm($gdc->message()) } sub command_move { $gdc->move (@_); pm($gdc->message()) } sub command_open { $gdc->open (@_); pm($gdc->message()) } sub command_steal { $gdc->steal (@_); pm($gdc->message()) } sub command_unlock { $gdc->unlock (@_); pm($gdc->message()) } sub command_set { my ($url,$pn,$pv,$ns) = @_; $gdc->set_prop (-url=>$url, -namespace=>$ns, -propname=>$pn, -propvalue=>$pv); pm($gdc->message()) } sub command_unset { my ($url,$pn,$ns) = @_; $gdc->unset_prop (-url=>$url, -namespace=>$ns, -propname=>$pn); pm($gdc->message()) } sub command_lock { my ($url,$timeout,$depth ) = @_; $gdc->lock (-url=>$url, -timeout=>$timeout, -depth=>$depth, -owner=>$LOCK_OWNER); pm($gdc->message()) } sub command_showlocks { my $rl = $gdc->get_lockedresourcelist(); if ($rl) { my $l = $rl->showlocks; print $OUT ($l ne "") ? $l : "No locks\n"; } } sub command_cat { my ($url) = @_; $gdc->get(-url=>$url, -callback=>\&cat_callback,-chunk=>128); } sub command_edit { my $remote_file = shift; my $EDITOR= $ENV{DAV_EDITOR} || $ENV{EDITOR} || 'vi'; my $local_file = HTTP::DAV::_tempfile('dave', $TMP_DIR); my $resource = $gdc->propfind($remote_file); if ( $resource && $resource->is_collection() ) { pm("Can't edit collections"); return; } my $locked=0; # Try a lock with a 10h timeout first. # If that doesn't work then try it without a timeout. if ( $gdc->lock(-url=>$remote_file, -timeout=>"10h",-owner=>$LOCK_OWNER ) ) { $locked=1; pm( "Locked with 10 hour timeout" ); } elsif ( $gdc->lock(-url=>$remote_file, -owner=>$LOCK_OWNER) ) { $locked=1; pm( "Locked with infinite timeout" ); } else { my $resp = $gdc->get_last_response(); if ($resp->messages =~ /Locked/ ) { pm("$remote_file is locked. Can't edit."); return; } else { pm("Couldn't lock $remote_file for editing (" . $gdc->message . ")" ); } } if ( $gdc->get($remote_file,$local_file) ) { pm( $gdc->message()); pm("Using $EDITOR to edit $local_file"); my $file_date_at_start = (stat($local_file))[9]; sleep 2; system("$EDITOR $local_file") == 0 || pm("$EDITOR $local_file failed: $!"); my $file_date_at_end = (stat($local_file))[9]; if ( $file_date_at_start eq $file_date_at_end ) { pm ("File unchanged"); } else { $gdc->put($local_file,$remote_file); pm( $gdc->message()); } unlink $local_file || pm("Couldn't remove $local_file: $!"); } else { pm( $gdc->message()); } if ($locked) { $gdc->unlock($remote_file); pm( $gdc->message()); } } sub command_get { my ($remote,$local) = @_; $local ||= "."; $gdc->get(-url=>$remote, -to =>$local, -callback=>\&cb ); } sub command_put { my ($local,$remote) = @_; $remote ||= "."; $gdc->put(-local=>$local, -url =>$remote, -callback=>\&cb ); } # PWD sub command_pwd { my $uri = $gdc->get_workingurl(); if ($uri) { print $OUT "$uri\n"; return 1; } else { pm("Not connected. Type \"help open\""); return 0; } } # OPTIONS sub command_options{ my $options = $gdc->options(@_); print $OUT "$options\n" if ($options); pm($gdc->message); return $options; } # HELP sub command_help { my (@args) = @_; # If they just typed help with no arguments then give them generic help if ( $#args < 0 ) { print $OUT "Type \"help \" for more detail:\n"; foreach my $i (sort @valid_commands ) { my($sect,$title,$first_line,$body) = $help->get_help($i); if ($sect) { printf $OUT (" %-10s%s\n",$i,$first_line); } else { printf $OUT (" %-10s%s\n",$i,"no help"); } } print $OUT "\n"; } # If they type "help " then look for help on . else { my $help_topic = shift @args; my $format = shift @args || "verbose"; my ($sect,$title,$first_line,$help_body) = $help->get_help( &get_command($help_topic) || $help_topic ); my $help_text; if ( defined $sect && $sect ne "" ) { if ($format eq "verbose" ) { $help_body =~ s/\n/\n /gs; $help_text = "\n $title\n $help_body\n"; } else { $help_text = "\n $sect - $first_line\n"; } } else { $help_text = "\nNo help for \"$help_topic\"\n"; } print $OUT $help_text; } } # LCD sub command_lcd { my (@args) = @_; my $args = join(' ', @args) || ""; chdir($args); } # LLS sub command_lls { my (@args) = @_; my $args = join(' ', @args) || ""; system("ls @args"); } # LPWD sub command_lpwd { system("pwd"); } # LS (client) sub command_ls { my $resource = $gdc->propfind(@_); if ($resource) { if ($resource->is_collection) { print $OUT $resource->get_property('short_ls'); } else { print $OUT $resource->get_property('long_ls'); } } else { pm($gdc->message); } } sub command_propfind { my $resource = $gdc->propfind(@_); if ($resource) { print $OUT $resource->get_property('long_ls'); } else { pm($gdc->message); } } # QUIT sub command_quit { my (@args) = @_; print $OUT "Bye\n"; exit; } # SH (!) sub command_sh { my (@args) = @_; my $args = join(' ', @args) || ""; system("$args"); } sub AUTOLOAD { my $sub = $AUTOLOAD || ""; #my @args = @{$_[0]} || (); die "Fatal Error. No function defined $sub ?!\n"; } ###################################################################### # CALLBACKS for cat, get and put { my $in_transfer=0; sub cat_callback { my($status,$mesg,$url,$so_far,$length,$data) = @_; $|=1; if ($status == 1) { print "\n" if ($in_transfer); print "**$mesg (success)\n"; $in_transfer=0; } if ($status == 0) { print "**$mesg\n"; $in_transfer=0; } if ($status == -1) { print $OUT $data; $in_transfer++; } } # Used for get and put. put doesn't support chunking though. sub cb { my($status,$mesg,$url,$so_far,$length,$data) = @_; $|=1; if ($status == 1) { print "\n" if ($in_transfer); print " $mesg (success)\n"; $in_transfer=0; } if ($status == 0) { print "**$mesg\n"; $in_transfer=0; } if ($status == -1) { if (!$in_transfer++) { print " Transferring $url ($length bytes):\n"; } my $width = 60; if ($length>0) { my $num = int($so_far/$length * $width); my $space = $width-$num; print " [" . "#"x$num . " "x$space . "]"; } print " $so_far bytes\r"; } } } ########################################################################### sub is_valid_command { my ($command) = @_; $command = lc($command); return 1 if defined $commands{$command}; } sub get_command { my ($command) = @_; $command = lc($command); return $commands{$command}; } BEGIN { # We make our own specialization of HTTP::DAV::UserAgent (which in turn is already a specialisation of LWP::UserAgent). # This user agent is able to: # - interact with the user on the command line to get user/pass's # - allow the user to try 3 times before failing. { package DAVE::UserAgent; use vars qw(@ISA); @ISA = qw(HTTP::DAV::UserAgent); sub new { my $self = HTTP::DAV::UserAgent::new(@_); #$self->agent("DAVE/v$VERSION"); $self->{_failed_logins} = (); return $self; } sub request { my($self) = shift; my $resp = $self->SUPER::request(@_); # Only if we did not get a 401 back from the server # do we go and # commit the user's details to memory. $self->_commit_credentials() if ($resp->code() != 401); return $resp; } sub _set_credentials {shift->{_temp_credentials} = \@_; } sub _commit_credentials { my ($self)=@_; if (defined $self->{_temp_credentials} ) { $self->credentials(@{$self->{_temp_credentials}}); $self->{_temp_credentials} = undef; } } sub get_basic_credentials { my($self, $realm, $url) = @_; my $userpass; # First, try to get the details from our memory. my @mem_userpass = $self->SUPER::get_basic_credentials($realm,$url); return @mem_userpass if @mem_userpass; if (-t) { my $netloc = $url->host_port; if ($self->{_failed_logins}->{$realm . $netloc}++ > 3) { return (undef,undef) } print "\nEnter username for $realm at $netloc: "; my $user = ; chomp($user); return (undef, undef) unless length $user; print "Password: "; system("stty -echo"); my $password = ; system("stty echo"); print "\n"; # because we disabled echo chomp($password); $self->_set_credentials($netloc, $realm,$user,$password); #print "Returning $user, $password\n"; return ($user, $password); } else { return (undef, undef) } } } ###################################################################### # Setup our help system with this nifty Pod::Parser from the # Pod at the end of this script. # { package Pod2HelpParser; use vars qw(@ISA); use Pod::Parser; @ISA = qw(Pod::Parser); ###### # Pod2HelpParser - public help access methods. # # get_help() will return from the pod any items # that start with $command as help # # For instance: # my($sect,$title,$terse,$long) = $parser->get_help("open"); sub get_help { my ($self,$command) = @_; foreach my $sect (keys %{$self->{_help_text}} ) { if ( $sect =~ /^$command\b/i ) { my $title = $self->{_title} {$sect} ||""; my $first_line = $self->{_first_line}{$sect} ||""; my $help_text = $self->{_help_text} {$sect} ||""; $help_text=~ s/\n*$//gs; return ($sect,$title,$first_line,$help_text); } } return (); } sub get_help_list { my ($self) = @_; my @return; foreach my $sect (keys %{$self->{_help_text}} ) { next if $sect eq "OTHER"; push (@return,$sect); } return @return; } ###### # INIT # These methods are all overriden from Pod::Parser. # They are effectively call-backs to handle pod. # Specifically, we're building a hash to provide convenient # access to the pod data as help information. sub command { my ($parser, $command, $paragraph, $line_num) = @_; my $title = $parser->interpolate($paragraph, $line_num); # Remove extraneous whitespace $title =~ s/^[\s\n]*(.*?)[\s\n]*$/$1/gis; my $section = $title; $section =~ s/^\s*(.+?)\s.*$/$1/; $section= ($command eq "item") ? $section : "OTHER"; $parser->{_last_section} = $section; $parser->{_help_text}{$section} = ""; $parser->{_title}{$section} = $title; } # Overrriden from Pod::Parser - interprets section text sub verbatim { my ($parser, $paragraph, $line_num) = @_; my $expansion = $parser->interpolate($paragraph, $line_num); # Get the first line my $first_line = $expansion; $first_line =~ s/^(.*?)\n.*/$1/gis; my $section_head = $parser->_get_last_section; $parser->{_help_text} {$section_head} .= $expansion; if (!defined $parser->{_first_line}{$section_head} ) { $parser->{_first_line}{$section_head} = $first_line; } } # Overrriden from Pod::Parser - do nothing with normal body text sub textblock { shift->verbatim(@_); } sub interior_sequence { return $_[2]; } sub _get_last_section { $_[0]->{_last_section}; } } } # END BEGIN ###################################################################### # PERLDOC __END__ =head1 DESCRIPTION dave is a powerful command-line program for interacting with WebDAV-enabled webservers. With dave you can: =over 4 =item * get and put files =item * make directories on a remote webserver =item * remove files and directories from a remote webserver =item * edit a file on the webserver with a single command =item * recursively get a remote directory =item * recursively put a local directory =item * lock and unlock remote files and directories =item * securely transfer over https =item * authenticate using the safer Digest authentication =back Dave is a part of the PerlDAV project (http://www.webdav.org/perldav/) and is built on top of the HTTP::DAV perl API. If you would like to script webdav interactions in Perl checkout the HTTP::DAV API as it's commands are the basis for dave's. =head1 OPTIONS =over 4 =item C<-debug N> Sets the debug level to N. 0=none. 3=noisy. =item C<-h> Prints basic help and options. =item C<-man> Prints the full manual (equivalent to perldoc dave). You will need to use a pager like C or C. e.g. dave -man |less =item C<< -p >> Sets the password to be used for the URL. You must also supply a user. See C<-u>. =item C<< -u >> Sets the username to be used for the URL. You must also supply a pass. See C<-p>. =item C<-tmpdir /some/path> Create temporary files in C instead of the default C. =back =head1 COMMANDS =over 4 =item B changes directories dave> open host.org/dav_dir/ dave> cd dir1 dave> cd ../dir2 =item B shows the contents of a remote file dave> open host.org/dav_dir/ dave> cat index.html Note: you cannot cat a directory (collection). =item B =item B copies one remote resource to another dave> open host.org/dav_dir/ Create a copy of dir1/ as dav2/ dave> cp dir1 dav2 Create a copy of dir1/file.txt as dav2/file.txt dave> cd dir1 dave> copy file.txt ../dav2 Create a copy of file.txt as ../dav2/new_file.txt dave> copy file.txt dav2/new_file.txt Aliases: cp =item B =item B =item B deletes a remote resource dave> open host.org/dav_dir/ dave> delete index.html dave> rmdir ./dir1 dave> delete /dav_dir/dir2/ dave> delete /dav_dir/*.html This command recursively deletes directories. BE CAREFUL :) This command supported wildcards (globbing). See get. Aliases: rm, rmdir =item B edits the contents of a remote file dave> open host.org/dav_dir/ dave> edit index.html Edit is equivalent to the following sequence of commands: LOCK index.html (if allowed) GET index.html /tmp/dave.perldav.421341234124 sh $EDITOR /tmp/dave.perldav.421341234124 PUT index.html (if modified) UNLOCK index.html (if locked) Where $EDITOR is determined from the environment variables DAV_EDITOR or EDITOR. If DAV_EDITOR is set, it will use that, otherwise it will use EDITOR. If neither variables are set, then "vi" will be used. Notes: The lock only lasts for 10 hours. You cannot edit a directory (collection). The temporary save directory is editable by editing dave and changing TMP_DIR =item B downloads the file or directory at URL If FILE is not specified it will be saved to your current working directory using the same name as the remote name. dave> open host.org/dav_dir/ Recursively get remote my_dir/ to . dave> get my_dir/ Recursively get remote my_dir/ to /tmp/my_dir/ dave> get my_dir /tmp Get remote my_dir/index.html to /tmp/index.html dave> get /dav_dir/my_dir/index.html /tmp Get remote index.html to /tmp/index1.html dave> get index.html /tmp/index1.html Use globs and save to /tmp dave> get index* /tmp # Gets index*.html, index*.txt, etc. dave> get index*.html /tmp/index1.html # Gets index*.html dave> get index[12].htm? # Gets file1 and file2, .htm and .html =item B =item B =item B prints list of commands or help for CMD dave> ? dave> help get Aliases: ?, h =item B changes local directory dave> lcd /tmp =item B lists local directory contents dave> lcd /tmp dave> lls dave> lls /home This command simply execs the local ls command and is equivalent to "!ls" =item B prints the current working directory, locally This command simply execs the local ls command and is equivalent to "!pwd" =item B =item B lists remote directory contents or file props dave> ls Listing of http://host.org/dav_dir/ ./ Aug 29 02:26 mtx_0.04.tar.gz 52640 Aug 11 11:45 index.html 4580 Aug 11 11:45 index0.04.html 4936 Nov 11 2000 mydir/ Aug 19 21:14 , dave> ls index.html URL: http://www.webdav.org/perldav/index.html Content-type: text/html Creation date: Sun Aug 12 21:58:02 2001 Last modified: Size: 4580 bytes Locks supported: write/exclusive write/shared Locks: Use propfind to get a similar printout of a collection (directory). Aliases: dir =item B locks a resource Without a URL you will lock the current remote collection. TIMEOUT can be any of the following formats: 30s 30 seconds from now 10m ten minutes from now 1h one hour from now 1d tomorrow 3M in three months 10y in ten years time 2000-02-31 00:40:33 2000-02-31 Default is an infinite timeout See perldoc C for more information about timeouts. DEPTH can be either "0" or "infinity" (default) Seeting the lock Scope and Type is not currently implemented. Let me know if you need it as it shouldn't be too much effort. =item B =item B make a remote collection (directory) dave> open host.org/dav_dir/ dave> mkcol new_dir dave> mkdir /dav_dir/new_dir Aliases: mkdir =item B =item B moves a remote resource to another dave> open host.org/dav_dir/ Move dir1/ to dav2/ dave> move dir1 dav2 Move file dir2/file.txt to ../file.txt dave> cd dir2 dave> move file.txt .. Move file.txt to dav2/new_file.txt dave> move file.txt dav2/new_file.txt Aliases: mv =item B connects to the WebDAV-enabled server at URL dave> open host.org/dav_dir/ Note that if authorization details are required you will be prompted for them. https and Digest authorization are not currently supported. Please let me know if you need it. =item B show the HTTP methods allowed for a URL dave> options index.html OPTIONS, GET, HEAD, POST, DELETE, TRACE, PROPFIND, PROPPATCH, COPY, MOVE, LOCK, UNLOCK Note that Microsoft's IIS does not support LOCK on collections (directories). Nor does it support PROPPATCH. =item B show the properties of a resource dave> propfind test URL: http://host.org/dav_dir/test/ Content-type: httpd/unix-directory Creation date: Wed Aug 29 00:36:42 2001 Last modified: Size: bytes Locks supported: write/exclusive write/shared Locks: Using ls will get you the same printout if you ls a file. But ls'ing a collection will show you the collections contents. =item B uploads a local file or directory to URL or the currently opened location. If URL is an existing collection then the dir/file will be copied INTO that collection. dave> open host.org/dav_dir/ Recursively put local my_dir/ to host.org/dav_dir/my_dir/: dave> put my_dir/ Put local index.html to host.org/dav_dir/index1.html: dave> put /tmp/index.html index1.html Put * to remote directory dave> put * Put index[12].htm? to remote directory /dav_dir (/dav_dir must exist) dave> put index[12].htm? /dav_dir Put index[1234].htm? to remote directory /dav_dir (/dav_dir must exist) dave> put index[1-4].htm? /dav_dir Glob types supported are, * (matches any characters), ? (matches any one character), [...] (matches any characters in the set ...). =item B prints the currently opened URL (working directory) dave> open host.org/dav_dir/ dave> cd new_dir/ dave> pwd http://host.org/dav_dir/new_dir/ =item B =item B =item B exits dave Note that dave does not unlock any locks created during your session. Aliases: q, quit =item B sets a custom property on a resource dave> set file.txt author "Patrick Collins" dave> set file.txt author "Patrick Collins" "mynamespace" The NAMESPACE by default is "DAV:". =item B =item B executes a local command (alias !) dave> sh cat localfile dave> !gzip localfile.gz dave> ! "cat localfile | less" Aliases: ! =item B show my locks on a resource Shows any locked resources that you've locked in this session. See C if you'd like to see anyone's locks held against a particular resource. =item B remove ANY locks on a resource Useful if you accidentally forgot to unlock a resource from a previous session or if you think that somebody has forgotten to unlock a resource. =item B unlocks a resource Note that unlock will only unlock locks that you have created. Use steal if you want to forcefully unlock somebody else's lock. =item B unsets a property from a resource dave> unset file.txt author dave> unset file.txt author "mynamespace" The NAMESPACE by default is "DAV:". =back =head1 GETTING HELP The perldav mailing list There is a mailing list for PerlDAV and dave for use by Developers and Users. Please see http://mailman.webdav.org/mailman/listinfo/perldav =head1 INSTALLATION dave is installed to /usr/local/bin by default when you install the PerlDAV library. See http://www.webdav.org/perldav/ for installation details of PerlDAV. =head1 WHAT PLATFORMS WILL IT WORK ON? dave is pure perl so only needs Perl5.003 (or later) and the C library to be installed. I have not ported dave to Windows but would like somebody to have a shot at it. =head1 SEE ALSO The C perl API at http://www.webdav.org/perldav/ or by typing "perldoc HTTP::DAV" on your command line. =head1 AUTHOR AND COPYRIGHT This module is Copyright (C) 2001 by Patrick Collins G03 Gloucester Place, Kensington Sydney, Australia Email: pcollins@cpan.org Phone: +61 2 9663 4916 All rights reserved. You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =head1 MAINTAINER Cosimo Streppone, Ecosimo@cpan.orgE =cut HTTP-DAV-0.50/doc/0000755000175000017500000000000014703666621012751 5ustar cosimocosimoHTTP-DAV-0.50/doc/html/0000755000175000017500000000000014703666621013715 5ustar cosimocosimoHTTP-DAV-0.50/doc/html/HTTP-DAV.html0000644000175000017500000012302414703665637016002 0ustar cosimocosimo HTTP::DAV - A WebDAV client library for Perl5

NAME

HTTP::DAV - A WebDAV client library for Perl5

SYNOPSIS

   # DAV script that connects to a webserver, safely makes 
   # a new directory and uploads all html files in 
   # the /tmp directory.

   use HTTP::DAV;
  
   $d = HTTP::DAV->new();
   $url = "http://host.org:8080/dav/";
 
   $d->credentials(
      -user  => "pcollins",
      -pass  => "mypass", 
      -url   => $url,
      -realm => "DAV Realm"
   );
 
   $d->open( -url => $url )
      or die("Couldn't open $url: " .$d->message . "\n");
 
   # Make a null lock on newdir
   $d->lock( -url => "$url/newdir", -timeout => "10m" ) 
      or die "Won't put unless I can lock for 10 minutes\n";

   # Make a new directory
   $d->mkcol( -url => "$url/newdir" )
      or die "Couldn't make newdir at $url\n";
  
   # Upload multiple files to newdir.
   if ( $d->put( -local => "/tmp/*.html", -url => $url ) ) {
      print "successfully uploaded multiple files to $url\n";
   } else {
      print "put failed: " . $d->message . "\n";
   }
  
   $d->unlock( -url => $url );

DESCRIPTION

HTTP::DAV is a Perl API for interacting with and modifying content on webservers using the WebDAV protocol. Now you can LOCK, DELETE and PUT files and much more on a DAV-enabled webserver.

HTTP::DAV is part of the PerlDAV project hosted at http://www.webdav.org/perldav/ and has the following features:

  • Full RFC2518 method support. OPTIONS, TRACE, GET, HEAD, DELETE, PUT, COPY, MOVE, PROPFIND, PROPPATCH, LOCK, UNLOCK.

  • A fully object-oriented API.

  • Recursive GET and PUT for site backups and other scripted transfers.

  • Transparent lock handling when performing LOCK/COPY/UNLOCK sequences.

  • http and https support (https requires the Crypt::SSLeay library). See INSTALLATION.

  • Basic AND Digest authentication support (Digest auth requires the MD5 library). See INSTALLATION.

  • dave, a fully-functional ftp-style interface written on top of the HTTP::DAV API and bundled by default with the HTTP::DAV library. (If you've already installed HTTP::DAV, then dave will also have been installed (probably into /usr/local/bin). You can see it's man page by typing "perldoc dave" or going to http://www.webdav.org/perldav/dave/.

  • It is built on top of the popular LWP (Library for WWW access in Perl). This means that HTTP::DAV inherits proxy support, redirect handling, basic (and digest) authorization and many other HTTP operations. See LWP for more information.

  • Popular server support. HTTP::DAV has been tested against the following servers: mod_dav, IIS5, Xythos webfile server and mydocsonline. The library is growing an impressive interoperability suite which also serves as useful "sample scripts". See "make test" and t/*.

HTTP::DAV essentially has two API's, one which is accessed through this module directly (HTTP::DAV) and is a simple abstraction to the rest of the HTTP::DAV::* Classes. The other interface consists of the HTTP::DAV::* classes which if required allow you to get "down and dirty" with your DAV and HTTP interactions.

The methods provided in HTTP::DAV should do most of what you want. If, however, you need more control over the client's operations or need more info about the server's responses then you will need to understand the rest of the HTTP::DAV::* interfaces. A good place to start is with the HTTP::DAV::Resource and HTTP::DAV::Response documentation.

METHODS

METHOD CALLING: Named vs Unnamed parameters

You can pass parameters to HTTP::DAV methods in one of two ways: named or unnamed.

Named parameters provides for a simpler/easier to use interface. A named interface affords more readability and allows the developer to ignore a specific order on the parameters. (named parameters are also case insensitive)

Each argument name is preceded by a dash. Neither case nor order matters in the argument list. -url, -Url, and -URL are all acceptable. In fact, only the first argument needs to begin with a dash. If a dash is present in the first argument, HTTP::DAV assumes dashes for the subsequent ones.

Each method can also be called with unnamed parameters which often makes sense for methods with only one parameter. But the developer will need to ensure that the parameters are passed in the correct order (as listed in the docs).

Doc:     method( -url=>$url, [-depth=>$depth] )
Named:   $d->method( -url=>$url, -depth=>$d ); # VALID
Named:   $d->method( -Depth=>$d, -Url=>$url ); # VALID
Named:   $d->method( Depth=>$d,  Url=>$url );  # INVALID (needs -)
Named:   $d->method( -Arg2=>$val2 ); # INVALID, ARG1 is not optional
Unnamed: $d->method( $val1 );        # VALID
Unnamed: $d->method( $val2,$val1 );  # INVALID, ARG1 must come first.

IMPORTANT POINT!!!! If you specify a named parameter first but then forget for the second and third parameters, you WILL get weird things happen. E.g. this is bad:

$d->method( -url=>$url, $arg2, $arg3 ); # BAD BAD BAD

THINGS YOU NEED TO KNOW

In all of the methods specified in "PUBLIC METHODS" there are some common concepts you'll need to understand:

  • URLs represent an absolute or relative URI.

    -url=>"host.org/dav_dir/"  # Absolute
-url=>"/dav_dir/"          # Relative
-url=>"file.txt"           # Relative

    You can only use a relative URL if you have already "open"ed an absolute URL.

    The HTTP::DAV module now consistently uses the named parameter: URL. The lower-level HTTP::DAV::Resource interface inconsistently interchanges URL and URI. I'm working to resolve this, in the meantime, you'll just need to remember to use the right one by checking the documentation if you need to mix up your use of both interfaces.

  • GLOBS

    Some methods accept wildcards in the URL. A wildcard can be used to indicate that the command should perform the command on all Resources that match the wildcard. These wildcards are called GLOBS.

    The glob may contain the characters "*", "?" and the set operator "[...]" where ... contains multiple characters ([1t2]) or a range such ([1-5]). For the curious, the glob is converted to a regex and then matched: "*" to ".*", "?" to ".", and the [] is left untouched.

    It is important to note that globs only operate at the leaf-level. For instance "/my_dir/*/file.txt" is not a valid glob.

    If a glob matches no URL's the command will fail (which normally means returns 0).

    Globs are useful in conjunction with CALLBACKS to provide feedback as each operation completes.

    See the documentation for each method to determine whether it supports globbing.

    Globs are useful for interactive style applications (see the source code for dave as an example).

    Example globs:

    $dav1->delete(-url=>"/my_dir/file[1-3]");     # Matches file1, file2, file3
$dav1->delete(-url=>"/my_dir/file[1-3]*.txt");# Matches file1*.txt,file2*.txt,file3*.txt
$dav1->delete(-url=>"/my_dir/*/file.txt");    # Invalid. Can only match at leaf-level

  • CALLBACKS

    Callbacks are used by some methods (primarily get and put) to give the caller some insight as to how the operation is progressing. A callback allows you to define a subroutine as defined below and pass a reference (\&ref) to the method.

    The rationale behind the callback is that a recursive get/put or an operation against many files (using a glob) can actually take a long time to complete.

    Example callback:

    $d->get( -url=>$url, -to=>$to, -callback=>\&mycallback );

    Your callback function MUST accept arguments as follows: sub cat_callback { my($status,$mesg,$url,$so_far,$length,$data) = @_; ... }

    The status argument specifies whether the operation has succeeded (1), failed (0), or is in progress (-1).

    The mesg argument is a status message. The status message could contain any string and often contains useful error messages or success messages.

    The url the remote URL.

    The so_far, length - these parameters indicate how many bytes have been downloaded and how many we should expect. This is useful for doing "56% to go" style-gauges.

    The data parameter - is the actual data transferred. The cat command uses this to print the data to the screen. This value will be empty for put.

    See the source code of dave for a useful sample of how to setup a callback.

    Note that these arguments are NOT named parameters.

    All error messages set during a "multi-operation" request (for instance a recursive get/put) are also retrievable via the errors() function once the operation has completed. See ERROR HANDLING for more information.

PUBLIC METHODS

new(USERAGENT)
new(USERAGENT, HEADERS)

Creates a new HTTP::DAV client

$d = HTTP::DAV->new();

The -useragent parameter allows you to pass your own user agent object and expects an HTTP::DAV::UserAgent object. See the dave program for an advanced example of a custom UserAgent that interactively prompts the user for their username and password.

The -headers parameter allows you to specify a list of headers to be sent along with all requests. This can be either a hashref like:

{ "X-My-Header" => "value", ... }

or a HTTP::Headers object.

credentials(USER,PASS,[URL],[REALM])

sets authorization credentials for a URL and/or REALM.

When the client hits a protected resource it will check these credentials to see if either the URL or REALM match the authorization response.

Either URL or REALM must be provided.

returns no value

Example:

$d->credentials( -url=>'myhost.org:8080/test/',
                 -user=>'pcollins',
                 -pass=>'mypass');
DebugLevel($val)

sets the debug level to $val. 0=off 3=noisy.

$val default is 0.

returns no value.

When the value is greater than 1, the HTTP::DAV::Comms module will log all of the client<=>server interactions into /tmp/perldav_debug.txt.

DAV OPERATIONS

For all of the following operations, URL can be absolute (http://host.org/dav/) or relative (../dir2/). The only operation that requires an absolute URL is open.

copy(URL,DEST,[OVERWRITE],[DEPTH])

copies one remote resource to another

-url

is the remote resource you'd like to copy. Mandatory

-dest

is the remote target for the copy command. Mandatory

-overwrite

optionally indicates whether the server should fail if the target exists. Valid values are "T" and "F" (1 and 0 are synonymous). Default is T.

-depth

optionally indicates whether the server should do a recursive copy or not. Valid values are 0 and (1 or "infinity"). Default is "infinity" (1).

The return value is always 1 or 0 indicating success or failure.

Requires a working resource to be set before being called. See open.

Note: if either 'URL' or 'DEST' are locked by this dav client, then the lock headers will be taken care of automatically. If the either of the two URL's are locked by someone else, the server should reject the request.

copy examples:

$d->open(-url=>"host.org/dav_dir/");

Recursively copy dir1/ to dir2/

$d->copy(-url=>"dir1/", -dest=>"dir2/");

Non-recursively and non-forcefully copy dir1/ to dir2/

$d->copy(-url=>"dir1/", -dest=>"dir2/",-overwrite=>0,-depth=>0);

Create a copy of dir1/file.txt as dir2/file.txt

$d->cwd(-url=>"dir1/");
$d->copy("file.txt","../dir2");

Create a copy of file.txt as dir2/new_file.txt

$d->copy("file.txt","/dav_dir/dir2/new_file.txt")
cwd(URL)

changes the remote working directory.

This is synonymous to open except that the URL can be relative and may contain a glob (the first match in a glob will be used).

$d->open("host.org/dav_dir/dir1/");
$d->cwd("../dir2");
$d->cwd(-url=>"../dir1");

The return value is always 1 or 0 indicating success or failure.

Requires a working resource to be set before being called. See open.

You can not cwd to files, only collections (directories).

delete(URL)

deletes a remote resource.

$d->open("host.org/dav_dir/");
$d->delete("index.html");
$d->delete("./dir1");
$d->delete(-url=>"/dav_dir/dir2/file*",-callback=>\&mycallback);
-url

is the remote resource(s) you'd like to delete. It can be a file, directory or glob.

-callback is a reference to a callback function which will be called everytime a file is deleted. This is mainly useful when used in conjunction with GLOBS deletes. See callbacks

The return value is always 1 or 0 indicating success or failure.

Requires a working resource to be set before being called. See open.

This command will recursively delete directories. BE CAREFUL of uninitialised file variables in situation like this: $d->delete("$dir/$file"). This will trash your $dir if $file is not set.

get(URL,[TO],[CALLBACK])

downloads the file or directory at URL to the local location indicated by TO.

-url

is the remote resource you'd like to get. It can be a file or directory or a "glob".

-to

is where you'd like to put the remote resource. The -to parameter can be:

- a B<filename> indicating where to save the contents.

- a B<FileHandle reference>.

- a reference to a B<scalar object> into which the contents will be saved.

If the -url matches multiple files (via a glob or a directory download), then the get routine will return an error if you try to use a FileHandle reference or a scalar reference.

-callback

is a reference to a callback function which will be called everytime a file is completed downloading. The idea of the callback function is that some recursive get's can take a very long time and the user may require some visual feedback. See CALLBACKS for an examples and how to use a callback.

The return value of get is always 1 or 0 indicating whether the entire get sequence was a success or if there was ANY failures. For instance, in a recursive get, if the server couldn't open 1 of the 10 remote files, for whatever reason, then the return value will be 0. This is so that you can have your script call the errors() routine to handle error conditions.

Previous versions of HTTP::DAV allowed the return value to be the file contents if no -to attribute was supplied. This functionality is deprecated.

Requires a working resource to be set before being called. See open.

get examples:

$d->open("host.org/dav_dir/");

Recursively get remote my_dir/ to .

$d->get("my_dir/",".");

Recursively get remote my_dir/ to /tmp/my_dir/ calling &mycallback($success,$mesg) everytime a file operation is completed.

$d->get("my_dir","/tmp",\&mycallback);

Get remote my_dir/index.html to /tmp/index.html

$d->get(-url=>"/dav_dir/my_dir/index.html",-to=>"/tmp");

Get remote index.html to /tmp/index1.html

$d->get("index.html","/tmp/index1.html");

Get remote index.html to a filehandle

my $fh = new FileHandle;
$fh->open(">/tmp/index1.html");
$d->get("index.html",\$fh);

Get remote index.html as a scalar (into the string $file_contents):

my $file_contents;
$d->get("index.html",\$file_contents);

Get all of the files matching the globs file1* and file2*:

$d->get("file[12]*","/tmp");

Get all of the files matching the glob file?.html:

$d->get("file?.html","/tmp"); # downloads file1.html and file2.html but not file3.html or file1.txt

Invalid glob:

$d->get("/dav_dir/*/index.html","/tmp"); # Can not glob like this.
lock([URL],[OWNER],[DEPTH],[TIMEOUT],[SCOPE],[TYPE])

locks a resource. If URL is not specified, it will lock the current working resource (opened resource).

$d->lock( -url     => "index.html",
          -owner   => "Patrick Collins",
          -depth   => "infinity",
          -scope   => "exclusive",
          -type    => "write",
          -timeout => "10h" )

See HTTP::DAV::Resource lock() for details of the above parameters.

The return value is always 1 or 0 indicating success or failure.

Requires a working resource to be set before being called. See open.

When you lock a resource, the lock is held against the current HTTP::DAV object. In fact, the locks are held in a HTTP::DAV::ResourceList object. You can operate against all of the locks that you have created as follows:

## Print and unlock all locks that we own.
my $rl_obj = $d->get_lockedresourcelist();
foreach $resource ( $rl_obj->get_resources() ) {
    @locks = $resource->get_locks(-owned=>1);
    foreach $lock ( @locks ) { 
      print $resource->get_uri . "\n";
      print $lock->as_string . "\n";
    }
    ## Unlock them?
    $resource->unlock;
}

Typically, a simple $d->unlock($uri) will suffice.

lock example

$d->lock($uri, -timeout=>"1d");
...
$d->put("/tmp/index.html",$uri);
$d->unlock($uri);
mkcol(URL)

make a remote collection (directory)

The return value is always 1 or 0 indicating success or failure.

Requires a working resource to be set before being called. See open.

$d->open("host.org/dav_dir/");
$d->mkcol("new_dir");                  # Should succeed
$d->mkcol("/dav_dir/new_dir");         # Should succeed
$d->mkcol("/dav_dir/new_dir/xxx/yyy"); # Should fail
move(URL,DEST,[OVERWRITE],[DEPTH])

moves one remote resource to another

-url

is the remote resource you'd like to move. Mandatory

-dest

is the remote target for the move command. Mandatory

-overwrite

optionally indicates whether the server should fail if the target exists. Valid values are "T" and "F" (1 and 0 are synonymous). Default is T.

Requires a working resource to be set before being called. See open.

The return value is always 1 or 0 indicating success or failure.

Note: if either 'URL' or 'DEST' are locked by this dav client, then the lock headers will be taken care of automatically. If either of the two URL's are locked by someone else, the server should reject the request.

move examples:

$d->open(-url=>"host.org/dav_dir/");

move dir1/ to dir2/

$d->move(-url=>"dir1/", -dest=>"dir2/");

non-forcefully move dir1/ to dir2/

$d->move(-url=>"dir1/", -dest=>"dir2/",-overwrite=>0);

Move dir1/file.txt to dir2/file.txt

$d->cwd(-url=>"dir1/");
$d->move("file.txt","../dir2");

move file.txt to dir2/new_file.txt

$d->move("file.txt","/dav_dir/dir2/new_file.txt")
open(URL)

opens the directory (collection resource) at URL.

open will perform a propfind against URL. If the server does not understand the request then the open will fail.

Similarly, if the server indicates that the resource at URL is NOT a collection, the open command will fail.

options([URL])

Performs an OPTIONS request against the URL or the working resource if URL is not supplied.

Requires a working resource to be set before being called. See open.

The return value is a string of comma separated OPTIONS that the server states are legal for URL or undef otherwise.

A fully compliant DAV server may offer as many methods as: OPTIONS, TRACE, GET, HEAD, DELETE, PUT, COPY, MOVE, PROPFIND, PROPPATCH, LOCK, UNLOCK

Note: IIS5 does not support PROPPATCH or LOCK on collections.

Example:

$options = $d->options($url);
print $options . "\n";
if ($options=~ /\bPROPPATCH\b/) {
   print "OK to proppatch\n";
}

Or, put more simply:

if ( $d->options($url) =~ /\bPROPPATCH\b/ ) {
   print "OK to proppatch\n";
}
propfind([URL],[DEPTH])

Perform a propfind against URL at DEPTH depth.

-depth can be used to specify how deep the propfind goes. "0" is collection only. "1" is collection and it's immediate members (This is the default value). "infinity" is the entire directory tree. Note that most DAV compliant servers deny "infinity" depth propfinds for security reasons.

Requires a working resource to be set before being called. See open.

The return value is an HTTP::DAV::Resource object on success or 0 on failure.

The Resource object can be used for interrogating properties or performing other operations.

## Print collection or content length
if ( $r=$d->propfind( -url=>"/my_dir", -depth=>1) ) {
   if ( $r->is_collection ) {
      print "Collection\n" 
      print $r->get_resourcelist->as_string . "\n"
   } else {
      print $r->get_property("getcontentlength") ."\n";
   }
}

Please note that although you may set a different namespace for a property of a resource during a set_prop, HTTP::DAV currently ignores all XML namespaces so you will get clashes if two properties have the same name but in different namespaces. Currently this is unavoidable but I'm working on the solution.

proppatch([URL],[NAMESPACE],PROPNAME,PROPVALUE,ACTION,[NSABBR])

If -action equals "set" then we set a property named -propname to -propvalue in the namespace -namespace for -url.

If -action equals "remove" then we unset a property named -propname in the namespace -namespace for -url.

If no action is supplied then the default action is "set".

The return value is an HTTP::DAV::Resource object on success or 0 on failure.

The Resource object can be used for interrogating properties or performing other operations.

To explicitly set a namespace in which to set the propname then you can use the -namespace and -nsabbr (namespace abbreviation) parameters. But you're welcome to play around with DAV namespaces.

Requires a working resource to be set before being called. See open.

It is recommended that you use set_prop and unset_prop instead of proppatch for readability.

set_prop simply calls proppatch(-action=set)> and unset_prop calls proppatch(-action="remove")>

See set_prop and unset_prop for examples.

put(LOCAL,[URL],[CALLBACK],[HEADERS])

uploads the files or directories at -local to the remote destination at -url.

-local points to a file, directory or series of files or directories (indicated by a glob).

If the filename contains any of the characters `*', `?' or `[' it is a candidate for filename substitution, also known as ``globbing''. This word is then regarded as a pattern (``glob-pattern''), and replaced with an alphabetically sorted list of file names which match the pattern.

One can upload/put a string by passing a reference to a scalar in the -local parameter. See example below.

put requires a working resource to be set before being called. See open.

The return value is always 1 or 0 indicating success or failure.

See get() for a description of what the optional callback parameter does.

You can also pass a -headers argument. That allows one to specify custom HTTP headers. It can be either a hashref with header names and values, or a HTTP::Headers object.

put examples:

Put a string to the server:

my $myfile = "This is the contents of a file to be uploaded\n";
$d->put(-local=>\$myfile,-url=>"http://www.host.org/dav_dir/file.txt");

Put a local file to the server:

$d->put(-local=>"/tmp/index.html",-url=>"http://www.host.org/dav_dir/");

Put a series of local files to the server:

 In these examples, /tmp contains file1.html, file1, file2.html, 
 file2.txt, file3.html, file2/

 $d->put(-local=>"/tmp/file[12]*",-url=>"http://www.host.org/dav_dir/");
 
 uploads file1.html, file1, file2.html, file2.txt and the directory file2/ to dav_dir/.
set_prop([URL],[NAMESPACE],PROPNAME,PROPVALUE)

Sets a property named -propname to -propvalue in the namespace -namespace for -url.

Requires a working resource to be set before being called. See open.

The return value is an HTTP::DAV::Resource object on success or 0 on failure.

The Resource object can be used for interrogating properties or performing other operations.

Example:

if ( $r = $d->set_prop(-url=>$url,
             -namespace=>"dave",
             -propname=>"author",
             -propvalue=>"Patrick Collins"
            ) ) {
   print "Author property set\n";
} else {
   print "set_prop failed:" . $d->message . "\n";
}

See the note in propfind about namespace support in HTTP::DAV. They're settable, but not readable.

steal([URL])

forcefully steals any locks held against URL.

steal will perform a propfind against URL and then, any locks that are found will be unlocked one by one regardless of whether we own them or not.

Requires a working resource to be set before being called. See open.

The return value is always 1 or 0 indicating success or failure. If multiple locks are found and unlocking one of them fails then the operation will be aborted.

if ($d->steal()) {
   print "Steal succeeded\n";
} else {
   print "Steal failed: ". $d->message() . "\n";
}
unlock([URL])

unlocks any of our locks on URL.

Requires a working resource to be set before being called. See open.

The return value is always 1 or 0 indicating success or failure.

if ($d->unlock()) {
   print "Unlock succeeded\n";
} else {
   print "Unlock failed: ". $d->message() . "\n";
}
unset_prop([URL],[NAMESPACE],PROPNAME)

Unsets a property named -propname in the namespace -namespace for -url. Requires a working resource to be set before being called. See open.

The return value is an HTTP::DAV::Resource object on success or 0 on failure.

The Resource object can be used for interrogating properties or performing other operations.

Example:

if ( $r = $d->unset_prop(-url=>$url,
             -namespace=>"dave",
             -propname=>"author",
            ) ) {
   print "Author property was unset\n";
} else {
   print "set_prop failed:" . $d->message . "\n";
}

See the note in propfind about namespace support in HTTP::DAV. They're settable, but not readable.

ACCESSOR METHODS

get_user_agent

Returns the clients' working HTTP::DAV::UserAgent object.

You may want to interact with the HTTP::DAV::UserAgent object to modify request headers or provide advanced authentication procedures. See dave for an advanced authentication procedure.

get_last_request

Takes no arguments and returns the clients' last outgoing HTTP::Request object.

You would only use this to inspect a request that has already occurred.

If you would like to modify the HTTP::Request BEFORE the HTTP request takes place (for instance to add another header), you will need to get the HTTP::DAV::UserAgent using get_user_agent and interact with that.

get_workingresource

Returns the currently "opened" or "working" resource (HTTP::DAV::Resource).

The working resource is changed whenever you open a url or use the cwd command.

e.g. $r = $d->get_workingresource print "pwd: " . $r->get_uri . "\n";

get_workingurl

Returns the currently "opened" or "working" URL.

The working resource is changed whenever you open a url or use the cwd command.

print "pwd: " . $d->get_workingurl . "\n";
get_lockedresourcelist

Returns an HTTP::DAV::ResourceList object that represents all of the locks we've created using THIS dav client.

print "pwd: " . $d->get_workingurl . "\n";
get_absolute_uri(REL_URI,[BASE_URI])

This is a useful utility function which joins BASE_URI and REL_URI and returns a new URI.

If BASE_URI is not supplied then the current working resource (as indicated by get_workingurl) is used. If BASE_URI is not set and there is no current working resource the REL_URI will be returned.

For instance: $d->open("http://host.org/webdav/dir1/");

# Returns "http://host.org/webdav/dir2/"
$d->get_absolute_uri(-rel_uri=>"../dir2");

# Returns "http://x.org/dav/dir2/file.txt"
$d->get_absolute_uri(-rel_uri  =>"dir2/file.txt",
                     ->base_uri=>"http://x.org/dav/");

Note that it subtly takes care of trailing slashes.

ERROR HANDLING METHODS

message

message gets the last success or error message.

The return value is always a scalar (string) and will change everytime a dav operation is invoked (lock, cwd, put, etc).

See also errors for operations which contain multiple error messages.

errors

Returns an @array of error messages that had been set during a multi-request operation.

Some of HTTP::DAV's operations perform multiple request to the server. At the time of writing only put and get are considered multi-request since they can operate recursively requiring many HTTP requests.

In these situations you should check the errors array if to determine if any of the requests failed.

The errors function is used for multi-request operations and not to be confused with a multi-status server response. A multi-status server response is when the server responds with multiple error messages for a SINGLE request. To deal with multi-status responses, see HTTP::DAV::Response.

# Recursive put
if (!$d->put( "/tmp/my_dir", $url ) ) {
   # Get the overall message
   print $d->message;
   # Get the individual messages
   foreach $err ( $d->errors ) { print "  Error:$err\n" }
}
is_success

Returns the status of the last DAV operation performed through the HTTP::DAV interface.

This value will always be the same as the value returned from an HTTP::DAV::method. For instance:

# This will always evaluate to true
($d->lock($url) eq $d->is_success) ?

You may want to use the is_success method if you didn't capture the return value immediately. But in most circumstances you're better off just evaluating as follows: if($d->lock($url)) { ... }

get_last_response

Takes no arguments and returns the last seen HTTP::DAV::Response object.

You may want to use this if you have just called a propfind and need the individual error messages returned in a MultiStatus.

If you find that you're using get_last_response() method a lot, you may be better off using the more advanced HTTP::DAV interface and interacting with the HTTP::DAV::* interfaces directly as discussed in the intro. For instance, if you find that you're always wanting a detailed understanding of the server's response headers or messages, then you're probably better off using the HTTP::DAV::Resource methods and interpreting the HTTP::DAV::Response directly.

To perform detailed analysis of the server's response (if for instance you got back a multistatus response) you can call get_last_response() which will return to you the most recent response object (always the result of the last operation, PUT, PROPFIND, etc). With the returned HTTP::DAV::Response object you can handle multi-status responses.

For example:

# Print all of the messages in a multistatus response
if (! $d->unlock($url) ) {
   $response = $d->get_last_response();
   if ($response->is_multistatus() ) {
     foreach $num ( 0 .. $response->response_count() ) {
        ($err_code,$mesg,$url,$desc) =
           $response->response_bynum($num);
        print "$mesg ($err_code) for $url\n";
     }
   }
}

ADVANCED METHODS

new_resource

Creates a new resource object with which to play. This is the preferred way of creating an HTTP::DAV::Resource object if required. Why? Because each Resource object needs to sit within a global HTTP::DAV client. Also, because the new_resource routine checks the HTTP::DAV locked resource list before creating a new object.

$dav->new_resource( -uri => "http://..." );
set_workingresource(URL)

Sets the current working resource to URL.

You shouldn't need this method. Call open or cwd to set the working resource.

You CAN call set_workingresource() but you will need to perform a propfind immediately following it to ensure that the working resource is valid.

INSTALLATION, TODO, MAILING LISTS and REVISION HISTORY

[OUTDATED]

Please see the primary HTTP::DAV webpage at (http://www.webdav.org/perldav/http-dav/) or the README file in this library.

SEE ALSO

You'll want to also read:

HTTP::DAV::Response
HTTP::DAV::Resource
dave

and maybe if you're more inquisitive:

LWP::UserAgent
HTTP::Request
HTTP::DAV::Comms
HTTP::DAV::Lock
HTTP::DAV::ResourceList
HTTP::DAV::Utils

AUTHOR AND COPYRIGHT

This module is Copyright (C) 2001-2008 by

Patrick Collins
G03 Gloucester Place, Kensington
Sydney, Australia

Email: pcollins@cpan.org
Phone: +61 2 9663 4916

All rights reserved.

Current co-maintainer of the module is Cosimo Streppone for Opera Software ASA, opera@cpan.org.

You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file.

HTTP-DAV-0.50/doc/html/index.html0000644000175000017500000001567114703665637015732 0ustar cosimocosimo PerlDAV

PerlDAV -- A WebDAV client library for Perl5

PerlDAV is a Perl library for modifying content on webservers using the WebDAV protocol. Now you can LOCK, DELETE and PUT files and much more on a DAV-enabled webserver.

The PerlDAV library consists of:

  • HTTP::DAV - an object-oriented Web-DAV client API.

  • dave - the DAV Explorer, an end-user Unix console program for interacting with WebDAV servers. dave looks and feels like a standard Unix ftp program.

LATEST VERSION AND WHAT'S NEW

See the included Changes file for the full changelog.

INSTALLING HTTP::DAV

The lazy way to install PerlDAV:

$ cpan HTTP::DAV

Or the normal way:

Retrieve the latest copy from CPAN: https://metacpan.org/module/HTTP-DAV/

$ perl Makefile.PL # Creates the Makefile
$ make             # Runs the makefile
$ make test        # Optional (See Interopability below)
$ make install     # Installs dave and HTTP::DAV

With this method you will first have to install the pre-requisites: LWP and XML::DOM, see "what are the prerequisites?".

When you install PerlDAV, the HTTP::DAV library will be installed to your Perl library location (usually /usr/local/lib/perl5)

dave will be installed to /usr/local/bin. This suits most people but you can modify this by using the INSTALLBIN flag:

$ perl Makefile.PL INSTALLBIN="/home/user/bin"

What Are The Prerequisites?

  • Perl 5.6.0+

  • LWP (Have not tested lower than v5.48)

  • Scalar::Util (standard library from 5.8.0+)

  • XML::DOM (Have not tested lower than v1.26). Requires James Clark's expat library:

  • To access SSL urls you will need Crypt::SSLeay and/or IO::Socket::SSL.

Optional Prerequisites.

  • Crypt::SSLeay if you'd like to use https. Crypt::SSLeay requires the openssl library as well. See Crypt::SSLeay's excellent install instructions for how to get https support into LWP (and hence HTTP::DAV). I've tested HTTP::DAV and Crypt::SSLeay against Apache/mod_dav with the mod_ssl plugin. Works seamlessly.

  • MD5 if you'd like to use LWP's Digest authentication.

To get the latest versions of these prerequisite modules you can simply type this at the command prompt:

   $ <install expat>
then:
   $ perl -MCPAN -e shell
   cpan> install LWP
   cpan> install XML::DOM

or if you just 'install HTTP::DAV' the lovely CPAN module should just magically install all of the prerequisites for you (you'll still need to manually instal expat though).

What Systems Does It Work With?

HTTP::DAV and dave are pure perl so only needs Perl 5.6.0 (or later). PerlDAV is known to run under Windows (although I haven't tried it myself) and should run under all Unix systems.

WHERE ARE THE MANUALS?

Once you've installed PerlDAV, you can type:

$ perldoc HTTP::DAV
$ man dave

Or you can view them here: HTTP::DAV, dave.

GETTING HELP

The perldav mailing list

There is a mailing list for PerlDAV for use by Developers and Users. Please see http://mailman.webdav.org/mailman/listinfo/perldav

THE TEST SUITE & INTEROPERABILITY

You will notice that the standard make test command invokes a large set of test procedures, but most will be skipped. This standard test is sufficient to give you a good indication that PerlDAV has installed properly.

If you'd like to see how well PerlDAV performs against a particular DAV server then you should set the URL (and username,password) in the test suite t/TestDetails.pm. Then you can run make test again and watch the test suite perform as many operations as the server supports. Please note that the test suite will perofrm well over 200 HTTP requests to your server.

I have tested PerlDAV against IIS5, mod_dav and the Xythos WFS.

Out of the box, the test suite should NOT fail on any tests.

The test suite is the best way to test interopability between PerlDAV and other servers. I'd really like help with testing PerlDAV's interoperability. So if one or more tests fail against your server please follow the following steps:

  • Determine which test is failing.

  • set DEBUG to on: edit the script and change HTTP::DAV::DebugLevel(0) to (3).

  • Delete previous server output: rm /tmp/perldav_debug.txt

  • Run that single test again:

    $make test TEST_FILES=t/thetest.t TEST_VERBOSE=1 > testoutput.log

  • Then gzip and mail me both testoutput.log and /tmp/perldav_debug.txt with details of the test environment. (My email is at the bottom)

Alternatively, you could have a shot at solving the bug yourself :)

BUGS and TODO

Need to convert XML::DOM to a DOM Level 2 compliant parser like XML::Gdome.

See TODO for what is left to be done.

AUTHOR AND COPYRIGHT

This module is Copyright (C) 2001 by

Patrick Collins
G03 Gloucester Place, Kensington
Sydney, Australia

mailto:pcollins@cpan.org
Phone: +61 2 9663 4916

All rights reserved.

MAINTAINER

The current maintainer of HTTP-DAV is Cosimo Streppone for Kahoot!, and previously for Opera Software ASA. You can contact me at cosimo@cpan.org.

GITHUB REPOSITORY

The official repository for HTTP-DAV is now on Github:

https://github.com/cosimo/perl5-http-dav

LICENSE

You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file.

$Id$

HTTP-DAV-0.50/doc/html/TODO.html0000644000175000017500000000626314703665637015365 0ustar cosimocosimo TODO

TODO

dave

- globs on lock(),unlock(),steal(),options()?,move(),copy(),propfind(),proppatch() (and set/unset).
- rework ls to use globs.
- multistatus responses don't come through nicely.

HTTP::DAV

- Rework the file transfer code to avoid slurping complete files in memory
  and read through a fixed size buffer, to avoid memory hogs or crashes
  when transferring huge files.
- LWP doesn't allow callback on upload, only download. This means
  we can't do progress indicators on "PUT". How to do it? Could patch
  LWP? Specialise LWP::UserAgent? Ugh.
- doco globs in DAV.pm
- fix get references
- _put calls propfind on every call throughout a recursive _put().
  need to adjust this so that it does it only once, in put(). After 
  the first time, we should be able to KNOW whether it is a collection
  or not instead of having to propfind to find out becasue in theory
  WE were the ones who put the file there.

- finish "source" property in DAV::Resource.pm
- redo POD Resource.pm

- setup_if_headers need to get just Rsource's locks not all RL's locks.
- discovery still isn't resetting locks properly ????
- DAV.pm as_string needs working resource
- finish lock (bug against mod_dav somewhere)

- mod t/* for IIS 5 lock and proppatch deficiencies.
- how to we handle degradation for incomplete servers in test suite (IIS)?
- mod_dav has a very strange bug with lock-null resources.
  The following combination of commands makes it weird out:
     $ mkdir dir1
     $ lock dir1
     $ lock dir2 (this is a lock null)
     $ move dir1 dir2
     Now, the spec says that dir2 should now be the copy of dir1 and it should be locked.
     However, mod_dav has an unlocked dir2. Even worse, if you delete dir2, there is 
     a shadowed lock-null resource called dir2 sitting behind the scenes. Bad.

Wishlist functions

- testing against Zope
- dave:implement netrc?
- dave:tab completion? history?
- dave:implement more advanced command-line interaction
- dave:copy/move should allow the user to set 'depth' and 'overwrite'
- redo auth as a callback? If so, needs 2 functions, get and success.

Wishlist projects

- Namespaces are not currently supported. I munge around them since
  they are not supported in DOM1 which is what XML::DOM uses.
- Rework Response.pm now that LWP::Status supports the status codes.

- support for LWPng which is fully HTTP/1.1 compliant.
- DAV Bindings
- DAV Redirects Reference
- DAV Ordered collections
- DAV DASL support
- DAV Delta-V
- DAV ACL's

$Id$

HTTP-DAV-0.50/doc/html/Changes.html0000644000175000017500000003035014703665637016162 0ustar cosimocosimo Changes

Revision history for HTTP::DAV

v0.50 (released 2024/10/16):

  • bug fixes

    Fixed missing custom headers when calling PUT methods. Closes RT#100756. Thanks Georg Acher for the patch and for patiently waiting a decade (!) for a fix.

v0.49 (released 2018/11/28):

  • bug fixes

    Fixed perl shebang line in dave script, for ExtUtils::MakeMaker to correctly replace it. Closes RT#127819.

    Fixed propfind response handling to also consider successful an HTTP 207 status code. Closes RT#127591.

    Fixed clone() method to properly respect the class name. Closes RT#123528. Thanks to Ricardo Signes for the patch.

  • documentation fixes

    Fixed various pod issues raised by Debian contributor fsfs@debian.org. Closes RT#119878.

v0.48 (released 2015/03/26):

  • bug fixes

    RT#103126, fixed faulty code to add trailing slash to URLs.

v0.47 (released 2012/03/24):

  • bug fixes

    Improve propfind() resilience when server response contains broken, truncated or no XML at all. RT#75011.

v0.46 (released 2012/01/11):

  • improvements

    HTTP::DAV should now be working with more WebDAV servers.

    We are more flexible in what content types we consider to be XML. Thanks Ron1 and Adam for the feedback and patches.

v0.45 (released 2011/09/18):

  • bug fixes

    - Fixed RT #69439 (http://rt.cpan.org/Public/Bug/Display.html?id=69439),
  insecure /tmp files handling in dave client.

  • improvements

    - Added -tmpdir option to dave client.
- Reorganized distribution layout to match usual CPAN practice
- Removed remains of svn-era ($Id and such...)

v0.44 (released 2011/06/19):

  • bug fixes

    - Fixed RT #68936 (http://rt.cpan.org/Public/Bug/Display.html?id=68936),
  Fixed errors() method that would bomb out when the "_errors" attribute
  wasn't initialized. Thanks to Michael Lackoff for reporting.

v0.43 (released 2011/04/12):

  • bug fixes

    - Fixed RT #38677 (http://rt.cpan.org/Public/Bug/Display.html?id=38677),
  Intercept correctly 405 (Method now allowed) errors and report them
  to the clients.

v0.42 (released 2010/11/07):

  • bug fixes

    - Fixed RT #60457 (http://rt.cpan.org/Public/Bug/Display.html?id=60457),
  Added and documented possibility to pass your own custom HTTP headers.
- Fixed errors in the code examples in the synopsis.

v0.41 (released 2010/07/24):

  • bug fixes

    - Fixed RT #59674 (http://rt.cpan.org/Public/Bug/Display.html?id=59674),
      When SSL support is needed but not installed, a more specific
  error messages is now displayed, instead of "not DAV enabled or not accessible".

v0.40 (released 2010/01/27):

  • bug fixes

    - Fixed RT #47500 (http://rt.cpan.org/Public/Bug/Display.html?id=47500),
      HTTP::DAV::Comms->credentials() method erroneously autovivified
      basic authentication internal values, causing wrong or undefined
      credentials to be sent out, or credentials to be "forgot" by HTTP::DAV.

v0.39 (released 2009/12/12):

  • bug fixes

    - Fixed RT #52665 (http://rt.cpan.org/Public/Bug/Display.html?id=52665),
      Using dave or propfind() on URLs containing escaped chars (%xx) could fail,
      due to upper/lower case differences. Thanks to cebjyre for the patch
      and the test case.

v0.38 (released 2009/06/09):

  • bug fixes

    - Fixed RT #14506 (http://rt.cpan.org/Public/Bug/Display.html?id=14506),
  about the missing get_lastresponse() method. It was a documentation bug.

- Fixed RT #29788 (http://rt.cpan.org/Public/Bug/Display.html?id=29788),
  avoid file corruptions on Win32 when calling HTTP::DAV::get() method.

- Fixed RT #31014 (http://rt.cpan.org/Public/Bug/Display.html?id=31014),
  probably already in v0.34, since it seems related to propfind() "depth" bug.

v0.37 (released 2009/03/24):

  • bug fixes

    - Fixed RT #44409 (http://rt.cpan.org/Public/Bug/Display.html?id=44409),
  Small bug in HTTP::DAV::put(). Passing a reference as local content resulted
      in the "SCALAR(0x12345678)" being logged instead of the real scalar.

v0.36 (released 2009/02/25):

  • bug fixes

    - Fixed RT #19616 (http://rt.cpan.org/Public/Bug/Display.html?id=19616),
  LWP::UserAgent::redirect_ok() is not changed anymore. We're subclassing
  it from HTTP::DAV::UserAgent and overriding redirect_ok() there.

- Fixed RT #42877 (http://rt.cpan.org/Public/Bug/Display.html?id=42877),
  HTTP::DAV::UserAgent::credentials() has been modified to behave like
  LWP::UserAgent::credentials(), otherwise basic authentication breakages
  can occur.

- Fixed a problem with C<-depth> argument to C<HTTP::DAV::propfind()> that
  could lead to massive performance degradation, especially when running
      C<propfind()> against large folders.
      C<-depth> was set to 1 even when passed as zero.

v0.35 (released 2008/11/03):

  • bug fixes

    - Fixed RT #40318 (http://rt.cpan.org/Public/Bug/Display.html?id=40318),
  about getting single or multiple files directly to \*STDOUT.

v0.34 (released 2008/09/11):

  • bug fixes

    - Fixed RT #39150 (http://rt.cpan.org/Public/Bug/Display.html?id=39150),
  about downloading multiple files in the same directory.

v0.33 (released 2008/08/24):

  • documentation

    - Clearly state that opera software asa is now co-maintainer of http::dav

- Fixed various inconsistencies in the v0.32 documentation

v0.32 (released 2008/08/24):

  • incompatibilities

    - Now HTTP::DAV requires Perl 5.6.0+ and Scalar::Util (core in 5.8.x).

  • bug fixes

    - Now HTTP::DAV objects are correctly released from memory when
  they go out of scope. Now it should be possible to use multiple instances
  of HTTP::DAV even in long-running processes.

  Was caused by circular references between HTTP::DAV and HTTP::DAV::Resource.

v0.31 (released 2002/04/13):

  • Apache 2 mod_dav support

    - Now works with mod_dav under Apache 2.

  • bug fixes

    - Fixed bug to correctly handle the put/get of filenames with spaces in them.

- Fixed bug to allow the PUT of empty files.

- put() now uses binmode so that it works under Windows.

- HTTP redirect code added in the previous release was incorrectly returning a HTTP::Response instead of a HTTP::DAV::Response

- Fixed bug to allow https for copy and move (http:// was hardcoded).

- Fixed strange copy/move bug for Apache2.0's mod_dav.

v0.29 (released 2001/10/31):

  • https

    https support as provided from the underlying LWP library has been tested against mod_dav and mod_ssl. Seems to work well. See INSTALLATION for more detail.

  • Digest authentication

    Requires MD5 to be installed. See INSTALLATION notes.

  • various bug fixes

  • more powerful callback support for get()

    Useful for giving progress indicators.

  • get() to filehandles and scalar references

    the get() routine now allows you to pass by reference a filehandle or scalar in which to save the contents of the GET request.

  • added namespace abbreviations in proppatch

    Thanks to Jeremy for this patch.

  • improved redirect handling in Comms.pm

    Thanks to Jeremy for this patch.

v0.23 (released 2001/09/07):

  • file globbing for get and put

    HTTP::DAV::get() and HTTP::DAV::put() now supports file globs. This functionality also propagates to dave. This allows you to do the following:

    dav> put /tmp/index*.html
dav> get index[12].htm? /tmp

?,* and sets ([]) are supported. See the docs for details.

    HTTP::DAV now requires the Perl module File::Glob which comes bundled with perl5.6 and later.

  • bug fix in -overwrite flag in HTTP::DAV::copy/move.

v0.22 (released 2001/09/03)

Complete overhaul of API, recursive get and put, addition of dave.

  • dave -- the new command line client

    I wrote dave (the DAV Explorer) because I needed an end-user application that allowed me to "feel" how well the HTTP::DAV API was performing. dave is quite similar to Joe Orton's C-based DAV client called cadaver (yes, imitation is the best form of flattery).

  • A new and simpler API

    This new API is accessed directly through the HTTP::DAV module and is based on the core API written in previous releases.

  • new methods

    The new API now supports, proppatch, recursive get and put.

  • A substantial core API overhaul

    Moving from v0.05 to v0.22 in one release might indicate the amount of work gone into this release.

  • A new interoperability test suite

    is now included in PerlDAV. The test suite is built on top of the standard Perl Test::Harness modules. Still in development, the test suite is highlighting interoperability problems with DAV-servers a lot quicker than before. See "the test suite & interoperability" section.

v0.05 (released 2001/07/24)

General bug fixes and addition of proppatch

- added PROPPATCH method to HTTP::DAV::Resource, thanks to Sylvain Plancon.
- fixed uninitialized warnings in test scripts.
- fixed new lock bug in DAV::Lock, thanks to Ben Evans
- fixed dumb mistake where PUT was calling get instead of put, 
  thanks to Sylvain and Ben again.
- fixed call to Utils::bad, thanks to Sylvain

v0.04 (released 2000/04/25)

Initial Release

- supports PUT,GET,MLCOL,DELETE,OPTIONS,PROPFIND,LOCK,UNLOCK,steal_lock,lock_discovery
HTTP-DAV-0.50/doc/html/dave.html0000644000175000017500000003546414703665637015544 0ustar cosimocosimo dave - DAV Explorer

NAME

dave - DAV Explorer

SYNOPSIS

dave [OPTIONS] URL

e.g.

$ dave -u pcollins -p mypass www.host.org/dav_dir/
...
dave> get file.txt

Use dave -h to get help on options.

Use perldoc dave for the whole manpage.

DESCRIPTION

dave is a powerful command-line program for interacting with WebDAV-enabled webservers. With dave you can:

  • get and put files

  • make directories on a remote webserver

  • remove files and directories from a remote webserver

  • edit a file on the webserver with a single command

  • recursively get a remote directory

  • recursively put a local directory

  • lock and unlock remote files and directories

  • securely transfer over https

  • authenticate using the safer Digest authentication

Dave is a part of the PerlDAV project (http://www.webdav.org/perldav/) and is built on top of the HTTP::DAV perl API.

If you would like to script webdav interactions in Perl checkout the HTTP::DAV API as it's commands are the basis for dave's.

OPTIONS

-debug N

Sets the debug level to N. 0=none. 3=noisy.

-h

Prints basic help and options.

-man

Prints the full manual (equivalent to perldoc dave).

You will need to use a pager like more or less. e.g.

dave -man |less
-p <password>

Sets the password to be used for the URL. You must also supply a user. See -u.

-u <username>

Sets the username to be used for the URL. You must also supply a pass. See -p.

-tmpdir /some/path

Create temporary files in /some/path instead of the default /tmp.

COMMANDS

cd URL

changes directories

dave> open host.org/dav_dir/
dave> cd dir1
dave> cd ../dir2
cat URL

shows the contents of a remote file

dave> open host.org/dav_dir/
dave> cat index.html

Note: you cannot cat a directory (collection).

cp
copy SOURCE_URL DEST_URL

copies one remote resource to another

dave> open host.org/dav_dir/

Create a copy of dir1/ as dav2/

dave> cp dir1 dav2

Create a copy of dir1/file.txt as dav2/file.txt

dave> cd dir1
dave> copy file.txt ../dav2

Create a copy of file.txt as ../dav2/new_file.txt

dave> copy file.txt dav2/new_file.txt

Aliases: cp

rmdir URL
rm URL
delete URL

deletes a remote resource

dave> open host.org/dav_dir/
dave> delete index.html
dave> rmdir ./dir1
dave> delete /dav_dir/dir2/
dave> delete /dav_dir/*.html

This command recursively deletes directories. BE CAREFUL :)

This command supported wildcards (globbing). See get.

Aliases: rm, rmdir

edit URL

edits the contents of a remote file

dave> open host.org/dav_dir/
dave> edit index.html

Edit is equivalent to the following sequence of commands:

LOCK index.html (if allowed)
GET index.html /tmp/dave.perldav.421341234124
sh $EDITOR /tmp/dave.perldav.421341234124
PUT index.html (if modified)
UNLOCK index.html (if locked)

Where $EDITOR is determined from the environment variables DAV_EDITOR or EDITOR.

If DAV_EDITOR is set, it will use that, otherwise it will use EDITOR. If neither variables are set, then "vi" will be used.

Notes:

The lock only lasts for 10 hours.

You cannot edit a directory (collection).

The temporary save directory is editable by editing dave and changing TMP_DIR

get URL [FILE]

downloads the file or directory at URL

If FILE is not specified it will be saved to your current working directory using the same name as the remote name.

dave> open host.org/dav_dir/

Recursively get remote my_dir/ to .

dave> get my_dir/

Recursively get remote my_dir/ to /tmp/my_dir/

dave> get my_dir /tmp

Get remote my_dir/index.html to /tmp/index.html

dave> get /dav_dir/my_dir/index.html /tmp

Get remote index.html to /tmp/index1.html

dave> get index.html /tmp/index1.html

Use globs and save to /tmp

dave> get index* /tmp                   # Gets index*.html, index*.txt, etc.
dave> get index*.html /tmp/index1.html  # Gets index*.html
dave> get index[12].htm?                # Gets file1 and file2, .htm and .html
? [CMD]
h [CMD]
help [CMD]

prints list of commands or help for CMD

dave> ?

dave> help get

Aliases: ?, h

lcd [DIR]

changes local directory

dave> lcd /tmp
lls [DIR]

lists local directory contents

dave> lcd /tmp
dave> lls
dave> lls /home

This command simply execs the local ls command and is equivalent to "!ls"

lpwd

prints the current working directory, locally

This command simply execs the local ls command and is equivalent to "!pwd"

dir [URL]
ls [URL]

lists remote directory contents or file props

dave> ls
Listing of http://host.org/dav_dir/
                ./          Aug 29 02:26  <dir>
   mtx_0.04.tar.gz   52640  Aug 11 11:45
        index.html    4580  Aug 11 11:45
    index0.04.html    4936  Nov 11  2000
            mydir/          Aug 19 21:14  <dir>,<locked>

dave> ls index.html
URL: http://www.webdav.org/perldav/index.html
Content-type: text/html
Creation date: Sun Aug 12 21:58:02 2001
Last modified:
Size: 4580 bytes
Locks supported: write/exclusive write/shared
Locks:

Use propfind to get a similar printout of a collection (directory).

Aliases: dir

lock [URL [TIMEOUT] [DEPTH]]

locks a resource

Without a URL you will lock the current remote collection.

TIMEOUT can be any of the following formats: 30s 30 seconds from now 10m ten minutes from now 1h one hour from now 1d tomorrow 3M in three months 10y in ten years time 2000-02-31 00:40:33 2000-02-31

Default is an infinite timeout

See perldoc HTTP::DAV::Resource for more information about timeouts.

DEPTH can be either "0" or "infinity" (default)

Seeting the lock Scope and Type is not currently implemented. Let me know if you need it as it shouldn't be too much effort.

mkdir URL
mkcol URL

make a remote collection (directory)

dave> open host.org/dav_dir/
dave> mkcol new_dir
dave> mkdir /dav_dir/new_dir

Aliases: mkdir

mv
move SOURCE_URL DEST_URL

moves a remote resource to another

dave> open host.org/dav_dir/

Move dir1/ to dav2/

dave> move dir1 dav2

Move file dir2/file.txt to ../file.txt

dave> cd dir2
dave> move file.txt ..

Move file.txt to dav2/new_file.txt

dave> move file.txt dav2/new_file.txt

Aliases: mv

open URL

connects to the WebDAV-enabled server at URL

dave> open host.org/dav_dir/

Note that if authorization details are required you will be prompted for them.

https and Digest authorization are not currently supported. Please let me know if you need it.

options [URL]

show the HTTP methods allowed for a URL

dave> options index.html
OPTIONS, GET, HEAD, POST, DELETE, TRACE, PROPFIND, 
PROPPATCH, COPY, MOVE, LOCK, UNLOCK

Note that Microsoft's IIS does not support LOCK on collections (directories). Nor does it support PROPPATCH.

propfind [URL]

show the properties of a resource

dave> propfind test
URL: http://host.org/dav_dir/test/
Content-type: httpd/unix-directory
Creation date: Wed Aug 29 00:36:42 2001
Last modified:
Size:  bytes
Locks supported: write/exclusive write/shared
Locks:

Using ls will get you the same printout if you ls a file. But ls'ing a collection will show you the collections contents.

put FILE [URL]

uploads a local file or directory to URL or the currently opened location.

If URL is an existing collection then the dir/file will be copied INTO that collection.

dave> open host.org/dav_dir/

Recursively put local my_dir/ to host.org/dav_dir/my_dir/:

dave> put my_dir/

Put local index.html to host.org/dav_dir/index1.html:

dave> put /tmp/index.html index1.html

Put * to remote directory

dave> put *

Put index[12].htm? to remote directory /dav_dir (/dav_dir must exist)

dave> put index[12].htm? /dav_dir

Put index[1234].htm? to remote directory /dav_dir (/dav_dir must exist)

dave> put index[1-4].htm? /dav_dir

Glob types supported are, * (matches any characters), ? (matches any one character), [...] (matches any characters in the set ...).

pwd

prints the currently opened URL (working directory)

dave> open host.org/dav_dir/
dave> cd new_dir/
dave> pwd
http://host.org/dav_dir/new_dir/
q
bye
quit

exits dave

Note that dave does not unlock any locks created during your session.

Aliases: q, quit

set URL PROPERTY VALUE [NAMESPACE]

sets a custom property on a resource

dave> set file.txt author "Patrick Collins"
dave> set file.txt author "Patrick Collins" "mynamespace"

The NAMESPACE by default is "DAV:".

!
sh

executes a local command (alias !)

dave> sh cat localfile
dave> !gzip localfile.gz
dave> ! "cat localfile | less"

Aliases: !

showlocks

show my locks on a resource

Shows any locked resources that you've locked in this session.

See propfind if you'd like to see anyone's locks held against a particular resource.

steal [URL]

remove ANY locks on a resource

Useful if you accidentally forgot to unlock a resource from a previous session or if you think that somebody has forgotten to unlock a resource.

unlock [URL]

unlocks a resource

Note that unlock will only unlock locks that you have created. Use steal if you want to forcefully unlock somebody else's lock.

unset URL PROPERTY [NAMESPACE]

unsets a property from a resource

dave> unset file.txt author
dave> unset file.txt author "mynamespace"

The NAMESPACE by default is "DAV:".

GETTING HELP

The perldav mailing list There is a mailing list for PerlDAV and dave for use by Developers and Users. Please see http://mailman.webdav.org/mailman/listinfo/perldav

INSTALLATION

dave is installed to /usr/local/bin by default when you install the PerlDAV library. See http://www.webdav.org/perldav/ for installation details of PerlDAV.

WHAT PLATFORMS WILL IT WORK ON?

dave is pure perl so only needs Perl5.003 (or later) and the PerlDAV library to be installed.

I have not ported dave to Windows but would like somebody to have a shot at it.

SEE ALSO

The PerlDAV perl API at http://www.webdav.org/perldav/ or by typing "perldoc HTTP::DAV" on your command line.

AUTHOR AND COPYRIGHT

This module is Copyright (C) 2001 by

Patrick Collins
G03 Gloucester Place, Kensington
Sydney, Australia

Email: pcollins@cpan.org
Phone: +61 2 9663 4916

All rights reserved.

You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file.

MAINTAINER

Cosimo Streppone, <cosimo@cpan.org>

HTTP-DAV-0.50/doc/TODO.pod0000644000175000017500000000550414703664237014227 0ustar cosimocosimo=for html

TODO

=begin text TODO =end text =head2 dave - globs on lock(),unlock(),steal(),options()?,move(),copy(),propfind(),proppatch() (and set/unset). - rework ls to use globs. - multistatus responses don't come through nicely. =head2 HTTP::DAV - Rework the file transfer code to avoid slurping complete files in memory and read through a fixed size buffer, to avoid memory hogs or crashes when transferring huge files. - LWP doesn't allow callback on upload, only download. This means we can't do progress indicators on "PUT". How to do it? Could patch LWP? Specialise LWP::UserAgent? Ugh. - doco globs in DAV.pm - fix get references - _put calls propfind on every call throughout a recursive _put(). need to adjust this so that it does it only once, in put(). After the first time, we should be able to KNOW whether it is a collection or not instead of having to propfind to find out becasue in theory WE were the ones who put the file there. - finish "source" property in DAV::Resource.pm - redo POD Resource.pm - setup_if_headers need to get just Rsource's locks not all RL's locks. - discovery still isn't resetting locks properly ???? - DAV.pm as_string needs working resource - finish lock (bug against mod_dav somewhere) - mod t/* for IIS 5 lock and proppatch deficiencies. - how to we handle degradation for incomplete servers in test suite (IIS)? - mod_dav has a very strange bug with lock-null resources. The following combination of commands makes it weird out: $ mkdir dir1 $ lock dir1 $ lock dir2 (this is a lock null) $ move dir1 dir2 Now, the spec says that dir2 should now be the copy of dir1 and it should be locked. However, mod_dav has an unlocked dir2. Even worse, if you delete dir2, there is a shadowed lock-null resource called dir2 sitting behind the scenes. Bad. =head2 Wishlist functions - testing against Zope - dave:implement netrc? - dave:tab completion? history? - dave:implement more advanced command-line interaction - dave:copy/move should allow the user to set 'depth' and 'overwrite' - redo auth as a callback? If so, needs 2 functions, get and success. =head2 Wishlist projects - Namespaces are not currently supported. I munge around them since they are not supported in DOM1 which is what XML::DOM uses. - Rework Response.pm now that LWP::Status supports the status codes. - support for LWPng which is fully HTTP/1.1 compliant. - DAV Bindings - DAV Redirects Reference - DAV Ordered collections - DAV DASL support - DAV Delta-V - DAV ACL's $Id$ =for text ** This file was automatically generated from ** ** doc/TODO.pod. To edit it, see there. ** =for html
HTTP-DAV-0.50/doc/README.pod0000644000175000017500000001345114703665435014420 0ustar cosimocosimo=for html

PerlDAV -- A WebDAV client library for Perl5

=begin text =head1 PerlDAV -- A WebDAV client library for Perl5 =end text PerlDAV is a Perl library for modifying content on webservers using the WebDAV protocol. Now you can LOCK, DELETE and PUT files and much more on a DAV-enabled webserver. The PerlDAV library consists of: =over 4 =item * B - an object-oriented Web-DAV client API. =item * B - the DAV Explorer, an end-user Unix console program for interacting with WebDAV servers. dave looks and feels like a standard Unix ftp program. =back =head1 LATEST VERSION AND WHAT'S NEW See the included C file for the full changelog. =head1 INSTALLING HTTP::DAV The lazy way to install PerlDAV: $ cpan HTTP::DAV Or the normal way: Retrieve the latest copy from CPAN: https://metacpan.org/module/HTTP-DAV/ $ perl Makefile.PL # Creates the Makefile $ make # Runs the makefile $ make test # Optional (See Interopability below) $ make install # Installs dave and HTTP::DAV With this method you will first have to install the pre-requisites: LWP and XML::DOM, see L. When you install PerlDAV, the HTTP::DAV library will be installed to your Perl library location (usually /usr/local/lib/perl5) C will be installed to /usr/local/bin. This suits most people but you can modify this by using the INSTALLBIN flag: $ perl Makefile.PL INSTALLBIN="/home/user/bin" =head2 What Are The Prerequisites? =over 4 =item * Perl 5.6.0+ =item * LWP (Have not tested lower than v5.48) =item * Scalar::Util (standard library from 5.8.0+) =item * XML::DOM (Have not tested lower than v1.26). Requires James Clark's expat library: =item * To access SSL urls you will need L and/or L. =back =head2 Optional Prerequisites. =over 4 =item * Crypt::SSLeay if you'd like to use https. Crypt::SSLeay requires the openssl library as well. See Crypt::SSLeay's excellent install instructions for how to get https support into LWP (and hence HTTP::DAV). I've tested HTTP::DAV and Crypt::SSLeay against Apache/mod_dav with the mod_ssl plugin. Works seamlessly. =item * MD5 if you'd like to use LWP's Digest authentication. =back To get the latest versions of these prerequisite modules you can simply type this at the command prompt: $ then: $ perl -MCPAN -e shell cpan> install LWP cpan> install XML::DOM or if you just 'install HTTP::DAV' the lovely CPAN module should just magically install all of the prerequisites for you (you'll still need to manually instal expat though). =head2 What Systems Does It Work With? HTTP::DAV and dave are pure perl so only needs Perl 5.6.0 (or later). PerlDAV is known to run under Windows (although I haven't tried it myself) and should run under all Unix systems. =head1 WHERE ARE THE MANUALS? Once you've installed PerlDAV, you can type: $ perldoc HTTP::DAV $ man dave =for html

Or you can view them here: HTTP::DAV, dave.

=head1 GETTING HELP =head2 The perldav mailing list There is a mailing list for PerlDAV for use by Developers and Users. Please see http://mailman.webdav.org/mailman/listinfo/perldav =head1 THE TEST SUITE & INTEROPERABILITY You will notice that the standard C command invokes a large set of test procedures, but most will be skipped. This standard test is sufficient to give you a good indication that PerlDAV has installed properly. If you'd like to see how well PerlDAV performs against a particular DAV server then you should set the URL (and username,password) in the test suite t/TestDetails.pm. Then you can run C again and watch the test suite perform as many operations as the server supports. Please note that the test suite will perofrm well over 200 HTTP requests to your server. I have tested PerlDAV against IIS5, mod_dav and the Xythos WFS. Out of the box, the test suite should NOT fail on any tests. The test suite is the best way to test interopability between PerlDAV and other servers. I'd really like help with testing PerlDAV's interoperability. So if one or more tests fail against your server please follow the following steps: =over 4 =item * Determine which test is failing. =item * set DEBUG to on: edit the script and change HTTP::DAV::DebugLevel(0) to (3). =item * Delete previous server output: rm /tmp/perldav_debug.txt =item * Run that single test again: $make test TEST_FILES=t/thetest.t TEST_VERBOSE=1 > testoutput.log =item * Then gzip and mail me both testoutput.log and /tmp/perldav_debug.txt with details of the test environment. (My email is at the bottom) =back Alternatively, you could have a shot at solving the bug yourself :) =head1 BUGS and TODO Need to convert XML::DOM to a DOM Level 2 compliant parser like XML::Gdome. =for html

See TODO for what is left to be done.

=for text See TODO for what is left to be done. =head1 AUTHOR AND COPYRIGHT This module is Copyright (C) 2001 by Patrick Collins G03 Gloucester Place, Kensington Sydney, Australia mailto:pcollins@cpan.org Phone: +61 2 9663 4916 All rights reserved. =head1 MAINTAINER The current maintainer of HTTP-DAV is Cosimo Streppone for Kahoot!, and previously for Opera Software ASA. You can contact me at C. =head1 GITHUB REPOSITORY The official repository for HTTP-DAV is now on Github: https://github.com/cosimo/perl5-http-dav =head1 LICENSE You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. $Id$ =cut =for text ** This file was automatically generated from ** ** doc/Changes.pod. To edit it, see there. ** =for html
HTTP-DAV-0.50/META.json0000664000175000017500000000231514703666621013630 0ustar cosimocosimo{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "HTTP-DAV", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Cwd" : "0", "File::Temp" : "0", "Getopt::Long" : "0", "LWP" : "5.48", "Pod::Usage" : "0", "Scalar::Util" : "0", "Term::ReadLine" : "0", "Text::ParseWords" : "0", "Time::Local" : "0", "URI" : "0", "URI::Escape" : "0", "XML::DOM" : "0" } } }, "release_status" : "stable", "version" : "0.50", "x_serialization_backend" : "JSON::PP version 4.16" } HTTP-DAV-0.50/lib/0000755000175000017500000000000014703666621012752 5ustar cosimocosimoHTTP-DAV-0.50/lib/HTTP/0000755000175000017500000000000014703666621013531 5ustar cosimocosimoHTTP-DAV-0.50/lib/HTTP/DAV/0000755000175000017500000000000014703666621014143 5ustar cosimocosimoHTTP-DAV-0.50/lib/HTTP/DAV/ResourceList.pm0000644000175000017500000001165414703664237017134 0ustar cosimocosimopackage HTTP::DAV::ResourceList; use strict; use vars qw($VERSION); $VERSION = '0.11'; #### # Construct a new object and initialize it sub new { my $class = shift; my $self = bless {}, ref($class) || $class; $self->_init(@_); return $self; } sub _init { my ($self,@p) = @_; #### # This is the order of the arguments unless used as # named parameters my @arg_names = qw ( RESOURCE_TYPE ); my @pa = HTTP::DAV::Utils::rearrange( \@arg_names, @p); $self->{_resources} = []; $self->{_resource_indexes} = {}; } #### # List Operators sub get_resources { my ($self) =shift; return @{$self->{_resources}}; } sub get_urls { return map { $_->get_uri } shift->get_resources; } sub count_resources { return $#{$_[0]->{_resources}}+1; } sub get_member { my ($self,$uri) = @_; $uri = HTTP::DAV::Utils::make_uri_canonical($uri); my $idx = $self->{_resource_indexes}{$uri}; return $idx ? $self->{_resources}[$idx] : 0; } sub add_resource { my ($self,$resource) = @_; $self->remove_resource($resource); $resource->set_parent_resourcelist($self); push @{$self->{_resources}}, $resource; my $uri = HTTP::DAV::Utils::make_uri_canonical($resource->get_uri); $self->{_resource_indexes}{$uri} = $self->count_resources - 1; } # Synopsis: $list->remove_resource( resource_obj : HTTP::DAV::Resource ); sub remove_resource { my ($self, $resource) = @_; my $ret; my $uri = HTTP::DAV::Utils::make_uri_canonical($resource->get_uri); my $idx = $self->{_resource_indexes}{$uri}; return 0 unless $idx; $resource = splice(@{$self->{_resources}}, $idx, 1); $resource->set_parent_resourcelist(); delete $self->{_resource_indexes}{$uri}; return $resource; } ########################################################################### # %tokens = get_locktokens( "http://localhost/test/dir" ) # Look for all of the lock tokens given a URI: # Returns: # %$tokens = ( # 'http://1' => ( token1, token2, token3 ), # 'http://2' => ( token4, token5, token6 ), # ); # sub get_locktokens { my ($self,@p) = @_; my($uri,$owned) = HTTP::DAV::Utils::rearrange(['URI','OWNED'],@p); $owned = 0 unless defined $owned; my %tokens; my @uris; if (ref($uri) =~ /ARRAY/ ) { @uris = map { HTTP::DAV::Utils::make_uri($_) } @{$uri}; } else { push( @uris, HTTP::DAV::Utils::make_uri($uri) ); } # OK, let's say we hold three locks on 3 resources: # 1./a/b/c/ 2./a/b/d/ and 3./f/g # If you ask me for /a/b you'll get the locktokens on 1 and 2. # If you ask me for /a and /f you'll get 1,2 and 3. # If you ask me for /a/b/c/x.txt you'll get 1 # If you ask me for /a/b/e you'll get nothing # So, for each locked resource, if it is a member # of the uri you specify, I'll tell you what the # locked resource tokens were foreach my $resource ( $self->get_resources ) { my $resource_uri = $resource->get_uri; foreach my $url ( @uris ) { # if $resource_uri is in $uri # e.g. u=/a r=/a/b/e # e.g. u=/a r=/a/b/c.txt my $r = $resource_uri->canonical(); my $u = $url->canonical(); # Add a trailing slash $r =~ s{/*$}{/}; $u =~ s{/*$}{/}; if ($u =~ m{\Q$r}) { my @locks = $resource->get_locks(-owned=>$owned); foreach my $lock (@locks) { my @lock_tokens = @{$lock->get_locktokens()}; push(@{$tokens{$resource_uri}}, @lock_tokens); } } } # foreach uri } # foreach resource return \%tokens; } # Utility to convert lock tokens to an if header # %$tokens = ( # 'http://1' => ( token1, token2, token3 ), # 'http://2' => ( token4, token5, token6 ), # ) # to # if tagged: # () # or if not tagged: # () # sub tokens_to_if_header { my ($self, $tokens, $tagged) = @_; my $if_header; foreach my $uri (keys %$tokens ) { $if_header .= "<$uri> " if $tagged; foreach my $token (@{$$tokens{$uri}}) { $if_header .= "(<$token>) "; } $if_header=~ s/\s+$//g; } return $if_header; } ########################################################################### # Dump the objects contents as a string sub as_string { my ($self,$space,$depth,$verbose) = @_; $verbose=1 if (!defined $verbose || $verbose!=0); $space||=" "; my ($return) = ""; $return .= "${space}ResourceList Object ($self)\n"; $space .= " "; foreach my $resource ( $self->get_resources() ) { if ($verbose) { $return .= $resource->as_string($space,$depth); } else { $return .= $space . $resource . " " . $resource->get_uri. "\n"; } } $return; } sub showlocks { my ($self,$space,$depth) = @_; $space||=" "; my ($return) = ""; foreach my $resource ( $self->get_resources() ) { $return .= $resource->as_string("$space",2); } $return; } 1; HTTP-DAV-0.50/lib/HTTP/DAV/Lock.pm0000644000175000017500000003340414703664237015376 0ustar cosimocosimopackage HTTP::DAV::Lock; use strict; use vars qw($VERSION); use HTTP::DAV::Utils; $VERSION = '0.09'; ########################################################################### =head1 NAME HTTP::DAV::Lock - Represents a WebDAV Lock. =head1 SYNOPSIS Need example =head1 DESCRIPTION =cut sub new { my $self = {}; bless $self, shift; $self->_init(@_); return $self; } sub _init { my ($self,@p) = @_; my($owned) = HTTP::DAV::Utils::rearrange(['OWNED'],@p); $self->{_owned} = $owned || 0; } ########################################################################### =head1 ACCESSOR METHODS =over =cut # GET sub get_owner { $_[0]->{_owner}; } sub get_token { $_[0]->{_token}; } sub get_depth { $_[0]->{_depth}; } sub get_timeout { $_[0]->{_timeout}; } sub get_locktoken { $_[0]->{_locktokens}[0]; } sub get_locktokens{ $_[0]->{_locktokens}; } sub set_scope { $_[0]->{_scope} = $_[1]; } sub set_owned { $_[0]->{_owned} = $_[1]; } sub set_type { $_[0]->{_type} = $_[1]; } sub set_owner { $_[0]->{_owner} = $_[1]; } sub set_depth { $_[0]->{_depth} = $_[1]; } sub set_timeout { $_[0]->{_timeout} = $_[1]; } sub set_locktoken { my ($self,$href) = @_; # Remove leading and trailing space from " http://.../..." $href =~ s/^\s*//g; $href =~ s/\s*$//g; # Remove < > from around it available $href =~ s/^<(.*)>$/$1/g; push (@{$self->{_locktokens}}, $href); } # IS sub is_owned { $_[0]->{_owned}; } ########################################################################### # Synopsis: # Full parameters # make_lock_xml ( # -owner => (owner|http://mysite/~mypage/) # -timeout => num_of_seconds (e.g. 134123432) # -scope => (exclusive|shared) # -type => (write) # ) sub make_lock_xml { my ($self,@p) = @_; my($owner,$timeout,$scope,$type,@other) = HTTP::DAV::Utils::rearrange(['OWNER','TIMEOUT','SCOPE','TYPE'],@p); #### # Create a new XML document # It may look something like this # # # # # # http://mysite/~mypage.html # # my $xml_request = qq{\n}; $xml_request .= "\n"; $xml_request .= "\n"; $xml_request .= "\n"; #$xml_request = < # #<$scope/> #<$type/> ## #END # If the owner is an HREF then set it into an tag # else just enter it as text. my $o = URI->new($owner); if ($o->scheme) { $xml_request .= "$owner\n"; #$xml_request .= "$owner\n"; } elsif ( $owner ) { $xml_request .= "$owner\n"; #$xml_request .= "$owner\n"; } $xml_request .= "\n"; #$xml_request .= "\n"; return ($xml_request); } ########################################################################### # Synopsis: @locks = XML_lockdiscovery_parse($node); # With this XML node: # # # # # 0 # Infinite # pcollins # # opaquelocktoken:d3ae67b0-1dd1-a5f7-f067587e98e1 # ... # # # # # returns an array of locks (will be more than one in shared locks scenarios) sub XML_lockdiscovery_parse { my ($self,$node_lockdiscovery) = @_; my @found_locks = (); # my @nodes_activelock= HTTP::DAV::Utils::get_elements_by_tag_name($node_lockdiscovery,"D:activelock"); # foreach my $node_activelock ( @nodes_activelock ) { my $lock = HTTP::DAV::Lock->new(); push(@found_locks,$lock); my $nodes_lock_params = $node_activelock->getChildNodes(); next unless $nodes_lock_params; my $prop_count = $nodes_lock_params->getLength; for (my $prop_num = 0; $prop_num < $prop_count; $prop_num++) { my $node_lock_param = $nodes_lock_params->item($prop_num); # $node_lock_param is one of the following # 1. # 2. # 3. # 4. # 5. # 6. my $lock_prop_name = $node_lock_param->getNodeName(); $lock_prop_name =~ s/.*:(.*)/$1/g; # 1. RFC2518 currently only allows locktype of exclusive or shared if ( $lock_prop_name eq "lockscope" ) { my $node_lock_scope = HTTP::DAV::Utils::get_only_element($node_lock_param); my $lock_scope = $node_lock_scope->getNodeName; $lock_scope =~ s/.*:(.*)/$1/g; $lock->set_scope($lock_scope); } # 2. RFC2518 currently only allows locktype of "write" elsif ( $lock_prop_name eq "locktype" ) { my $node_lock_type = HTTP::DAV::Utils::get_only_element($node_lock_param); my $lock_type = $node_lock_type->getNodeName; $lock_type =~ s/.*:(.*)/$1/g; $lock->set_type($lock_type); } # 3. RFC2518 allows only depth of 0,1,infinity elsif ( $lock_prop_name eq "depth" ) { my $lock_depth = HTTP::DAV::Utils::get_only_cdata($node_lock_param); $lock->set_depth($lock_depth); } # 4. RFC2518 allows anything here. # Patrick: I'm just going to convert the XML to a string elsif ( $lock_prop_name eq "owner" ) { $lock->set_owner( $node_lock_param->getFirstChild->toString ); } # 5. RFC2518 (Section 9.8) e.g. Timeout: Second-234234 or Timeout: infinity elsif ( $lock_prop_name eq "timeout" ) { my $lock_timeout = HTTP::DAV::Utils::get_only_cdata($node_lock_param); my $timeout = HTTP::DAV::Lock->interpret_timeout($lock_timeout); $lock->set_timeout( $timeout ); #if ( $HTTP::DAV::DEBUG ) { # $lock->{ "_timeout_val" } = HTTP::Date::time2str($timeout) #} } # 6. RFC2518 allows one or more 's # Push them all into the lock object. elsif ( $lock_prop_name eq "locktoken" ) { my @nodelist_hrefs = HTTP::DAV::Utils::get_elements_by_tag_name($node_lock_param,"D:href"); foreach my $node ( @nodelist_hrefs) { my $href_cdata = HTTP::DAV::Utils::get_only_cdata( $node ); $lock->set_locktoken( $href_cdata ); } } } # Foreach property } # Foreach ActiveLock return @found_locks; } ########################################################################### # Synopsis: $hashref = get_supportedlock_details($node); # # # # # # # # # # # # Returns something similar to: # @supportedlocks' = ( # { 'type' => 'write', 'scope' => 'exclusive' }, # { 'type' => 'write', 'scope' => 'shared' } # ); sub get_supportedlock_details { my ($node_supportedlock) = @_; return unless $node_supportedlock; # Return values my @supportedlocks=(); my @nodelist_lockentries = HTTP::DAV::Utils::get_elements_by_tag_name($node_supportedlock,"D:lockentry"); foreach my $i ( 0 .. $#nodelist_lockentries ) { my $node_lockentry = $nodelist_lockentries[$i]; my $lock_prop_name = $node_lockentry->getNodeName(); next unless $lock_prop_name; # RFC2518 currently only allows lockscope of exclusive or shared # my $node_lockscope=HTTP::DAV::Utils::get_only_element($node_lockentry,"D:lockscope"); if ( $node_lockscope ) { my $node_lockscope_param =HTTP::DAV::Utils::get_only_element($node_lockscope); my $lockscope = $node_lockscope_param->getNodeName; $lockscope =~ s/.*:(.*)/$1/g; $supportedlocks[$i]{ "scope" } = $lockscope; } # RFC2518 currently only allows locktype of "write" # my $node_locktype = HTTP::DAV::Utils::get_only_element($node_lockentry,"D:locktype"); if ( $node_locktype ) { my $node_locktype_param =HTTP::DAV::Utils::get_only_element($node_locktype); my $locktype = $node_locktype_param->getNodeName; $locktype =~ s/.*:(.*)/$1/g; $supportedlocks[$i]{ "type" } = $locktype; } } return \@supportedlocks; } ########################################################################### =item Timeout This parameter can take an absolute or relative timeout. The following forms are all valid for the -timeout field: Timeouts in: 300 30s 30 seconds from now 10m ten minutes from now 1h one hour from now 1d tomorrow 3M in three months 10y in ten years time Timeout at: 2000-02-31 00:40:33 at the indicated time & date For more time and date formats that are handled see HTTP::Date RFC2518 states that the timeout value MUST NOT be greater than 2^32-1. If this occurs it will simply set the timeout to infinity =cut sub timeout { my ($self,$timeout) = @_; my $timeoutret; return 0 unless $timeout; if ($timeout =~ /^\d+[a-zA-Z]$/ ) { $timeoutret = _timeout_calc($timeout); } elsif ($timeout =~ /infinity/i || $timeout =~ /^\d+$/ ) { $timeoutret = $timeout; } else { my ($epochgmt) = HTTP::Date::str2time($timeout); $timeoutret = $epochgmt - time; } # Timeout value cannot be greater than 2^32-1 as per RFC2518 if ( $timeoutret =~ /infinity/i || $timeoutret >= 4294967295 ) { return "Infinite, Second-4294967295 "; } elsif ( $timeoutret <= 0 ) { return 0; } else { return "Second-$timeoutret "; } } ########################################################################### sub interpret_timeout { my ($self,$timeout) = @_; return "Infinite" if $timeout =~ /Infinite/i; return "Infinite" if !defined $timeout || $timeout eq ""; if ($timeout =~ /Second\-(\d+)/ ) { return time + $1; } else { HTTP::DAV::Utils::bad("Ugh... can't interpret Timeout value \"timeout: $timeout\"\n"); } } ########################################################################### # This internal routine creates an expires time exactly some number of # hours from the current time. It incorporates modifications from # Mark Fisher. # Borrowed from Lincoln Stein's CGI.pm sub _timeout_calc { my($time) = @_; my(%mult) = ('s'=>1, 'm'=>60, 'h'=>60*60, 'd'=>60*60*24, 'M'=>60*60*24*30, 'y'=>60*60*24*365); # format for time can be in any of the forms... # "180s" -- in 180 seconds # "2m" -- in 2 minutes # "12h" -- in 12 hours # "1d" -- in 1 day # "3M" -- in 3 months # "2y" -- in 2 years # "3m" -- 3 minutes # If you don't supply one of these forms, we assume you are # specifying the date yourself my($offset); if (!$time || (lc($time) eq 'now')) { $offset = 0; } elsif ($time=~/^(\d+|\d*\.\d*)([mhdMy]?)/) { $offset = ($mult{$2} || 1)*$1; } else { return $time; } return $offset; } ########################################################################### =item $r->as_string() Method returning a textual representation of the request. Mainly useful for debugging purposes. It takes no arguments. =cut sub as_string { my ($self,$space,$debug) = @_; my ($str) = ""; $space = " " if !defined $space; $str .= "${space}Lock Object ($self)\n"; $space .= " "; $str .= "${space}'_owned': " . ($self->{_owned}||"") . "\n"; $str .= "${space}'_scope': " . ($self->{_scope}||"") . "\n"; $str .= "${space}'_type': " . ($self->{_type} ||"") . "\n"; $str .= "${space}'_owner': " . ($self->{_owner}||"") . "\n"; $str .= "${space}'_depth': " . ($self->{_depth}||"") . "\n"; $str .= "${space}'_timeout': " . ($self->{_timeout}||"") . "\n"; $str .= "${space}'_locktokens': " . join(", ", @{$self->get_locktokens()} ) . "\n"; $str; } sub pretty_print { my ($self,$space) = @_; my ($str) = ""; $str .= "${space}Owner: $self->{_owner}\n"; $str .= "${space}Scope: $self->{_scope}\n"; $str .= "${space}Type: $self->{_type}\n"; $str .= "${space}Depth: $self->{_depth}\n"; $str .= "${space}Timeout: $self->{_timeout}\n"; $str .= "${space}LockTokens: " . join(", ", @{$self->get_locktokens()} ) . "\n"; $str; } ########################################################################### =back =head1 SEE ALSO L, L, L =head1 COPYRIGHT Copyright 2000 Patrick Collins. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; HTTP-DAV-0.50/lib/HTTP/DAV/Resource.pm0000644000175000017500000016023514703664662016302 0ustar cosimocosimopackage HTTP::DAV::Resource; use strict; use vars qw($VERSION); $VERSION = '0.50'; use HTTP::DAV; use HTTP::DAV::Utils; use HTTP::DAV::Lock; use HTTP::Date qw(str2time); use HTTP::DAV::ResourceList; use Scalar::Util (); use URI::Escape; ########################################################################### # Construct a new object and initialize it sub new { my $class = shift; my $self = bless {}, ref($class) || $class; $self->_init(@_); return $self; } sub _init { my ($self, @p) = @_; #### # This is the order of the arguments unless used as # named parameters my ($uri, $lockedresourcelist, $comms, $client) = HTTP::DAV::Utils::rearrange( [ 'URI', 'LOCKEDRESOURCELIST', 'COMMS', 'CLIENT' ], @p); # Optionally add a scheme. $uri =~ s/^\s*(.*?)\s*$/$1/g; # Remove leading and trailing slashes $uri = "http://$uri" if ($uri ne "" && $uri !~ /^https?:\/\//); $self->{"_uri"} = $uri || ""; $self->{"_lockedresourcelist"} = $lockedresourcelist || ""; $self->{"_comms"} = $comms || ""; $self->{"_dav_client"} = $client || ""; # Avoid circular references between # - HTTP::DAV -> {_workingresource} and # - HTTP::DAV::Resource -> {_dav_client} Scalar::Util::weaken($self->{"_dav_client"}); #### # Set the _uri $self->{_uri} = HTTP::DAV::Utils::make_uri($self->{_uri}); die "HTTP URL required when creating a Resource object\n" if (!$self->{_uri}->scheme); #### # Check that the required objects exist die("Comms object required when creating a Resource object") unless (defined $self->{_comms} && $self->{_comms} =~ /HTTP::DAV::Comms/); die("Locked ResourceList object required when creating a Resource object") unless (defined $self->{_lockedresourcelist} && $self->{_lockedresourcelist} =~ /HTTP::DAV::ResourceList/); die("DAV Client required when creating a Resource object") unless (defined $self->{_dav_client} && $self->{_dav_client} =~ /HTTP::DAV/); } ########################################################################### # GET/SET #sub set_lockpolicy { cluck("Can't reset the lockpolicy on a Resource"); 0; } sub set_parent_resourcelist { my ($self, $resource_list) = @_; # Avoid circular references between the # parent resource list and this child resource Scalar::Util::weaken($self->{_parent_resourcelist} = $resource_list); } sub set_property { $_[0]->{_properties}{ $_[1] } = $_[2]; } sub set_uri { $_[0]->{_uri} = HTTP::DAV::Utils::make_uri($_[1]); } # PRIVATE SUBROUTINES sub _set_content { $_[0]->{_content} = $_[1]; } sub _set_options { $_[0]->{_options} = $_[1]; } sub _set_compliance { $_[0]->{_compliance} = $_[1]; } sub set_locks { my ($self, @locks) = @_; # Unset any existing locks because we're about to reset them # But keep their name temporarily because some of them # may be ours. my @old_lock_tokens = keys %{ $self->{_locks} } || (); #if (@locks && defined $self->{_locks}) { if (defined $self->{_locks}) { delete $self->{_locks}; } foreach my $lock (@locks) { my $token = $lock->get_locktoken(); #print "Adding $token\n"; # If it exists, we'll set it to owned and reapply # it (it may have changed since we saw it last. # Like it might have timed out? if (grep($token, @old_lock_tokens)) { $lock->set_owned(1); } $self->{_locks}{$token} = $lock; } #print "Locks: " . join(' ',keys %{$self->{_locks}} )."\n"; } sub is_option { my ($self, $option) = @_; $self->options if (!defined $self->{_options}); return ($self->{_options} =~ /\b$option\b/i) ? 1 : 0; } sub is_dav_compliant { my $resp = $_[0]->options if (!defined $_[0]->{_options}); $_[0]->{_compliance}; } sub get_options { $_[0]->{_options}; } sub get_content { $_[0]->{_content}; } sub get_content_ref { \$_[0]->{_content}; } sub get_username { my ($self) = @_; my $ra = $self->{_comms}->get_user_agent(); my @userpass = $ra->get_basic_credentials(undef, $self->get_uri()); return $userpass[0]; } #sub get_lockpolicy { $_[0]->{_lockpolicy}; } sub get_client { $_[0]->{_dav_client}; } sub get_resourcelist { $_[0]->{_resource_list}; } sub get_lockedresourcelist { $_[0]->{_lockedresourcelist}; } sub get_comms { $_[0]->{_comms}; } sub get_property { $_[0]->{_properties}{ $_[1] } || ""; } sub get_uri { $_[0]->{_uri}; } sub get_uristring { $_[0]->{_uri}->as_string; } sub get_parent_resourcelist { $_[0]->{_parent_resourcelist}; } # $self->get_locks( -owned => [0|1] ); # '1' = return any locks owned be me # '0' = return any locks NOT owned be me # no value = return all locks # sub get_locks { my ($self, @p) = @_; my ($owned) = HTTP::DAV::Utils::rearrange(['OWNED'], @p); $owned = "" unless defined $owned; #print "owned=$owned,\@p=\"@p\"\n"; my @return_locks = (); foreach my $token (sort keys %{ $self->{_locks} }) { my $lock = $self->{_locks}{$token}; if ($owned eq "1" && $lock->is_owned) { push(@return_locks, $lock); } elsif ($owned eq "0" && !$lock->is_owned) { push(@return_locks, $lock); } elsif ($owned eq "") { push(@return_locks, $lock); } } return @return_locks; } sub get_lock { my ($self, $token) = @_; return $self->{_locks}{$token} if ($token); } # Just pass through to get_locks all of our parameters. # Then count how many we get back. >1 lock returns 1. sub is_locked { my ($self, @p) = @_; return scalar $self->get_locks(@p); } sub is_collection { my $type = $_[0]->get_property("resourcetype"); return (defined $type && $type =~ /collection/) ? 1 : 0; } sub _unset_properties { $_[0]->{_properties} = (); } sub _unset_lock { delete $_[0]->{_locks}{ $_[1] } if $_[1]; } sub _unset_locks { $_[0]->{_locks} = (); } sub _unset_my_locks { my ($self) = @_; my @locks = $self->get_locks(-owned => 1); foreach my $lock (@locks) { $self->_unset_lock($lock->get_locktoken); } $self->get_lockedresourcelist->remove_resource($self); } ########################################################################### sub lock { my ($self, @p) = @_; my $lock = HTTP::DAV::Lock->new(-owned => 1); #my $existing_lock = $self->get_lockedresourcelist->get_member($self->uri); my ($owner, $depth, $timeout, $scope, $type, @other) = HTTP::DAV::Utils::rearrange( [ 'OWNER', 'DEPTH', 'TIMEOUT', 'SCOPE', 'TYPE' ], @p); #### # Set the defaults # 'owner' default is DAV.pm/v0.1 (ProcessId) $owner ||= "DAV.pm/v$HTTP::DAV::VERSION ($$)"; # Sanity check. If it ain't 0, then make it infinity. $depth = (defined $depth && $depth eq "0") ? 0 : "infinity"; # 'scope' default is exclusive $scope ||= "exclusive"; # 'type' default is write $type ||= "write"; #### # Setup the headers for the lock request my $headers = HTTP::DAV::Headers->new; $headers->header("Content-type", "text/xml; charset=\"utf-8\""); $headers->header("Depth", $depth); my $timeoutval = $lock->timeout($timeout); $headers->header("Timeout", $timeoutval) if ($timeoutval); # Add any If headers required #$self->_setup_if_headers($headers); #### # Setup the XML content for the lock request my $xml_request = HTTP::DAV::Lock->make_lock_xml( -owner => $owner, -timeout => $timeout, -scope => $scope, -type => $type, ); #print "$xml_request\n"; #### # Put the lock request to the remote server my $resp = $self->{_comms}->do_http_request( -method => "LOCK", -url => $self->{_uri}, -headers => $headers, -content => $xml_request, ); ### # Handle the lock response # Normal spec scenario if ($self->content_type_is_xml($resp)) { # use XML::DOM to parse the result. my $parser = new XML::DOM::Parser; my $doc = $parser->parse($resp->content); ### # Multistatus response. Generally indicates a failure if ($resp->code == 207) { # We're only interested in the error codes that come # out of the multistatus $resp. eval { $self->_XML_parse_multistatus($doc, $resp) }; print "XML error: " . $@ if $@; } ### # Lock succeeded # 1. I assume from RFC2518 that if it successsfully locks # then we will only get back the lockdiscover element # for MY lock. If not, I will warn the user. # # 2. I am fairly sure that my client should only ever be able to # take out one lock on a resource. As such this program assumes # that a resource can only have one lock held against it (locks # owned by other people do not get stored here). # elsif ($resp->is_success) { my $node_prop = HTTP::DAV::Utils::get_only_element($doc, "D:prop"); my $lock_discovery = HTTP::DAV::Utils::get_only_element($node_prop, "D:lockdiscovery"); my @locks = HTTP::DAV::Lock->XML_lockdiscovery_parse($lock_discovery); # Degenerate case for bad server mydocsonline. # Doesn't return a proper lockdiscovery. # Just use the Lock-Token in the header instead. if (!@locks && $resp->header('Lock-Token')) { print "Using degenerate case of getting Lock-Token from Header.\n" if $HTTP::DAV::DEBUG > 2; $locks[0] = HTTP::DAV::Lock->new(-owned => 1); $locks[0]->set_locktoken($resp->header('Lock-Token')); } if ($#locks > 0) { warn( "Serious protocol error, expected 1 lock back from request " . "but got more than one. Don't know which one is mine" ); } else { $self->set_locks(@locks); foreach my $lock (@locks) { $lock->set_owned(1); } $self->{_lockedresourcelist}->add_resource($self); #print $self->{_lockedresourcelist}->as_string; } } # Discard of XML doc safely. $doc->dispose; } return $resp; } ########################################################################### sub unlock { my ($self, @p) = @_; my ($opaquelocktoken) = HTTP::DAV::Utils::rearrange(['TOKEN'], @p); my $resp; my $uri = $self->get_uri(); # If you passed no lock token then I'll try # and unlock with any tokens I own. if (!$opaquelocktoken) { my @locks = $self->get_locks(-owned => 1); my $num_locks = $#locks + 1; if ($num_locks == 0) { # Just use a dummy token. They're unique anyway. #$opaquelocktoken = "opaquelocktoken:dummytoken-82d32fa22932"; $opaquelocktoken = ""; } if ($num_locks == 1) { $opaquelocktoken = $locks[0]->get_locktoken; } else { foreach my $lock (@locks) { $resp = $self->unlock(-token => $lock->get_locktoken); return $resp if $resp->is_error(); } } } my $headers = HTTP::DAV::Headers->new; #$headers->header("Lock-Token", "<${opaquelocktoken}>") if $opaquelocktoken; $headers->header("Lock-Token", "<${opaquelocktoken}>"); if ($opaquelocktoken) { warn "UNLOCKING with '$opaquelocktoken'\n" if $HTTP::DAV::DEBUG > 2; # Put the unlock request to the remote server $resp = $self->{_comms}->do_http_request( -method => "UNLOCK", -url => $self->get_uri, -headers => $headers, #-content => no content required ); } else { #print "START\n"; $resp = HTTP::Response->new(500, "Client error. No lock held."); $resp = HTTP::DAV::Response->clone_http_resp($resp); #print $resp->as_string(); #print "END\n"; } if ($resp->is_success) { $self->_unset_lock($opaquelocktoken); } return $resp; } ########################################################################### sub forcefully_unlock_all { my ($self) = @_; my $resp; my $discovery_resp = $self->lockdiscovery; if ($discovery_resp->is_success) { my @locks = $self->get_locks(); foreach my $lock (@locks) { my $token = $lock->get_locktoken; $resp = $self->unlock(-token => $token) if $token; return $resp if $resp->is_error; } } # In the event that there were no locks to steal, # then just send a dud request out and let the # server fail it. if (!$resp) { $resp = $self->unlock(); } return $resp; } ########################################################################### sub steal_lock { my ($self) = @_; $self->forcefully_unlock_all; return $self->lock; } ########################################################################### sub lockdiscovery { my ($self, @p) = @_; my ($depth, @other) = HTTP::DAV::Utils::rearrange(['DEPTH'], @p); return $self->propfind( -depth => $depth, -text => "" ); } ########################################################################### sub propfind { my ($self, @p) = @_; my ($depth, $text, @other) = HTTP::DAV::Utils::rearrange([ 'DEPTH', 'TEXT' ], @p); # 'depth' default is 1 $depth = 1 unless (defined $depth && $depth ne ""); #### # Setup the headers for the request my $headers = new HTTP::Headers; $headers->header("Content-type", "text/xml; charset=\"utf-8\""); $headers->header("Depth", $depth); # Create a new XML document # # # my $xml_request = qq{}; $xml_request .= ''; $xml_request .= $text || ""; $xml_request .= ""; #### # Put the propfind request to the remote server my $resp = $self->{_comms}->do_http_request( -method => "PROPFIND", -url => $self->{_uri}, -headers => $headers, -content => $xml_request, ); # Reset the resource list, in case of intermediate errors, # to keep object state consistent $self->{_resource_list} = undef; if (! $self->content_type_is_xml($resp)) { $resp->add_status_line( "HTTP/1.1 422 Unprocessable Entity, no XML body.", "", $self->{_uri}, $self->{_uri} ); return $resp; } # use XML::DOM to parse the result. my $parser = XML::DOM::Parser->new(); my $xml_resp = $resp->content; my $doc; if (! $xml_resp) { $resp->add_status_line( "HTTP/1.1 422 Unprocessable Entity, no XML body.", "", $self->{_uri}, $self->{_uri} ); return $resp; } eval { $doc = $parser->parse($xml_resp); } or do { warn "Unparsable XML received from server (" . length($xml_resp) . " bytes)\n"; warn "ERROR: $@\n"; return $resp; }; # Setup a ResourceList in which to pump all of the collection my $resource_list; eval { $resource_list = $self->_XML_parse_multistatus($doc, $resp) } or do { warn "Error parsing PROPFIND response XML: $@\n"; }; if ($resource_list && $resource_list->count_resources()) { $self->{_resource_list} = $resource_list; } $doc->dispose; return $resp; } ########################################################################### # get/GET the body contents sub get { my ($self, @p) = @_; my ($save_to, $progress_callback, $chunk) = HTTP::DAV::Utils::rearrange( [ 'SAVE_TO', 'PROGRESS_CALLBACK', 'CHUNK' ], @p); #$save_to = URI::Escape::uri_unescape($save_to); my $resp = $self->{_comms}->do_http_request( -method => "GET", -uri => $self->get_uri, -save_to => $save_to, -callback => $progress_callback, -chunk => $chunk ); # What to do with all of the headers in the response. Put # them into this object? If so, which ones? if ($resp->is_success) { $self->_set_content($resp->content); } return $resp; } sub GET { shift->get(@_); } ########################################################################### # put/PUT the body contents sub put { my ($self, $content, $custom_headers) = @_; my $resp; # Setup the If: header if it is locked my $headers = HTTP::DAV::Headers->new(); $self->_setup_if_headers($headers); $self->_setup_custom_headers($headers, $custom_headers); if (!defined $content) { $content = $self->get_content(); # if ( ! $content ) { # #$resp = HTTP::DAV::Response->new; # #$resp->code("400"); ?? # return $resp; # } } $resp = $self->{_comms}->do_http_request( -method => "PUT", -uri => $self->get_uri, -headers => $headers, -content => $content, ); #my $unlockresp = $self->unlock; # What to do with all of the headers in the response. Put # them into this object? If so, which ones? # $self->_set_content( $resp->content ); return $resp; } sub PUT { my $self = shift; $self->put(@_); } ########################################################################### # Make a collection sub mkcol { my ($self) = @_; # Setup the If: header if it is locked my $headers = HTTP::DAV::Headers->new(); $self->_setup_if_headers($headers); my $resp = $self->{_comms}->do_http_request( -method => "MKCOL", -uri => $self->get_uri, -headers => $headers, ); # Handle a multistatus response if ($self->content_type_is_xml($resp) && # XML body $resp->is_multistatus() # Multistatus ) { # use XML::DOM to parse the result. my $parser = new XML::DOM::Parser; my $doc = $parser->parse($resp->content); # We're only interested in the error codes that come out of $resp. eval { $self->_XML_parse_multistatus($doc, $resp) }; warn "XML error: " . $@ if $@; $doc->dispose; } return $resp; } ########################################################################### # Get OPTIONS available on a resource/collection sub options { my ($self, $entire_server) = @_; my $uri = $self->get_uri; # Doesn't work properly. Sets it as /* # How do we get LWP to send through just # OPTIONS * HTTP/1.1 # ?? #$uri->path("*") if $entire_server; my $resp = $self->{_comms}->do_http_request( -method => "OPTIONS", -uri => $uri, ); if ($resp->header("Allow")) { #print "Allow: ". $resp->header("Allow") . "\n"; $self->_set_options($resp->header("Allow")); } # Get the "DAV" header and look for # either "DAV:1" or "DAV:1,2" my $compliance = 0; if ($resp->header("DAV")) { $compliance = $resp->header("DAV"); if ($compliance =~ /^\s*1\s*,\s*2/) { $compliance = 2; } elsif ($compliance =~ /^\s*1/) { $compliance = 1; } } $self->_set_compliance($compliance); return $resp; } sub OPTIONS { my $self = shift; $self->options(@_); } ########################################################################### # Move or copy a resource/collection sub move { return shift->_move_copy("MOVE", @_); } sub copy { return shift->_move_copy("COPY", @_); } sub _move_copy { my ($self, $method, @p) = @_; my ($dest_resource, $overwrite, $depth, $text, @other) = HTTP::DAV::Utils::rearrange( [ 'DEST', 'OVERWRITE', 'DEPTH', 'TEXT' ], @p); # Sanity check. If depth ain't 0, then make it infinity. # Only infinity allowed for move. # 0 or infinity allowed for copy. if ($method eq "MOVE") { $depth = "infinity"; } else { $depth = (defined $depth && $depth eq "0") ? 0 : "infinity"; } # Sanity check. If overwrite ain't F or 0, then make it T $overwrite = "F" if (defined $overwrite && $overwrite eq "0"); $overwrite = (defined $overwrite && $overwrite eq "F") ? "F" : "T"; #### # 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': # # * # or # # ...url1... # ...url2... # # or # # my $xml_request; if ($text) { $headers->header("Content-type", "text/xml; charset=\"utf-8\""); $xml_request = qq{}; $xml_request .= ''; $xml_request .= $text; $xml_request .= ""; } #### # 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"; #### # Setup the headers for the lock request my $headers = new HTTP::Headers; $headers->header("Content-type", "text/xml; charset=\"utf-8\""); $self->_setup_if_headers($headers); my $xml_request = qq{}; # $xml_request .= ""; # $xml_request .= ""; $xml_request .= ""; } # else { # $xml_request .= ""; # if ($action eq "set" ) { # $xml_request .= "$propvalue"; # } else { # $xml_request .= ""; # } $xml_request .= ""; $xml_request .= ""; if ($action eq "set") { $xml_request .= "<$nsabbr:$propname>$propvalue"; } else { $xml_request .= "<$nsabbr:$propname/>"; } $xml_request .= ""; $xml_request .= ""; $xml_request .= ""; #### # Put the proppatch request to the remote server my $resp = $self->{_comms}->do_http_request( -method => "PROPPATCH", -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; } return $resp; } ########################################################################### # Delete a resource/collection sub delete { my ($self) = @_; # Setup the If: header if it is locked my $headers = HTTP::DAV::Headers->new(); $self->_setup_if_headers($headers); # Setup the Depth for the delete request # The only valid depth is infinity. #$headers->header("Depth", "infinity"); my $resp = $self->{_comms}->do_http_request( -method => "DELETE", -uri => $self->get_uri, -headers => $headers, ); # Handle a multistatus response if ($self->content_type_is_xml($resp) && # XML body $resp->is_multistatus() # Multistatus ) { # use XML::DOM to parse the result. my $parser = new XML::DOM::Parser; my $doc = $parser->parse($resp->content); # We're only interested in the error codes that come out of $resp. eval { $self->_XML_parse_multistatus($doc, $resp) }; warn "XML error: " . $@ if $@; $doc->dispose; } if ($resp->is_success) { $self->_unset_my_locks(); } return $resp; } sub content_type_is_xml { my ($self, $resp) = @_; return unless $resp; my $type = $resp->content_type; return unless $type; if ($type =~ m{(?:application|text)/xml}) { return 1; } return; } ########################################################################### ########################################################################### # parses a element. # This is the root level element for a # PROPFIND body or a failed DELETE body. # For example. The following is the result of a DELETE operation # with a locked progeny (child). # # >> DELETE /test/dir/newdir/ HTTP/1.1 # << HTTP/1.1 207 Multistatus # # # # /test/dir/newdir/locker/ # HTTP/1.1 423 Locked # Twas locked baby # # # /test/dir/newdir/ # # # HTTP/1.1 424 Failed Dependency # Locks here somewhere # # Can't delete him. Lock here # # Failed delete # # sub _XML_parse_multistatus { my ($self, $doc, $resp) = @_; my $resource_list = HTTP::DAV::ResourceList->new; # # Parse I II III ### # Parse I my $node_multistatus = HTTP::DAV::Utils::get_only_element($doc, "D:multistatus"); ### # Parse III # Get the overarching responsedescription for the # multistatus and set it into the DAV:Response object. my $node_rd = HTTP::DAV::Utils::get_only_element($node_multistatus, "D:responsedescription"); if ($node_rd) { my $rd = $node_rd->getFirstChild->getNodeValue(); $resp->set_responsedescription($rd) if $rd; } ### # Parse II # Get all the responses in the multistatus element # my @nodes_response = HTTP::DAV::Utils::get_elements_by_tag_name($node_multistatus, "D:response"); # Process each response object # # Parse 1 2 2a 3 4 5 ### # Parse 1. for my $node_response (@nodes_response) { ### # Parse 2 and 2a (one or more hrefs) my @nodes_href = HTTP::DAV::Utils::get_elements_by_tag_name($node_response, "D:href"); # Get href my ($href, $href_a, $resource); foreach my $node_href (@nodes_href) { $href = $node_href->getFirstChild->getNodeValue(); # The href may be relative. If so make it absolute. # With the uri data "/mydir/myfile.txt" # And the uri of "this" object, "http://site/dir", # return "http://site/mydir/myfile.txt" # See the rules of URI.pm my $href_uri = HTTP::DAV::Utils::make_uri($href); my $res_url = $href_uri->abs($self->get_uri); # Just store the first one for later use $href_a = $res_url unless defined $href_a; # Create a new Resource to put into the list # Remove trailing slashes before comparing. #warn "Am about to compare $res_url and ". $self->get_uri . "\n" ; if (HTTP::DAV::Utils::compare_uris($res_url, $self->get_uri)) { $resource = $self; #warn " Exists. $resource\n"; } else { $resource = $self->get_client->new_resource(-uri => $res_url); $resource_list->add_resource($resource); #warn " New. $resource\n"; } } ### # Parse 3 and 5 # Get the values out of each Response # # my ($response_status, $response_rd) = $self->_XML_parse_status($node_response); if ($response_status) { $resp->add_status_line( $response_status, $response_rd, "$href_a:response:$node_response", $href_a ); } ### # Parse 4. # Get the propstat+ list to be processed below # Process each propstat object within this response # # # Parse a b c d ### # Parse a my @nodes_propstat = HTTP::DAV::Utils::get_elements_by_tag_name($node_response, "D:propstat"); # Unset any old properties $resource->_unset_properties(); foreach my $node_propstat (@nodes_propstat) { ### # Parse b my $node_prop = HTTP::DAV::Utils::get_only_element($node_propstat, "D:prop"); my $prop_hashref = $resource->_XML_parse_and_store_props($node_prop); ### # Parse c and d my ($propstat_status, $propstat_rd) = $self->_XML_parse_status($node_propstat); # If there is no rd for this propstat, then use the # enclosing rd from the actual response. $propstat_rd = $response_rd unless $propstat_rd; if ($propstat_status) { $resp->add_status_line( $propstat_status, $propstat_rd, "$href_a:propstat:$node_propstat", $href_a ); } } # foreach propstat } # foreach response #warn "\nEND MULTI:". $self->as_string . $resource_list->as_string; return $resource_list; } ### # This routine takes an XML node and: # Extracts the D:status and D:responsedescription elements. # If either of these exists, sets messages into the passed HTTP::DAV::Response object. # The handle should be unique. sub _XML_parse_status { my ($self, $node) = @_; # # my $node_status = HTTP::DAV::Utils::get_only_element($node, "D:status"); my $node_rd = HTTP::DAV::Utils::get_only_element($node, "D:responsedescription"); my $status = $node_status->getFirstChild->getNodeValue() if ($node_status); my $rd = $node_rd->getFirstChild->getNodeValue() if ($node_rd); return ($status, $rd); } ### # Pass in the XML::DOM prop node Element and it will # parse and store all of the properties. These ones # are specifically dealt with: # creationdate # getcontenttype # getcontentlength # displayname # getetag # getlastmodified # resourcetype # supportedlock # lockdiscovery # source sub _XML_parse_and_store_props { my ($self, $node) = @_; my %return_props = (); return unless ($node && $node->hasChildNodes()); # These elements will just get copied straight into our properties hash. my @raw_copy = qw( creationdate getlastmodified getetag displayname getcontentlength getcontenttype ); my $props = $node->getChildNodes; my $n = $props->getLength; for (my $i = 0; $i < $n; $i++) { my $prop = $props->item($i); # Ignore anything in the element which is # not an Element. i.e. ignore comments, text, etc... next if ($prop->getNodeTypeName() ne "ELEMENT_NODE"); my $prop_name = $prop->getNodeName(); $prop_name = HTTP::DAV::Utils::XML_remove_namespace($prop_name); if (grep (/^$prop_name$/i, @raw_copy)) { my $cdata = HTTP::DAV::Utils::get_only_cdata($prop); $self->set_property($prop_name, $cdata); } elsif ($prop_name eq "lockdiscovery") { my @locks = HTTP::DAV::Lock->XML_lockdiscovery_parse($prop); $self->set_locks(@locks); } elsif ($prop_name eq "supportedlock") { my $supportedlock_hashref = HTTP::DAV::Lock::get_supportedlock_details($prop); $self->set_property("supportedlocks", $supportedlock_hashref); } # Work in progress # elsif ( $prop_name eq "source" ) { # my $links = $self->_XML_parse_source_links( $prop ); # $self->set_property( "supportedlocks", $supportedlock_hashref ); # } #resourcetype and others else { my $node_name = HTTP::DAV::Utils::XML_remove_namespace( $prop->getNodeName()); my $str = ""; my @nodes = $prop->getChildNodes; foreach my $node (@nodes) { $str .= $node->toString; } $self->set_property($node_name, $str); } } ### # Cleanup work # set collection based on resourcetype #my $getcontenttype = $self->get_property("getcontenttype"); #($getcontenttype && $getcontenttype =~ /directory/i ) || my $resourcetype = $self->get_property("resourcetype"); if (($resourcetype && $resourcetype =~ /collection/i)) { $self->set_property("resourcetype", "collection"); my $uri = HTTP::DAV::Utils::make_trail_slash($self->get_uri); $self->set_uri($uri); } # Clean up the date work. my $creationdate = $self->get_property("creationdate"); if ($creationdate) { my ($epochgmt) = HTTP::Date::str2time($creationdate); $self->set_property("creationepoch", $epochgmt); $self->set_property("creationdate", HTTP::Date::time2str($epochgmt)); } my $getlastmodified = $self->get_property("getlastmodified"); if ($getlastmodified) { my ($epochgmt) = HTTP::Date::str2time($getlastmodified); $self->set_property("lastmodifiedepoch", $epochgmt); $self->set_property("lastmodifieddate", HTTP::Date::time2str($epochgmt)); } } sub _setup_custom_headers { my ($self, $headers, $custom_headers) = @_; if ($custom_headers && ref $custom_headers eq 'HASH') { for my $hdr_name (keys %{$custom_headers}) { my $hdr_value = $custom_headers->{$hdr_name}; warn "Setting custom header $hdr_name to '$hdr_value'\n" if $HTTP::DAV::DEBUG; $headers->header($hdr_name => $hdr_value); } } return; } ########################################################################### # $self->_setup_if_headers( $headers_obj, [0|1] ); # used by at least PUT,MKCOL,DELETE,COPY/MOVE sub _setup_if_headers { my ($self, $headers, $tagged) = @_; # Setup the If: header if it is locked my $tokens = $self->{_lockedresourcelist} ->get_locktokens(-uri => $self->get_uri, -owned => 1); $tagged = 1 unless defined $tagged; my $if = $self->{_lockedresourcelist}->tokens_to_if_header($tokens, $tagged); $headers->header("If", $if) if $if; warn "Setting if_header to \"If: $if\"\n" if $if && $HTTP::DAV::DEBUG; } ########################################################################### # Dump the objects contents as a string sub as_string { my ($self, $space, $depth) = @_; $depth = 1 if (!defined $depth || $depth eq ""); $space = "" unless $space; my $return; # Do lock only if ($depth == 2) { $return = "${space}'Url': "; $return .= $self->{_uri}->as_string . "\n"; foreach my $lock ($self->get_locks()) { $return .= $lock->pretty_print("$space "); } return $return; } $return .= "${space}Resource\n"; $space .= " "; $return .= "${space}'Url': "; $return .= $self->{_uri}->as_string . "\n"; $return .= "${space}'Options': " . $self->{_options} . "\n" if $self->{_options}; $return .= "${space}Properties\n"; foreach my $prop (sort keys %{ $self->{_properties} }) { next if $prop =~ /_ls$/; my $prop_val; if ($prop eq "supportedlocks" && $depth > 1) { use Data::Dumper; $prop_val = $self->get_property($prop); $prop_val = Data::Dumper->Dump([$prop_val], ['$prop_val']); } else { $prop_val = $self->get_property($prop); $prop_val =~ s/\n/\\n/g; } $return .= "${space} '$prop': $prop_val\n"; } if (defined $self->{_content}) { $return .= "${space}'Content':" . substr($self->{_content}, 0, 50) . "...\n"; } # DEEP PRINT if ($depth) { $return .= "${space}'_locks':\n"; foreach my $lock ($self->get_locks()) { $return .= $lock->as_string("$space "); } $return .= $self->{_resource_list}->as_string($space) if $self->{_resource_list}; } # SHALLOW PRINT else { $return .= "${space}'_locks': "; foreach my $lock ($self->get_locks()) { my $locktoken = $lock->get_locktoken(); my $owned = ($lock->is_owned) ? "owned" : "not owned"; $return .= "${space} $locktoken ($owned)\n"; } $return .= "${space}'_resource_list': " . $self->{_resource_list} . "\n"; } $return; } ###################################################################### # Dump myself as an 'ls' might. # Requires you to have already performed a propfind sub build_ls { my ($self, $parent_resource) = @_; # Build some local variables that have been sanitised. my $exec = $self->get_property("executable") || "?"; my $contenttype = $self->get_property("getcontenttype") || ""; my $supportedlocks = $self->get_property("supportedlocks") || (); my $epoch = $self->get_property("lastmodifiedepoch") || 0; my $size = $self->get_property("getcontentlength") || ""; my $is_coll = $self->is_collection() || "?"; my $is_lock = $self->is_locked() || "?"; # Construct a relative URI; my $abs_uri = $self->get_uri(); my $rel_uri = $abs_uri->rel($parent_resource->get_uri()); $rel_uri = uri_unescape($rel_uri); #### # Build up a long display name. # 1. my $lls = "URL: $abs_uri\n"; foreach my $prop (sort keys %{ $self->{_properties} }) { next if ($prop eq "lastmodifiedepoch" || $prop eq "creationepoch" || $prop eq "supportedlocks"); $lls .= "$prop: "; if ($prop =~ /Content-Length/) { $lls .= $self->get_property($prop) . " bytes"; } else { $lls .= $self->get_property($prop); } $lls .= "\n"; } # 2. Build a supportedlocks string if (defined $supportedlocks and ref($supportedlocks) eq "ARRAY") { my @supported_locks = @{$supportedlocks}; $supportedlocks = ""; foreach my $lock_type_hash (@supported_locks) { $supportedlocks .= $$lock_type_hash{'type'} . "/" . $$lock_type_hash{'scope'} . " "; } } else { $supportedlocks = '"No locking supported"'; } $lls .= "Locks supported: $supportedlocks\n"; # 3. Print all of the locks. my @my_locks = $self->get_locks(-owned => 1); my @not_my_locks = $self->get_locks(-owned => 0); if ($is_lock) { $lls .= "Locks: \n"; if (@my_locks) { $lls .= " My locks:\n"; foreach my $lock (@my_locks) { $lls .= $lock->pretty_print(" ") . "\n"; } } if (@not_my_locks) { $lls .= " Others' locks:\n"; foreach my $lock (@not_my_locks) { $lls .= $lock->pretty_print(" ") . "\n"; } } } else { $lls .= "Locks: Not locked\n"; } ###################################################################### #### # Build up a list of useful information $self->set_property('rel_uri', $rel_uri); my @props = (); push(@props, "") if ($exec eq "T"); push(@props, "") if ($is_coll eq "1"); push(@props, "") if ($is_lock eq "1"); $self->set_property('short_props', join(',', @props)); # Build a (short) display date in either # "Mmm dd yyyy" or "Mmm dd HH:MM" format. my $display_date = "?"; if ($epoch > 1) { my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($epoch); my %mons = ( 0 => 'Jan', 1 => 'Feb', 2 => 'Mar', 3 => 'Apr', 4 => 'May', 5 => 'Jun', 6 => 'Jul', 7 => 'Aug', 8 => 'Sep', 9 => 'Oct', 10 => 'Nov', 11 => 'Dec' ); $year += 1900; my $month = $mons{$mon}; # If the last modified time is older than six months # then display in "Mmm dd yyyy" format. # else display in "Mmm dd HH:MM" format. if (time - $epoch > (3600 * 24 * 30 * 6)) { $self->set_property( 'display_date', sprintf( "%3s %0.2d %4d", $month, $mday, $year ) ); } else { $self->set_property( 'display_date', sprintf( "%3s %0.2d %0.2d:%0.2d", $month, $mday, $hour, $min ) ); } } $self->set_property('long_ls', $lls); # Preset this, but it will be overwritten below # if it is a collection $self->set_property('short_ls', $lls); # Build the short listing if it is a collection if ($self->is_collection) { my $short = ""; $short .= "Listing of " . $self->get_uri() . "\n"; my $child_resource_list = $self->get_resourcelist; if (defined $child_resource_list) { my @resources = $child_resource_list->get_resources; foreach my $child_res (@resources) { $child_res->build_ls($self); } # Get the maximum uri length for pretty printing. my $max_uri_length = 0; my $max_bytes_length = 0; foreach my $r ($self, sort by_URI @resources) { my $l; $l = length($r->get_property('rel_uri')); $max_uri_length = $l if $l > $max_uri_length; $l = length($r->get_property('getcontentlength')); $max_bytes_length = $l if $l > $max_bytes_length; } # Print the listing foreach my $r ($self, sort by_URI @resources) { $short .= sprintf( " %${max_uri_length}s %${max_bytes_length}s %12s %s\n", $r->get_property('rel_uri'), $r->get_property('getcontentlength'), $r->get_property('display_date'), $r->get_property('short_props') ); } } # if defined resource_list $self->set_property('short_ls', $short); } sub by_URI { my $a_str = $a->get_uri; my $b_str = $b->get_uri; return $a_str cmp $b_str; } } 1; __END__ =head1 NAME HTTP::DAV::Resource - Represents and interfaces with WebDAV Resources =head1 SYNOPSIS Sample =head1 DESCRIPTION Description here =head1 CONSTRUCTORS =over 4 =item B Returns a new resource represented by the URI. $r = HTTP::DAV::Resource->new( -uri => $uri, -LockedResourceList => $locks, -Comms => $comms -Client => $dav_client ); On creation a Resource object needs 2 other objects passed in: 1. a C Object. This list will be added to if you lock this Resource. 2. a C Object. This object will be used for HTTP communication. 2. a C Object. This object is where all locks are stored =back =head1 METHODS =over 4 =item B Performs an HTTP GET and returns a DAV::Response object. $response = $resource->get; print $resource->get_content if ($response->is_success); =item B Performs an HTTP PUT and returns a DAV::Response object. $response = $resource->put( $string ); $string is be passed as the body. e.g. $response = $resource->put($string); print $resource->get_content if ($response->is_success); Will use a Lock header if this resource was previously locked. =item B Not implemented =item B Not implemented =item B Performs an HTTP DELETE and returns a DAV::Response object. $response = $resource->delete; print "Delete successful" if ($response->is_success); Will use a Lock header if this resource was previously locked. =item B Performs an HTTP OPTIONS and returns a DAV::Response object. $response = $resource->options; print "Yay for PUT!" if $resource->is_option("PUT"); =item B Performs a WebDAV MKCOL request and returns a DAV::Response object. $response = $resource->mkcol; print "MKCOL successful" if ($response->is_success); Will use a Lock header if this resource was previously locked. =item B xxx =item B Performs a WebDAV PROPFIND request and returns a DAV::Response object. $response = $resource->propfind; if ($response->is_success) { print "PROPFIND successful\n"; print $resource->get_property("displayname") . "\n"; } A successful PROPFIND fills the object with much data about the Resource. Including: displayname ... TODO =item B Performs a WebDAV LOCK request and returns a DAV::Response object. $resource->lock( -owner => "Patrick Collins", -depth => "infinity" -scope => "exclusive", -type => "write" -timeout => TIMEOUT', ) lock takes the following arguments. B - Indicates who locked this resource The default value is: DAV.pm/v$DAV::VERSION ($$) e.g. DAV.pm/v0.1 (123) If you use a URL as the owner, the module will automatically indicate to the server that is is a URL (http://...) B - Indicates the depth of the lock. Legal values are 0 or infinity. (1 is not allowed). The default value is infinity. 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. B - Indicates the scope of the lock. Legal DAV values are "exclusive" or "shared". The default value is exclusive. See section 6.1 of RFC2518 for a description of shared vs. exclusive locks. B - Indicates the type of lock (read, write, etc) The only legal DAV value currently is "write". The default value is write. B - Indicates when the lock will timeout The timeout value may be one of, an Absolute Date, a Time Offset from now, or the word "infinity". The default value is "infinity". The following are all valid timeout values: Time Offset: 30s 30 seconds from now 10m ten minutes from now 1h one hour from now 1d tomorrow 3M in three months 10y in ten years time Absolute Date: timeout at the indicated time & date (UTC/GMT) 2000-02-31 00:40:33 timeout at the indicated date (UTC/GMT) 2000-02-31 You can use any of the Absolute Date formats specified in HTTP::Date (see perldoc HTTP::Date) Note: the DAV server may choose to ignore your specified timeout. =item B Performs a WebDAV UNLOCK request and returns a DAV::Response object. $response = $resource->unlock() $response = $resource->unlock( -force => 1 ) $response = $resource->unlock( -token => "opaquelocktoken:1342-21423-2323" ) This method will automatically use the correct locktoken If: header if this resource was previously locked. B - Synonymous to calling $resource->forcefully_unlock_all. =item B Remove all locks from a resource and return the last DAV::Response object. This method take no arguments. $response = $resource->forcefully_unlock_all; 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 ). This unlock process is achievable because DAV does not enforce any security over locks. 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. Don't run with this knife, you could hurt someone (or yourself). =item B 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. $response = $resource->steal_lock; Synonymous to forcefully_unlock_all() and then lock(). =item B Discover the locks held against this resource and return a DAV::Response object. This method take no arguments. $response = $resource->lockdiscovery; @locks = $resource->get_locks if $response->is_success; This method is in fact a simplified version of propfind(). =item B Returns a string representation of the object. Mainly useful for debugging purposes. It takes no arguments. print $resource->as_string =back =head1 ACCESSOR METHODS (get, set and is) =over 4 =item B 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. if ($resource->is_option( "PUT" ) ) { $resource->put( ... ) } 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() =item B Returns a boolean indicating whether this resource is locked. @lock = $resource->is_locked( -owned=>[1|0] ); B - this parameter is used to ask, is this resource locked by me? Note: You must have already called propfind() or lockdiscovery() e.g. Is the resource locked at all? print "yes" if $resource->is_locked(); Is the resource locked by me? print "yes" if $resource->is_locked( -owned=>1 ); Is the resource locked by someone other than me? print "yes" if $resource->is_locked( -owned=>0 ); =item B Returns a boolean indicating whether this resource is a collection. print "Directory" if ( $resource->is_collection ); You must first have performed a propfind. =item B Returns the URI object for this resource. print "URL is: " . $resource->get_uri()->as_string . "\n"; See the URI manpage from the LWP libraries (perldoc URI) =item B Returns a property value. Takes a string as an argument. print $resource->get_property( "displayname" ); You must first have performed a propfind. =item B Returns an array of options allowed on this resource. Note: If $resource->options has not been called then it will return an empty array. @options = $resource->get_options =item B Returns the resource's content/body as a string. The content is typically the result of a GET. $content = $resource->get_content =item B Returns the resource's content/body as a reference to a string. This is useful and more efficient if the content is large. ${$resource->get_content_ref} =~ s/\bfoo\b/bar/g; Note: You must have already called get() =item B Returns the DAV::Lock object if it exists. Requires opaquelocktoken passed as a parameter. $lock = $resource->get_lock( "opaquelocktoken:234214--342-3444" ); =item B Returns a list of any DAV::Lock objects held against the resource. @lock = $resource->get_locks( -owned=>[1|0] ); B - this parameter indicates which locks you want. - '1', requests any of my locks. (Locked by this DAV instance). - '0' ,requests any locks not owned by us. - any other value or no value, requests ALL locks. Note: You must have already called propfind() or lockdiscovery() e.g. Give me my locks @lock = $resource->get_locks( -owned=>1 ); Give me all locks @lock = $resource->get_locks(); =item B =item B =item B =item B $resource->set_parent_resourcelist( $resourcelist ) Sets the parent resource list (ask the question, which collection am I a member of?). See L. =back =cut HTTP-DAV-0.50/lib/HTTP/DAV/Comms.pm0000644000175000017500000003311114703664237015557 0ustar cosimocosimopackage HTTP::DAV::Comms; use strict; use vars qw($VERSION $DEBUG); $VERSION = q(0.23); use HTTP::DAV::Utils; use HTTP::DAV::Response; use LWP; use URI; #### # Construct a new object and initialize it sub new { my $class = shift; my $self = bless {}, ref($class) || $class; #print Data::Dumper->Dump( [$self] , [ '$self' ] ); $self->_init(@_); return $self; } # Requires a reusable HTTP Agent. # and some default headers, like, the user agent sub _init { my ( $self, @p ) = @_; my ( $headers, $useragent ) = HTTP::DAV::Utils::rearrange( [ 'HEADERS', 'USERAGENT' ], @p ); # This is cached in this object here so that each http request # doesn't have to invoke a new useragent. $self->init_user_agent($useragent); $self->set_headers($headers); } sub init_user_agent { my ( $self, $useragent ) = @_; if ( defined $useragent ) { $self->{_user_agent} = $useragent; } else { $self->{_user_agent} = HTTP::DAV::UserAgent->new; $self->set_agent("DAV.pm/v$HTTP::DAV::VERSION"); } } #### # GET/SET # Sets a User-Agent as specified by user or as the default sub set_agent { my ( $self, $agent ) = @_; $self->{_user_agent}->agent($agent); } sub set_header { my ( $self, $var, $val ) = @_; $self->set_headers() unless defined $self->{_headers}; $self->{_headers}->header( $var, $val ); } sub get_user_agent { $_[0]->{_user_agent}; } sub get_headers { $_[0]->{_headers}; } sub set_headers { my ( $self, $headers ) = @_; my $dav_headers; if ( defined $headers && ref($headers) eq "HTTP::Headers" ) { $dav_headers = HTTP::DAV::Headers->clone($headers); } elsif (defined $headers && ref($headers) eq "HASH") { $dav_headers = HTTP::DAV::Headers->new(); for (keys %{ $headers }) { $dav_headers->header($_ => $headers->{$_}); } } else { $dav_headers = HTTP::DAV::Headers->new; } $self->{_headers} = $dav_headers; } sub _set_last_request { $_[0]->{_last_request} = $_[1]; } sub _set_last_response { $_[0]->{_last_response} = $_[1]; } # Save the Server: header line into this object instance # We will want to use it later to workaround server bugs. # For instance mod_dav has a bug in the Destination: header # whereby it incorrectly throws "Bad Gateway" errors. # The only way we can munge around this is if the copy() routine # has some idea of the server it is talking to. # So this routine stores the "Server: Apache..." line into a host:port hash (i.e. localhost:443). # so $comms->_set_server_type( "host.org:443", "Apache/1.3.22 (Unix) DAV/1.0.2 ") # yields # %_server_type = { # "host.org:443" => "Apache/1.3.22 (Unix) DAV/1.0.2 SSL" # "host.org:80" => "Apache/1.3.22 (Unix) DAV/1.0.2 " # }; # Note that this is an instance hash NOT a class hash. # So each comms object will be learning independently. sub _set_server_type { $_[0]->{_server_type}{ $_[1] } = $_[2]; } # $server = $comms->get_server_type( "host.org:443" ) sub get_server_type { $_[0]->{_server_type}{ $_[1] } } # Returns an HTTP::Request object sub get_last_request { $_[0]->{_last_request}; } # Returns an HTTP::DAV::Response object sub get_last_response { $_[0]->{_last_response}; } #### # Ensure there is a Host: header based on the URL # sub do_http_request { my ( $self, @p ) = @_; my ( $method, $url, $newheaders, $content, $save_to, $callback_func, $chunk ) = HTTP::DAV::Utils::rearrange( [ 'METHOD', [ 'URL', 'URI' ], 'HEADERS', 'CONTENT', 'SAVE_TO', 'CALLBACK', 'CHUNK' ], @p ); # Method management if ( !defined $method || $method eq "" || $method !~ /^\w+$/ ) { die "Incorrect HTTP Method specified in do_http_request: \"$method\""; } $method = uc($method); # URL management my $url_obj; $url_obj = ( ref($url) =~ /URI/ ) ? $url : URI->new($url); die "Comms: Bad HTTP Url: \"$url_obj\"\n" if ( $url_obj->scheme !~ /^http/ ); # If you see user:pass detail embedded in the URL. Then get it out. if ( $url_obj->userinfo ) { $self->{_user_agent} ->credentials( $url, undef, split( ':', $url_obj->userinfo ) ); } # Header management if ( $newheaders && ref($newheaders) !~ /Headers/ ) { die "Bad headers object: " . Data::Dumper->Dump( [$newheaders], ['$newheaders'] ); } my $headers = HTTP::DAV::Headers->new(); $headers->add_headers( $self->{_headers} ); $headers->add_headers($newheaders); #$headers->header("Host", $url_obj->host); $headers->header( "Host", $url_obj->host_port ); my $length = ($content) ? length($content) : 0; $headers->header( "Content-Length", $length ); #print "HTTP HEADERS\n" . $self->get_headers->as_string . "\n\n"; # It would be good if, at this stage, we could prefill the # username and password values to prevent the client having # to submit 2 requests, submit->401, submit->200 # This is the same kind of username, password remembering # functionality that a browser performs. #@userpass = $self->{_user_agent}->get_basic_credentials(undef, $url); # Add a Content-type of text/xml if the body has header( "Content-Type", "text/xml" ); } #### # Do the HTTP call my $req = HTTP::Request->new( $method, $url_obj, $headers->to_http_headers, $content ); # It really bugs me, but libwww-perl doesn't honour this call. # I'll leave it here anyway for future compatibility. $req->protocol("HTTP/1.1"); my $resp; # If a callback is set and it is a ref to a function # then pass it through to LWP::UserAgent::request. # See man page of LWP for more details of callback. # callback is primarily used by DAV::get(); # if ( defined $save_to && $save_to ne "" ) { $resp = $self->{_user_agent}->request( $req, $save_to ); } elsif ( ref($callback_func) =~ /CODE/ ) { $resp = $self->{_user_agent}->request( $req, $callback_func, $chunk ); } else { $resp = $self->{_user_agent}->request($req); } # Redirect loop {{{ my $code = $resp->code; if ( $code == &HTTP::Status::RC_MOVED_PERMANENTLY or $code == &HTTP::Status::RC_MOVED_TEMPORARILY ) { # And then we update the URL based on the Location:-header. my ($referral_uri) = $resp->header('Location'); { # Some servers erroneously return a relative URL for redirects, # so make it absolute if it not already is. local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; my $base = $resp->base; $referral_uri = $HTTP::URI_CLASS->new( $referral_uri, $base )->abs($base); } # Check for loop in the redirects my $count = 0; my $r = $resp; my $bad_loop = 0; while ($r) { if ( ++$count > 13 || $r->request->url->as_string eq $referral_uri->as_string ) { $resp->header( "Client-Warning" => "Redirect loop detected" ); #if ( $HTTP::DAV::DEBUG ) { # print "*** CLIENT AND SERVER STUCK IN REDIRECT LOOP OR MOVED PERMENANTLY. $count. BREAKING ***\n"; # print "*** " . $r->request->url->as_string . "***\n"; # print "*** " . $referral_uri->as_string . "***\n"; #} $bad_loop = 1; last; } $r = $r->previous; } $resp = $self->do_http_request( -method => $method, -url => $referral_uri, -headers => $newheaders, -content => $content, -saveto => $save_to, -callback => $callback_func, -chunk => $chunk, ) unless $bad_loop; } # }}} if ($HTTP::DAV::DEBUG > 1) { no warnings; #open(DEBUG, ">&STDOUT") || die ("Can't open STDERR");; my $old_umask = umask 0077; open( DEBUG, ">>/tmp/perldav_debug.txt" ); print DEBUG "\n" . "-" x 70 . "\n"; print DEBUG localtime() . "\n"; print DEBUG "$method REQUEST>>\n" . $req->as_string(); if ( $resp->headers->header('Content-Type') =~ /xml/ ) { my $body = $resp->as_string(); #$body =~ s/>\n*/>\n/g; print DEBUG "$method XML RESPONSE>>$body\n"; #} elsif ( $resp->headers->header('Content-Type') =~ /text.html/ ) { #require HTML::TreeBuilder; #require HTML::FormatText; #my $tree = HTML::TreeBuilder->new->parse($resp->content()); #my $formatter = HTML::FormatText->new(leftmargin => 0); #print DEBUG "$method RESPONSE (HTML)>>\n" . $resp->headers->as_string(); #print DEBUG $formatter->format($tree); } else { print DEBUG "$method RESPONSE>>\n" . $resp->as_string(); } close DEBUG; umask $old_umask; } #### # Copy the HTTP:Response into a HTTP::DAV::Response. It specifically # knows details about DAV Status Codes and their associated # messages. my $dav_resp = HTTP::DAV::Response->clone_http_resp($resp); $dav_resp->set_message( $resp->code ); #### # Save the req and resp objects as the "last used" $self->_set_last_request($req); $self->_set_last_response($dav_resp); $self->_set_server_type( $url_obj->host_port, $dav_resp->headers->header("Server") ); return $dav_resp; } sub credentials { my ( $self, @p ) = @_; my ( $user, $pass, $url, $realm ) = HTTP::DAV::Utils::rearrange( [ 'USER', 'PASS', 'URL', 'REALM' ], @p ); $self->{_user_agent}->credentials( $url, $realm, $user, $pass ); } ########################################################################### # We make our own specialization of LWP::UserAgent # called HTTP::DAV::UserAgent. # The variations allow us to have various levels of protection. # Where the user hasn't specified what Realm to use we pass the # userpass combo to all realms of that host # Also this UserAgent remembers a user on the next request. # The standard UserAgent doesn't. { package HTTP::DAV::UserAgent; use strict; use vars qw(@ISA); @ISA = qw(LWP::UserAgent); #require LWP::UserAgent; sub new { my $self = LWP::UserAgent::new(@_); $self->agent("lwp-request/$HTTP::DAV::VERSION"); $self; } sub credentials { my ( $self, $netloc, $realm, $user, $pass ) = @_; $realm = 'default' unless $realm; if ($netloc) { $netloc = "http://$netloc" unless $netloc =~ m{^http}; my $uri = URI->new($netloc); $netloc = $uri->host_port; } else { $netloc = 'default'; } { no warnings; if ($HTTP::DAV::DEBUG > 2) { if (defined $user) { print "Setting auth details for $netloc, $realm to '$user', '$pass'\n"; } else { print "Resetting user and password for $netloc, $realm\n"; } } } # Pay attention to not autovivify the hash value (RT #47500) my $cred; if ( exists $self->{basic_authentication}->{$netloc} && exists $self->{basic_authentication}->{$netloc}->{$realm}) { $cred = $self->{basic_authentication}->{$netloc}->{$realm}; } else { $cred = []; } # Replace with new credentials (if any) if (defined $user) { $self->{basic_authentication}->{$netloc}->{$realm}->[0] = $user; $self->{basic_authentication}->{$netloc}->{$realm}->[1] = $pass; $cred = $self->{basic_authentication}->{$netloc}->{$realm}; } # Return current values if (! @{$cred}) { return wantarray ? () : undef; } # User/password pair if (wantarray) { return @{$cred} } # As string: 'user:password' return join( ':', @{$cred} ); } sub get_basic_credentials { my ( $self, $realm, $uri ) = @_; $uri = HTTP::DAV::Utils::make_uri($uri); my $netloc = $uri->host_port; my $userpass; { no warnings; # SHUTUP with your silly warnings. $userpass = $self->{'basic_authentication'}{$netloc}{$realm} || $self->{'basic_authentication'}{default}{$realm} || $self->{'basic_authentication'}{$netloc}{default} || []; print "Using user/pass combo: @$userpass. For $realm, $uri\n" if $HTTP::DAV::DEBUG > 2; } return @$userpass; } # Override to disallow redirects. Also, see RT #19616 sub redirect_ok { return 0; } } ########################################################################### # We make our own special version of HTTP::Headers # called HTTP::DAV::Headers. This is because we want to add # a new method called add_headers { package HTTP::DAV::Headers; use strict; use vars qw(@ISA); @ISA = qw( HTTP::Headers ); require HTTP::Headers; # $dav_headers = HTTP::DAV::Headers->clone( $http_headers ); sub to_http_headers { my ($self) = @_; my %clone = %{$self}; bless {%clone}, "HTTP::Headers"; } sub clone { my ( $class, $headers ) = @_; my %clone = %{$headers}; bless {%clone}, ref($class) || $class; } sub add_headers { my ( $self, $headers ) = @_; return unless ( defined $headers && ref($headers) =~ /Headers/ ); #print "About to add headers!!\n"; #print Data::Dumper->Dump( [$headers] , [ '$headers' ] ); foreach my $key ( sort keys %$headers ) { $self->header( $key, $headers->{$key} ); } } } 1; HTTP-DAV-0.50/lib/HTTP/DAV/Changes.pod0000644000175000017500000002364014703665135016223 0ustar cosimocosimo=for html

Revision history for HTTP::DAV

=begin text Revision history for HTTP::DAV =end text =head2 v0.50 (released 2024/10/16): =over 4 =item * B Fixed missing custom headers when calling PUT methods. Closes C. Thanks Georg Acher for the patch and for patiently waiting a decade (!) for a fix. =back =head2 v0.49 (released 2018/11/28): =over 4 =item * B Fixed perl shebang line in C script, for ExtUtils::MakeMaker to correctly replace it. Closes C. Fixed C response handling to also consider successful an HTTP 207 status code. Closes C. Fixed C method to properly respect the class name. Closes C. Thanks to Ricardo Signes for the patch. =item * B Fixed various pod issues raised by Debian contributor C. Closes C. =back =head2 v0.48 (released 2015/03/26): =over 4 =item * B C, fixed faulty code to add trailing slash to URLs. =back =head2 v0.47 (released 2012/03/24): =over 4 =item * B Improve C resilience when server response contains broken, truncated or no XML at all. RT#75011. =back =head2 v0.46 (released 2012/01/11): =over 4 =item * B HTTP::DAV should now be working with more WebDAV servers. We are more flexible in what content types we consider to be XML. Thanks Ron1 and Adam for the feedback and patches. =back =head2 v0.45 (released 2011/09/18): =over 4 =item * B - Fixed RT #69439 (http://rt.cpan.org/Public/Bug/Display.html?id=69439), insecure /tmp files handling in dave client. =item * B - Added -tmpdir option to dave client. - Reorganized distribution layout to match usual CPAN practice - Removed remains of svn-era ($Id and such...) =back =head2 v0.44 (released 2011/06/19): =over 4 =item * B - Fixed RT #68936 (http://rt.cpan.org/Public/Bug/Display.html?id=68936), Fixed errors() method that would bomb out when the "_errors" attribute wasn't initialized. Thanks to Michael Lackoff for reporting. =back =head2 v0.43 (released 2011/04/12): =over 4 =item * B - Fixed RT #38677 (http://rt.cpan.org/Public/Bug/Display.html?id=38677), Intercept correctly 405 (Method now allowed) errors and report them to the clients. =back =head2 v0.42 (released 2010/11/07): =over 4 =item * B - Fixed RT #60457 (http://rt.cpan.org/Public/Bug/Display.html?id=60457), Added and documented possibility to pass your own custom HTTP headers. - Fixed errors in the code examples in the synopsis. =back =head2 v0.41 (released 2010/07/24): =over 4 =item * B - Fixed RT #59674 (http://rt.cpan.org/Public/Bug/Display.html?id=59674), When SSL support is needed but not installed, a more specific error messages is now displayed, instead of "not DAV enabled or not accessible". =back =head2 v0.40 (released 2010/01/27): =over 4 =item * B - Fixed RT #47500 (http://rt.cpan.org/Public/Bug/Display.html?id=47500), HTTP::DAV::Comms->credentials() method erroneously autovivified basic authentication internal values, causing wrong or undefined credentials to be sent out, or credentials to be "forgot" by HTTP::DAV. =back =head2 v0.39 (released 2009/12/12): =over 4 =item * B - Fixed RT #52665 (http://rt.cpan.org/Public/Bug/Display.html?id=52665), Using dave or propfind() on URLs containing escaped chars (%xx) could fail, due to upper/lower case differences. Thanks to cebjyre for the patch and the test case. =back =head2 v0.38 (released 2009/06/09): =over 4 =item * B - Fixed RT #14506 (http://rt.cpan.org/Public/Bug/Display.html?id=14506), about the missing get_lastresponse() method. It was a documentation bug. - Fixed RT #29788 (http://rt.cpan.org/Public/Bug/Display.html?id=29788), avoid file corruptions on Win32 when calling HTTP::DAV::get() method. - Fixed RT #31014 (http://rt.cpan.org/Public/Bug/Display.html?id=31014), probably already in v0.34, since it seems related to propfind() "depth" bug. =back =head2 v0.37 (released 2009/03/24): =over 4 =item * B - Fixed RT #44409 (http://rt.cpan.org/Public/Bug/Display.html?id=44409), Small bug in HTTP::DAV::put(). Passing a reference as local content resulted in the "SCALAR(0x12345678)" being logged instead of the real scalar. =back =head2 v0.36 (released 2009/02/25): =over 4 =item * B - Fixed RT #19616 (http://rt.cpan.org/Public/Bug/Display.html?id=19616), LWP::UserAgent::redirect_ok() is not changed anymore. We're subclassing it from HTTP::DAV::UserAgent and overriding redirect_ok() there. - Fixed RT #42877 (http://rt.cpan.org/Public/Bug/Display.html?id=42877), HTTP::DAV::UserAgent::credentials() has been modified to behave like LWP::UserAgent::credentials(), otherwise basic authentication breakages can occur. - Fixed a problem with C<-depth> argument to C that could lead to massive performance degradation, especially when running C against large folders. C<-depth> was set to 1 even when passed as zero. =back =head2 v0.35 (released 2008/11/03): =over 4 =item * B - Fixed RT #40318 (http://rt.cpan.org/Public/Bug/Display.html?id=40318), about getting single or multiple files directly to \*STDOUT. =back =head2 v0.34 (released 2008/09/11): =over 4 =item * B - Fixed RT #39150 (http://rt.cpan.org/Public/Bug/Display.html?id=39150), about downloading multiple files in the same directory. =back =head2 v0.33 (released 2008/08/24): =over 4 =item * B - Clearly state that opera software asa is now co-maintainer of http::dav - Fixed various inconsistencies in the v0.32 documentation =back =head2 v0.32 (released 2008/08/24): =over 4 =item * B - Now HTTP::DAV requires Perl 5.6.0+ and Scalar::Util (core in 5.8.x). =item * B - Now HTTP::DAV objects are correctly released from memory when they go out of scope. Now it should be possible to use multiple instances of HTTP::DAV even in long-running processes. Was caused by circular references between HTTP::DAV and HTTP::DAV::Resource. =back =head2 v0.31 (released 2002/04/13): =over 4 =item * B - Now works with mod_dav under Apache 2. =item * B - Fixed bug to correctly handle the put/get of filenames with spaces in them. - Fixed bug to allow the PUT of empty files. - put() now uses binmode so that it works under Windows. - HTTP redirect code added in the previous release was incorrectly returning a HTTP::Response instead of a HTTP::DAV::Response - Fixed bug to allow https for copy and move (http:// was hardcoded). - Fixed strange copy/move bug for Apache2.0's mod_dav. =back =head2 v0.29 (released 2001/10/31): =over 4 =item * B https support as provided from the underlying LWP library has been tested against mod_dav and mod_ssl. Seems to work well. See INSTALLATION for more detail. =item * B Requires MD5 to be installed. See INSTALLATION notes. =item * B =item * B Useful for giving progress indicators. =item * B the get() routine now allows you to pass by reference a filehandle or scalar in which to save the contents of the GET request. =item * B Thanks to Jeremy for this patch. =item * B Thanks to Jeremy for this patch. =back =head2 v0.23 (released 2001/09/07): =over 4 =item * B HTTP::DAV::get() and HTTP::DAV::put() now supports file globs. This functionality also propagates to dave. This allows you to do the following: dav> put /tmp/index*.html dav> get index[12].htm? /tmp ?,* and sets ([]) are supported. See the docs for details. HTTP::DAV now requires the Perl module File::Glob which comes bundled with perl5.6 and later. =item * bug fix in -overwrite flag in HTTP::DAV::copy/move. =back =head2 v0.22 (released 2001/09/03) Complete overhaul of API, recursive get and put, addition of dave. =over 4 =item * B I wrote dave (the DAV Explorer) because I needed an end-user application that allowed me to "feel" how well the HTTP::DAV API was performing. dave is quite similar to Joe Orton's C-based DAV client called cadaver (yes, imitation is the best form of flattery). =item * B This new API is accessed directly through the HTTP::DAV module and is based on the core API written in previous releases. =item * B The new API now supports, proppatch, recursive get and put. =item * B Moving from v0.05 to v0.22 in one release might indicate the amount of work gone into this release. =item * B is now included in PerlDAV. The test suite is built on top of the standard Perl Test::Harness modules. Still in development, the test suite is highlighting interoperability problems with DAV-servers a lot quicker than before. See L section. =back =head2 v0.05 (released 2001/07/24) General bug fixes and addition of proppatch - added PROPPATCH method to HTTP::DAV::Resource, thanks to Sylvain Plancon. - fixed uninitialized warnings in test scripts. - fixed new lock bug in DAV::Lock, thanks to Ben Evans - fixed dumb mistake where PUT was calling get instead of put, thanks to Sylvain and Ben again. - fixed call to Utils::bad, thanks to Sylvain =head2 v0.04 (released 2000/04/25) Initial Release - supports PUT,GET,MLCOL,DELETE,OPTIONS,PROPFIND,LOCK,UNLOCK,steal_lock,lock_discovery =for text ** This file was automatically generated from ** ** doc/Changes.pod. To edit it, see there. ** =for html
HTTP-DAV-0.50/lib/HTTP/DAV/Utils.pm0000644000175000017500000002017214703664237015604 0ustar cosimocosimopackage HTTP::DAV::Utils; use strict; use vars qw($VERSION); $VERSION = '0.11'; ########################################################################### # Borrowed from Lincoln Stein's CGI.pm # Smart rearrangement of parameters to allow named parameter # calling. We do the rearangement if: # 1. The first parameter begins with a - # 2. The use_named_parameters() method returns true sub rearrange { my($order,@param) = @_; return () unless @param; # IF the user has passed a hashref instead of a hash then flatten it out. if (ref($param[0]) eq 'HASH') { @param = %{$param[0]}; } else { # If the user has specified that they will be explicitly # using named_parameters (by setting &use_named_parameters(1)) # or the first parameter starts with a -, then continue. # Otherwise just return the parameters as they were given to us. return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-') || &use_named_parameters(); } # map parameters into positional indices my ($i,%pos); $i = 0; foreach (@$order) { foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; } $i++; } my (@result,%leftover); $#result = $#$order; # preextend while (@param) { my $key = uc(shift(@param)); $key =~ s/^\-//; if (exists $pos{$key}) { $result[$pos{$key}] = shift(@param); } else { $leftover{$key} = shift(@param); } } push (@result,&make_attributes(\%leftover)) if %leftover; @result; } #### Method: use_named_parameters # Borrowed from Lincoln Stein's CGI.pm # Force DAV.pm to use named parameter-style method calls # rather than positional parameters. The same effect # will happen automatically if the first parameter # begins with a -. my $named=0; sub use_named_parameters { my($use_named) = shift; return $named unless defined ($use_named); # stupidity to avoid annoying warnings return $named = $use_named; } # Borrowed from Lincoln Stein's CGI.pm sub make_attributes { my($attr) = @_; return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; my(@att); foreach (keys %{$attr}) { my($key) = $_; $key=~s/^\-//; # get rid of initial - if present $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/); } return @att; } ########################################################################### sub bad { my($str) = @_; print STDERR "Error: $str\n"; exit; } sub bad_node { my($node,$str) = @_; print STDERR "XML error in " . $node->getNodeName . ": $str"; print STDERR "\n"; print STDERR "DUMP:\n"; print STDERR $node->toString if $node; exit; } ########################################################################### # This method searches for any text-based data in the children of # the node supplied. It will croak if the node has anything other # than text values (such as Elements or Comments). sub get_only_cdata { my($node) = @_; my $return_cdata = ""; my $nodes = $node->getChildNodes(); my $n = $nodes->getLength; for (my $i = 0; $i < $n; $i++) { my $node = $nodes->item($i); if ( $node->getNodeTypeName eq "TEXT_NODE" ) { $return_cdata .= $node->getNodeValue; } else { #bad_node($node, "node has non TEXT children"); } } return $return_cdata; } # This is a sibling to the XML::DOM's getElementsByTagName(). # The main difference here is that it ignores the namespace # component of the element. This was done because it # Takes a node and returns a list of nodes. # Note that the real getElementsByTagName allows you to # specify recurse or not. This routine doesn't allow recurse. sub get_elements_by_tag_name { my ($node, $elemname ) = @_; return unless $node; my @return_nodes; # This is gruesome. Because we don't yet support namespaces, it # just lops off the first half of the Element name $elemname =~ s/.*?:(.*)$/$1/g; my $nodelist = $node->getChildNodes(); my $length = $nodelist->getLength(); for ( my $i=0; $i < $length; $i++ ) { my $node = $nodelist->item($i); # Debian change? if ( $node->getNodeName() =~ /(?:^|:)$elemname$/ ) { push(@return_nodes,$node); } } return @return_nodes; } sub get_only_element { my($node,$elemname) = @_; return unless $node; # Find the one child element of a specific name if ( $elemname ) { # This is gruesome. Because we don't yet support namespaces, it # just lops off the first half of the Element name. $elemname =~ s/.*?:(.*)$/$1/g; #my $nodes = $node->getElementsByTagName($elemname,0); my $nodelist = $node->getChildNodes(); my $length = $nodelist->getLength(); for ( my $i=0; $i < $length; $i++ ) { my $node = $nodelist->item($i); return $node if $node->getNodeName() =~ /$elemname/; } # if ( $nodes->getLength > 1 ) { # bad_node($node, "Too many \"$elemname\" in node"); # } elsif ( $nodes->getLength < 1 ) { # return; # #bad_node($node, "No node found matching \"$elemname\" in node"); # } # return $nodes->item(0); # Just get the first child element. } else { my $nodelist = $node->getChildNodes(); my $length = $nodelist->getLength(); for ( my $i=0; $i < $length; $i++ ) { my $node = $nodelist->item($i); if ($node->getNodeTypeName eq "ELEMENT_NODE" ) { return $nodelist->item($i); } } } } ########################################################################### sub XML_remove_namespace { #print "XML: $_[0] -> "; $_[0] =~ s/.*?:(.*)/$1/g; #$_[0] =~ s/(.*?)\s.*/$1/g; #print "$_[0]\n"; return $_[0]; } ########################################################################### sub make_uri { my $uri = shift; if (ref($uri) =~ /URI/) { $uri = $uri->as_string; } # Remove double slashes from the url $uri = URI->new($uri); my $path = $uri->path; $path =~ s{//}{/}g; #print "make_uri: $uri->$path\n"; $uri->path($path); #print "make_uri: $uri\n"; return $uri; } sub make_uri_canonical { $_ = make_uri(shift); s{/$}{}; s{(%[0-9a-fA-F][0-9a-fA-F])}{lc $1}eg; return $_; } sub make_trail_slash { my ($uri) = @_; $uri =~ s{/*$}{}g; $uri .= '/'; return $uri; } sub compare_uris { my ($uri1,$uri2) = @_; return make_uri_canonical($uri1) eq make_uri_canonical($uri2); } # This subroutine takes a URI and gets the last portion # of it: the filename. # e.g. /dir1/dir2/file.txt => file.txt # /dir1/dir2/ => dir2 # / => undef sub get_leafname { my($url) = shift; my $leaf; ($url,$leaf) = &split_leaf($url); return $leaf; } # This subroutine takes a URI and splits the leaf from the path. # It returns both. # of it: the filename. # e.g. /dir1/dir2/file.txt => file.txt # /dir1/dir2/ => dir2 # / => undef sub split_leaf { my($url) = shift; $url =~ s#[\/\\]$##; #Remove trailing slashes. $url = HTTP::DAV::Utils::make_uri($url); # Remove the leaf from the path. my $path = $url->path_query(); my @path = split(/[\/\\]+/,$path); my $leaf = pop @path || ""; $path = join('/',@path); #Now put the path back into the URL. $url->path_query($path); return ($url,$leaf); } # Turns a file-oriented glob # into a regular expression. # BTW, I recommend you eval any regex command you use on # this outputted regex value. # If somebody types uses an incorrect glob and you try to /$regex/ it # then perl will bomb with a fatal regex error. # For instance, /file[ab.txt/ would bomb. sub glob2regex { my($f) = @_; # Turn the leafname glob into a regex. # Substitute \ for \\ # Substitute . for \. # Substitute * for .* # Substitute ? for . # No need to substitute [...] $f =~ s/\\/\\\\/g; $f =~ s/\./\\./g; $f =~ s/\*/.*/g; $f =~ s/\?/./g; print "Glob regex becomes $f\n" if $HTTP::DAV::DEBUG>1; return $f; } 1; HTTP-DAV-0.50/lib/HTTP/DAV/Response.pm0000644000175000017500000002355214703664237016307 0ustar cosimocosimopackage HTTP::DAV::Response; use strict; use vars qw(@ISA $VERSION); $VERSION = '0.14'; require HTTP::Response; @ISA = qw(HTTP::Response); my %dav_status_codes = ( 102 => "Processing. Server has accepted the request, but has not yet completed it", 204 => "No Content", 207 => "Multistatus", 422 => "Unprocessable Entity. Bad client XML sent?", 423 => "Locked. The source or destination resource is locked", 424 => "Failed Dependency", 507 => "Insufficient Storage. The server is unable to store the request", ); # PROTECTED METHODS sub clone_http_resp { my ($class,$http_resp) = @_; my %clone = %{$http_resp}; my $self = \%clone; bless $self, (ref($class) || $class); } # This routine resets the base # message in the # object based on the # code and the status_codes above. # set_message('207'); sub set_message { my ($self,$code) = @_; # Set the status code if ( defined $dav_status_codes{$code} ) { $self->message( $dav_status_codes{$code} ); } } sub set_responsedescription { $_[0]->{'_dav_responsedescription'} = $_[1] if $_[1]; } sub get_responsedescription { $_[0]->{'_dav_responsedescription'}; } sub add_status_line { my($self,$message,$responsedescription,$handle,$url) = @_; # Parse "status-line". See section 6.1 of RFC 2068 # Status-Line= HTTP-Version SP Status-Code SP Reason-Phrase CRLF if (defined $message && $message =~ /^(.*?)\s(.*?)\s(.*?)$/ ) { my ($http_version,$status_code,$reason_phrase) = ($1,$2,$3); push ( @{$self->{_dav_multistatus}}, { 'handle' => $handle, 'url' => $url, 'HTTP Version' => $http_version, 'code' => $status_code, 'message' => $reason_phrase, 'description' => $responsedescription, } ); return 1; } else { return 0; } } # PUBLIC METHODS sub is_multistatus { return ($_[0]->code eq "207" )? 1:0; } sub messages { my ($self) = @_; my @messages = (); if ($self->is_multistatus() ) { foreach my $num ( 0 .. $self->response_count()) { push(@messages, $self->message_bynum($num)); } } else { push(@messages,$self->message()); } return wantarray ? @messages : join("\n",@messages); } sub codes { my ($self) = @_; my @codes = (); if ($self->is_multistatus() ) { foreach my $num ( 0 .. $self->response_count()) { push(@codes, $self->code_bynum($num)); } } else { push(@codes,$self->code()); } return \@codes; } sub response_count { return -1 unless exists $_[0]->{_dav_multistatus}; return -1 unless ref($_[0]->{_dav_multistatus}) =~ /ARRAY/; return $#{$_[0]->{_dav_multistatus}}; } sub message_bynum { $_[0]->{_dav_multistatus}[$_[1]]{'message'}; } sub code_bynum { $_[0]->{_dav_multistatus}[$_[1]]{'code'}; } sub url_bynum { $_[0]->{_dav_multistatus}[$_[1]]{'url'}; } sub description_bynum { $_[0]->{_dav_multistatus}[$_[1]]{'description'}; } sub response_bynum { my ($self,$number) = @_; if (defined $number && $number>=0 ) { return ( $self->code_bynum($number), $self->message_bynum($number), $self->url_bynum($number), $self->description_bynum($number), ); } } sub is_success { my ($self) = @_; if ($self->is_multistatus() ) { foreach my $code ( @{ $self->codes() } ) { return 0 if ( HTTP::Status::is_error($code) ); } } else { return ($self->SUPER::is_success() || 0); } return 1; } sub as_string { my ($self) = @_; my ($ms, $returnstr) = ""; # use Data::Dumper; # print Data::Dumper->Dump( [\$self] , [ '$self' ] ); foreach my $num ( 0 .. $self->response_count() ) { my %h = %{$self->{_dav_multistatus}[$num]}; $ms .= "Error number $num ($h{handle}):\n"; $ms .= " Href: $h{url}\n" if defined $h{url}; $ms .= " Mesg(code): $h{message} ($h{code})\n" if defined $h{code}; $ms .= " Desc: $h{'description'}\n" if defined $h{'description'}; $ms .= "\n"; } my $rd = $self->get_responsedescription() || ""; $returnstr .= "Multistatus lines:\n$ms\n" if $ms; $returnstr .= "Overall responsedescription: \"$rd\"\n" if $rd; $returnstr .= $self->SUPER::as_string; $returnstr; } =head1 NAME HTTP::DAV::Response - represents a WebDAV HTTP Response (ala HTTP::Response) =head1 SYNOPSIS require HTTP::DAV::Response; =head1 DESCRIPTION The HTTP::DAV::Response class encapsulates HTTP style responses. A response consists of a response line, some headers, and (potentially empty) content. HTTP::DAV::Response is a subclass of C and therefore inherits its methods. (HTTP::Response in turn inherits it's methods from C). Therefore, this class actually inherits a rich library of functions. You are more likely wanting to read the C class as opposed to this class. Instances of this class are usually created by a C object after it has performed some request (such as get, lock, delete, etc). You use the object to analyse the success or otherwise of the request. HTTP::DAV::Response was created to handle two extra functions that normal HTTP Responses don't require: - WebDAV responses have 6 extra error codes: 102, 207, 422, 423, 424 and 507. Older versions of the LWP's C class did not have these extra codes. These were added. - WebDAV responses can actually contain more than one response (and often DO contain more than one) in the form of a "Multistatus". These multistatus responses come in the form of an XML document. HTTP::DAV::Response can accurately parse these XML responses and emulate the normal of the C. HTTP::DAV::Response transparently implements these extra features without the user having to be aware, so you really should be reading the C documentation for most of the things you want to do (have I already said that?). There are only a handful of custom functions that HTTP::DAV::Response returns and those are to handle multistatus requests, C and C. The six extra status codes that DAV servers can be returned in an HTTP Response are: 102 => "Processing. Server has accepted the request, but has not yet completed it", 207 => "Multistatus", 422 => "Unprocessable Entity. Bad client XML sent?", 423 => "Locked. The source or destination resource is locked", 424 => "Failed Dependency", 507 => "Insufficient Storage. The server is unable to store the request", See C for the rest. =head1 HANDLING A MULTISTATUS So, many DAV requests may return a multistatus ("207 multistatus") instead of, say, "200 OK" or "403 Forbidden". The HTTP::DAV::Response object stores each "response" sent back in the multistatus. You access them by array number. The following code snippet shows what you will normally want to do: ... $response = $resource->lock(); if ( $response->is_multistatus() ) { foreach $num ( 0 .. $response->response_count() ) { ($err_code,$mesg,$url,$desc) = $response->response_bynum($num); print "$mesg ($err_code) for $url\n"; } } Would produce something like this: Failed Dependency (424) for /test/directory Locked (423) for /test/directory/file3 This says that we couldn't lock /test/directory because file3 which exists inside is already locked by somebody else. =head1 METHODS =over 4 =item B This function takes no arguments and returns a 1 or a 0. For example: if ($response->is_multistatus() ) { } If the HTTP reply had "207 Multistatus" in the header then that indicates that there are multiple status messages in the XML content that was returned. In this event, you may be interested in knowing what the individual messages were. To do this you would then use C. =item B Takes no arguments and returns "the number of error responses -1" that we got. Why -1? Because usually you will want to use this like an array operator: foreach $num ( 0 .. $response->response_count() ) { print $response->message_bynum(); } =item B Takes one argument, the "response number" that you're interested in. And returns an array of details: ($code,$message,$url,$description) = response_bynum(2); where $code - is the HTTP error code (e.g. 403, 423, etc). $message - is the associated message for that error code. $url - is the url that this error applies to (recall that there can be multiple responses within one response and they all relate to one URL) $description - is server's attempt at an english description of what happened. =item B Takes one argument, the "response number" that you're interested in, and returns it's code. E.g: $code = $response->code_bynum(1); See C =item B Takes one argument, the "response number" that you're interested in, and returns it's message. E.g: $code = $response->message_bynum(1); See C =item B Takes one argument, the "response number" that you're interested in, and returns it's url. E.g: $code = $response->message_bynum(1); See C =item B Takes one argument, the "response number" that you're interested in, and returns it's description. E.g: $code = $response->message_description(1); See C =item B Takes no arguments and returns all of the messages returned in a multistatus response. If called in a scalar context then all of the messages will be returned joined together by newlines. If called in an array context the messages will be returned as an array. $messages = $response->messages(); e.g. $messages eq "Forbidden\nLocked"; @messages = $response->messages(); e.g. @messages eq ["Forbidden", "Locked"]; This routine is a variant on the standard C C. =back =cut HTTP-DAV-0.50/lib/HTTP/DAV.pm0000644000175000017500000020205414703664736014511 0ustar cosimocosimo# Perl WebDAV client library package HTTP::DAV; use strict; use vars qw($VERSION $VERSION_DATE $DEBUG); # Globals $VERSION = '0.50'; $VERSION_DATE = '2024/10/16'; # Set this up to 3 $DEBUG = 0; #use Carp (cluck); use Cwd (); # Can't import all of it, cwd clashes with our namespace. use LWP; use XML::DOM; use Time::Local; use HTTP::DAV::Lock; use HTTP::DAV::ResourceList; use HTTP::DAV::Resource; use HTTP::DAV::Comms; use URI::file; use URI::Escape; use FileHandle; use File::Glob; use File::Temp (); sub new { my $class = shift; my $self = bless {}, ref($class) || $class; $self->_init(@_); return $self; } ########################################################################### sub clone { my ($self)= @_; my $class = ref($self); my %clone = %{$self}; bless {%clone}, $class; } ########################################################################### { sub _init { my ( $self, @p ) = @_; my ( $uri, $headers, $useragent ) = HTTP::DAV::Utils::rearrange( [ 'URI', 'HEADERS', 'USERAGENT' ], @p ); $self->{_lockedresourcelist} = HTTP::DAV::ResourceList->new(); $self->{_comms} = HTTP::DAV::Comms->new( -useragent => $useragent, -headers => $headers ); if ($uri) { $self->set_workingresource( $self->new_resource( -uri => $uri ) ); } return $self; } } sub DebugLevel { shift if ref( $_[0] ) =~ /HTTP/; my $level = shift; $level = 256 if !defined $level || $level eq ""; $DEBUG = $level; } sub _tempfile { my ($prefix, $tempdir) = @_; $prefix ||= 'dav'; $tempdir ||= '/tmp'; my $template = $prefix . 'XXXXXXXXXXXXX'; my $old_umask = umask 0077; my ($fh, $filename) = File::Temp::tempfile($template, DIR => $tempdir, SUFFIX => '.tmp' ); umask $old_umask; return wantarray ? ($fh, $filename) : $filename; } ###################################################################### # new_resource acts as a resource factory. # It will create a new one for you each time you ask. # Sometimes, if it holds state information about this # URL, it may return an old populated object. sub new_resource { my ($self) = shift; #### # This is the order of the arguments unless used as # named parameters my ($uri) = HTTP::DAV::Utils::rearrange( ['URI'], @_ ); $uri = HTTP::DAV::Utils::make_uri($uri); #cluck "new_resource: now $uri\n"; my $resource = $self->{_lockedresourcelist}->get_member($uri); if ($resource) { print "new_resource: For $uri, returning existing resource $resource\n" if $HTTP::DAV::DEBUG > 2; # Just reset the url to honour trailing slash status. $resource->set_uri($uri); return $resource; } else { print "new_resource: For $uri, creating new resource\n" if $HTTP::DAV::DEBUG > 2; return HTTP::DAV::Resource->new( -Comms => $self->{_comms}, -LockedResourceList => $self->{_lockedresourcelist}, -uri => $uri, -Client => $self ); } } ########################################################################### # ACCESSOR METHODS # GET sub get_user_agent { $_[0]->{_comms}->get_user_agent(); } sub get_last_request { $_[0]->{_comms}->get_last_request(); } sub get_last_response { $_[0]->{_comms}->get_last_response(); } sub get_workingresource { $_[0]->{_workingresource} } sub get_workingurl { $_[0]->{_workingresource}->get_uri() if defined $_[0]->{_workingresource}; } sub get_lockedresourcelist { $_[0]->{_lockedresourcelist} } # SET sub set_workingresource { $_[0]->{_workingresource} = $_[1]; } sub credentials { shift->{_comms}->credentials(@_); } ###################################################################### # Error handling ## Error conditions my %err = ( 'ERR_WRONG_ARGS' => 'Wrong number of arguments supplied.', 'ERR_UNAUTHORIZED' => 'Unauthorized. ', 'ERR_NULL_RESOURCE' => 'Not connected. Do an open first. ', 'ERR_RESP_FAIL' => 'Server response: ', 'ERR_501' => 'Server response: ', 'ERR_405' => 'Server response: ', 'ERR_GENERIC' => '', ); sub err { my ( $self, $error, $mesg, $url ) = @_; my $err_msg; $err_msg = ""; $err_msg .= $err{$error} if defined $err{$error}; $err_msg .= $mesg if defined $mesg; $err_msg .= "ERROR" unless defined $err_msg; $self->{_message} = $err_msg; my $callback = $self->{_callback}; &$callback( 0, $err_msg, $url ) if $callback; if ( $self->{_multi_op} ) { push( @{ $self->{_errors} }, $err_msg ); } $self->{_status} = 0; return 0; } sub ok { my ($self, $mesg, $url, $so_far, $length) = @_; $self->{_message} = $mesg; my $callback = $self->{_callback}; &$callback(1, $mesg, $url, $so_far, $length) if $callback; if ($self->{_multi_op}) { $self->{_status} = 1 unless $self->{_status} == 0; } else { $self->{_status} = 1; } return 1; } sub _start_multi_op { my ($self, $mesg, $callback) = @_; $self->{_multi_mesg} = $mesg || ""; $self->{_status} = 1; $self->{_errors} = []; $self->{_multi_op} = 1; $self->{_callback} = $callback if defined $callback; } sub _end_multi_op { my ($self) = @_; $self->{_multi_op} = 0; $self->{_callback} = undef; my $message = $self->{_multi_mesg} . " "; $message .= ( $self->{_status} ) ? "succeeded" : "failed"; $self->{_message} = $message; $self->{_multi_mesg} = undef; } sub message { my ($self) = @_; return $self->{_message} || ""; } sub errors { my ($self) = @_; my $err_ref = $self->{_errors} || []; return @{ $err_ref }; } sub is_success { my ($self) = @_; return $self->{_status}; } ###################################################################### # Operations # CWD sub cwd { my ( $self, @p ) = @_; my ($url) = HTTP::DAV::Utils::rearrange( ['URL'], @p ); return $self->err('ERR_WRONG_ARGS') if ( !defined $url || $url eq "" ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); $url = HTTP::DAV::Utils::make_trail_slash($url); my $new_uri = $self->get_absolute_uri($url); ($new_uri) = $self->get_globs($new_uri); return 0 unless ($new_uri); print "cwd: Changing to $new_uri\n" if $DEBUG; return $self->open($new_uri); } # DELETE sub delete { my ( $self, @p ) = @_; my ( $url, $callback ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'CALLBACK' ], @p ); return $self->err('ERR_WRONG_ARGS') if ( !defined $url || $url eq "" ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); my $new_url = $self->get_absolute_uri($url); my @urls = $self->get_globs($new_url); $self->_start_multi_op( "delete $url", $callback ) if @urls > 1; foreach my $u (@urls) { my $resource = $self->new_resource( -uri => $u ); my $resp = $resource->delete(); if ( $resp->is_success ) { $self->ok( "deleted $u successfully", $u ); } else { $self->err( 'ERR_RESP_FAIL', $resp->message(), $u ); } } $self->_end_multi_op() if @urls > 1; return $self->is_success; } # GET # Handles globs by doing multiple recursive gets # GET dir* produces # _get dir1, to_local # _get dir2, to_local # _get dir3, to_local sub get { my ( $self, @p ) = @_; my ( $url, $to, $callback, $chunk ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'TO', 'CALLBACK', 'CHUNK' ], @p ); return $self->err('ERR_WRONG_ARGS') if ( !defined $url || $url eq "" ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); $self->_start_multi_op( "get $url", $callback ); my $new_url = $self->get_absolute_uri($url); my (@urls) = $self->get_globs($new_url); return 0 unless ( $#urls > -1 ); ############ # HANDLE -TO # $to ||= ''; if ( $to eq '.' ) { $to = Cwd::getcwd(); } # If the TO argument is a file handle or a scalar # then check that we only got one glob. If we got multiple # globs, then we can't keep going because we can't write multiple files # to one FileHandle. if ( $#urls > 0 ) { if ( ref($to) =~ /SCALAR/ ) { return $self->err( 'ERR_WRONG_ARGS', "Can't retrieve multiple files to a single scalar\n" ); } elsif ( ref($to) =~ /GLOB/ ) { return $self->err( 'ERR_WRONG_ARGS', "Can't retrieve multiple files to a single filehandle\n" ); } } # If it's a dir, remove last '/' from destination. # Later we need to concatenate the destination filename. if ( defined $to && $to ne '' && -d $to ) { $to =~ s{/$}{}; } # Foreach file... do the get. foreach my $u (@urls) { my ( $left, $leafname ) = HTTP::DAV::Utils::split_leaf($u); # Handle SCALARREF and GLOB cases my $dest_file = $to; # Directories if ( -d $to ) { $dest_file = "$to/$leafname"; # Multiple targets } elsif ( !defined $to || $to eq "" ) { $dest_file = $leafname; } warn "get: $u -> $dest_file\n" if $DEBUG; # Setup the resource based on the passed url and do a propfind. my $resource = $self->new_resource( -uri => $u ); my $resp = $resource->propfind( -depth => 1 ); if ( $resp->is_error ) { return $self->err( 'ERR_RESP_FAIL', $resp->message(), $u ); } $self->_get( $resource, $dest_file, $callback, $chunk ); } $self->_end_multi_op(); return $self->is_success; } # Note: is is expected that $resource has had # a propfind depth 1 performed on it. # sub _get { my ( $self, @p ) = @_; my ( $resource, $local_name, $callback, $chunk ) = HTTP::DAV::Utils::rearrange( [ 'RESOURCE', 'TO', 'CALLBACK', 'CHUNK' ], @p ); my $url = $resource->get_uri(); # GET A DIRECTORY if ( $resource->is_collection ) { # If the TO argument is a file handle, a scalar or empty # then we # can't keep going because we can't write multiple files # to one FileHandle, scalar, etc. if ( ref($local_name) =~ /SCALAR/ ) { return $self->err( 'ERR_WRONG_ARGS', "Can't retrieve a collection to a scalar\n", $url ); } elsif ( ref($local_name) =~ /GLOB/ ) { return $self->err( 'ERR_WRONG_ARGS', "Can't retrieve a collection to a filehandle\n", $url ); } elsif ( $local_name eq "" ) { return $self->err( 'ERR_GENERIC', "Can't retrieve a collection without a target directory (-to).", $url ); } # Try and make the directory locally print "MKDIR $local_name (before escape)\n" if $DEBUG > 2; $local_name = URI::Escape::uri_unescape($local_name); if ( !mkdir $local_name ) { return $self->err( 'ERR_GENERIC', "mkdir local:$local_name failed: $!" ); } $self->ok("mkdir $local_name"); # This is the degenerate case for an empty dir. print "Made directory $local_name\n" if $DEBUG > 2; my $resource_list = $resource->get_resourcelist(); if ($resource_list) { # FOREACH FILE IN COLLECTION, GET IT. foreach my $progeny_r ( $resource_list->get_resources() ) { my $progeny_url = $progeny_r->get_uri(); print "Found progeny:$progeny_url\n" if $DEBUG > 2; my $progeny_local_filename = HTTP::DAV::Utils::get_leafname($progeny_url); $progeny_local_filename = URI::Escape::uri_unescape($progeny_local_filename); $progeny_local_filename = URI::file->new($progeny_local_filename) ->abs("$local_name/"); if ( $progeny_r->is_collection() ) { $progeny_r->propfind( -depth => 1 ); } $self->_get( $progeny_r, $progeny_local_filename, $callback, $chunk ); # } else { # $self->_do_get_tofile($progeny_r,$progeny_local_filename); # } } } } # GET A FILE else { my $response; my $name_ref = ref $local_name; if ( $callback || $name_ref =~ /SCALAR/ || $name_ref =~ /GLOB/ ) { $self->{_so_far} = 0; my $fh; my $put_to_scalar = 0; if ( $name_ref =~ /GLOB/ ) { $fh = $local_name; } elsif ( $name_ref =~ /SCALAR/ ) { $put_to_scalar = 1; $$local_name = ""; } else { $fh = FileHandle->new; $local_name = URI::Escape::uri_unescape($local_name); if (! $fh->open(">$local_name") ) { return $self->err( 'ERR_GENERIC', "open \">$local_name\" failed: $!", $url ); } # RT #29788, avoid file corruptions on Win32 binmode $fh; } $self->{_fh} = $fh; $response = $resource->get( -chunk => $chunk, -progress_callback => sub { my ( $data, $response, $protocol ) = @_; $self->{_so_far} += length($data); my $fh = $self->{_fh}; print $fh $data if defined $fh; $$local_name .= $data if ($put_to_scalar); my $user_callback = $self->{_callback}; &$user_callback( -1, "transfer in progress", $url, $self->{_so_far}, $response->content_length(), $data ) if defined $user_callback; } ); # end get( ... ); # Close the filehandle if it was set. if ( defined $self->{_fh} ) { $self->{_fh}->close(); delete $self->{_fh}; } } else { $local_name = URI::Escape::uri_unescape($local_name); $response = $resource->get( -save_to => $local_name ); } # Handle response if ( $response->is_error ) { return $self->err( 'ERR_GENERIC', "get $url failed: " . $response->message, $url ); } else { return $self->ok( "get $url", $url, $self->{_so_far}, $response->content_length() ); } } return 1; } # LOCK sub lock { my ( $self, @p ) = @_; my ( $url, $owner, $depth, $timeout, $scope, $type, @other ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'OWNER', 'DEPTH', 'TIMEOUT', 'SCOPE', 'TYPE' ], @p ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); my $resource; if ($url) { $url = $self->get_absolute_uri($url); $resource = $self->new_resource( -uri => $url ); } else { $resource = $self->get_workingresource(); $url = $resource->get_uri; } # Make the lock my $resp = $resource->lock( -owner => $owner, -depth => $depth, -timeout => $timeout, -scope => $scope, -type => $type ); if ( $resp->is_success() ) { return $self->ok( "lock $url succeeded", $url ); } else { return $self->err( 'ERR_RESP_FAIL', $resp->message, $url ); } } # UNLOCK sub unlock { my ( $self, @p ) = @_; my ($url) = HTTP::DAV::Utils::rearrange( ['URL'], @p ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); my $resource; if ($url) { $url = $self->get_absolute_uri($url); $resource = $self->new_resource( -uri => $url ); } else { $resource = $self->get_workingresource(); $url = $resource->get_uri; } # Make the lock my $resp = $resource->unlock(); if ( $resp->is_success ) { return $self->ok( "unlock $url succeeded", $url ); } else { # The Resource.pm::lock routine has a hack # where if it doesn't know the locktoken, it will # just return an empty response with message "Client Error". # Make a custom message for this case. my $msg = $resp->message; if ( $msg =~ /Client error/i ) { $msg = "No locks found. Try steal"; return $self->err( 'ERR_GENERIC', $msg, $url ); } else { return $self->err( 'ERR_RESP_FAIL', $msg, $url ); } } } sub steal { my ( $self, @p ) = @_; my ($url) = HTTP::DAV::Utils::rearrange( ['URL'], @p ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); my $resource; if ($url) { $url = $self->get_absolute_uri($url); $resource = $self->new_resource( -uri => $url ); } else { $resource = $self->get_workingresource(); } # Go the steal my $resp = $resource->forcefully_unlock_all(); if ( $resp->is_success() ) { return $self->ok( "steal succeeded", $url ); } else { return $self->err( 'ERR_RESP_FAIL', $resp->message(), $url ); } } # MKCOL sub mkcol { my ( $self, @p ) = @_; my ($url) = HTTP::DAV::Utils::rearrange( ['URL'], @p ); return $self->err('ERR_WRONG_ARGS') if ( !defined $url || $url eq "" ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); $url = HTTP::DAV::Utils::make_trail_slash($url); my $new_url = $self->get_absolute_uri($url); my $resource = $self->new_resource( -uri => $new_url ); # Make the lock my $resp = $resource->mkcol(); if ( $resp->is_success() ) { return $self->ok( "mkcol $new_url", $new_url ); } else { return $self->err( 'ERR_RESP_FAIL', $resp->message(), $new_url ); } } # OPTIONS sub options { my ( $self, @p ) = @_; my ($url) = HTTP::DAV::Utils::rearrange( ['URL'], @p ); #return $self->err('ERR_WRONG_ARGS') if (!defined $url || $url eq ""); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); my $resource; if ($url) { $url = $self->get_absolute_uri($url); $resource = $self->new_resource( -uri => $url ); } else { $resource = $self->get_workingresource(); $url = $resource->get_uri; } # Make the call my $resp = $resource->options(); if ( $resp->is_success() ) { $self->ok( "options $url succeeded", $url ); return $resource->get_options(); } else { $self->err( 'ERR_RESP_FAIL', $resp->message(), $url ); return undef; } } # MOVE sub move { return shift->_move_copy( "move", @_ ); } sub copy { return shift->_move_copy( "copy", @_ ); } sub _move_copy { my ( $self, $method, @p ) = @_; my ( $url, $dest_url, $overwrite, $depth, $text, @other ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'DEST', 'OVERWRITE', 'DEPTH', 'TEXT' ], @p ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); if (!( defined $url && $url ne "" && defined $dest_url && $dest_url ne "" ) ) { return $self->err( 'ERR_WRONG_ARGS', "Must supply a source and destination url" ); } $url = $self->get_absolute_uri($url); $dest_url = $self->get_absolute_uri($dest_url); my $resource = $self->new_resource( -uri => $url ); my $dest_resource = $self->new_resource( -uri => $dest_url ); my $resp = $dest_resource->propfind( -depth => 1 ); if ( $resp->is_success && $dest_resource->is_collection ) { my $leafname = HTTP::DAV::Utils::get_leafname($url); $dest_url = "$dest_url/$leafname"; $dest_resource = $self->new_resource( -uri => $dest_url ); } # Make the lock $resp = $resource->$method( -dest => $dest_resource, -overwrite => $overwrite, -depth => $depth, -text => $text, ); if ( $resp->is_success() ) { return $self->ok( "$method $url to $dest_url succeeded", $url ); } else { return $self->err( 'ERR_RESP_FAIL', $resp->message, $url ); } } # OPEN # Must be a collection resource # $dav->open( -url => http://localhost/test/ ); # $dav->open( localhost/test/ ); # $dav->open( -url => localhost:81 ); # $dav->open( localhost ); sub open { my ( $self, @p ) = @_; my ($url) = HTTP::DAV::Utils::rearrange( ['URL'], @p ); my $resource; if ( defined $url && $url ne "" ) { $url = HTTP::DAV::Utils::make_trail_slash($url); $resource = $self->new_resource( -uri => $url ); } else { $resource = $self->get_workingresource(); $url = $resource->get_uri() if ($resource); return $self->err('ERR_WRONG_ARGS') if ( !defined $url || $url eq "" ); } my $response = $resource->propfind( -depth => 0 ); #print $response->as_string; #print $resource->as_string; my $result = $self->what_happened($url, $resource, $response); if ($result->{success} == 0) { return $self->err($result->{error_type}, $result->{error_msg}, $url); } # If it is a collection but the URI doesn't end in a trailing slash. # Then we need to reopen with the / elsif ($resource->is_collection && $url !~ m#/\s*$# ) { my $newurl = $url . "/"; print "Redirecting to $newurl\n" if $DEBUG > 1; return $self->open($newurl); } # If it is not a collection then we # can't open it. elsif ( !$resource->is_collection ) { return $self->err( 'ERR_GENERIC', "Operation failed. You can only open a collection (directory)", $url ); } else { $self->set_workingresource($resource); return $self->ok( "Connected to $url", $url ); } return $self->err( 'ERR_GENERIC', $url ); } # Performs a propfind and then returns the populated # resource. The resource will have a resourcelist if # it is a collection. sub propfind { my ( $self, @p ) = @_; my ( $url, $depth ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'DEPTH' ], @p ); # depth = 1 is the default if (! defined $depth) { $depth = 1; } return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); my $resource; if ($url) { $url = $self->get_absolute_uri($url); $resource = $self->new_resource( -uri => $url ); } else { $resource = $self->get_workingresource(); } # Make the call my $resp = $resource->propfind( -depth => $depth ); if ($resp->is_success() || $resp->code == 207) { $resource->build_ls($resource); $self->ok( "propfind " . $resource->get_uri() . " succeeded", $url ); return $resource; } else { return $self->err( 'ERR_RESP_FAIL', $resp->message(), $url ); } } # Set a property on the resource sub set_prop { my ( $self, @p ) = @_; my ( $url, $namespace, $propname, $propvalue, $nsabbr ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'NAMESPACE', 'PROPNAME', 'PROPVALUE', 'NSABBR' ], @p ); $self->proppatch( -url => $url, -namespace => $namespace, -propname => $propname, -propvalue => $propvalue, -action => "set", -nsabbr => $nsabbr, ); } # Unsets a property on the resource sub unset_prop { my ( $self, @p ) = @_; my ( $url, $namespace, $propname, $nsabbr ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'NAMESPACE', 'PROPNAME', 'NSABBR' ], @p ); $self->proppatch( -url => $url, -namespace => $namespace, -propname => $propname, -action => "remove", -nsabbr => $nsabbr, ); } # Performs a proppatch on the resource sub proppatch { my ( $self, @p ) = @_; my ( $url, $namespace, $propname, $propvalue, $action, $nsabbr ) = HTTP::DAV::Utils::rearrange( [ 'URL', 'NAMESPACE', 'PROPNAME', 'PROPVALUE', 'ACTION', 'NSABBR' ], @p ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); my $resource; if ($url) { $url = $self->get_absolute_uri($url); $resource = $self->new_resource( -uri => $url ); } else { $resource = $self->get_workingresource(); } # Make the call my $resp = $resource->proppatch( -namespace => $namespace, -propname => $propname, -propvalue => $propvalue, -action => $action, -nsabbr => $nsabbr ); if ( $resp->is_success() ) { $resource->build_ls($resource); $self->ok( "proppatch " . $resource->get_uri() . " succeeded", $url ); return $resource; } else { return $self->err( 'ERR_RESP_FAIL', $resp->message(), $url ); } } ###################################################################### sub put { my ( $self, @p ) = @_; my ( $local, $url, $callback, $custom_headers ) = HTTP::DAV::Utils::rearrange( [ 'LOCAL', 'URL', 'CALLBACK', 'HEADERS' ], @p ); if ( ref($local) eq "SCALAR" ) { $self->_start_multi_op( 'put ' . ${$local}, $callback ); $self->_put(@p); } else { $self->_start_multi_op( 'put ' . $local, $callback ); $local =~ s/\ /\\ /g; my @globs = glob("$local"); #my @globs=glob("\"$local\""); foreach my $file (@globs) { print "Starting put of $file\n" if $HTTP::DAV::DEBUG > 1; $self->_put( -local => $file, -url => $url, -callback => $callback, -headers => $custom_headers, ); } } $self->_end_multi_op(); return $self->is_success; } sub _put { my ( $self, @p ) = @_; my ( $local, $url, $custom_headers ) = HTTP::DAV::Utils::rearrange( [ 'LOCAL', 'URL', 'HEADERS' ], @p ); return $self->err('ERR_WRONG_ARGS') if ( !defined $local || $local eq "" ); return $self->err('ERR_NULL_RESOURCE') unless $self->get_workingresource(); # Check if they passed a reference to content rather than a filename. my $content_ptr = ( ref($local) eq "SCALAR" ) ? 1 : 0; # Setup the resource based on the passed url # Check if the remote resource exists and is a collection. $url = $self->get_absolute_uri($url); my $resource = $self->new_resource($url); my $response = $resource->propfind( -depth => 0 ); my $leaf_name; if ( $response->is_success && $resource->is_collection && !$content_ptr ) { # Add one / to the end of the collection $url =~ s/\/*$//g; #Strip em $url .= "/"; #Add one $leaf_name = HTTP::DAV::Utils::get_leafname($local); } else { $leaf_name = HTTP::DAV::Utils::get_leafname($url); } my $target = $self->get_absolute_uri( $leaf_name, $url ); #print "$local => $target ($url, $leaf_name)\n"; # PUT A DIRECTORY if ( !$content_ptr && -d $local ) { # mkcol # Return 0 if fail because the error will have already # been set by the mkcol routine if ( $self->mkcol($target, -headers => $custom_headers) ) { if ( !opendir( DIR, $local ) ) { $self->err( 'ERR_GENERIC', "chdir to \"$local\" failed: $!" ); } else { my @files = readdir(DIR); close DIR; foreach my $file (@files) { next if $file eq "."; next if $file eq ".."; my $progeny = "$local/$file"; $progeny =~ s#//#/#g; # Fold down double slashes $self->_put( -local => $progeny, -url => "$target/$file", ); } } } # PUT A FILE } else { my $content = ""; my $fail = 0; if ($content_ptr) { $content = $$local; } else { if ( !CORE::open( F, $local ) ) { $self->err( 'ERR_GENERIC', "Couldn't open local file $local: $!" ); $fail = 1; } else { binmode F; while (my $line = ) { $content .= $line; } close F; } } if ( !$fail ) { my $resource = $self->new_resource( -uri => $target ); my $response = $resource->put($content,$custom_headers); if ( $response->is_success ) { $self->ok( "put $target (" . length($content) . " bytes)", $target ); } else { $self->err( 'ERR_RESP_FAIL', "put failed " . $response->message(), $target ); } } } } ###################################################################### # UTILITY FUNCTION # get_absolute_uri: # Synopsis: $new_url = get_absolute_uri("/foo/bar") # Takes a URI (or string) # and returns the absolute URI based # on the remote current working directory sub get_absolute_uri { my ( $self, @p ) = @_; my ( $rel_uri, $base_uri ) = HTTP::DAV::Utils::rearrange( [ 'REL_URI', 'BASE_URI' ], @p ); local $URI::URL::ABS_REMOTE_LEADING_DOTS = 1; if ( !defined $base_uri ) { $base_uri = $self->get_workingresource()->get_uri(); } if ($base_uri) { my $new_url = URI->new_abs( $rel_uri, $base_uri ); return $new_url; } else { $rel_uri; } } ## Takes a $dav->get_globs(URI) # Where URI may contain wildcards at the leaf level: # URI: # http://www.host.org/perldav/test*.html # /perldav/test?.html # test[12].html # # Performs a propfind to determine the url's that match # sub get_globs { my ( $self, $url ) = @_; my @urls = (); my ( $left, $leafname ) = HTTP::DAV::Utils::split_leaf($url); # We need to unescape it because it may have been encoded. $leafname = URI::Escape::uri_unescape($leafname); if ( $leafname =~ /[\*\?\[]/ ) { my $resource = $self->new_resource( -uri => $left ); my $resp = $resource->propfind( -depth => 1 ); if ( $resp->is_error ) { $self->err( 'ERR_RESP_FAIL', $resp->message(), $left ); return (); } $leafname = HTTP::DAV::Utils::glob2regex($leafname); my $rl = $resource->get_resourcelist(); if ($rl) { my $match = 0; # We eval this because a bogus leafname could bomb the regex. eval { foreach my $progeny ( $rl->get_resources() ) { my $progeny_url = $progeny->get_uri; my $progeny_leaf = HTTP::DAV::Utils::get_leafname($progeny_url); if ( $progeny_leaf =~ /^$leafname$/ ) { print "Matched $progeny_url\n" if $HTTP::DAV::DEBUG > 1; $match++; push( @urls, $progeny_url ); } else { print "Skipped $progeny_url\n" if $HTTP::DAV::DEBUG > 1; } } }; $self->err( 'ERR_GENERIC', "No match found" ) unless ($match); } } else { push( @urls, $url ); } return @urls; } sub what_happened { my ($self, $url, $resource, $response) = @_; if (! $response->is_error()) { return { success => 1 } } my $error_type; my $error_msg; # Method not allowed if ($response->status_line =~ m{405}) { $error_type = 'ERR_405'; $error_msg = $response->status_line; } # 501 most probably means your LWP doesn't support SSL elsif ($response->status_line =~ m{501}) { $error_type = 'ERR_501'; $error_msg = $response->status_line; } elsif ($response->www_authenticate) { $error_type = 'ERR_UNAUTHORIZED'; $error_msg = $response->www_authenticate; } elsif ( !$resource->is_dav_compliant ) { $error_type = 'ERR_GENERIC'; $error_msg = qq{The URL "$url" is not DAV enabled or not accessible.}; } else { $error_type = 'ERR_RESP_FAIL'; my $message = $response->message(); $error_msg = qq{Could not access $url: $message}; } return { success => 0, error_type => $error_type, error_msg => $error_msg, } } 1; __END__ =head1 NAME HTTP::DAV - A WebDAV client library for Perl5 =head1 SYNOPSIS # DAV script that connects to a webserver, safely makes # a new directory and uploads all html files in # the /tmp directory. use HTTP::DAV; $d = HTTP::DAV->new(); $url = "http://host.org:8080/dav/"; $d->credentials( -user => "pcollins", -pass => "mypass", -url => $url, -realm => "DAV Realm" ); $d->open( -url => $url ) or die("Couldn't open $url: " .$d->message . "\n"); # Make a null lock on newdir $d->lock( -url => "$url/newdir", -timeout => "10m" ) or die "Won't put unless I can lock for 10 minutes\n"; # Make a new directory $d->mkcol( -url => "$url/newdir" ) or die "Couldn't make newdir at $url\n"; # Upload multiple files to newdir. if ( $d->put( -local => "/tmp/*.html", -url => $url ) ) { print "successfully uploaded multiple files to $url\n"; } else { print "put failed: " . $d->message . "\n"; } $d->unlock( -url => $url ); =head1 DESCRIPTION HTTP::DAV is a Perl API for interacting with and modifying content on webservers using the WebDAV protocol. Now you can LOCK, DELETE and PUT files and much more on a DAV-enabled webserver. HTTP::DAV is part of the PerlDAV project hosted at http://www.webdav.org/perldav/ and has the following features: =over 4 =item * Full RFC2518 method support. OPTIONS, TRACE, GET, HEAD, DELETE, PUT, COPY, MOVE, PROPFIND, PROPPATCH, LOCK, UNLOCK. =item * A fully object-oriented API. =item * Recursive GET and PUT for site backups and other scripted transfers. =item * Transparent lock handling when performing LOCK/COPY/UNLOCK sequences. =item * http and https support (https requires the Crypt::SSLeay library). See INSTALLATION. =item * Basic AND Digest authentication support (Digest auth requires the MD5 library). See INSTALLATION. =item * C, a fully-functional ftp-style interface written on top of the HTTP::DAV API and bundled by default with the HTTP::DAV library. (If you've already installed HTTP::DAV, then dave will also have been installed (probably into /usr/local/bin). You can see it's man page by typing "perldoc dave" or going to http://www.webdav.org/perldav/dave/. =item * It is built on top of the popular LWP (Library for WWW access in Perl). This means that HTTP::DAV inherits proxy support, redirect handling, basic (and digest) authorization and many other HTTP operations. See C for more information. =item * Popular server support. HTTP::DAV has been tested against the following servers: mod_dav, IIS5, Xythos webfile server and mydocsonline. The library is growing an impressive interoperability suite which also serves as useful "sample scripts". See "make test" and t/*. =back C essentially has two API's, one which is accessed through this module directly (HTTP::DAV) and is a simple abstraction to the rest of the HTTP::DAV::* Classes. The other interface consists of the HTTP::DAV::* classes which if required allow you to get "down and dirty" with your DAV and HTTP interactions. The methods provided in C should do most of what you want. If, however, you need more control over the client's operations or need more info about the server's responses then you will need to understand the rest of the HTTP::DAV::* interfaces. A good place to start is with the C and C documentation. =head1 METHODS =head2 METHOD CALLING: Named vs Unnamed parameters You can pass parameters to C methods in one of two ways: named or unnamed. Named parameters provides for a simpler/easier to use interface. A named interface affords more readability and allows the developer to ignore a specific order on the parameters. (named parameters are also case insensitive) Each argument name is preceded by a dash. Neither case nor order matters in the argument list. -url, -Url, and -URL are all acceptable. In fact, only the first argument needs to begin with a dash. If a dash is present in the first argument, C assumes dashes for the subsequent ones. Each method can also be called with unnamed parameters which often makes sense for methods with only one parameter. But the developer will need to ensure that the parameters are passed in the correct order (as listed in the docs). Doc: method( -url=>$url, [-depth=>$depth] ) Named: $d->method( -url=>$url, -depth=>$d ); # VALID Named: $d->method( -Depth=>$d, -Url=>$url ); # VALID Named: $d->method( Depth=>$d, Url=>$url ); # INVALID (needs -) Named: $d->method( -Arg2=>$val2 ); # INVALID, ARG1 is not optional Unnamed: $d->method( $val1 ); # VALID Unnamed: $d->method( $val2,$val1 ); # INVALID, ARG1 must come first. IMPORTANT POINT!!!! If you specify a named parameter first but then forget for the second and third parameters, you WILL get weird things happen. E.g. this is bad: $d->method( -url=>$url, $arg2, $arg3 ); # BAD BAD BAD =head2 THINGS YOU NEED TO KNOW In all of the methods specified in L there are some common concepts you'll need to understand: =over 4 =item * URLs represent an absolute or relative URI. -url=>"host.org/dav_dir/" # Absolute -url=>"/dav_dir/" # Relative -url=>"file.txt" # Relative You can only use a relative URL if you have already "open"ed an absolute URL. The HTTP::DAV module now consistently uses the named parameter: URL. The lower-level HTTP::DAV::Resource interface inconsistently interchanges URL and URI. I'm working to resolve this, in the meantime, you'll just need to remember to use the right one by checking the documentation if you need to mix up your use of both interfaces. =item * GLOBS Some methods accept wildcards in the URL. A wildcard can be used to indicate that the command should perform the command on all Resources that match the wildcard. These wildcards are called GLOBS. The glob may contain the characters "*", "?" and the set operator "[...]" where ... contains multiple characters ([1t2]) or a range such ([1-5]). For the curious, the glob is converted to a regex and then matched: "*" to ".*", "?" to ".", and the [] is left untouched. It is important to note that globs only operate at the leaf-level. For instance "/my_dir/*/file.txt" is not a valid glob. If a glob matches no URL's the command will fail (which normally means returns 0). Globs are useful in conjunction with L to provide feedback as each operation completes. See the documentation for each method to determine whether it supports globbing. Globs are useful for interactive style applications (see the source code for C as an example). Example globs: $dav1->delete(-url=>"/my_dir/file[1-3]"); # Matches file1, file2, file3 $dav1->delete(-url=>"/my_dir/file[1-3]*.txt");# Matches file1*.txt,file2*.txt,file3*.txt $dav1->delete(-url=>"/my_dir/*/file.txt"); # Invalid. Can only match at leaf-level =item * CALLBACKS Callbacks are used by some methods (primarily get and put) to give the caller some insight as to how the operation is progressing. A callback allows you to define a subroutine as defined below and pass a reference (\&ref) to the method. The rationale behind the callback is that a recursive get/put or an operation against many files (using a C) can actually take a long time to complete. Example callback: $d->get( -url=>$url, -to=>$to, -callback=>\&mycallback ); Your callback function MUST accept arguments as follows: sub cat_callback { my($status,$mesg,$url,$so_far,$length,$data) = @_; ... } The C argument specifies whether the operation has succeeded (1), failed (0), or is in progress (-1). The C argument is a status message. The status message could contain any string and often contains useful error messages or success messages. The C the remote URL. The C, C - these parameters indicate how many bytes have been downloaded and how many we should expect. This is useful for doing "56% to go" style-gauges. The C parameter - is the actual data transferred. The C command uses this to print the data to the screen. This value will be empty for C. See the source code of C for a useful sample of how to setup a callback. Note that these arguments are NOT named parameters. All error messages set during a "multi-operation" request (for instance a recursive get/put) are also retrievable via the C function once the operation has completed. See C for more information. =back =head2 PUBLIC METHODS =over 4 =item B =item B Creates a new C client $d = HTTP::DAV->new(); The C<-useragent> parameter allows you to pass your own B and expects an C object. See the C program for an advanced example of a custom UserAgent that interactively prompts the user for their username and password. The C<-headers> parameter allows you to specify a list of headers to be sent along with all requests. This can be either a hashref like: { "X-My-Header" => "value", ... } or a L object. =item B sets authorization credentials for a C and/or C. When the client hits a protected resource it will check these credentials to see if either the C or C match the authorization response. Either C or C must be provided. returns no value Example: $d->credentials( -url=>'myhost.org:8080/test/', -user=>'pcollins', -pass=>'mypass'); =item B sets the debug level to C<$val>. 0=off 3=noisy. C<$val> default is 0. returns no value. When the value is greater than 1, the C module will log all of the client<=>server interactions into /tmp/perldav_debug.txt. =back =head2 DAV OPERATIONS For all of the following operations, URL can be absolute (http://host.org/dav/) or relative (../dir2/). The only operation that requires an absolute URL is open. =over 4 =item B copies one remote resource to another =over 4 =item C<-url> is the remote resource you'd like to copy. Mandatory =item C<-dest> is the remote target for the copy command. Mandatory =item C<-overwrite> optionally indicates whether the server should fail if the target exists. Valid values are "T" and "F" (1 and 0 are synonymous). Default is T. =item C<-depth> optionally indicates whether the server should do a recursive copy or not. Valid values are 0 and (1 or "infinity"). Default is "infinity" (1). =back The return value is always 1 or 0 indicating success or failure. Requires a working resource to be set before being called. See C. Note: if either C<'URL'> or C<'DEST'> are locked by this dav client, then the lock headers will be taken care of automatically. If the either of the two URL's are locked by someone else, the server should reject the request. B $d->open(-url=>"host.org/dav_dir/"); Recursively copy dir1/ to dir2/ $d->copy(-url=>"dir1/", -dest=>"dir2/"); Non-recursively and non-forcefully copy dir1/ to dir2/ $d->copy(-url=>"dir1/", -dest=>"dir2/",-overwrite=>0,-depth=>0); Create a copy of dir1/file.txt as dir2/file.txt $d->cwd(-url=>"dir1/"); $d->copy("file.txt","../dir2"); Create a copy of file.txt as dir2/new_file.txt $d->copy("file.txt","/dav_dir/dir2/new_file.txt") =item B changes the remote working directory. This is synonymous to open except that the URL can be relative and may contain a C (the first match in a glob will be used). $d->open("host.org/dav_dir/dir1/"); $d->cwd("../dir2"); $d->cwd(-url=>"../dir1"); The return value is always 1 or 0 indicating success or failure. Requires a working resource to be set before being called. See C. You can not cwd to files, only collections (directories). =item B deletes a remote resource. $d->open("host.org/dav_dir/"); $d->delete("index.html"); $d->delete("./dir1"); $d->delete(-url=>"/dav_dir/dir2/file*",-callback=>\&mycallback); =item C<-url> is the remote resource(s) you'd like to delete. It can be a file, directory or C. =item C<-callback> is a reference to a callback function which will be called everytime a file is deleted. This is mainly useful when used in conjunction with L deletes. See L The return value is always 1 or 0 indicating success or failure. Requires a working resource to be set before being called. See C. This command will recursively delete directories. BE CAREFUL of uninitialised file variables in situation like this: $d->delete("$dir/$file"). This will trash your $dir if $file is not set. =item B downloads the file or directory at C to the local location indicated by C. =over 4 =item C<-url> is the remote resource you'd like to get. It can be a file or directory or a "glob". =item C<-to> is where you'd like to put the remote resource. The -to parameter can be: - a B indicating where to save the contents. - a B. - a reference to a B into which the contents will be saved. If the C<-url> matches multiple files (via a glob or a directory download), then the C routine will return an error if you try to use a FileHandle reference or a scalar reference. =item C<-callback> is a reference to a callback function which will be called everytime a file is completed downloading. The idea of the callback function is that some recursive get's can take a very long time and the user may require some visual feedback. See L for an examples and how to use a callback. =back The return value of get is always 1 or 0 indicating whether the entire get sequence was a success or if there was ANY failures. For instance, in a recursive get, if the server couldn't open 1 of the 10 remote files, for whatever reason, then the return value will be 0. This is so that you can have your script call the C routine to handle error conditions. Previous versions of HTTP::DAV allowed the return value to be the file contents if no -to attribute was supplied. This functionality is deprecated. Requires a working resource to be set before being called. See C. B $d->open("host.org/dav_dir/"); Recursively get remote my_dir/ to . $d->get("my_dir/","."); Recursively get remote my_dir/ to /tmp/my_dir/ calling &mycallback($success,$mesg) everytime a file operation is completed. $d->get("my_dir","/tmp",\&mycallback); Get remote my_dir/index.html to /tmp/index.html $d->get(-url=>"/dav_dir/my_dir/index.html",-to=>"/tmp"); Get remote index.html to /tmp/index1.html $d->get("index.html","/tmp/index1.html"); Get remote index.html to a filehandle my $fh = new FileHandle; $fh->open(">/tmp/index1.html"); $d->get("index.html",\$fh); Get remote index.html as a scalar (into the string $file_contents): my $file_contents; $d->get("index.html",\$file_contents); Get all of the files matching the globs file1* and file2*: $d->get("file[12]*","/tmp"); Get all of the files matching the glob file?.html: $d->get("file?.html","/tmp"); # downloads file1.html and file2.html but not file3.html or file1.txt Invalid glob: $d->get("/dav_dir/*/index.html","/tmp"); # Can not glob like this. =item B locks a resource. If URL is not specified, it will lock the current working resource (opened resource). $d->lock( -url => "index.html", -owner => "Patrick Collins", -depth => "infinity", -scope => "exclusive", -type => "write", -timeout => "10h" ) See C lock() for details of the above parameters. The return value is always 1 or 0 indicating success or failure. Requires a working resource to be set before being called. See C. When you lock a resource, the lock is held against the current HTTP::DAV object. In fact, the locks are held in a C object. You can operate against all of the locks that you have created as follows: ## Print and unlock all locks that we own. my $rl_obj = $d->get_lockedresourcelist(); foreach $resource ( $rl_obj->get_resources() ) { @locks = $resource->get_locks(-owned=>1); foreach $lock ( @locks ) { print $resource->get_uri . "\n"; print $lock->as_string . "\n"; } ## Unlock them? $resource->unlock; } Typically, a simple $d->unlock($uri) will suffice. B $d->lock($uri, -timeout=>"1d"); ... $d->put("/tmp/index.html",$uri); $d->unlock($uri); =item B make a remote collection (directory) The return value is always 1 or 0 indicating success or failure. Requires a working resource to be set before being called. See C. $d->open("host.org/dav_dir/"); $d->mkcol("new_dir"); # Should succeed $d->mkcol("/dav_dir/new_dir"); # Should succeed $d->mkcol("/dav_dir/new_dir/xxx/yyy"); # Should fail =item B moves one remote resource to another =over 4 =item C<-url> is the remote resource you'd like to move. Mandatory =item C<-dest> is the remote target for the move command. Mandatory =item C<-overwrite> optionally indicates whether the server should fail if the target exists. Valid values are "T" and "F" (1 and 0 are synonymous). Default is T. =back Requires a working resource to be set before being called. See C. The return value is always 1 or 0 indicating success or failure. Note: if either C<'URL'> or C<'DEST'> are locked by this dav client, then the lock headers will be taken care of automatically. If either of the two URL's are locked by someone else, the server should reject the request. B $d->open(-url=>"host.org/dav_dir/"); move dir1/ to dir2/ $d->move(-url=>"dir1/", -dest=>"dir2/"); non-forcefully move dir1/ to dir2/ $d->move(-url=>"dir1/", -dest=>"dir2/",-overwrite=>0); Move dir1/file.txt to dir2/file.txt $d->cwd(-url=>"dir1/"); $d->move("file.txt","../dir2"); move file.txt to dir2/new_file.txt $d->move("file.txt","/dav_dir/dir2/new_file.txt") =item B opens the directory (collection resource) at URL. open will perform a propfind against URL. If the server does not understand the request then the open will fail. Similarly, if the server indicates that the resource at URL is NOT a collection, the open command will fail. =item B Performs an OPTIONS request against the URL or the working resource if URL is not supplied. Requires a working resource to be set before being called. See C. The return value is a string of comma separated OPTIONS that the server states are legal for URL or undef otherwise. A fully compliant DAV server may offer as many methods as: OPTIONS, TRACE, GET, HEAD, DELETE, PUT, COPY, MOVE, PROPFIND, PROPPATCH, LOCK, UNLOCK Note: IIS5 does not support PROPPATCH or LOCK on collections. Example: $options = $d->options($url); print $options . "\n"; if ($options=~ /\bPROPPATCH\b/) { print "OK to proppatch\n"; } Or, put more simply: if ( $d->options($url) =~ /\bPROPPATCH\b/ ) { print "OK to proppatch\n"; } =item B Perform a propfind against URL at DEPTH depth. C<-depth> can be used to specify how deep the propfind goes. "0" is collection only. "1" is collection and it's immediate members (This is the default value). "infinity" is the entire directory tree. Note that most DAV compliant servers deny "infinity" depth propfinds for security reasons. Requires a working resource to be set before being called. See C. The return value is an C object on success or 0 on failure. The Resource object can be used for interrogating properties or performing other operations. ## Print collection or content length if ( $r=$d->propfind( -url=>"/my_dir", -depth=>1) ) { if ( $r->is_collection ) { print "Collection\n" print $r->get_resourcelist->as_string . "\n" } else { print $r->get_property("getcontentlength") ."\n"; } } Please note that although you may set a different namespace for a property of a resource during a set_prop, HTTP::DAV currently ignores all XML namespaces so you will get clashes if two properties have the same name but in different namespaces. Currently this is unavoidable but I'm working on the solution. =item B If C<-action> equals "set" then we set a property named C<-propname> to C<-propvalue> in the namespace C<-namespace> for C<-url>. If C<-action> equals "remove" then we unset a property named C<-propname> in the namespace C<-namespace> for C<-url>. If no action is supplied then the default action is "set". The return value is an C object on success or 0 on failure. The Resource object can be used for interrogating properties or performing other operations. To explicitly set a namespace in which to set the propname then you can use the C<-namespace> and C<-nsabbr> (namespace abbreviation) parameters. But you're welcome to play around with DAV namespaces. Requires a working resource to be set before being called. See C. It is recommended that you use C and C instead of proppatch for readability. C simply calls Cset)> and C calls C"remove")> See C and C for examples. =item B uploads the files or directories at C<-local> to the remote destination at C<-url>. C<-local> points to a file, directory or series of files or directories (indicated by a glob). If the filename contains any of the characters `*', `?' or `[' it is a candidate for filename substitution, also known as ``globbing''. This word is then regarded as a pattern (``glob-pattern''), and replaced with an alphabetically sorted list of file names which match the pattern. One can upload/put a string by passing a reference to a scalar in the -local parameter. See example below. put requires a working resource to be set before being called. See C. The return value is always 1 or 0 indicating success or failure. See L for a description of what the optional callback parameter does. You can also pass a C<-headers> argument. That allows one to specify custom HTTP headers. It can be either a hashref with header names and values, or a L object. B Put a string to the server: my $myfile = "This is the contents of a file to be uploaded\n"; $d->put(-local=>\$myfile,-url=>"http://www.host.org/dav_dir/file.txt"); Put a local file to the server: $d->put(-local=>"/tmp/index.html",-url=>"http://www.host.org/dav_dir/"); Put a series of local files to the server: In these examples, /tmp contains file1.html, file1, file2.html, file2.txt, file3.html, file2/ $d->put(-local=>"/tmp/file[12]*",-url=>"http://www.host.org/dav_dir/"); uploads file1.html, file1, file2.html, file2.txt and the directory file2/ to dav_dir/. =item B Sets a property named C<-propname> to C<-propvalue> in the namespace C<-namespace> for C<-url>. Requires a working resource to be set before being called. See C. The return value is an C object on success or 0 on failure. The Resource object can be used for interrogating properties or performing other operations. Example: if ( $r = $d->set_prop(-url=>$url, -namespace=>"dave", -propname=>"author", -propvalue=>"Patrick Collins" ) ) { print "Author property set\n"; } else { print "set_prop failed:" . $d->message . "\n"; } See the note in propfind about namespace support in HTTP::DAV. They're settable, but not readable. =item B forcefully steals any locks held against URL. steal will perform a propfind against URL and then, any locks that are found will be unlocked one by one regardless of whether we own them or not. Requires a working resource to be set before being called. See C. The return value is always 1 or 0 indicating success or failure. If multiple locks are found and unlocking one of them fails then the operation will be aborted. if ($d->steal()) { print "Steal succeeded\n"; } else { print "Steal failed: ". $d->message() . "\n"; } =item B unlocks any of our locks on URL. Requires a working resource to be set before being called. See C. The return value is always 1 or 0 indicating success or failure. if ($d->unlock()) { print "Unlock succeeded\n"; } else { print "Unlock failed: ". $d->message() . "\n"; } =item B Unsets a property named C<-propname> in the namespace C<-namespace> for C<-url>. Requires a working resource to be set before being called. See C. The return value is an C object on success or 0 on failure. The Resource object can be used for interrogating properties or performing other operations. Example: if ( $r = $d->unset_prop(-url=>$url, -namespace=>"dave", -propname=>"author", ) ) { print "Author property was unset\n"; } else { print "set_prop failed:" . $d->message . "\n"; } See the note in propfind about namespace support in HTTP::DAV. They're settable, but not readable. =back =head2 ACCESSOR METHODS =over 4 =item B Returns the clients' working C object. You may want to interact with the C object to modify request headers or provide advanced authentication procedures. See dave for an advanced authentication procedure. =item B Takes no arguments and returns the clients' last outgoing C object. You would only use this to inspect a request that has already occurred. If you would like to modify the C BEFORE the HTTP request takes place (for instance to add another header), you will need to get the C using C and interact with that. =item B Returns the currently "opened" or "working" resource (C). The working resource is changed whenever you open a url or use the cwd command. e.g. $r = $d->get_workingresource print "pwd: " . $r->get_uri . "\n"; =item B Returns the currently "opened" or "working" C. The working resource is changed whenever you open a url or use the cwd command. print "pwd: " . $d->get_workingurl . "\n"; =item B Returns an C object that represents all of the locks we've created using THIS dav client. print "pwd: " . $d->get_workingurl . "\n"; =item B This is a useful utility function which joins C and C and returns a new URI. If C is not supplied then the current working resource (as indicated by get_workingurl) is used. If C is not set and there is no current working resource the C will be returned. For instance: $d->open("http://host.org/webdav/dir1/"); # Returns "http://host.org/webdav/dir2/" $d->get_absolute_uri(-rel_uri=>"../dir2"); # Returns "http://x.org/dav/dir2/file.txt" $d->get_absolute_uri(-rel_uri =>"dir2/file.txt", ->base_uri=>"http://x.org/dav/"); Note that it subtly takes care of trailing slashes. =back =head2 ERROR HANDLING METHODS =over 4 =item B C gets the last success or error message. The return value is always a scalar (string) and will change everytime a dav operation is invoked (lock, cwd, put, etc). See also C for operations which contain multiple error messages. =item B Returns an @array of error messages that had been set during a multi-request operation. Some of C's operations perform multiple request to the server. At the time of writing only put and get are considered multi-request since they can operate recursively requiring many HTTP requests. In these situations you should check the errors array if to determine if any of the requests failed. The C function is used for multi-request operations and not to be confused with a multi-status server response. A multi-status server response is when the server responds with multiple error messages for a SINGLE request. To deal with multi-status responses, see C. # Recursive put if (!$d->put( "/tmp/my_dir", $url ) ) { # Get the overall message print $d->message; # Get the individual messages foreach $err ( $d->errors ) { print " Error:$err\n" } } =item B Returns the status of the last DAV operation performed through the HTTP::DAV interface. This value will always be the same as the value returned from an HTTP::DAV::method. For instance: # This will always evaluate to true ($d->lock($url) eq $d->is_success) ? You may want to use the is_success method if you didn't capture the return value immediately. But in most circumstances you're better off just evaluating as follows: if($d->lock($url)) { ... } =item B Takes no arguments and returns the last seen C object. You may want to use this if you have just called a propfind and need the individual error messages returned in a MultiStatus. If you find that you're using get_last_response() method a lot, you may be better off using the more advanced C interface and interacting with the HTTP::DAV::* interfaces directly as discussed in the intro. For instance, if you find that you're always wanting a detailed understanding of the server's response headers or messages, then you're probably better off using the C methods and interpreting the C directly. To perform detailed analysis of the server's response (if for instance you got back a multistatus response) you can call C which will return to you the most recent response object (always the result of the last operation, PUT, PROPFIND, etc). With the returned HTTP::DAV::Response object you can handle multi-status responses. For example: # Print all of the messages in a multistatus response if (! $d->unlock($url) ) { $response = $d->get_last_response(); if ($response->is_multistatus() ) { foreach $num ( 0 .. $response->response_count() ) { ($err_code,$mesg,$url,$desc) = $response->response_bynum($num); print "$mesg ($err_code) for $url\n"; } } } =back =head2 ADVANCED METHODS =over 4 =item B Creates a new resource object with which to play. This is the preferred way of creating an C object if required. Why? Because each Resource object needs to sit within a global HTTP::DAV client. Also, because the new_resource routine checks the C locked resource list before creating a new object. $dav->new_resource( -uri => "http://..." ); =item B Sets the current working resource to URL. You shouldn't need this method. Call open or cwd to set the working resource. You CAN call C but you will need to perform a C immediately following it to ensure that the working resource is valid. =back =head1 INSTALLATION, TODO, MAILING LISTS and REVISION HISTORY [OUTDATED] Please see the primary HTTP::DAV webpage at (http://www.webdav.org/perldav/http-dav/) or the README file in this library. =head1 SEE ALSO You'll want to also read: =over =item C =item C =item C =back and maybe if you're more inquisitive: =over =item C =item C =item C =item C =item C =item C =back =head1 AUTHOR AND COPYRIGHT This module is Copyright (C) 2001-2008 by Patrick Collins G03 Gloucester Place, Kensington Sydney, Australia Email: pcollins@cpan.org Phone: +61 2 9663 4916 All rights reserved. Current co-maintainer of the module is Cosimo Streppone for Opera Software ASA, L. You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut