view release on metacpan or  search on metacpan

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

    #trace    => 1,
    #lock     => 1,
    #unlock   => 1,
);

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

    bless {}, $class;
}

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

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

#
# Process the request.  The $r is the apache object passed in from the mod_perl
# handler.
#
sub process
{
    my ($self, $r) = @_;

    my $uri    = $r->uri();
    my $method = lc($r->method());

    my $handler = $self->get_handler_for_path($uri);

    if($implemented{$method})
    {
        return $self->$method($r, $handler);
    }
    else
    {
        return DECLINED;
    }
}

#
# Started working on this, targetted clients don't need it, never finished.
#

# sub proppatch
# {
#     my ($self, $r, $handler) = @_;
# 
#     $r->status(200);
#     $r->header_out("Allow",
#                    "OPTIONS, HEAD, GET, PUT, " .
#                    "DELETE, MKCOL, PROPPATCH, PROPFIND, COPY, MOVE");
#     $r->header_out("DAV", "1,<http://apache.org/dav/propset/fs/1>");
#     $r->send_http_header();
# 
#     return OK;
# }

#
# Copy a resource to another location.
#
sub copy
{
    my ($self, $r, $handler) = @_;

    my $path = $r->uri();

    my $destination = $r->header_in('Destination');
    my $depth       = $r->header_in('Depth');
    my $overwrite   = $r->header_in('Overwrite');

    # Default according to the book is overwrite = T
    if(!defined($overwrite))
    {
        $overwrite = 'T';
    }

    # Translate the destination into a usable format
    $destination = URI->new($destination)->path();

    # If it's a regular file, don't sweat it
    if($handler->test('f', $path))
    {
        return $self->copy_file($r, $handler, $path, $destination, $overwrite);
    }

    # Otherwise, we're copying a directory and we have to do it recursively.
    # The logic for this was taken from Net::DAV::Server.  It's creepy.

    # We can't really go to infinity, but we can fake it.
    $depth = 100 if defined($depth) && $depth eq 'infinity';

    # Search for source files that we have to copy
    my @files = map { s|/+|/|g; $_ }
        File::Find::Rule::Filesys::Virtual->virtual($handler)->file->maxdepth($depth)->in($path);

    # Search for source directories that we have to copy (didn't I tell you it
    # was creepy?)
    my @dirs = reverse sort
        grep { $_ !~ m|/\.\.?$| }
         map { s|/+|/|g; $_ }
        File::Find::Rule::Filesys::Virtual->virtual($handler)->directory->maxdepth($depth)->in($path);

    push @dirs, $path;

    # Create all required directories first
    foreach my $dir (sort @dirs)
    {
        my $dest_dir = $dir;

        $dest_dir =~ s/^$path/$destination/;

        if($overwrite eq 'F' && $handler->test('e', $dest_dir))

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

    {
        if($overwrite eq 'T')
        {
            if($handler->test('d', $destination))
            {
                $overwrote_collection = 1;
            }

            $r->uri($destination); # Specify the URI for the following deletion

            my $result = $self->delete($r, $handler);

            $r->uri($path);        # Reset URI to original value
        }
    }

    my $copy_result = $self->copy($r, $handler);

    if($copy_result != 201)
    {
        if($copy_result == 412)
        {
            return 412;
        }
        elsif($copy_result == HTTP_NO_CONTENT) # Directory already existed
        {
            return 403;
        }
        else
        {
            return FORBIDDEN;
        }
    }

    my $delete_result = $self->delete_resource($r, $handler, $path);

    # Did the delete work properly?
    if(!$delete_result)
    {
        return FORBIDDEN;
    }

    if($already_exists)
    {
        return 204;
    }
    else
    {
        return 201;
    }
}

#
# Specify the options this WebDAV server supports.
#
sub options
{
    my ($self, $r, $handler) = @_;

    $r->header_out('Allow'         => join(',', map { uc } keys %implemented));
    $r->header_out('DAV'           => '1,2,<http://apache.org/dav/propset/fs/1>');
    $r->header_out('MS-Author-Via' => 'DAV');
    $r->header_out('Keep-Alive'    => 'timeout=15, max=96');

    $r->send_http_header();

    return OK;
}

#
# Get information about a file or a directory (or the contents of a directory).
#
sub propfind
{
    my ($self, $r, $handler) = @_;

    my $depth = $r->header_in('Depth');
    my $uri   = $r->uri();

    # Make sure the resource exists
    if(!$handler->test('e', $uri))
    {
        return NOT_FOUND;
    }

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

    my @files;

    if($depth == 0)
    {
        @files = ($uri);
    }
    elsif($depth == 1)
    {
        $uri =~ s/\/$//; # strip trailing slash, we don't store it in the db

        @files = $handler->list($uri);

        # remove . and .. from the list
        @files = grep( $_ !~ /^\.\.?$/, @files );

        # Add a trailing slash to the directory if there isn't one already
        if($uri !~ /\/$/)
        {
            $uri .= '/';
        }

        # Add the current folder to the front of the filename
        @files = map { "$uri$_" } @files;

        # Goliath only doesn't want to see the current/base directory in the
        # response.
        if($r->header_in('User-Agent') !~ /Goliath/)
        {
            push @files, $uri;
        }
    }

    my %wanted_properties = $self->get_wanted_properties($r);