view release on metacpan or  search on metacpan

bin/bcvi  view on Meta::CPAN

#!/usr/bin/perl
##############################################################################
#
# Script:   bcvi
#
# The 'Back-Channel vim' tool works with SSH to allow commands which are run
# on an SSH server to invoke processes back on the originating SSH client
# machine.
#
# Use 'bcvi --help' for the documentation
#
# Copyright (c) 2007-2012 Grant McLean <grantm@cpan.org>
#

use strict;
use warnings;

require 5.008;

##############################################################################
# This package implements some common functionality required by both the
# client and the server.
#
# It also serves as the entry-point for the command-line script.
##############################################################################

package App::BCVI;

our $VERSION   = '3.09';

use File::Spec;
use File::Path;
use Getopt::Long qw();
use Encode       qw(encode decode);
use IO::Socket::INET;

my %class_map = (
    base   => 'App::BCVI',
    client => 'App::BCVI::Client',
    server => 'App::BCVI::Server',
    pod    => 'App::BCVI::POD',
);

my %response_message = (
    100 => "Ready ($App::BCVI::VERSION)",
    200 => "Success",
    300 => "Response follows",
    900 => "Permission denied",
    910 => "Unrecognised command",
);

my $LF = "\x0A";

my(
    %options, %option_name, %commands, @aliases, @installables,
    %plugin_loaded, @plugins,
);

run(@ARGV) unless caller();       # Don't run anything if loaded via 'require'

sub run {
    App::BCVI->base_init();

    App::BCVI->load_plugins();

    App::BCVI->base_class()->process_command_line(@_);

    exit;
}

sub version      { return $App::BCVI::VERSION; }
sub base_class   { return $class_map{base};    }
sub client_class { return $class_map{client};  }
sub server_class { return $class_map{server};  }
sub pod_class    { return $class_map{pod};     }
sub map_class    { $class_map{$_[1]} = $_[2];  }
sub sock         { shift->{sock};              }

sub installable_files { return @installables;     }
sub message_from_code { $response_message{$_[1]}; }

