#!/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;
  $input =~ s/%2E/./g;  ## No semantical side effect since "." is unreserved
  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;
}