LCFG::Build::VCS::CVS - LCFG build tools for CVS version-control

    LCFG::Build::VCS::CVS - LCFG build tools for CVS version-control

    This documentation refers to LCFG::Build::VCS::CVS version 0.0.33

    my $dir = ".";

    my $spec = LCFG::Build::PkgSpec->new_from_metafile("$dir/lcfg.yml");

    my $vcs = LCFG::Build::VCS::CVS->new( module  => $spec->fullname,
                                          workdir => $dir );

    $vcs->genchangelog();

    if ( $vcs->checkcommitted() ) {
      $vcs->tagversion();
    }

    Stephen Quinney <squinney@inf.ed.ac.uk>

package LCFG::Build::VCS::CVS;  # -*-perl-*-
use strict;
use warnings;

# $Id: CVS.pm.in 3582 2009-03-13 15:11:36Z squinney@INF.ED.AC.UK $
# $Source: /var/cvs/dice/LCFG-Build-VCS/lib/LCFG/Build/VCS/CVS.pm.in,v $
# $Revision: 3582 $
# $HeadURL: https://svn.lcfg.org/svn/source/tags/LCFG-Build-VCS/LCFG_Build_VCS_0_0_33/lib/LCFG/Build/VCS/CVS.pm.in $
# $Date: 2009-03-13 15:11:36 +0000 (Fri, 13 Mar 2009) $

our $VERSION = '0.0.33';

use Cwd            ();
use File::Find     ();
use File::Path     ();
use File::Spec     ();
use IO::File qw(O_WRONLY O_CREAT O_NONBLOCK O_NOCTTY);

use Moose;
with 'LCFG::Build::VCS';

has '+binpath' => ( default => '/usr/bin/cvs' );

has 'root' => (
    is      => 'rw',
    isa     => 'Str',
    lazy    => 1,
    default => sub { _get_root(@_) },
);

has '+id' => ( default => 'CVS' );

sub build_cmd {
    my ( $self, @args ) = @_;

    my @cmd = ( $self->binpath, '-d', $self->root );
    if ( $self->quiet ) {
        push @cmd, '-Q';
    }
    push @cmd, @args;

    return @cmd;
}

# This should give a speed-up in loading

no Moose;
__PACKAGE__->meta->make_immutable;

sub _get_root {
    my ($self) = @_;

    my $root;

    my $rootfile = File::Spec->catfile( $self->workdir, 'CVS', 'Root' );
    if ( -f $rootfile ) {
        eval {
            my $fh = IO::File->new( $rootfile, 'r' );
            chomp( $root = $fh->getline );
            $fh->close;
        };
    }

    if ( !$root ) {
        $root = $ENV{CVSROOT};
    }

    return $root;
}

sub genchangelog {
    my ($self) = @_;

    my $dir     = $self->workdir;
    my $logfile = $self->logfile;

    my $orig_dir = Cwd::abs_path();
    chdir $dir or die "gen: Could not access directory, $dir: $!\n";

    if ( !-e $logfile ) {

        # This bit borrowed from File::Touch
        sysopen my $fh, $logfile, O_WRONLY | O_CREAT | O_NONBLOCK | O_NOCTTY
            or die "Cannot create $logfile : $!\n";
        $fh->close or die "Cannot close $logfile : $!\n";

        # Assume it is not already part of the repository
        $self->run_cmd( 'add', $logfile );
    }

    my $cmd = '/usr/bin/cvs2cl --hide-filenames --accum --file ' . $logfile;

    if ( $self->quiet ) {
        $cmd .= ' --global-opts \'-Q\'';
    }

    # This requires a full shell to actually work, I think the cvs
    # command is the root cause.

    if ( $self->dryrun ) {
        print "Dry-run: $cmd\n";
    }
    else {
        system $cmd;
        if ( $? != 0 ) {
            die "Could not run cvs2cl: $!\n";
        }
    }

    chdir $orig_dir
        or die "Could not return to original directory, $orig_dir: $!\n";

    return;
}

sub checkcommitted {
    my ($self) = @_;

    my $orig_dir = Cwd::abs_path();

    my $dir = $self->workdir;
    chdir $dir or die "check: Could not access directory, $dir: $!\n";

    my @status = $self->run_cmd('status');

    my @notcommitted;
    for my $line (@status) {
        if ( $line =~ m/^File: (.+?)\s+Status: (.+)$/ ) {
            my ( $file, $status ) = ( $1, $2 );
            if ( $status !~ m/Up-to-date/ ) {
                push @notcommitted, $file;
            }
        }
    }

    chdir $orig_dir
        or die "Could not return to original directory, $orig_dir: $!\n";

    my $allcommitted;
    if ( scalar @notcommitted > 0 ) {
        $allcommitted = 0;
    }
    else {
        $allcommitted = 1;
    }

    if (wantarray) {
        return ( $allcommitted, @notcommitted );
    }
    else {
        return $allcommitted;
    }
}

