comma/cgi-bin/comma-cvslog.cgi

#!/usr/bin/perl 

use strict;

## NOTE: This script must not be called other than from mod_rewrite

my $path = $ENV{QUERY_STRING};
$path =~ s#^uri=##;
$path =~ s#,[^,]+$##;
$path =~ s/\#.*\z//s;
$path =~ s/\?.*\z//s;
$path = '/' . $path;
$path =~ s#//+#/#g;
$path ||= '/';
if ($path =~ /%2F/) {
  print "Status: 404 Not Found\n";
  print "\n";
  print "Not found";
  exit;
}
$path =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
if ($path =~ m#/\.\.?/# or $path =~ m#/\.\.?$# or $path =~ /[^\x21-\x7E]/) {
  ## BUG: Status 404
  print "Location: /error/404\n";
  print "\n";
  exit;
}

my $file;
my $root = '/home/httpd/html/';
if ($path =~ s#^/~(hero|wakaba)/##) {
  $file = qq'/home/$1/public_html/' . $path;
} else {
  $file = '/home/httpd/html' . $path;
} 

my $dir = $file;
my $file_name = '';
$dir =~ s#/$##;
unless (-d $dir) {
  $dir =~ s#/([^/]+)$##;
  $file_name = $1 if -f $file;
}


my $cvsuri = '';
if (-d $dir . '/CVS') {
  if (-f $dir . '/CVS/Root') {
    open my $root, '<', $dir . '/CVS/Root';
    ## NOTE: Branch is not supported
    if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)/?$#) {
      my $rpath = $1;
      if (-f $dir . '/CVS/Repository') {
        open my $repo, '<', $dir . '/CVS/Repository';
        my $reppath = <$repo>;
        $reppath =~ tr/\x0A\x0D//d;
        if ($reppath) {
          $cvsuri = qq{/gate/cvs/$reppath/$file_name@{[
                         {q[/home/cvs] => '',
                          q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath}
                       ]}};
        }
      }
    }
  }
}

unless ($cvsuri) {
  ## Bug: Status 404
  print "Location: /error/404\n";
  print "\n";
  exit;
}

print "Status: 301 Found\n";
print "Location: http://suika.fam.cx$cvsuri\n";
print "\n";
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			{q[/home/cvs] => '',
61			q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath}
62			]}};
63			}
64			}
65			}
66			}
67			}
68
69			unless ($cvsuri) {
70			## Bug: Status 404
71			print "Location: /error/404\n";
72			print "\n";
73			exit;
74			}
75
76			print "Status: 301 Found\n";
77			print "Location: http://suika.fam.cx$cvsuri\n";
78			print "\n";