Parent Directory
| 
Revision Log
Comma tools: new
| 1 | wakaba | 1.1 | #!/usr/bin/perl |
| 2 | |||
| 3 | use strict; | ||
| 4 | |||
| 5 | ## NOTE: This script must not be called other than from mod_rewrite | ||
| 6 | |||
| 7 | my $path = $ENV{QUERY_STRING}; | ||
| 8 | $path =~ s#^uri=##; | ||
| 9 | $path =~ s#,[^,]+$##; | ||
| 10 | $path =~ s/\#.*\z//s; | ||
| 11 | $path =~ s/\?.*\z//s; | ||
| 12 | $path = '/' . $path; | ||
| 13 | $path =~ s#//+#/#g; | ||
| 14 | $path ||= '/'; | ||
| 15 | if ($path =~ /%2F/) { | ||
| 16 | print "Status: 404 Not Found\n"; | ||
| 17 | print "\n"; | ||
| 18 | print "Not found"; | ||
| 19 | exit; | ||
| 20 | } | ||
| 21 | $path =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge; | ||
| 22 | if ($path =~ m#/\.\.?/# or $path =~ m#/\.\.?$# or $path =~ /[^\x21-\x7E]/) { | ||
| 23 | ## BUG: Status 404 | ||
| 24 | print "Location: /error/404\n"; | ||
| 25 | print "\n"; | ||
| 26 | exit; | ||
| 27 | } | ||
| 28 | |||
| 29 | my $file; | ||
| 30 | my $root = '/home/httpd/html/'; | ||
| 31 | if ($path =~ s#^/~(hero|wakaba)/##) { | ||
| 32 | $file = qq'/home/$1/public_html/' . $path; | ||
| 33 | } else { | ||
| 34 | $file = '/home/httpd/html' . $path; | ||
| 35 | } | ||
| 36 | |||
| 37 | my $dir = $file; | ||
| 38 | my $file_name = ''; | ||
| 39 | $dir =~ s#/$##; | ||
| 40 | unless (-d $dir) { | ||
| 41 | $dir =~ s#/([^/]+)$##; | ||
| 42 | $file_name = $1 if -f $file; | ||
| 43 | } | ||
| 44 | |||
| 45 | |||
| 46 | |||
| 47 | my $cvsuri = ''; | ||
| 48 | if (-d $dir . '/CVS') { | ||
| 49 | if (-f $dir . '/CVS/Root') { | ||
| 50 | open my $root, '<', $dir . '/CVS/Root'; | ||
| 51 | ## NOTE: Branch is not supported | ||
| 52 | if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)/?$#) { | ||
| 53 | my $rpath = $1; | ||
| 54 | if (-f $dir . '/CVS/Repository') { | ||
| 55 | open my $repo, '<', $dir . '/CVS/Repository'; | ||
| 56 | my $reppath = <$repo>; | ||
| 57 | $reppath =~ tr/\x0A\x0D//d; | ||
| 58 | if ($reppath) { | ||
| 59 | $cvsuri = qq{/gate/cvs/$reppath/$file_name@{[ | ||
| 60 |