view release on metacpan or  search on metacpan

eg/server.cgi  view on Meta::CPAN

Copyright (C) 1998-2019 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See C<LICENSE> file and L<https://dev.perl.org/licenses/>

=cut

use CGI qw/-putdata_upload/;
use Cwd qw/getcwd/;
use Fcntl qw(:flock);
use File::Spec;
use File::Path qw/mkpath/;
use File::Find;

use constant BASE_URI_PREFIX => '/mbuserver';
#use constant BASE_URI_PREFIX => '/server.cgi';

use constant {
        CONTENT_TYPE    => 'text/plain',
        DEFAULT_METHOD  => 'GET',
        DEFAULT_PATH    => '/',
        BUFFER_SIZE     => 4*1024, # 4kB
    };

my $q = new CGI;

my $meth = $q->request_method || DEFAULT_METHOD;
my $ruri = $q->request_uri || DEFAULT_PATH;
   $ruri =~ s/[?\#](.*)$//;
   $ruri =~ s/\/+$//;
my $path = $ruri;
my $info = $q->path_info();
if ($info) {
    $path = $info;
} else {
    my $i = index($path, BASE_URI_PREFIX);
    substr($path, $i, length(BASE_URI_PREFIX), '') if $i > -1;
}
$path = DEFAULT_PATH unless length($path);
my $reqkey = sprintf("%s %s", $meth, $path);
my $root = $ENV{DOCUMENT_ROOT} // getcwd();
if ($reqkey eq 'GET /') { # lwp-request -E "http://localhost/mbuserver"
    print  $q->header(-type => CONTENT_TYPE, -charset => 'utf-8',);
    print get_list($root);
} elsif ($meth eq 'GET') { # lwp-request -E "http://localhost/mbuserver/foo/bar/test.txt"
    my $file = File::Spec->catfile($root, $path);
    if (-f $file) {
        raise("Incorrect path: %s. Check BASE_URI_PREFIX constant first", $ruri) if $ruri eq $path;
        print $q->redirect($path);
    } elsif (-d $file) {
        print $q->header(-type => CONTENT_TYPE, -charset => 'utf-8',);
        print get_list($file);
    } else {
        print $q->header(
            -type       => CONTENT_TYPE,
            -charset    => 'utf-8',
            -status     => '404 Not Found',
        );
        print "Not Found";
    }
} elsif ($meth eq 'HEAD') { # lwp-request -E -m HEAD "http://localhost/mbuserver/foo/bar/test.txt"
    my $file = File::Spec->catfile($root, $path);
    if (-f $file) {
        raise("Incorrect path: %s. Check BASE_URI_PREFIX constant first", $ruri) if $ruri eq $path;
        print $q->redirect($path);
    } elsif (-d $file) {
        my $content = get_list($file);
        print $q->header(-type => CONTENT_TYPE, -charset => 'utf-8', -content_length => length($content));
    } else {
        print $q->header(
            -type       => CONTENT_TYPE,
            -charset    => 'utf-8',
            -status     => '404 Not Found',
        );
    }
} elsif ($meth eq 'PUT') { # lwp-request -E -m PUT -c "application/octet-stream" "http://localhost/mbuserver/foo/bar/test.txt" < test.txt
    # Get filename
    my ($volume, $directories, $file) = File::Spec->splitpath( $path );
    my $dir = File::Spec->catfile($root, $directories);
    unless (-d $dir or -l $dir) {
        mkpath( $dir, {verbose => 0} );
    }

    # Uploading
    my $out_file = File::Spec->catfile($dir, $file);
    my $got_size = 0;
    UPLOADBLOCK: {
        my $buffer = "";
        my $io_handle = $q->upload('PUTDATA') or last UPLOADBLOCK;
        open( MBUUPLOAD, '>', $out_file ) or raise("Can't open file %s", $out_file);
        flock(MBUUPLOAD, LOCK_EX) or raise("Can't lock file %s: %s", $out_file, $!);
        binmode(MBUUPLOAD);
        while (my $bytesread = $io_handle->read($buffer, BUFFER_SIZE) ) {
            print MBUUPLOAD $buffer;
            $got_size += $bytesread;
        }
        close MBUUPLOAD;
    }
    raise("Can't upload file %s", $file) unless $got_size && $got_size == -s $out_file;

    # Response
    print $q->header(
        -type               => 'application/octet-stream',
        -content_location   => $ruri,
        -status             => '201 Created',
    );
} elsif ($meth eq 'DELETE') { # lwp-request -E -m DELETE "http://localhost/mbuserver/foo/bar/test.txt"
    my $file = File::Spec->catfile($root, $path);
    if (-f $file) {
        unlink $file or raise("Could not unlink %s: %s", $file, $!);
        print $q->header(
            -status     => '204 No Content',
        );
    } elsif (-d $file) {
        print $q->header(
            -type       => CONTENT_TYPE,
            -charset    => 'utf-8',
            -status     => '405 Method Not Allowed',
        );
        print "Method Not Allowed";
    } else {
        print $q->header(
            -type       => CONTENT_TYPE,
            -charset    => 'utf-8',
            -status     => '404 Not Found',
        );
        print "Not Found";
    }
} else {
    print $q->header(
        -type       => CONTENT_TYPE,
        -charset    => 'utf-8',
        -status     => '501 Not Implemented',
    );
    printf "Not Implemented: %s", $reqkey;
}

sub get_list {
    my $r = shift || $root;
    my $name = $q->param("name") || $q->param("host");
    my @list = ();
    find({wanted => sub {
        return if $File::Find::dir ne $r;
        return if $name && index($_, $name) < 0;
        push @list, $_ if -f $_;
    }}, $r);
    return join "\n", @list;
}
sub raise {
    my $format = shift || "Unknown error";
    my @err = @_;
    print $q->header(
        -type       => CONTENT_TYPE,
        -charset    => 'utf-8',
        -status     => '500 Internal Server Error',
    );
    printf $format, @err;
    exit 0;
}

1;

__END__