view release on metacpan or  search on metacpan

lib/Net/DAV/Server.pm  view on Meta::CPAN

    my $class = shift;
    my %args = @_ % 2 ? () : @_;
    my $self = {};
    if ( $args{'-dbobj'} ) {
        $self->{'lock_manager'} = Net::DAV::LockManager->new( $args{'-dbobj'} );
    }
    elsif ( $args{'-dbfile'} ) {
        $self->{'_dsn'} = "dbi:SQLite:dbname=$args{'-dbfile'}";
    }
    elsif ( $args{'-dsn'} ) {
        $self->{'_dsn'} = $args{'-dsn'};
    }
    bless $self, $class;
    if ( $args{'-filesys'} ) {
        $self->filesys( $args{'-filesys'} );
    }
    return $self;
}

sub filesys {
    my ($self, $nfs) = @_;
    $self->{'-filesys'} = $nfs if defined $nfs;
    return $self->{'-filesys'};
}

sub run {
    my ( $self, $request, $response ) = @_;

    my $fs = $self->filesys || die 'Filesys missing';

    my $method = $request->method;
    my $path   = uri_unescape $request->uri->path;

    if ( !defined $response ) {
        $response = HTTP::Response->new;
    }

    $method = lc $method;
    if ( $implemented{$method} ) {
        $response->code(200);
        $response->message('OK');
        eval {
            $response = $self->$method( $request, $response );
            $response->header( 'Content-Length' => length( $response->content ) ) if defined $response->content;
            1;
        } or do {
            return HTTP::Response->new( 400, 'Bad Request' );
        };
    }
    else {

        # Saying it isn't implemented is better than crashing!
        $response->code(501);
        $response->message('Not Implemented');
    }
    return $response;
}

sub options {
    my ( $self, $request, $response ) = @_;
    $response->header( 'DAV'           => '1,2,<http://apache.org/dav/propset/fs/1>' );    # Nautilus freaks out
    $response->header( 'MS-Author-Via' => 'DAV' );                                         # Nautilus freaks out
    $response->header( 'Allow'         => join( ',', map { uc } keys %implemented ) );
    $response->header( 'Content-Type'  => 'httpd/unix-directory' );
    $response->header( 'Keep-Alive'    => 'timeout=15, max=96' );
    return $response;
}

sub head {
    my ( $self, $request, $response ) = @_;
    my $path = uri_unescape $request->uri->path;
    my $fs   = $self->filesys;

    if ( $fs->test( 'f', $path ) && $fs->test( 'r', $path ) ) {
        $response->last_modified( $fs->modtime($path) );
    }
    elsif ( $fs->test( 'd', $path ) ) {
        $response->header( 'Content-Type' => 'text/html; charset="utf-8"' );
    }
    else {
        $response = HTTP::Response->new( 404, 'NOT FOUND', $response->headers );
    }
    return $response;
}

sub get {
    my ( $self, $request, $response ) = @_;
    my $path = uri_unescape $request->uri->path;
    my $fs   = $self->filesys;

    if ( $fs->test( 'f', $path ) && $fs->test( 'r', $path ) ) {
        my $fh = $fs->open_read($path);
        my $file = join '', <$fh>;
        $fs->close_read($fh);
        $response->content($file);
        $response->last_modified( $fs->modtime($path) );
    }
    elsif ( $fs->test( 'd', $path ) ) {

        # a web browser, then
        my @files = $fs->list($path);
        my $body;
        my $fpath = $path =~ m{/$} ? $path : $path . '/';
        foreach my $file (@files) {
            if ( $fs->test( 'd', $fpath . $file ) ) {
                $body .= qq|<a href="$file/">$file/</a><br>\n|;
            }
            else {
                $file =~ s{/$}{};
                $body .= qq|<a href="$file">$file</a><br>\n|;
            }
        }
        $response->header( 'Content-Type' => 'text/html; charset="utf-8"' );
        $response->content($body);
    }
    else {
        return HTTP::Response->new( 404, 'Not Found' );
    }
    return $response;
}