Apache::CVS - method handler provide a web interface to CVS repositories

    <Location /cvs>
        SetHandler perl-script
        PerlHandler Apache::CVS::HTML
        PerlSetVar CVSRoots cvs1=>/usr/local/CVS
    </Location>

    Location of the CVS Roots.  Set this like you would hash.  This
    variable is required.

    PerlSetVar CVSRoots cvs1=>/path/to/cvsroot1,cvs2=>/path/to/cvsroot2

    File extension of RCS files.  Defaults to ',v'.

    PerlSetVar RCSExtension ,yourextension

    A directory to keep temporary files.  Defaults to /var/tmp.
    Apache::CVS will try to clean up after itself and message to the
    error log if it couldn't.

    PerlSetVar WorkingDirectory /usr/tmp

    The directory of the rcs binaries.  Defaults to /usr/bin.

    PerlSetVar BinaryDirectory /usr/local/bin

    The different types of diffs you want to provide to users.
    The values will be passed to cvs diff as arguments. If not
    set users will see a unified diff.

    PerlSetVar DiffStyles unified=>ua,side-by-side=>ya

    The default diff style. The value must be a valid predefined
    DiffStyle.  If not set or set incorrectly Apache::CVS will default to
    the first DiffStyle.

    PerlSetVar DefaultDiffStyle unified

# $Id: CVS.pm,v 1.35 2003/12/07 00:00:37 barbee Exp $

package Apache::CVS;

use strict;

use Apache::URI();
use Apache::CVS::RcsConfig();
use Apache::CVS::PlainFile();
use Apache::CVS::Directory();
use Apache::CVS::File();
use Apache::CVS::Revision();
use Apache::CVS::Diff();
eval "use Apache::CVS::Graph();";
if ($@) {
    $Apache::CVS::Graph = 0;
} else {
    $Apache::CVS::Graph = 1;
}

$Apache::CVS::VERSION = '0.10';

sub print_http_header {
    my $self = shift;
    return if $self->http_headers_sent();
    $self->request()->content_type($self->content_type());
    $self->request()->send_http_header;
    $self->http_headers_sent(1);
}

sub print_error {
    return;
}

sub print_page_header {
    return;
}

sub print_page_footer {
    return;
}

sub print_root_list_header {
    return;
}

sub print_root {
    return;
}

sub print_root_list_footer {
    return;
}

sub print_directory_list_header {
    return;
}

sub print_directory {
    return;
}

sub print_file {
    return;
}

sub sort_files {
    return $_[1]
}

sub print_plain_file {
    return;
}

sub print_directory_list_footer {
    return;
}

sub print_file_list_header {
    return;
}

sub print_revision {
    return;
}

sub sort_revisions {
    return $_[1];
}

sub print_file_list_footer {
    return;
}

sub print_text_revision {
    return;
}

sub print_diff {
    return;
}

sub print_graph {
    return;
}

sub _get_roots {
    my $request = shift;
    my %cvsroots = split /\s*(?:=>|,)\s*/, $request->dir_config('CVSRoots');
    return \%cvsroots;
}

sub _get_rcs_config {
    my $request = shift;
    return Apache::CVS::RcsConfig->new($request->dir_config('RCSExtension'),
                                       $request->dir_config('WorkingDirectory'),
                                       $request->dir_config('BinaryDirectory'));
}

sub _get_diff_styles {
    my $request = shift;
    my %styles = split /\s*(?:=>|,)\s*/, $request->dir_config('DiffStyles');

    # default style
    $styles{unified} = 'ua' unless scalar keys %styles;
    return \%styles;
}

sub _get_default_diff_style {
    my $request = shift;
    my $styles = shift;
    my $default = $request->dir_config('DefaultDiffStyle');

    # if directive not set or style is not set up then grab a style
    # from the list
    unless ($default && exists($styles->{$default})) {
        if (scalar keys %{ $styles} == 1) {
            # if there is only one style we can stop here
            $default = (keys %{ $styles})[0];
        } else {
            # otherwise parse the DiffStyles directive for the first style
            $request->dir_config('DiffStyles') =~ /([^\s=,]*)/;
            $default = $1;
        }
    }
    # we absolutely must have a valid default, so we should check our
    # work
    unless (exists(${$styles}{$default})) {
        # alright, so we screwed up somewhere, fallback to the first
        # style
        $default = (keys %{ $styles})[0];
    }
    return $default;
}

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $request = shift;
    my $self;

    $self->{request} = $request;
    $self->{rcs_config} = _get_rcs_config($self->{request});
    $self->{roots} = _get_roots($self->{request});
    $self->{content_type} = 'text/html';
    $self->{http_headers_sent} = 0;
    $self->{page_headers_sent} = 0;
    $self->{current_root} = undef;
    $self->{path} = undef;
    $self->{diff_styles} = _get_diff_styles($self->{request});
    $self->{default_diff_style} =
        _get_default_diff_style($self->{request}, $self->{diff_styles});
    $self->{file_sorting_available} = 0;
    $self->{revision_sorting_available} = 0;
    bless ($self, $class);
    return $self;
}