sub tagversion {
    my ( $self, $version ) = @_;

    $self->update_changelog($version);

    my $tag = $self->gen_tag($version);

    my $orig_dir = Cwd::abs_path();

    my $dir = $self->workdir;
    chdir $dir or die "tag: Could not access directory, $dir: $!\n";

    eval { $self->run_cmd( 'commit', '-m', "Release: $version" ) };
    if ($@) {
        die "Could not mark release for $dir at $version\n";
    }

    eval { $self->run_cmd( 'tag', '-F', '-c', $tag ) };
    if ($@) {
        die "Could not tag $dir with $tag\n";
    }

    eval { $self->run_cmd( 'tag', '-F', '-c', 'latest' ) };
    if ($@) {
        die "Could not tag $dir as latest\n";
    }

    chdir $orig_dir
        or die "Could not return to original directory, $orig_dir: $!\n";

    return;
}

sub _process_cvs_entries {
    my ( $workdir, $entries ) = @_;

    my $path = $File::Find::name;

    if ( -f $path ) {
        my ( $vol, $dirname, $basename ) = File::Spec->splitpath($path);
        my @dirs = File::Spec->splitdir($dirname);

        # If the last element of the directory list is empty throw it away
        if ( length $dirs[-1] == 0 ) {
            pop @dirs;
        }

        if ( $dirs[-1] eq 'CVS' && $basename eq 'Entries' ) {
            pop @dirs; # remove the 'CVS' directory

            # This is a (hopefully) system-independent way of removing
            # the working directory from the front of the current
            # directory name to produce relative filenames.

            for ( my $i=0; $i<scalar(@{$workdir}); $i++) {
                if ( $dirs[0] eq $workdir->[$i] ) {
                    shift @dirs;
                }
                else {
                    last;
                }
            }

            my $dir = File::Spec->catdir(@dirs);

            my $fh = IO::File->new( $path, 'r' )
                or die "Could not open $path for reading: $!\n";
            while ( defined( my $entry = $fh->getline ) ) {

                if ( $entry =~ m{^/      # Line starts with a forward slash
                                                                  ([^/]+) # Stuff which is not a forward slash
                                                                  /       # Another forward slash
                                                                  \d      # Any digit (avoids deleted files)
                                                                }x ) {
                    push @{$entries}, [ $dir, $1 ];
                }
            }
            $fh->close;
        }
    }

    return;
}

sub export_devel {
    my ( $self, $version, $builddir ) = @_;

    my $workdir = $self->workdir;
    my $target = join q{-}, $self->module, $version;

    my $exportdir = File::Spec->catdir( $builddir, $target );

    if ( !$self->dryrun ) {
        File::Path::rmtree($exportdir);
        eval { File::Path::mkpath($exportdir) };
        if ($@) {
            die "Could not create $exportdir: $@\n";
        }
    }

    my @workdir = File::Spec->splitdir($workdir);
    # If the last element of the directory list is empty throw it away
    if ( length $workdir[-1] == 0 ) {
        pop @workdir;
    }

    my @entries;
    File::Find::find(
        {   wanted   => sub { _process_cvs_entries( \@workdir, \@entries ) },
            no_chdir => 1,
        },
        $workdir
    );

    for my $entry (@entries) {
        $self->mirror_file( $workdir, $exportdir, @{$entry} );
    }

    return $exportdir;
}

sub export {
    my ( $self, $version, $builddir ) = @_;

    my $tag = $self->gen_tag($version);

    my $target = join q{-}, $self->module, $version;
    my $exportdir = File::Spec->catdir( $builddir, $target );

    if ( !$self->dryrun ) {
        if ( !-d $builddir ) {
            eval { File::Path::mkpath($builddir) };
            if ($@) {
                die "Could not create $builddir: $@\n";
            }
        }

        if ( -d $exportdir ) {
            File::Path::rmtree($exportdir);
        }
    }

    my $orig_dir = Cwd::abs_path();

    chdir $builddir
        or die "export: Could not access directory, $builddir: $!\n";

    $self->run_cmd( 'export', '-r', $tag, '-d', $target, $self->module );

    chdir $orig_dir
        or die "Could not return to original directory, $orig_dir: $!\n";

    return $exportdir;
}

sub checkout_project {
    my ( $self, $version, $outdir ) = @_;

    if ( !defined $outdir ) {
        $outdir = '.';
    }

    my @args;
    if ( defined $version ) {
        my $tag = $self->gen_tag($version);

        @args = ( 'r', $tag );
    }

    my $orig_dir = Cwd::abs_path();

    chdir $outdir or die "tag: Could not access directory, $outdir: $!\n";

    $self->run_cmd( 'checkout', @args, $self->module );

    chdir $orig_dir
        or die "Could not return to original directory, $orig_dir: $!\n";

    return;
}

sub import_project {
    my ( $self, $dir, $version, $message ) = @_;

    if ( !defined $message ) {
        $message = 'Imported with LCFG build tools';
    }

    my $vendor_tag  = $self->gen_tag();
    my $release_tag = $self->gen_tag($version);

    my $orig_dir = Cwd::abs_path();

    chdir $dir or die "tag: Could not access directory, $dir: $!\n";

    $self->run_cmd( 'import',
                    '-I', '!',
                    '-m', $message,
                    $self->module, $vendor_tag, $release_tag );

    chdir $orig_dir
        or die "Could not return to original directory, $orig_dir: $!\n";

    return;
}

1;
__END__