—

              
#!/usr/bin/perl
use strict;
use warnings;
use Term::ReadLine;
use VCS::Lite::Shell qw(:all);
use Parse::RecDescent;
our $prompt = 'VCSLite> ';
my $term = Term::ReadLine->new('VCS Lite');
my $parser = Parse::RecDescent->new( q{
        <autotree>
        command: vcs {$return = $item[1]; }
        |       shell {$return = $item[1]; }
        vcs:    'prompt' arg
        |       'cd' arg
        |       'add' arg(s)
        |       'remove' arg(s)
        |       'ci' arg(s)
        |       'check_in' arg(s)
        |       /co\b/ arg
        |       'check_out' arg
        |       'commit'
        |       'update'
        |       'fetch' opt_ver redir_out(?)
        |       'diff' opt_ver opt_ver2 redir_out(?)
        |       'help'
        |       'use' arg store_opt(s?)
        |       'debug' 'off'
        shell:  /.*/
        opt_ver:        arg '@@' /\d+|latest/
        |               arg
        opt_ver2:       opt_ver { $return = $item[1]; }
        |               '@@' /\d+|latest/ { $return = $item[2]; }
        |
         
        redir_out:      />>?/ arg
        arg:    '"' /[^"]+/ '"' { $return = $item[2]; }
        |       /[^@ ]+/ { $return = $item[1]; }
        store_opt:      '--store' arg
        |               '--user' arg
        |               '--pass' arg
        |               '--head' arg
        |               '--root' arg
} );
if (@ARGV) {
        execute_command(join(' ',@ARGV),$parser);
        exit(0);
}
while (defined (my $input = $term->readline($prompt))) {
        execute_command($input,$parser);
}
sub execute_command {
    my ($cmd,$parser) = @_;
    my $tree = $parser->command($cmd);
    $tree->execute;
}
package shell;
use strict;
sub execute {
    my $self = shift;
    system($self->{__VALUE__});
}
package redir_out;
use strict;
use Carp;
sub apply {
    my ($self, $oldfh, $newfh) = @_;
    my $arg = $self->{arg};
    open $$newfh,$self->{__PATTERN1__},$arg 
        or croak "Failed to write to $arg\n$!";
    $$oldfh = select $$newfh;
}
package opt_ver;
use strict;
sub decode {
    my $self = shift;
    my @out = ($self->{arg});
    push @out, $self->{__PATTERN1__} if exists $self->{__PATTERN1__};
    @out;
}
package store_opt;
use strict;
sub decode {
    my $self = shift;
    ($self->{__STRING1__} =~ /--(\w+)/, $self->{arg});
}
package vcs;
use strict;
use Data::Dumper;
our %alias;
BEGIN {
    %alias = (
        ci => 'check_in',
        co => 'check_out',
        );
}
sub execute {
    my $self = shift;
    my @arg = (exists($self->{arg}) ? $self->{arg} : '.');
    @arg = map {glob $_} @{$self->{'arg(s)'}} if exists($self->{'arg(s)'});
    my ($oldfh,$newfh);
    if (exists $self->{'redir_out(?)'}) {
        my @rd = @{$self->{'redir_out(?)'}};
        $rd[0]->apply(\$oldfh,\$newfh) if @rd;
    }
  ACTION:
  {
     
    for (qw/ __VALUE__ __STRING1__ __PATTERN1__ /) {
        next unless exists $self->{$_};
        my $meth = $self->{$_};
        $meth = $alias{$meth} if exists $alias{$meth};
        if ($self->can($meth)) {
            $self->$meth($_) for @arg;
            last ACTION;
        }
        if (VCS::Lite::Shell->can($meth)) {
            no strict 'refs';
            &{"VCS::Lite::Shell::$meth"}($_) for @arg;
            last ACTION;
        }
    }
    print Dumper $self;
  }
  select($oldfh) if $oldfh;
}
sub cd {
    my ($self,$dir) = @_;
    chdir $dir;
}
sub prompt {
    my ($self,$pmt) = @_;
    $::prompt = $pmt;
}
sub help {
    print <<HELP;
     
VCS::Lite::Repository Version $VCS::Lite::Repository::VERSION
   add element|repository [element|repository...]
   cd repository
   ci name [name...]
   commit name [name...]
   diff file1[\@\@gen1] [file2[\@\@gen2]] [>outfile]
   fetch name\@\@gen [>outfile]
   remove name [name...]
   update name [name...]
   Anything else will be executed as a host operating system command.
HELP
}
sub check_in {
    my ($self,$elename) = @_;
    print "Enter a description of the change made\n";
    print "Terminate with a dot\n";
    my $remark = '';
     
    while ((my $input = $term->readline) ne '.') {
        $remark .= $input . "\n";
    }
    VCS::Lite::Shell::check_in($elename,$remark);
}
sub fetch {
    my $self = shift;
    print VCS::Lite::Shell::fetch($self->{opt_ver}->decode);
}
sub diff {
    my $self = shift;
    my @el1 = $self->{opt_ver}->decode;
    my %par = ( file1 => shift @el1);
    $par{gen1} = shift @el1 if @el1;
    if (exists $self->{opt_ver2}) {
        my $ov2 = $self->{opt_ver2};
        if (ref($ov2) eq 'opt_ver') {
            my @el2 = $ov2->decode;
            $par{file2} = shift @el2;
            $par{gen2} = shift @el2 if @el2;
        }
        elsif (ref $ov2) {
            $par{gen2} = $ov2->{__PATTERN1__};
        }
    }
    print VCS::Lite::Shell::diff(%par);
}
sub use {
    my ($self,$store_id) = @_;
    my %par = map { $_->decode } @{$self->{'store_opt(s?)'}};
    my $store_type = $par{store} || VCS::Lite::Repository->default_store;
    delete $par{store};
    VCS::Lite::Shell::store($store_id, $store_type, %par);
}
HideShow 74 lines of Pod
=head1 NAME
VCShell  - a command line interface for L<VCS::Lite::Repository>
=head1 SYNOPSIS
   B<add> element|repository [element|repository...]
   B<remove> name [name...]
   B<ci>|check_in name [name...]
   B<co>|check_out parent_repository
   B<commit>
   B<update>
   B<cd> repository
   B<fetch> name@@gen [>outfile]
   B<diff> file1[@@gen1] [file2[@@gen2]] [>outfile]
=head1 DESCRIPTION
VCShell provides a command line interface to the VCS Lite Repository. This
aims to be usable by non-Perl programmers, as it provides a wrapper to the
functionality in the module.
=head1 COMMANDS
=head2 add
The C<add> command adds something to a repository: an element or a repository.
If the parameter given is a directory, it makes it a repository, otherwise
an element. An empty file is created for the element if none exists.
=head2 remove
Remove breaks the association between a repository and something it contains.
It does not delete any files.
=head2 ci
This command is used to B<check in> changes to one or more elements and 
repositories. Each repository checked in is also recursively checked in.
=head2 clone
This makes a B<clone> of one repository into another, and recursively for
everything in it. The new repository contains a B<parent> link which points
at the original.
=head2 commit
If the repository is a clone of a parent repository, this propagates any 
changes to the parent. Note, a check in (B<ci>) is needed on the parent,
for this change to be applied.
=head2 update
This command is used to apply any changes that have happened to the parent.
Three way merging occurs for any change that has happened in the mean time.
=head2 diff
This command outputs a udiff listing for two generations of an element, or
for two different elements. The default generation used is the latest, and the
default generation for the "from" file is the predecessor to the "to" 
generation if comparing the same element.
The output is in diff -u format.
=head1 COPYRIGHT
Copyright (C) 2003-2004 Ivor Williams (IVORW (at) CPAN {dot} org)
All rights reserved.
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.