sub request {
    my $self = shift;
    $self->{request} = shift if scalar @_;
    return $self->{request};
}

sub rcs_config {
    my $self = shift;
    return $self->{rcs_config};
}

sub content_type {
    my $self = shift;
    $self->{content_type} = shift if scalar @_;
    return $self->{content_type};
}

sub http_headers_sent {
    my $self = shift;
    $self->{http_headers_sent} = shift if scalar @_;
    return $self->{http_headers_sent};
}

sub page_headers_sent {
    my $self = shift;
    $self->{page_headers_sent} = shift if scalar @_;
    return $self->{page_headers_sent};
}

sub path {
    my $self = shift;
    if (scalar @_) {
        $self->{path} = shift;
        my $real_file_path = $self->{path} . $self->rcs_config()->extension();
        unless (-d $self->{path}  || -r $real_file_path) {
            die "File or directory ($self->{path} or $real_file_path) does " .
                "not exist.";
        }
    }

    return $self->{path};
}

sub current_root {
    my $self = shift;
    $self->{current_root} = shift if scalar @_;
    return $self->{current_root};
}

sub roots {
    my $self = shift;
    return $self->{roots};
}

sub diff_styles {
    my $self = shift;
    $self->{diff_styles} = shift if scalar @_;
    return $self->{diff_styles};
}

sub default_diff_style {
    my $self = shift;
    $self->{default_diff_style} = shift if scalar @_;
    return $self->{default_diff_style};
}   

sub current_root_path {
    my $self = shift;
    return $self->roots()->{$self->current_root()};
}

sub file_sorting_available {
    my $self = shift;
    $self->{file_sorting_available} = shift if scalar @_;
    return $self->{file_sorting_available};
}

sub revision_sorting_available {
    my $self = shift;
    $self->{revision_sorting_available} = shift if scalar @_;
    return $self->{revision_sorting_available};
}

sub handle_root {
     my $self = shift;
     $self->print_root($_) foreach ( keys %{ $self->roots()} );
 }

sub handle_directory {
    my $self = shift;
    my $row_counter = 0;
    my ($uri_base, $sort_criterion, $sort_direction) = @_;
    $self->print_directory_list_header($uri_base, $sort_criterion,
                                       $sort_direction);
    my $directory = Apache::CVS::Directory->new($self->path(),
                                                $self->rcs_config());
    $directory->load();
    foreach ( @{ $directory->directories() } ) {
        $self->print_directory($uri_base, $_, $row_counter);
        $row_counter++;
    }

    my $sorted_files = $directory->files();
    if ($self->file_sorting_available()) {
        $sorted_files = $self->sort_files($directory->files(), $sort_criterion,
                                          $sort_direction);
    }
    foreach ( @{ $sorted_files } ) {
        $self->print_file($uri_base, $_, $row_counter);
        $row_counter++;
    }

    foreach ( @{ $directory->plain_files() } ) {
        $self->print_plain_file($_);
        $row_counter++;
    }
    $self->print_directory_list_footer();
}

sub handle_file {
    my $self = shift;
    my ($uri_base, $diff_revision, $sort_criterion, $sort_direction) = @_;
    my $file = Apache::CVS::File->new($self->path(), $self->rcs_config());
    my $row_counter = 0;

    $uri_base .= $file->name();
    $self->print_file_list_header($uri_base, $sort_criterion, $sort_direction);

    # if sorting available, go with new behavior
    if ($self->revision_sorting_available()) {
        my $sorted_revisions = $self->sort_revisions($file->revisions(),
                                                     $sort_criterion,
                                                     $sort_direction);
        foreach ( @{ $sorted_revisions }) {
            $self->print_revision($uri_base, $_, $row_counter, $diff_revision);
            $row_counter++;
        }
    # otherwise, just use old behavior where we iterate through revisions
    } else {
        while ( my $revision = $file->revision('prev') ) {
            $self->print_revision($uri_base, $revision, $row_counter,
                                  $diff_revision);
            $row_counter++;
        }
    }
    $self->print_file_list_footer();
}

