view release on metacpan or  search on metacpan

lib/SVK/Command.pm  view on Meta::CPAN

use Class::Autouse
    qw( Path::Class SVK::Path SVK::Path::Checkout SVK::Notify
	SVK::Editor::Status SVK::Editor::Diff
	Pod::Simple::Text SVK::Merge );

=head1 NAME

SVK::Command - Base class and dispatcher for SVK commands

=head1 SYNOPSIS

    use SVK::Command;
    my $xd = SVK::XD->new ( ... );
    my $cmd = 'checkout';
    my @args = qw( file1 file2 );
    open my $output_fh, '>', 'svk.log' or die $!;
    SVK::Command->invoke ($xd, $cmd, $output_fh, @args);

=head1 DESCRIPTION

This module resolves alias for commands and dispatches them, usually with
the C<invoke> method.  If the command invocation is incorrect, usage
information is displayed instead.

=head1 METHODS

=head2 Class Methods

=cut

use constant alias =>
            qw( ann		annotate
                blame		annotate
                praise		annotate
		br		branch
		co		checkout
		cm		cmerge
		ci		commit
		cp		copy
		del		delete
		remove		delete
		rm		delete
		depot		depotmap
		desc		describe
		di		diff
                h               help
                ?               help
		ls		list
		mi		mirror
		mv		move
		ren		move
		rename	    	move
		pd		propdel
		pdel		propdel
		pe		propedit
		pedit		propedit
		pg		propget
		pget		propget
		pl		proplist
		plist		proplist
		ps		propset
		pset		propset
		sm		smerge
		st		status
		stat		status
		sw		switch
		sy		sync
		up		update
		ver		version
	    );

use constant global_options => ( 'h|help|?'   => 'help',
				 'encoding=s' => 'encoding',
				 'ignore=s@'  => 'ignore',
			       );

my %alias = alias;
my %cmd2alias = map { $_ => [] } values %alias;
while( my($alias, $cmd) = each %alias ) {
    push @{$cmd2alias{$cmd}}, $alias;
}

=head3 invoke ($xd, $cmd, $output_fh, @args)

Takes a L<SVK::XD> object, the command name, the output scalar reference,
and the arguments for the command. The command name is translated with the
C<%alias> map.

On Win32, after C<@args> is parsed for named options, the remaining positional
arguments are expanded for shell globbing with C<bsd_glob>.

=cut

sub invoke {
    my ($pkg, $xd, $cmd, $output, @args) = @_;
    my ($help, $ofh, $ret);
    my $pool = SVN::Pool->new_default;

    local *ARGV = [$cmd, @args];
    $ofh = select $output if $output;
    $ret = eval {$pkg->dispatch ($xd ? (xd => $xd) : (),
				 output => $output) };

    $ofh = select STDERR unless $output;
    $logger->info( $ret) if $ret && $ret !~ /^\d+$/;
    if ($@ && !ref($@)) {
        $logger->info("$@");
    }
    $ret = 1 if ($ret ? $ret !~ /^\d+$/ : $@);

    undef $pool;
    select $ofh if $ofh;
    return ($ret || 0);
}

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

    local $SVN::Error::handler = sub {
	my $error = $_[0];
	my $error_message = $error->expanded_message();