sub base_init {
    my($class) = @_;

    $class->register_option(
        name        => 'help',
        alias       => '?',
        dispatch_to => 'show_help',
        summary     => 'detailed help message',
        description => <<'END_POD'
Display this documentation.
END_POD
    );

    $class->register_option(
        name        => 'debug',
        alias       => 'd',
        summary     => 'turn on debugging',
        description => <<'END_POD'
Turn on debugging messages.
END_POD
    );

    $class->register_option(
        name        => 'add-aliases',
        dispatch_to => 'add_aliases',
        summary     => 'install bcvi into shell startup files',
        description => <<'END_POD'
Edit the bash startup script to add (or update) the required command aliases
for bcvi.
END_POD
    );

    $class->register_option(
        name        => 'listener',
        alias       => 'l',
        dispatch_to => 'start_listener',
        summary     => 'start in listener mode',
        description => <<'END_POD'

bin/bcvi  view on Meta::CPAN

        summary     => "display documentation for <plugin>",
        description => <<'END_POD'
The --help output includes a list of installed plugins.  Use this option to
read the documentation for a named plugin.
END_POD
    );


    $class->register_command(
        name        => 'vi',
        description => <<'END_POD'
Invokes C<gvim> on the remote file - after translating the host+path to
an scp URI.  This is the default command if no C<--command> option is
specified.  If multiple filenames are supplied, the first will be opened
in gvim and you should use C<:n> to load the 'next' file.
END_POD
    );

    $class->register_command(
        name        => 'viwait',
        description => <<'END_POD'
This command works exactly the same as C<vi> above, except it waits for the
editor process to exit before bcvi exits on the remote machine.  This is
primarily for use with C<sudoedit>.  Note: when used with C<sudoedit>, the file
will not be updated on the remote machine until you exit the editor on your
workstation.
END_POD
    );

    $class->register_command(
        name        => 'scpd',
        description => <<'END_POD'
Uses C<scp> to copy the specified files or directories to the calling user's
F<~/Desktop>.`
END_POD
    );


    $class->add_home_bin();
    $class->register_aliases(
        'test -n "$(which bcvi)" && eval "$(bcvi --unpack-term)"',
        'test -n "${BCVI_CONF}"  && alias vi="bcvi"',
        'test -n "${BCVI_CONF}"  && alias suvi="EDITOR=\'bcvi -c viwait\' sudoedit"',
        'test -n "${BCVI_CONF}"  && alias bcp="bcvi -c scpd"',
    );

    $class->pod_class->init();

}


sub register_option {
    my $class = shift;
    my $opt   = { @_ };
    my $key   = $opt->{name};

    if(!defined $key or !length $key) {
        die "Can't register option without 'name'";
    }

    my($package, $filename, $line) = caller();
    $opt->{provider} = "$package at $filename line $line";
    my $taken = $options{$key};
    if($taken && !$opt->{force_override}) {
        warn "option '--$key' already registered by $taken->{provider}\n";
    }
    if($opt->{alias}) {
        foreach my $a (map { s/^-+//; $_ } split /\|/, $opt->{alias}) {
            if($option_name{$a} && !$opt->{force_override}) {
                if($taken = $options{$option_name{$a}}) {
                    warn "alias '$a' already registered for option "
                       . "'--$taken->{name}' by $taken->{provider}\n";
                }
            }
            $option_name{$a} = $key;
        }
    }
    $options{$key} = $opt;
}


sub register_command {
    my $class = shift;
    my $cmd   = { @_ };
    my $key   = $cmd->{name};

    if(!defined $key or !length $key) {
        die "Can't register command without 'name'";
    }

    $cmd->{dispatch_to} ||= "execute_$key";

    my($package, $filename, $line) = caller();
    $cmd->{provider} = "$package at $filename line $line";
    warn "option '$key' already registered by $commands{$key}->{provider}\n"
        if $commands{$key} && !$cmd->{force_override};
    $commands{$key} = $cmd;
}


sub each_option {
    my($class, $sub) = @_;

    $sub->($options{$_}) foreach sort keys %options;
}


sub each_command {
    my($class, $sub) = @_;

    $sub->($commands{$_}) foreach sort keys %commands;
}


sub command_handler {
    my($class, $name) = @_;

    return unless defined $name;
    return "execute_commands_pod" if $name eq 'commands_pod';
    my $spec = $commands{$name} or return;
    return $spec->{dispatch_to};
}


sub add_home_bin {
    my $class = shift;
    my $home_bin = $class->home_directory . '/bin';
    $class->register_aliases(
        qq{echo \$PATH | grep -q $home_bin || PATH="$home_bin:\$PATH"},
    );
}


sub register_aliases {
    my $class = shift;
    push @aliases, @_;
}


sub register_installable {
    my $class = shift;
    my($package, $filename, $line) = caller();
    push @installables, $filename;
}


sub shell_aliases {
    my($self) = @_;

    return
        "## START-BCVI\n"
        . join("\n", map { "  $_" } @aliases)
        . "\n## END-BCVI\n";
}


sub load_plugins {
    my($class) = @_;

    my $dir = $class->conf_directory();
    foreach my $file (sort glob("$dir/*.pm")) {
        $class->load_plugin_file($file);
    }
}


sub load_plugin_file {
    my($class, $file) = @_;

    my @parts = File::Spec->splitdir($file);
    my $key = pop @parts;
    return if $plugin_loaded{$key};

    eval { require $file; };
    if($@) {
        die qq{Error loading plugin "$file"\n$@\n}
    }

    $plugin_loaded{$key} = $file;
}


sub hook_client_class {
    my($class) = @_;

    my($calling_class, $calling_file) = caller();
    my $client_class = $class->client_class();
    $class->map_class(client => $calling_class);

    no strict 'refs';
    unshift @{"${calling_class}::ISA"}, $client_class;
    push @plugins, { class => $calling_class, file => $calling_file };
    return 1;
}


sub hook_server_class {
    my($class) = @_;

    my($calling_class, $calling_file) = caller();
    my $server_class = $class->server_class();
    $class->map_class(server => $calling_class);

    no strict 'refs';
    unshift @{"${calling_class}::ISA"}, $server_class;
    push @plugins, { class => $calling_class, file => $calling_file };
    return 1;
}


sub process_command_line {
    my($class, @args) = @_;

    my $opt = $class->option_defaults();
    my @cfg = $class->getopt_config();

    local(@ARGV) = @args;
    Getopt::Long::GetOptions($opt, @cfg) or $class->die_synopsis();

    my $handler = $opt->{listener}
                ? $class->server_class
                : $class->client_class;

    $handler->new(_options => $opt)->dispatch(@ARGV);
}


sub option_defaults {
    return { };
}


sub getopt_config {
    my($class) = @_;

    my @spec;
    $class->each_option(sub {
        my($o) = @_;
        my $def = $o->{name};
        $def .= "|$o->{alias}" if defined $o->{alias};
        $def .= $o->{arg_spec} if defined $o->{arg_spec};
        push @spec, $def;
    });
    return @spec
}


sub die_synopsis {
    my($class, $message) = @_;

    warn "$message\n" if $message;
    $class->pod_class->synopsis();
    exit(1);
}


sub new {
    my $class = shift;

    return bless { @_ }, $class;