sub handle_revision {
    my $self = shift;
    my ($uri_base, $revision_num) = @_;
    
    my $file = Apache::CVS::File->new($self->path(), $self->rcs_config());
    my $revision = $file->revision($revision_num);

    eval {
        if ($revision->is_binary()) {
            my $subrequest =
                $self->request()->lookup_file($revision->co_file());
            $self->content_type($subrequest->content_type);
            $self->print_http_header();
            $self->request()->send_fd($revision->filehandle());
            close $revision->filehandle();
        } else {
            $self->print_http_header();
            $self->print_page_header();
            $self->print_text_revision($revision->content());
        }
    };
    if ($@) {
        $self->request()->log_error($@);
        $self->print_error("Unable to get revision.\n$@");
        return;
    }
}

sub handle_diff {
    my $self = shift;
    my ($source_version, $target_version, $diff_style, $uri_base) = @_;

    my $file = Apache::CVS::File->new($self->path(), $self->rcs_config());
    my $source = $file->revision($source_version);
    my $target = $file->revision($target_version);
    $diff_style ||= $self->default_diff_style();
    my $diff = Apache::CVS::Diff->new($source, $target,
                                      $self->diff_styles()->{$diff_style});
    $self->print_diff($diff, $uri_base . $file->name());
}

sub handle_graph {
    return unless $Apache::CVS::Graph;
    my $self = shift;
    my $uri_base = shift;
    my $file = Apache::CVS::File->new($self->path(), $self->rcs_config());
    my $graph = Apache::CVS::Graph->new($file);
    $self->print_graph($uri_base, $file->name(), $graph);
}

sub handler_internal {
    my $self = shift;

    my $path_info = $self->request()->path_info;

    my $is_real_root = 1 unless ( $path_info and $path_info ne '/' );

    if ( $is_real_root ) {

        $self->print_http_header();
        $self->print_page_header();
        $self->handle_root();
        return;
    }

    # strip off the cvs root id from the front
    $path_info =~ s#/([^/]+)/?##;
    $self->current_root($1);

    # determine current path
    my $is_cvsroot;
    unless ( $path_info and $path_info ne '/' ) {

        $self->path($self->current_root_path());
        $is_cvsroot = 1;
    } else {

        $self->path($self->current_root_path() . q(/) .  $path_info);
    }

    my %query = $self->request()->args;
    my $is_revision = exists $query{'r'};

    my $uri_base = $self->request()->parsed_uri->rpath() . q(/) .
                   $self->current_root() . q(/) .  $path_info;

    if ( -d $self->path() ) {

        $self->print_http_header();
        $self->print_page_header();
        $uri_base .= q(/) unless $uri_base =~ /\/$/;
        $self->handle_directory($uri_base, $query{'o'}, $query{'asc'});
    } else {

        $uri_base =~ s/[^\/]*$//;

        my %query = $self->request()->args;
        if ( $query{'ds'} && $query{'dt'} ) {
            $self->print_http_header();
            $self->print_page_header();
            $self->handle_diff($query{'ds'}, $query{'dt'}, $query{'dy'},
                               $uri_base);
        } elsif ( $is_revision ) {
            $self->handle_revision($uri_base, $query{'r'});
        } elsif ( $Apache::CVS::Graph and exists($query{'g'}) ) {
            $self->print_http_header();
            $self->print_page_header();
            $self->handle_graph($uri_base, $query{'r'});
        } else {
            $self->print_http_header();
            $self->print_page_header();
            $self->handle_file($uri_base, $query{'ds'}, $query{'o'},
                               $query{'asc'});
        }
    }
}

sub handler($$) {

    my ($self, $request) = @_;

    delete $ENV{'PATH'};

    $self = $self->new($request) unless ref $self;

    eval {
        $self->handler_internal();
    };

    if ($@) {
        $self->request()->log_error($@);
        $self->print_error($@);
    }
}

1;