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	#!/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";