comma/cgi-bin/comma-cvslog.cgi

#!/usr/bin/perl 

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

my $path = $ENV{QUERY_STRING};
$path =~ s#^uri=##;
$path =~ s#,[^,]+$##;
$path =~ s/\#.*\z//s;
$path =~ s/\?.*\z//s;
$path = decode_path (canon_path ($path));

my $file;
if ($path =~ s#^/~(hero|wakaba|fuyu)/##) {
  $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}
                       ]}};
        }
      }
    }
  }
}

err_not_found () unless $cvsuri;

print "Status: 301 Found\n";
print "Location: http://suika.fam.cx$cvsuri\n";
print "\n";

exit;

sub err_not_found {
  print "Status: 404 Not Found\n";
  print "Content-Type: text/plain; charset=us-ascii\n";
  print "\n";
  print "Not found.";
  exit;
}

sub decode_path ($) {
  my $path = shift;
  if ($path =~ /%2F/) {
    err_not_found;
  }
  $path =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
  if ($path =~ /[^\x21-\x7E]/) {
    err_not_found;
  }
  $path;
}

sub canon_path ($) {
  my $path = '/' . remove_dot_segments (shift or '');
  $path =~ s#//+#/#g;
  $path;
}

sub remove_dot_segments ($) {
  my $input = shift;
  my @output;
  while (length $input) {
    if ($input =~ s#^\.\.?/##g or $input =~ s#^/\.(?:/|(?![^/]))#/#g) {
      # 
    } elsif ($input =~ s#^/\.\.(?:/|(?![^/]))#/#) {
      pop @output;
    } elsif ($input eq '.' or $input eq '..') {
      last;
    } elsif ($input =~ s#^(/?[^/]*)##) {
      push @output, $1;
    } else {
      die;
    }
  }
  join '', @output;
}
1	wakaba	1.1	#!/usr/bin/perl
2
3	wakaba	1.2	## NOTE: This script must not be called other than from mod_rewrite
4	wakaba	1.1	use strict;
5
6			my $path = $ENV{QUERY_STRING};
7			$path =~ s#^uri=##;
8			$path =~ s#,[^,]+$##;
9			$path =~ s/\#.*\z//s;
10			$path =~ s/\?.*\z//s;
11	wakaba	1.2	$path = decode_path (canon_path ($path));
12	wakaba	1.1
13			my $file;
14	wakaba	1.2	if ($path =~ s#^/~(hero\|wakaba\|fuyu)/##) {
15	wakaba	1.1	$file = qq'/home/$1/public_html/' . $path;
16			} else {
17			$file = '/home/httpd/html' . $path;
18			}
19
20			my $dir = $file;
21			my $file_name = '';
22			$dir =~ s#/$##;
23			unless (-d $dir) {
24			$dir =~ s#/([^/]+)$##;
25			$file_name = $1 if -f $file;
26			}
27
28
29
30			my $cvsuri = '';
31			if (-d $dir . '/CVS') {
32			if (-f $dir . '/CVS/Root') {
33			open my $root, '<', $dir . '/CVS/Root';
34			## NOTE: Branch is not supported
35			if (<$root> =~ m#^(/home/cvs\|/home/wakaba/pub/cvs)/?$#) {
36			my $rpath = $1;
37			if (-f $dir . '/CVS/Repository') {
38			open my $repo, '<', $dir . '/CVS/Repository';
39			my $reppath = <$repo>;
40			$reppath =~ tr/\x0A\x0D//d;
41			if ($reppath) {
42			$cvsuri = qq{/gate/cvs/$reppath/$file_name@{[
43			{q[/home/cvs] => '',
44			q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath}
45			]}};
46			}
47			}
48			}
49			}
50			}
51
52	wakaba	1.2	err_not_found () unless $cvsuri;
53
54			print "Status: 301 Found\n";
55			print "Location: http://suika.fam.cx$cvsuri\n";
56			print "\n";
57
58			exit;
59
60			sub err_not_found {
61			print "Status: 404 Not Found\n";
62			print "Content-Type: text/plain; charset=us-ascii\n";
63	wakaba	1.1	print "\n";
64	wakaba	1.2	print "Not found.";
65	wakaba	1.1	exit;
66			}
67
68	wakaba	1.2	sub decode_path ($) {
69			my $path = shift;
70			if ($path =~ /%2F/) {
71			err_not_found;
72			}
73			$path =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
74			if ($path =~ /[^\x21-\x7E]/) {
75			err_not_found;
76			}
77			$path;
78			}
79
80			sub canon_path ($) {
81			my $path = '/' . remove_dot_segments (shift or '');
82			$path =~ s#//+#/#g;
83			$path;
84			}
85
86			sub remove_dot_segments ($) {
87			my $input = shift;
88			my @output;
89			while (length $input) {
90			if ($input =~ s#^\.\.?/##g or $input =~ s#^/\.(?:/\|(?![^/]))#/#g) {
91			#
92			} elsif ($input =~ s#^/\.\.(?:/\|(?![^/]))#/#) {
93			pop @output;
94			} elsif ($input eq '.' or $input eq '..') {
95			last;
96			} elsif ($input =~ s#^(/?[^/]*)##) {
97			push @output, $1;
98			} else {
99			die;
100			}
101			}
102			join '', @output;
103			}