File Coverage

blib/lib/Cvs/Simple.pm

Criterion	Covered	Total	%
statement	110	205	53.6
branch	32	80	40.0
condition	10	24	41.6
subroutine	29	42	69.0
pod	20	20	100.0
total	201	371	54.1

package Cvs::Simple;
use common::sense;

use Capture::Tiny     qw(capture_merged);
use Carp;
use Class::Std::Utils;
use Cvs::Simple::Hook;

use File::Which       qw(which);

use IO::Lines;

use Module::Runtime   qw(require_module);

use Scalar::Util      qw(reftype);

use Try::Tiny;

# Version set by dist.ini; do not change here.
our $VERSION = '0.07_04'; # VERSION

{
    my(%cvs_bin_of);
    my(%external_of);
    my(%callback_of);
    my(%repos_of);

    sub new
    {
        my $class = shift;
        my $self = bless(anon_scalar(), $class);
        $self->_init(@_);
        return $self;
    }

    sub _init
    {
        my $self = shift;
        my %args = @_;

        if(exists $args{cvs_bin}) {
            $self->cvs_bin($args{cvs_bin});
        } else {
            if(defined($ENV{CVS_SIMPLE_BIN})) {
                $self->cvs_bin($ENV{CVS_SIMPLE_BIN});
            } else {
                my $m =
                    try { require_module('Cvs::Simple::Config') }
                    catch { undef };
                if(defined($m)) {
                    my $cvs_bin =
                        try   { Cvs::Simple::Config::CVS_BIN() }
                        catch { warn($_); undef; };
                    if(defined($cvs_bin)) {
                        $self->cvs_bin( $cvs_bin );
                    } else {
                        croak("csv binary location not specified and cannot find.");
                    }

                    my $ext =
                    try { Cvs::Simple::Config::EXTERNAL() }
                    catch { undef; };
                    if(defined($ext)) {
                        $self->external( $ext );
                    }
                } elsif ( my $exe_path = which('cvs') ) {
                    $self->cvs_bin( $exe_path );
                } else {
                    croak("csv binary location not specified and cannot find.");
                }
            }
        }

        if(exists($args{external})) {
            $self->external($args{external});
        } elsif (defined($ENV{CVS_SIMPLE_EXTERNAL})) {
            $self->external($ENV{CVS_SIMPLE_EXTERNAL});
        }
        else {
            ();
        }

        if(exists $args{callback}) {
            $self->callback($args{callback});
        }
    }

    sub callback
    {
        my $self = shift;
        my $hook = shift;
        my $func = shift;

        # If 'hook' is not supplied, callback is global, i.e. apply to all.
        defined($hook) || ($hook = 'All');

        unless(Cvs::Simple::Hook::permitted($hook)) {
            croak "Invalid hook type in callback: $hook.";
        }

        if(defined($func)) {
            (reftype($func) eq 'CODE') or do {
                croak "Argument supplied to callback() should be a coderef.";
            };
            $callback_of{ident $self}{$hook} = $func;
        }

        if(exists $callback_of{ident $self}{$hook}) {
            return $callback_of{ident $self}{$hook};
        } else {
            return;
        }
    }

    sub unset_callback
    {
        my $self = shift;
        my $hook = shift;

        unless(Cvs::Simple::Hook::permitted($hook)) {
            croak "Invalid hook type in unset_callback: $hook.";
        }

        return delete $callback_of{ident $self}{$hook};
    }

    sub cvs_bin
    {
        my $self = shift;

        if(@_==1) {
            $cvs_bin_of{ident $self} = shift;
        }

        return $cvs_bin_of{ident $self};
    }

    sub _pipe
    {
        my $self = shift;
        my $cmd = shift;

        my ($output,@result) = capture_merged {
            system( $cmd );
        };

        # 'man cvs' tells us that the return code from 'cvs diff' never
        # indicates an error, so we only check this for other commands.
        if($cmd =~ m{\bdiff\b}) {
            if($output =~ m{unknown command}i) {
                croak("Failed to execute diff command: $output");
            } else {
                ()
            }
        } else {
            if($result[0] == 0 ) {
                ();
            } else {
                croak("Failed to execute command: $output");
            }
        }

        my $SH = IO::Lines->new();
        $SH->print( $output );
        return $SH;
    }

    sub cvs_cmd
    {
        my $self = shift;
        my $cmd  = shift;

        croak "Syntax: cvs_cmd(cmd)" unless (defined($cmd) && $cmd);

        STDOUT->autoflush;

        my $hook = Cvs::Simple::Hook::get_hook $cmd;

        my $fh = $self->_pipe( $cmd );

        my($hookfunc) = $self->callback($hook) ||
        $self->callback();

        if(defined( $hookfunc )) {
            while(defined($_=$fh->getline)) {
                $hookfunc->( $cmd, $_ );
            }
        } else {
            print STDOUT $fh->getlines;
        }

        $fh->close;

        return 1;
    }

    sub merge
    {
# merge(old_rev,new_rev,file);
        my $self = shift;
        my @args = @_;

        croak "Syntax: merge(old_rev,new_rev,file)"
        unless (@args && scalar(@args)==3);

        my $cmd = $self->_cmd('-q update');
        $cmd .= sprintf("-j%s -j%s %s", @args);

        return $self->cvs_cmd($cmd);
    }

    sub undo
    {
        goto &backout;
    }

    sub backout
    {
# Revert to previous revision of a file, i.e. backout/undo change(s).
# backout(current_rev,revert_rev,file);
        my $self = shift;
        my @args = @_;

        unless (@args && scalar(@args)==3) {
            croak <
Syntax: backout(current_rev,revert_rev,file)
        undo   (current_rev,revert_rev,file)
SYN
        }

        return $self->merge(@args);
    }

    sub external
    {
        my $self = shift;

        if(@_==1) {
            $repos_of{ident $self} = shift;
        }
        return $repos_of{ident $self};
    }

    sub _cmd
    {
        my $self = shift;
        my $type = shift;

        my $cvs  = $self->cvs_bin;

        my $cmd =
        $self->external
        ?   sprintf("%s -d %s %s ", $cvs,$self->external,$type)
        :   sprintf("%s %s ",       $cvs,$type);

        return $cmd;
    }

    sub add
    {
#   Can only be called as:
#    cvs add file1 [, .... , ]
        my $self = shift;
        my @args = @_;

        croak "Syntax: add(file1, ...)" unless(@args);

        my $cmd = $self->_cmd('add');

        if(@args) {
            $cmd .= join ' ' => @args;
        }

        return $self->cvs_cmd($cmd);
    }

    sub add_bin
    {
# Can only be called as :
#    cvs add -kb file1 [, .... , ]
        my($self) = shift;
        my(@args) = @_;

        croak "Syntax: add_bin(file1, ...)" unless (@args);

        my($cmd) = $self->_cmd('add -kb');

        if(@args) {
            $cmd .= join ' ' => @args;
        }

        return $self->cvs_cmd($cmd);
    }

    sub checkout
    {
# Can be called as:
#  cvs co module
#  cvs co -r tag module
#  Calling signature is checkout(tag,module) or checkout(module).
        my($self) = shift;
        my(@args) = @_;

        unless (@args && (scalar(@args)==2 || scalar(@args)==1)) {
            croak <
Syntax: co(tag)
        co(module)
        checkout(tag)
        checkout(module)
SYN

        }

        my($cmd) = $self->_cmd('co');

        $cmd    .= @args==2         ?   sprintf("-r %s %s", @args)
        :   sprintf("%s", @args);

        return $self->cvs_cmd($cmd);
    }

    sub co {
        goto &checkout;
    }

    sub _pattern {
        my $self = shift;
        my @args = @_;
        return join '' => ('%s ' x @{$args[0]});
    }

    sub commit {
# Can be called as :
# commit()
# commit([file_list])
# commit(tag1)
# commit(tag1, [file_list])
        my $self = shift;
        my @args = @_;

        my $cmd = $self->_cmd('commit -m ""');
        if(@args==0) { # 'cvs commit -m ""'
            return $self->cvs_cmd($cmd);
        } elsif(@args==2) { # 'cvs commit -m "" -r TAG file(s)'
            croak "Syntax: commit([rev],[\@filelist])"
              unless (reftype($args[1]) eq 'ARRAY');
            my $pattern = join '' => '-r %s ', $self->_pattern($args[1]);
            $cmd .= sprintf($pattern, $args[0], @{$args[1]});
            return $self->cvs_cmd($cmd);
        } elsif(@args==1) { # 'cvs commit -m "" -r TAG' or
            # 'cvs commit -m "" file(s)'
            my($pattern);
            if(reftype($args[0]) eq 'ARRAY') {
                $pattern = sprintf($self->_pattern($args[0]), @{$args[0]});
            }
            else {
                $pattern = sprintf('-r %s', $args[0]);
            }

            $cmd .= $pattern;

            return $self->cvs_cmd($cmd);
        } else { # Anything else is an error
            croak <
Syntax: commit([rev],[\@filelist])
        ci    ([rev],[\@filelist])
SYN

        }
    }

    sub ci
    {
        goto &commit;
    }

    sub diff
    {
# Can be called as :
# diff(file_or_dir)
# diff(tag1,tag2,file_or_dir)
        my($self) = shift;
        my(@args) = @_;

        croak "Syntax: diff(file) or diff(tag1,tag2,file)"
        unless (@args && (scalar(@args)==1 || scalar(@args)==3));

        my($cmd) = $self->_cmd('diff -c');

        $cmd .=     @args==3
        ?   sprintf("-r %s -r %s %s", @args)
        :   sprintf("%s"            , @args);

        return $self->cvs_cmd($cmd);
    }

    sub status
    {
# status()
# status(file1, ... )
        my($self) = shift;
        my(@args) = @_;

        my($cmd) = $self->_cmd('status -v');

        if(@args) {
            $cmd .= join ' ' => @args;
        }

        return $self->cvs_cmd($cmd);
    }

    sub upd
    {
        goto &update;
    }

    sub update
    {
# update() -> update workspace (cvs -q update -d).
# update(file) -> update file  (cvs -q update file [file ... ]).
# Doesn't permit -r.
        my($self) = shift;
        my(@args) = @_;

        my($cmd) = $self->_cmd('-q update');

        $cmd .= @args   ? join ' ' => @args
        : '-d';

        return $self->cvs_cmd($cmd);
    }

    sub up2date
    {
    # Checks workspace status. No args.
        my($self) = shift;

        my($cmd) = $self->_cmd('-nq update -d');

        return $self->cvs_cmd($cmd);
    }

    sub DESTROY
    {
        my($self) = shift;
        delete($cvs_bin_of {ident $self});
        delete($external_of{ident $self});
        delete($callback_of{ident $self});

        return;
    }
}

1;

# ABSTRACT: Perl interface to cvs.

__END__