File Coverage

blib/lib/Cvs/Simple.pm

Criterion	Covered	Total	%
statement	97	181	53.5
branch	24	70	34.2
condition	11	23	47.8
subroutine	27	37	72.9
pod	20	20	100.0
total	179	331	54.0

#!/usr/bin/perl
package Cvs::Simple::Hook;
use strict;
use warnings;

{
my(%PERMITTED) = (
    'All'      => '',
    'add'      => '',
    'checkout' => '',
    'commit'   => '',
    'update'   => '',
    'diff'     => '',
    'status'   => '',
);
sub PERM_REQ () {
    my($patt) = join '|' => keys %PERMITTED;
    return qr/$patt/;
}

sub permitted ($) {
    return exists $PERMITTED{$_[0]} ? 1 : 0;
}

sub get_hook ($) {
    my($cmd)      = shift;

    my($PERM_REQ) = PERM_REQ;

    if(($cmd)=~/\b($PERM_REQ)\b/) {
        return $1;
    }
    else {
        return;
    }
}

}

1;

package Cvs::Simple;
use strict;
use warnings;
use Carp;
use Class::Std::Utils;
use Cvs::Simple::Config;
use FileHandle;

use vars  qw($VERSION);
use version; $VERSION = version->new( 0.06 );

{
    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 {
           $self->cvs_bin(Cvs::Simple::Config::CVS_BIN);
        }

        if(exists $args{external}) {
            $self->external($args{external});
        }
        elsif (Cvs::Simple::Config::EXTERNAL) {
            $self->external(Cvs::Simple::Config::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.
        $hook ||= 'All';

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

        if(defined($func)) {
            UNIVERSAL::isa(($func), '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 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) = FileHandle->new("$cmd 2>&1 |");
    defined($fh) or croak "Failed to open $cmd:$!";

    while(<$fh>) {
        if(defined($hook)) {
            if($self->callback($hook)) {
                $self->callback($hook)->($cmd,$_);
            }
            else {
                print STDOUT $_;
            }
        }
        else {
            if($self->callback('All')) {
                $self->callback('All')->($cmd, $_);
            }
            else {
                print STDOUT $_;
            }
        }
    }

    $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 {
    return join '' => ('%s ' x @{$_[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(scalar(@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 (UNIVERSAL::isa($args[1], 'ARRAY'));
        my($pattern) = join '' => '-r %s ', _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(UNIVERSAL::isa($args[0], 'ARRAY')) {
            $pattern = sprintf(_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;
__END__