svk の shell が欲しい

と思って探したら，ありました。

svk使ってると「svk st」→「svk di」→「svk ci ファイル名 -m ほげほげ」とかよくやるんですが、「svk」の部分がDRYじゃないと思ったので超簡易SVKシェルを作ってみましたよ。

いちいち「svk なんちゃら」って打つのが面倒な人のためのSVKシェル - Greenbear Diary

Ruby 使って readline と system を利用してます。のでびっくりするほどシンプル。

2008/01/25 追記: yhara さんがさらに発展させた Reposh というシェルをリリースなさってます。

んで，svk はせっかく Perl で書かれていますし，モジュールもあるので，Perl で書いてみました。まるでシンプルじゃなくなってしまった罠。

Term::ShellUI は神! でも，このスクリプトのままだとファイル名補完とか使えないです。もっとあれこれいじるとできそうなんですが，とりあえず。

#!/usr/bin/perl

use strict;
use warnings;

our $SUPPORT_ESCAPE_COMMAND = 0;

use SVK 2.0;
use SVK::I18N;
use autouse 'SVK::Util' => qw( get_anchor catfile catdir find_dotsvk );
use Class::Autouse qw( SVK::Command SVK::XD );

use Cwd;
use Term::ShellUI;
use YAML;
$YAML::UseCode = $YAML::UseCode = 1;    # avoid warn

my $term_settings = Load(<<'END_TERM_SETTINGS');
---
  app: svk

  prompt: !!perl/code |
    { prompt(); }

  commands:

    quit:
      method: !!perl/code |
        { shift->exit_requested(1); }
    q:
      alias: quit
      exclude_from_completion: 1
    exit:
      alias: quit

    help:
      proc: !!perl/code |
        { help(@_); }
    h:
      alias: help
      exclude_from_completion: 1
    "?":
      alias: help
      exclude_from_completion: 1

    version:
      proc: !!perl/code |
        { show_version(); }
    v:
      alias: version
      exclude_from_completion: 1

    # pwd
    pwd:
      proc: !!perl/code: |
        { pwd(@_); }

    # local ls
    lls:
      proc: !!perl/code: |
        { lls(@_); }

    # local cd
    lcd:
      proc: !!perl/code: |
        { lcd(@_); }
    cd:
      alias: lcd

    # fallbacks
    "":
      method: !!perl/code |
        { invoke(@_); }
END_TERM_SETTINGS


$ENV{HOME} ||= (
    $ENV{HOMEDRIVE} ? catdir(@ENV{qw( HOMEDRIVE HOMEPATH )}) : ''
) || (getpwuid($<))[7];
$ENV{USER} ||= (
    (defined &Win32::LoginName) ? Win32::LoginName() : ''
) || $ENV{USERNAME} || (getpwuid($<))[0];

our $svkpath  = find_dotsvk || $ENV{SVKROOT} || catfile($ENV{HOME}, ".svk");
our $floating = undef;
if (-e catfile($svkpath, 'floating')) {
    require Path::Class;
    $floating = Path::Class::Dir->new( $svkpath )->parent();
}


my $term = Term::ShellUI->new(%$term_settings);

show_version();

print "using ", $term->{term}->ReadLine, ", ";

if (! $term->{term}->can('history_expand')) {
    $term->{disable_history_expansion} = 1;
}

if ($term->{disable_history_expansion} || $SUPPORT_ESCAPE_COMMAND) {
    print "doesn't support history expansion.\n";
    $SUPPORT_ESCAPE_COMMAND = 1;
}
else {
    print "support history expansion.\n";
}

$term->run();

exit;


sub invoke {
    my ($term, $params) = @_;
    my $ret;

    my $cmd  = $params->{cname}->[0];
    my @argv = @{ $params->{args} };

    if ($SUPPORT_ESCAPE_COMMAND && $cmd =~ s{ \A ! \s* }{}xmso) {
        if ($cmd =~ m{ \A \s* \z }xmso) {
            $cmd = shift @argv;
        }

        unshift @argv, $cmd;
        system $cmd @argv;
        return;
    }

    my $xd = SVK::XD->new ( giantlock => catfile($svkpath, 'lock'),
                            statefile => catfile($svkpath, 'config'),
                            svkpath => $svkpath,
                            floating => $floating,
                          );

    $xd->load();

    local $SIG{INT} = sub {
        die loc("Interrupted.\n");
    };

    $ret = SVK::Command->invoke ( $xd, $cmd, undef, @argv );

    $xd->store ();
}

sub help {
    SVK::Command->invoke(undef, 'help', undef, @_);
}

sub pwd {
    print getcwd, "\n";
}

sub lls {
    system 'ls', @_;
}

sub lcd {
    my $wd = @_ ? shift : $ENV{HOME};

    chdir $wd;
}

sub show_version {
    print
        loc("This is svk, version %1 (using Subversion bindings %2)\n",
            $SVK::VERSION, $SVN::Core::VERSION);
}

my $cmd_index = 0;
sub prompt {
    return sprintf 'svk[%d]> ', ++ $cmd_index;
}

無駄に YAML 使ってたり不味いコード書いてたりして見通しが悪くなってますが，Term::ShellUI はほんとおすすめです。ヒストリも（上記コードでは有効にしてませんが）簡単にとれるようにできるし。