ossp-pkg/ac/ac
#!/usr/opkg/bin/perl -w
##
## OSSP ac -- Auto Connection
## Copyright (c) 2003-2004 The OSSP Project <http://www.ossp.org/>
## Copyright (c) 2003-2004 Cable & Wireless <http://www.cw.com/>
## Copyright (c) 2003-2004 Ralf S. Engelschall <rse@engelschall.com>
##
## This file is part of OSSP ac, a tool for automated login
## sessions which can be found at http://www.ossp.org/pkg/tool/ac/.
##
## This program is free software; you can redistribute it and/or
## modify it under the terms of the GNU General Public License
## as published by the Free Software Foundation; either version
## 2.0 of the License, or (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
## General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this file; if not, write to the Free Software
## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
## USA, or contact The OSSP Project <http://www.ossp.org>
##
## ac: program implementation (syntax: Perl 5.x)
##
require 5.008;
use strict;
$|++;
# load a plethora of Perl modules
use IO::File; # from OpenPKG "perl"
use POSIX; # from OpenPKG "perl"
use Getopt::Long; # from OpenPKG "perl"
use Data::Dumper; # from OpenPKG "perl"
use Parse::RecDescent; # from OpenPKG "perl-parse"
#use Term::ReadLine; # from OpenPKG "perl-term" (deferred loaded!)
#use Term::ReadLine::Gnu; # from OpenPKG "perl-term" (deferred loaded!)
#use Curses; # from OpenPKG "perl-curses" (deferred loaded!)
#use Curses::UI; # from OpenPKG "perl-curses" (deferred loaded!)
#use Expect; # from OpenPKG "perl-sys" (deferred loaded!)
# configure optional debugging
$Data::Dumper::Purity = 1;
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
# fixed program information
my $my = {
prog_name => "ac",
prog_vers => "2.0.0",
prog_date => "11-Apr-2003",
prog_global => "/u/rse/ac/src/config",
prog_homedir => "$ENV{HOME}/.ac",
prog_config => "$ENV{HOME}/.ac/config",
prog_complete => "$ENV{HOME}/.ac/.complete",
prog_history => "$ENV{HOME}/.ac/.history",
prog_grammar => "$ENV{HOME}/.ac/.grammar",
prog_tmpfile => "$ENV{HOME}/.ac/.tmp.$$",
user_name => ($ENV{USER} || $ENV{LOGNAME} || "unknown"),
};
## _________________________________________________________________________
##
## Command Line Option Parsing
## _________________________________________________________________________
##
# default command line options
my $opt = {
version => 0,
verbose => 0,
debug => 0,
update => 0,
config => "",
help => 0,
define => [],
};
# global exception handling support
$SIG{__DIE__} = sub {
my ($err) = @_;
$err =~ s|\s+at\s+.*||s if (not $opt->{verbose});
print STDERR "$my->{prog_name}:ERROR: $err ". ($! ? "($!)" : "") . "\n";
exit(1);
};
# parse command line options
Getopt::Long::Configure("bundling");
my %getopt_spec = (
'V|version' => \$opt->{version},
'v|verbose' => \$opt->{verbose},
'd|debug' => \$opt->{debug},
'h|help' => \$opt->{help},
'u|update' => \$opt->{update},
'D|define=s' => $opt->{define},
'c|config=s' => \$opt->{config},
);
my $result = GetOptions(%getopt_spec)
|| die "command line option parsing failed";
if ($opt->{help}) {
print "usage: $my->{prog_name} [<options>] <hostname>\n" .
"available options are:\n" .
" -v,--verbose enable verbose run-time mode\n" .
" -u,--update update Bash command completion cache\n" .
" -V,--version print program version\n" .
" -h,--help print out this usage page\n" .
" -D,--define NAME=VAL set (and overwrite) variable definitions\n" .
" -c,--config FILE read this configuration file only\n";
exit(0);
}
if ($opt->{version}) {
print "$my->{prog_name} $my->{prog_vers} ($my->{prog_date})\n";
exit(0);
}
## _________________________________________________________________________
##
## Configuration Parsing
## _________________________________________________________________________
##
# $cf = {
# user => {
# -order => [ rse, ... ],
# rse => { realname => "...", description => ... },
# ...
# },
# group => {
# -order => [ en, ... ],
# en => { description => "...", members => [...] },
# ...
# },
# host => {
# -order => [ en1, ... ],
# en1 => { hostname => "...", ... },
# ...
# },
# domain => {
# -order => [ en, ... ],
# en => { description => "...", members => [...] },
# ...
# },
# grant => [
# [ [ "...", ... ], [ "...", ... ] ],
# ...
# ],
# method => {
# ssh => [ [], [], ... ],
# ...
# }
# };
# prepare in-core configuration representation
use vars qw($cf);
$cf = {
user => { -order => [] },
group => { -order => [] },
host => { -order => [] },
domain => { -order => [] },
grant => [],
method => {}
};
# parsing utility function: read configuration file
sub config_load {
my ($ctx, $filename) = @_;
if ($filename !~ m|^/|s) {
# make absolute out of relative path
$filename = $ctx->{cwd}->[-1]."/".$filename;
$filename = &path_canonicalize($filename);
}
my $io = new IO::File "<$filename"
or die "cannot open configuration file \"$filename\"";
my $config = '';
$config .= $_ while (<$io>);
$io->close;
$config =~ s|^\s*#.*?$||mg;
return $config;
}
# parsing utility function: expand a token
sub expand_token {
my ($ctx, $token) = @_;
$token =~ s/\$\{([a-zA-Z][a-zA-Z0-9_]*)\}/$ctx->{def}->{$1} || $ENV{$1} || ''/sge;
$token =~ s/\%\{([a-zA-Z][a-zA-Z0-9_]*)\}/$ctx->{def}->{$1} || $ctx->{env}->{$1} || ''/sge;
$token =~ s/\@\{([^\}]+)\}/&base64_decode($1)/sge;
$token =~ s/\\t/\t/sg;
$token =~ s/\\r/\r/sg;
$token =~ s/\\n/\n/sg;
$token =~ s/\\c(.)/eval "\\c$1"/sge;
return $token;
}
# the top-down parsing grammar itself
my $grammar = q[
# create local variable for holding parsing context
{ use vars qw($ctx); $ctx = ""; }
# start rule (for explicit context init and EOF handling)
start: { $ctx = $arg[0]; }
<skip: '[ \t\r\n]*'>
config /^\Z/
| <error>
# whole configuration
config: directive(s)
| <error>
# single configuration directive
directive: include
| scope
| set
| user
| group
| host
| domain
| grant
| method
| ""
| <error>
# directive: "set <var-name> <var-value>;"
set: "set" token token ";" {
$ctx->{env}->{$item[2]} = &::expand_token($ctx, $item[3]);
}
| <error>
# directive: "include <filename>;"
include: "include" token ";" {
my $file = $item[2];
my $dir = $file;
$dir =~ s|/[^/]+$||s;
$dir = $ctx->{cwd}->[-1]."/".$dir if ($dir !~ m|^/|s);
$dir = &::path_canonicalize($dir);
#$text = "scope \"$dir\" { " . &::config_load($ctx, $file) . "}; " . $text;
$text = &::config_load($ctx, $file) . $text;
Parse::RecDescent::LineCounter::resync($thisline);
}
| <error>
# directive: "scope <dir> { ... };"
scope: "scope" token "{" {
push(@{$ctx->{cwd}}, $item[2]);
}
config {
pop(@{$ctx->{cwd}});
} "}" ";"
| <error>
# directive: "user <username> <realname> <email-address>;"
user: "user" token token token ";" {
die "line $thisline (column $thiscolumn): " .
"user \"$item[2]\" already defined"
if (defined($ctx->{cf}->{user}->{$item[2]}));
push(@{$ctx->{cf}->{user}->{-order}}, $item[2]);
$ctx->{cf}->{user}->{$item[2]} = {
'realname' => $item[3],
'email' => $item[4]
};
}
| <error>
# directive: "group <groupname> <description> { [<member> ...] };"
group: "group" token token "{" token(s?) "}" ";" {
die "line $thisline (column $thiscolumn): " .
"group \"$item[2]\" already defined"
if (defined($ctx->{cf}->{group}->{$item[2]}));
push(@{$ctx->{cf}->{group}->{-order}}, $item[2]);
$ctx->{cf}->{group}->{$item[2]} = {
'description' => $item[3],
'members' => $item[5]
};
}
| <error>
# directive: "host <hostname> { ... };"
host: <rulevar: $param = {};>
| "host" token "{" host_param[$param](s) "}" ";" {
die "line $thisline (column $thiscolumn): " .
"host \"$item[2]\" already defined"
if (defined($ctx->{cf}->{host}->{$item[2]}));
push(@{$ctx->{cf}->{host}->{-order}}, $item[2]);
$ctx->{cf}->{host}->{$item[2]} = $param;
}
| <error>
host_param: /(hostname|purpose|system|platform|location)/ token ";" {
$arg[0]->{$item[1]} = $item[2];
}
| /(login|domain)/ token(s) ";" {
$arg[0]->{$item[1]} = $item[2];
}
| <error>
# directive: "domain <domainname> <description> { [<member> ...] };"
domain: "domain" token token "{" token(s?) "}" ";" {
die "line $thisline (column $thiscolumn): " .
"domain \"$item[2]\" already defined"
if (defined($ctx->{cf}->{domain}->{$item[2]}));
push(@{$ctx->{cf}->{domain}->{-order}}, $item[2]);
$ctx->{cf}->{domain}->{$item[2]} = {
'description' => $item[3],
'members' => $item[5]
};
}
| <error>
# directive: "grant { [<host> ...] } { [<user> ...] };"
grant: "grant" "{" token(s) "}" "{" token(s) "}" ";" {
push(@{$ctx->{cf}->{grant}}, [ $item[3], $item[6] ]);
}
| <error>
# directive: "method <methodname> { [...] };"
method: "method" token "{" script "}" ";" {
die "line $thisline (column $thiscolumn): " .
"method \"$item[2]\" already defined"
if (defined($ctx->{cf}->{method}->{$item[2]}));
$ctx->{cf}->{method}->{$item[2]} = $item[4];
}
| <error>
# login script
script: command ";" script { unshift(@{$item[3]}, $item[1]);
$return = $item[3]; }
| command { $return = $item[1]; }
| <error>
# login script: scripting directives
command: "system" token { $return = [ $item[1], $item[2] ]; }
| "spawn" token { $return = [ $item[1], $item[2] ]; }
| "timeout" token { $return = [ $item[1], $item[2] ]; }
| "send" token { $return = [ $item[1], $item[2] ]; }
| "expect" expect_args { $return = [ $item[1], $item[2] ]; }
| "sleep" token { $return = [ $item[1], $item[2] ]; }
| "repeat" { $return = [ $item[1] ]; }
| "interact" { $return = [ $item[1] ]; }
| if_clause { $return = $item[1]; }
| "" { $return = [ ]; }
| <error>
# login script: expect argument(s): "regex [ script [ regex script ... ]]"
expect_args: expect_arg_std(1..) { $return = $item[1]; }
| expect_arg_abr { $return = [ $item[1] ]; }
| <error>
expect_arg_std: regex "{" script "}" { $return = [ $item[1], $item[3] ]; }
| <error>
expect_arg_abr: regex { $return = [ $item[1], [] ]; }
| <error>
# if clause
if_clause: "if" "(" expr ")" "{" script "}" ("else" "{" script "}")(?) {
$return = [ $item[1], $item[3], $item[6], $item[10] ];
}
| <error>
# boolean expression
# (clean and obvious, but for top-down parsing
# not usable version because of left-recursion)
#expr: "(" expr ")" { $return = $item[2]; }
# | /[!-]/ expr { $return = [ "op:$item[1]", $item[2] ]; }
# | expr /[.*\/%+-]/ expr { $return = [ "op:$item[2]", $item[1], $item[3] ]; }
# | expr /(==|!=|<|<=|>=|>)/ expr { $return = [ "op:$item[2]", $item[1], $item[3] ]; }
# | expr "=~" regex { $return = [ "op:$item[2]", $item[1], $item[3] ]; }
# | token { $return = [ "tok", $item[1] ]; }
# | <error>
# boolean expression
# (ugly and confusing, but usable version,
# resulted through left-recursion elemination)
expr: "(" expr ")" { $return = $item[2]; }
term[$item[4]] { $return = $item[5]; }
| /[!-]/ expr { $return = [ "op:$item[1]", $item[2] ]; }
term[$item[3]] { $return = $item[4]; }
| token { $return = [ "tok", $item[1] ]; }
term[$item[2]] { $return = $item[3]; }
| <error>
term: /[.*\/%+-]/ expr { $return = [ "op:$item[1]", $arg[0], $item[2] ]; }
term[$item[3]] { $return = $item[4]; }
| /(==|!=|<|<=|>=|>)/ expr { $return = [ "op:$item[1]", $arg[0], $item[2] ]; }
term[$item[3]] { $return = $item[4]; }
| "=~" regex { $return = [ "op:$item[1]", $arg[0], $item[2] ]; }
term[$item[3]] { $return = $item[4]; }
| {1} { $return = $arg[0]; }
| <error>
# regular expression token
regex: m{/((\\\\/|[^/])*)/} { $return = &::expand_token($ctx, $1); }
| token { $return = quotemeta($item[1]); }
| <error>
# plain text token
token: m/\"((\\\"|[^\"])*)\"/ { $return = &::expand_token($ctx, $1); }
| m/'((\\\\'|[^'])*)'/ { $return = &::expand_token($ctx, $1); }
| m/[^ \t\r\n;\{\}\(\)]+/ { $return = &::expand_token($ctx, $item[1]); }
| <error>
];
# create configuration parser
if ($opt->{debug}) {
#$::RD_TRACE = 1;
$::RD_HINT = 1;
$::RD_ERRORS = 1;
$::RD_WARN = 1;
}
my $parser;
if (not $opt->{debug}) {
# speed up run-time processing by pre-compiling grammar
if (! -f "$my->{prog_grammar}") {
# perform pre-compilation operation
my $cwd = POSIX::getcwd();
chdir($my->{prog_homedir});
Parse::RecDescent->Precompile($grammar, "ac::grammar");
my $io = new IO::File "<grammar.pm"
or die "unable to read precompiled grammar";
my $pm; { local $/ = undef; $pm = <$io>; }
$io->close;
unlink("grammar.pm");
chdir($cwd);
# fixup pre-compilation result (at least necessary for P::RD <= 1.93)
$pm =~ s|(sub\s+new\s+\{\s+)my\s+(bless\()|$1$2|s;
$pm =~ s|$|\n1;\n|s;
# store pre-compilation result for reuse
$io = new IO::File ">$my->{prog_grammar}"
or die "unable to write pre-compiled grammar to \"$my->{prog_grammar}\"";
$io->print($pm);
$io->close;
}
# read pre-compiled grammar
require "$my->{prog_grammar}";
import ac::grammar;
$parser = new ac::grammar;
}
else {
# slow approach: parse from scratch
$parser = new Parse::RecDescent ($grammar)
or die "unable to parse configuration parsing grammar";
}
# prepare parsing context
my $ctx = {};
$ctx->{cf} = $cf;
$ctx->{cwd} = [ POSIX::getcwd() ];
$ctx->{env} = {};
$ctx->{def} = {};
foreach my $define (@{$opt->{define}}) {
if ($define =~ m|^([a-zA-Z][a-zA-Z0-9_]*)(?:[=:](.*))?$|) {
my ($name, $value) = ($1, $2);
$value ||= '';
$ctx->{def}->{$name} = $value;
}
}
# on-the-fly generate top-level configuration
my $config = '';
if ($opt->{config} ne '') {
# explicitly supplied configuration file
$config .= "include \"$opt->{config}\";";
}
else {
# implicitly supplied global and local configuration files
if (-f $my->{prog_global}) {
$config .= "include \"$my->{prog_global}\";";
}
if (-f $my->{prog_config}) {
$config .= "include \"$my->{prog_config}\";";
}
}
# recursively parse configuration
defined $parser->start($config, 1, $ctx)
or die "failed to parse configuration directives";
## _________________________________________________________________________
##
## Configuration Post-Processing
## _________________________________________________________________________
##
# expand group references in community group memberships configuration
sub expand_group {
my ($name) = @_;
my $members = {};
foreach my $member (@{$cf->{group}->{$name}->{members}}) {
if ($member =~ m|^\@(.+)$|s) {
die "reference to unknown group \"$1\" in group \"$name\""
if (not defined($cf->{group}->{$1}));
my $M = &expand_group($1);
map { $members->{$_} = 1 } (@{$M});
}
else {
die "reference to unknown user \"$member\" in group \"$name\""
if (not defined($cf->{user}->{$member}));
$members->{$member} = 1;
}
}
return [ keys(%{$members}) ];
}
foreach my $name (keys(%{$cf->{group}})) {
next if ($name eq '-order');
$cf->{group}->{$name}->{members} = &expand_group($name);
}
# extend domain memberships with reverse/per-host domain specification
foreach my $host (keys(%{$cf->{host}})) {
next if ($host eq '-order');
if (defined($cf->{host}->{$host}->{domain})) {
foreach my $domain (@{$cf->{host}->{$host}->{domain}}) {
die "unknown domain \"$domain\""
if (not defined($cf->{domain}->{$domain}));
push(@{$cf->{domain}->{$domain}->{members}}, $host);
}
}
}
# expand domain references in system domain memberships configuration
sub expand_domain {
my ($name) = @_;
my $members = {};
foreach my $member (@{$cf->{domain}->{$name}->{members}}) {
if ($member =~ m|^\@(.+)$|s) {
die "reference to unknown domain \"$1\" in domain \"$name\""
if (not defined($cf->{domain}->{$1}));
my $M = &expand_domain($1);
map { $members->{$_} = 1 } (@{$M});
}
else {
die "reference to unknown host \"$member\" in domain \"$name\""
if (not defined($cf->{host}->{$member}));
$members->{$member} = 1;
}
}
return [ keys(%{$members}) ];
}
foreach my $name (keys(%{$cf->{domain}})) {
next if ($name eq '-order');
$cf->{domain}->{$name}->{members} = &expand_domain($name);
}
# extend reverse/per-host domain specification with domain memberships
foreach my $host (keys(%{$cf->{host}})) {
next if ($host eq '-order');
if (not defined($cf->{host}->{$host}->{domain})) {
$cf->{host}->{$host}->{domain} = [];
}
foreach my $domain (@{$cf->{domain}->{-order}}) {
next if ($domain eq '-order');
foreach my $member (@{$cf->{domain}->{$domain}->{members}}) {
if ($member eq $host) {
if (not grep { $_ eq $domain } @{$cf->{host}->{$host}->{domain}}) {
push(@{$cf->{host}->{$host}->{domain}}, $domain);
}
}
}
}
}
# expand group/domain references in access grant configuration
foreach my $grant (@{$cf->{grant}}) {
$grant->[0] = [ map { &expand_host($_) } @{$grant->[0]} ];
$grant->[1] = [ map { &expand_user($_) } @{$grant->[1]} ];
sub expand_host {
my ($host) = @_;
my $tag = "";
if ($host =~ m|^(.+)(\[[^\]]+\])$|s) {
($host, $tag) = ($1, $2);
}
if ($host =~ m|^~(.+)$|s) {
# regular expression match
$host = $1;
if ($host =~ m|^\@(.+)$|s) {
my $regex = $1;
my @hosts = ();
foreach my $domain (keys(%{$cf->{domain}})) {
next if ($domain eq '-open');
if ($domain =~ m|$regex|s) {
foreach my $host (@{$cf->{domain}->{$domain}->{members}}) {
push(@hosts, $host.$tag);
}
}
}
die "no domains match regular expression \"$regex\""
if (@hosts == 0);
return @hosts;
}
else {
my $regex = $host;
my @hosts = ();
foreach my $host (keys(%{$cf->{host}})) {
next if ($host eq '-open');
if ($host =~ m|$regex|s) {
push(@hosts, $host.$tag);
}
}
die "no hosts match regular expression \"$regex\""
if (@hosts == 0);
return @hosts;
}
}
else {
# plain text match
if ($host =~ m|^\@(.+)$|s) {
my $domain = $1;
die "unknown domain \"$domain\""
if (not defined($cf->{domain}->{$domain}));
return map { $_.$tag } @{$cf->{domain}->{$domain}->{members}};
}
else {
die "unknown host \"$host\""
if (not defined($cf->{host}->{$host}));
return ($host.$tag);
}
}
}
sub expand_user {
my ($user) = @_;
my @user = ();
if ($user =~ m|^\@(.+)$|s) {
my $group = $1;
die "unknown community group \"$group\""
if (not defined($cf->{group}->{$group}));
return @{$cf->{group}->{$group}->{members}};
}
else {
die "unknown user \"$user\""
if (not defined($cf->{user}->{$user}));
return ($user);
}
}
}
# multiply out access control list
my $acl_by_user = {};
my $acl_by_host = {};
foreach my $grant (@{$cf->{grant}}) {
my ($hosts, $users) = ($grant->[0], $grant->[1]);
foreach my $host (@{$hosts}) {
foreach my $user (@{$users}) {
$acl_by_user->{$user} ||= {};
$acl_by_user->{$user}->{$host} = 1;
$acl_by_host->{$host} ||= {};
$acl_by_host->{$host}->{$user} = 1;
}
}
}
# optional configuration debugging
#print Data::Dumper->Dump([$cf]);
#exit(0);
## _________________________________________________________________________
##
## Main Procedure
## _________________________________________________________________________
##
# operation: update Bash command line completion cache
my $rc = 0;
if ($opt->{update}) {
$rc = &do_update();
}
if (@ARGV == 0) {
$rc = &do_cli();
}
elsif (@ARGV == 1) {
$rc = &do_connect($ARGV[0]);
}
else {
die "invalid number of arguments";
}
exit($rc);
## _________________________________________________________________________
##
## Utility Functions
## _________________________________________________________________________
##
# canonicalize filesystem path
sub path_canonicalize {
my ($path) = @_;
$path =~ s|/{2,}|/|sg;
1 while ($path =~ s|/\./||s);
1 while ($path =~ s|/[^/]+/\.\./|/|s);
return $path;
}
# encode a string into Base64 chunk
sub base64_encode {
my ($obj, $eol) = @_;
my $res = '';
$eol = "\n" unless defined($eol);
pos($obj) = 0;
while ($obj =~ m/(.{1,45})/gs) {
$res .= substr(pack('u', $1), 1);
chop($res);
}
$res =~ tr/` -_/AA-Za-z0-9+\//;
my $padding = (3 - length($obj) % 3) % 3;
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
$res =~ s/(.{1,64})/$1$eol/g if (length($eol) > 0);
return $res;
}
# decode a string from a Base64 chunk
sub base64_decode {
local($^W) = 0;
my ($str) = @_;
my $res = '';
$str =~ tr|A-Za-z0-9+=/||cd;
die 'invalid length of Base64 chunk' if (length($str) % 4);
$str =~ s/=+$//;
$str =~ tr|A-Za-z0-9+/| -_|;
while ($str =~ m/(.{1,60})/gs) {
my $len = chr(32 + length($1)*3/4);
$res .= unpack('u', $len.$1);
}
return $res;
}
sub text_fit {
my ($col, $str) = @_;
if (length($str) > $col) {
$str = substr($str, 0, $col);
}
return sprintf("%-${col}s", $str);
}
sub text_trim {
my ($col, $str) = @_;
if (length($str) > $col) {
$str = substr($str, 0, $col);
}
return $str;
}
## _________________________________________________________________________
##
## Operation: Update Command Line Completion Cache
## _________________________________________________________________________
##
sub do_update {
my $cache = '';
# command line options
foreach my $opt (keys(%getopt_spec)) {
if ($opt =~ m/^(.)\|(.*)$/s) {
$cache .= "option -$1\n";
$cache .= "option --$2\n";
}
}
# hostnames
foreach my $host (@{$cf->{host}->{-order}}) {
if ($acl_by_user->{$my->{user_name}}->{$host}) {
$cache .= "host ".$cf->{host}->{$host}->{hostname}."\n";
}
}
my $io = new IO::File ">$my->{prog_complete}"
or die "cannot write to completion cache file \"$my->{prog_complete}\"";
$io->print($cache);
$io->close;
exit(0);
}
## _________________________________________________________________________
##
## User Interface: Command Line Interface (CLI)
## _________________________________________________________________________
##
sub do_cli {
my $user = $cf->{user}->{$my->{user_name}}
or die "unknown user \"$my->{user_name}\"";
# FIXME
print " __ _ ___ \n" .
" / _\` |/ __| Welcome ".$user->{realname}." <".$user->{email}.">\n" .
"| (_| | (__ to the Cable & Wireless Auto Connect (AC) frontend\n" .
" \\__,_|\\___| shell running on server ac.de.cw.net\n" .
"\n" .
"In case of any questions or problems please contact:\n" .
"Internet Services, Ralf S. Engelschall <rse\@de.cw.com>\n" .
"\n";
# deferred loading of Term::ReadLine::Gnu
eval {
local $^W = 0;
use Term::ReadLine;
use Term::ReadLine::Gnu;
};
my $rl = new Term::ReadLine $my->{prog_name};
my $out = $rl->OUT || \*STDOUT;
my $prompt = $my->{user_name}."@".$my->{prog_name}."> ";
my $input;
$rl->ornaments("md,me,,");
$rl->MinLine(undef);
$rl->read_history($my->{prog_history});
my $rla = $rl->Attribs;
$rla->{completion_function} = sub {
my ($text, $line, $start) = @_;
my @r = ();
if ($start == 0) {
@r = qw(info connect quit);
}
elsif ($line =~ m|^\s*i(n(f(o?)?)?)?\s+\S*$|s) {
@r = map { $cf->{host}->{$_}->{hostname} }
keys(%{$acl_by_user->{$my->{user_name}}});
}
elsif ($line =~ m|^\s*c(o(n(n(e(ct?)?)?)?)?)?\s+\S*$|s) {
@r = map { $cf->{host}->{$_}->{hostname} }
keys(%{$acl_by_user->{$my->{user_name}}});
}
return @r;
};
while (defined ($input = $rl->readline($prompt))) {
if ($input =~ m|^\s*q(u(it?)?)?\s*$|s) {
last;
}
elsif ($input =~ m|^\s*i(n(f(o?)?)?)?|s) {
if ($input =~ m|^\s*\S+\s*$|s) {
my $rc = &do_info("*");
}
elsif ($input =~ m|^\s*\S+\s+(\S+)\s*$|s) {
my $rc = &do_info($1);
}
else {
print $out $my->{prog_name}.":ERROR: invalid arguments on 'info' command\n";
}
}
elsif ($input =~ m|^\s*c(o(n(n(e(ct?)?)?)?)?)?|s) {
if ($input =~ m|^\s*\S+\s*$|s) {
my $rc = &do_connect("*");
}
elsif ($input =~ m|^\s*\S+\s+(\S+)\s*$|s) {
my $rc = &do_connect($1);
}
else {
print $out $my->{prog_name}.":ERROR: invalid arguments on 'connect' command\n";
}
}
elsif ($input =~ m/^\s*\?\s*$/s) {
print $out
"info <hostname> ......... output summary information\n" .
"connect <hostname> ...... connect to a particular host\n" .
"quit .................... quit this session\n";
}
elsif ($input eq '') {
# no operation
}
else {
print $out $my->{prog_name}.":ERROR: invalid command (press '?' for help)\n";
}
$rl->addhistory($input) if ($input !~ m/^\S+$/);
}
print $out "\n" if (not defined($input));
$rl->write_history($my->{prog_history});
return 0;
}
## _________________________________________________________________________
##
## User Interface: Console User Interface (CUI)
## _________________________________________________________________________
##
sub do_cui {
my (@hosts) = @_;
# deferred loading of Curses::UI
if (not defined($Curses::VERSION) and not defined($Curses::UI::VERSION)) {
eval {
local $^W = 0;
use Curses;
use Curses::UI;
};
}
# create the CUI root object
my $cui = new Curses::UI (
-clear_on_exit => 0,
-debug => 0
);
my $W = {};
# determine width of screen
my $max_width = $cui->width();
die "screen width smaller than 80 characters" if ($max_width < 80);
my $cols = [["p", 2], ["s", 22], ["p", 1], ["s", 13], ["p", 1],
["s", 12], ["p", 1], ["s", 12], ["p", 1], ["s", 13], ["p", 2]];
my $width = 0;
foreach my $col (@{$cols}) {
$width += $col->[1];
}
my $i = 0;
while ($width < $max_width) {
while ($cols->[$i]->[0] eq 'p') {
$i = (($i + 1) % ($#{$cols}+1));
}
$cols->[$i]->[1]++;
$width++;
$i = (($i + 1) % ($#{$cols}+1));
}
my $fmt = "";
foreach my $col (@{$cols}) {
if ($col->[0] eq 'p') {
$fmt .= (" " x ($col->[1]));
}
else {
$fmt .= "%-". $col->[1] . "s";
}
}
# determine host list
my $list_values = [];
my $list_labels = {};
my $domains = $cf->{domain}->{-order};
$i = 0;
foreach my $domain (@{$domains}) {
my $headed = 0;
my $hosts = $cf->{host}->{-order};
foreach my $host (@{$hosts}) {
if ((grep { $_ eq $cf->{host}->{$host}->{hostname} } @hosts) == 1
and $cf->{host}->{$host}->{domain}->[0] eq $domain) {
if (not $headed) {
push(@{$list_values}, "::$i");
$list_labels->{"::$i"} = "";
$i++;
push(@{$list_values}, "::$i");
$list_labels->{"::$i"} = " <bold>".$cf->{domain}->{$domain}->{description}."</bold>";
$i++;
$headed = 1;
}
my $label = sprintf($fmt,
&text_trim($cols->[1]->[1], $cf->{host}->{$host}->{'hostname'}),
&text_trim($cols->[3]->[1], $cf->{host}->{$host}->{'purpose'}),
&text_trim($cols->[5]->[1], $cf->{host}->{$host}->{'system'}),
&text_trim($cols->[7]->[1], $cf->{host}->{$host}->{'platform'}),
&text_trim($cols->[9]->[1], $cf->{host}->{$host}->{'location'}),
$cf->{host}->{$host}->{'hostname'});
push(@{$list_values}, $cf->{host}->{$host});
$list_labels->{$cf->{host}->{$host}} = $label;
}
}
}
# add main full-size window
$W->{main} = $cui->add(
'main', 'Window',
-title => "",
-border => 0,
-padtop => 0,
-padbottom => 0,
-ipad => 0,
-width => -1,
-height => -1,
);
# add header line
my $header = sprintf($fmt,
"Hostname", "Purpose", "System", "Platform", "Location"
);
$W->{header} = $W->{main}->add(
'header', 'Label',
-y => 0,
-x => 0,
-width => -1,
-height => 1,
-border => 0,
-reverse => 1,
-paddingspaces => 1,
-text => $header,
);
# add scrolling list
$W->{list} = $W->{main}->add(
'list', 'Listbox',
-y => 1,
-x => 0,
-width => $W->{main}->width,
-height => $W->{main}->height - 2,
-border => 0,
-values => $list_values,
-labels => $list_labels,
-multi => 0,
-title => "",
-vscrollbar => 0,
-htmltext => 1,
);
# add footer line
my $footer = sprintf($fmt,
"Hostname", "Purpose", "System", "Platform", "Location"
);
$W->{footer} = $W->{main}->add(
'footer', 'Label',
-y => -1,
-x => 0,
-width => -1,
-height => 1,
-text => $footer,
-border => 0,
-reverse => 1,
-paddingspaces => 1
);
# overwrite Curses::UI::Listbox key bindings
# to provide skipped plain-text list items
$W->{list}->set_binding(sub {
my $w = shift;
$w->do_routine("option-prevpage");
$w->layout_content;
while ($w->get_active_value() =~ m|^::|) {
$w->do_routine("option-next");
}
}, KEY_PPAGE());
$W->{list}->set_binding(sub {
my $w = shift;
$w->do_routine("option-nextpage");
$w->layout_content;
while ($w->get_active_value() =~ m|^::|) {
$w->do_routine("option-prev");
}
}, KEY_NPAGE());
$W->{list}->set_binding(sub {
my $w = shift;
my $n = 0;
my $y = $w->{-ypos};
return if ($y <= 0);
$y--, $n++;
$y--, $n++ while ($y > 0 and $w->{-values}->[$y] =~ m|^::|);
$y++, $n-- while ($w->{-values}->[$y] =~ m|^::|);
$w->do_routine("option-prev") while ($n-- > 0);
}, KEY_UP());
$W->{list}->set_binding(sub {
my $w = shift;
my $n = 0;
my $y = $w->{-ypos};
return if ($y >= $w->{-max_selected});
$y++, $n++;
$y++, $n++ while ($y < $w->{-max_selected} and $w->{-values}->[$y] =~ m|^::|);
$y--, $n-- while ($w->{-values}->[$y] =~ m|^::|);
$w->do_routine("option-next") while ($n-- > 0);
}, KEY_DOWN());
# CUI termination indicator
my $cui_exit = 0;
# terminate with "q" and LEFT
$cui->set_binding(sub {
$cui_exit = 2;
}, "q");
$cui->set_binding(sub {
$cui_exit = 2;
}, KEY_LEFT());
# select entry on RETURN and RIGHT
$W->{list}->set_binding(sub {
my $w = shift;
$w->do_routine("option-select");
$cui_exit = 1;
}, KEY_ENTER());
$W->{list}->set_binding(sub {
my $w = shift;
$w->do_routine("option-select");
$cui_exit = 1;
}, KEY_RIGHT());
# show info box on SPACE
$W->{list}->set_binding(sub {
my $w = shift;
my $host = $w->get_active_value() || return;
my $lastlogin = "NOW";
my $text = sprintf(
" Hostname: %s Purpose: %s \n" .
" Platform: %s Location: %s \n" .
" System: %s Last Login: %s ",
&text_fit(22, $host->{'hostname'}),
&text_fit(22, $host->{'purpose'}),
&text_fit(22, $host->{'platform'}),
&text_fit(22, $host->{'location'}),
&text_fit(22, $host->{'system'}),
&text_fit(22, $lastlogin));
my $box = $W->{main}->add(
'box', 'Dialog::Status',
-message => $text
);
$box->draw;
$box->focus;
$W->{main}->delete('box');
}, " ");
# hack: inject DOWN and UP key sequence in order to get rid of
# special case when first entry is a skipped plain-text entry.
$W->{list}->process_bindings(KEY_DOWN());
$W->{list}->process_bindings(KEY_UP());
# now perform the CUI main loop
$cui->focus(undef, 1);
$cui->draw;
$cui->do_one_event() until ($cui_exit);
# determine result
my $host = ($cui_exit == 1 ? $W->{list}->get_active_value() : undef);
$host = $host->{hostname} if (defined($host) and ref($host));
# shutdown CUI
$cui->DESTROY;
undef $cui;
# install program termination preparation sequence where stdout is
# redirected to get rid of the nasty (screen clearing) after-endwin()
# NCurses program termination cleanup sequence (which cannot be
# disabled from Perl as it looks).
END {
my $fd_stdout_new = POSIX::open("/dev/null", O_RDWR) || die;
my $fd_stdout_old = POSIX::dup(fileno(STDOUT));
dup2($fd_stdout_new, fileno(STDOUT));
}
return $host;
}
## _________________________________________________________________________
##
## Operation: Display Host Information
## _________________________________________________________________________
##
sub do_info {
my ($hostname) = @_;
# create hostname regex out of hostname pattern
my $re_hostname = $hostname;
$re_hostname =~ s|([.\$\@\%])|\\$1|sg;
$re_hostname =~ s|\*|.*|s;
$re_hostname =~ s|\?|.|s;
# iterate over all hosts in configuration order
my $first = 1;
foreach my $host (@{$cf->{host}->{-order}}) {
my $host = $cf->{host}->{$host};
if ($host->{hostname} =~ m/^.*${re_hostname}.*$/) {
# FIXME
my $lastlogin = "NOW";
print "\n" if (not $first);
$first = 0;
printf(" Hostname: %s Purpose: %s\n" .
" Platform: %s Location: %s\n" .
" System: %s Last Login: %s\n",
&text_fit(22, $host->{'hostname'}),
&text_fit(22, $host->{'purpose'}),
&text_fit(22, $host->{'platform'}),
&text_fit(22, $host->{'location'}),
&text_fit(22, $host->{'system'}),
&text_fit(22, $lastlogin));
}
}
return 0;
}
## _________________________________________________________________________
##
## Operation: Connect to a Host
## _________________________________________________________________________
##
# operation: connect to a host
sub do_connect {
my ($host) = @_;
# expand hostname via full hostname list
my @hosts = map { $cf->{host}->{$_}->{hostname} }
keys(%{$acl_by_user->{$my->{user_name}}});
my $re_host = $host;
$re_host =~ s|([.\$\@\%])|\\$1|sg;
$re_host =~ s|\*|.*|s;
$re_host =~ s|\?|.|s;
@hosts = grep { m/^.*${re_host}.*$/ } @hosts;
my $rc = 0;
if (@hosts == 0) {
die "host \"".$host."\" not known";
}
elsif (@hosts == 1) {
$rc = &do_connect_host($hosts[0]);
}
else {
my $hostname = &do_cui(@hosts);
if (defined($hostname)) {
$rc = &do_connect_host($hostname);
}
}
return $rc;
}
sub do_connect_host {
my ($hostname) = @_;
my $host = undef;
foreach my $h (keys(%{$cf->{host}})) {
next if ($h eq '-order');
if ($cf->{host}->{$h}->{hostname} eq $hostname) {
$host = $cf->{host}->{$h};
last;
}
}
# FIXME
my $lastlogin = "NOW";
# FIXME? Really?
if ($opt->{verbose}) {
&do_info($host->{'hostname'});
}
# deferred loading of Term::ReadLine::Gnu
if (not defined($Expect::VERSION)) {
eval {
local $^W = 0;
use Expect;
};
};
print "$my->{prog_name}: connection establishing\n";
# prepare script execution context
my $login = $host->{login};
my $scr = $cf->{method}->{$login->[0]}
or die "invalid login method \"$login->[0]\"";
my $ctx = {};
$ctx->{exp} = new Expect;
$ctx->{exp}->raw_pty(0);
$ctx->{timeout} = [ 10 ];
$ctx->{level} = 0;
$ctx->{args_by_pos} = [ $login->[0] ];
$ctx->{args_by_name} = {};
$ctx->{backref} = [ '' ];
$ctx->{spawned} = 0;
my $i = 1;
$ctx->{args_by_name}->{hostname} = $host->{hostname}; # special
foreach my $arg (@{$login}[1..$#{$login}]) {
if ($arg =~ m|^([a-zA-Z][a-zA-Z0-9_]*)=(.*)$|) {
$ctx->{args_by_name}->{$1} = $2;
}
else {
$ctx->{args_by_pos}->[$i++] = $arg;
}
};
# perform script execution
&execute_script($ctx, $scr);
# shutdown script execution and destroy context
$ctx->{exp}->soft_close() if ($ctx->{spawned});
print "\r"; # fix terminal cursor after scripting
undef $ctx->{exp};
print "$my->{prog_name}: connection droppped\n";
return 0;
}
## _________________________________________________________________________
##
## Operation: Execute Send/Expect Script
## _________________________________________________________________________
##
# expand an $X argument
sub expand_arg {
my ($ctx, $token) = @_;
$token =~ s/\#(\d+)/$ctx->{backref}->[$1] || ''/sge;
$token =~ s/\#\{(\d+)\}/$ctx->{backref}->[$1] || ''/sge;
$token =~ s/\$(\d+)/$ctx->{args_by_pos}->[$1] || ''/sge;
$token =~ s/\$\{(\d+)\}/$ctx->{args_by_pos}->[$1] || ''/sge;
$token =~ s/\&\{([a-zA-Z][a-zA-Z0-9_]*)\}/$ctx->{args_by_name}->{$1} || ''/sge;
return $token;
}
# execute send/expect script
sub execute_script {
my ($ctx, $scr) = @_;
# execute all commands in sequence
foreach my $cmd (@{$scr}) {
if ($cmd->[0] eq 'system') {
# execute a command synchronous
my $shcmd = &expand_arg($ctx, $cmd->[1]);
my $rc = system($shcmd);
if ($rc != 0) {
die "failed to spawn synchronous command: \"$shcmd\": $!";
}
}
elsif ($cmd->[0] eq 'spawn') {
# execute a command asynchronous
my $shcmd = &expand_arg($ctx, $cmd->[1]);
$ctx->{exp}->spawn($shcmd)
or die "failed to spawn asynchronous command \"$shcmd\": $!";
$ctx->{spawned} = 1;
}
elsif ($cmd->[0] eq 'timeout') {
# set timeout (locally scoped)
my $timeout = &expand_arg($ctx, $cmd->[1]);
$timeout =~ m|^\d+$|
or die "invalid timeout \"$timeout\"";
$ctx->{timeout}->[-1] = $timeout;
}
elsif ($cmd->[0] eq 'send') {
# send a string
my $string = &expand_arg($ctx, $cmd->[1]);
$ctx->{exp}->send($string);
}
elsif ($cmd->[0] eq 'expect') {
# expect one ore more strings
# open new scope
push(@{$ctx->{timeout}}, $ctx->{timeout}->[-1]);
$ctx->{level}++;
# assemble expect list
my @expected = ();
sub expect_cb {
my ($exp, $ctx, $scr) = @_;
return '' if (@{$scr} == 0); # short circuiting
$ctx->{backref} = [ '', $exp->matchlist() ];
return &::execute_script($ctx, $scr); # recursion(!)
};
foreach my $rule (@{$cmd->[1]}) {
my $regex = &expand_arg($ctx, $rule->[0]);
my $expect = [
"-re", $regex,
\&expect_cb, $ctx, $rule->[1]
];
push(@expected, $expect);
}
# perform expect operation
$ctx->{exp}->expect($ctx->{timeout}->[-1], @expected);
# close current scope
pop(@{$ctx->{timeout}});
$ctx->{level}--;
}
elsif ($cmd->[0] eq 'sleep') {
# sleep for a while
my $num = &expand_arg($ctx, $cmd->[1]);
die "non-numeric argument to command 'sleep'"
if ($num !~ m/^(\d+|\d*\.\d+)$/);
select(undef, undef, undef, $num);
}
elsif ($cmd->[0] eq 'repeat') {
# indicate to Expect module the repeating of
# current 'expect' operation (see Expect manpage)
if ($ctx->{level} == 0) {
die "command 'repeat' not allowed at outmost level";
}
return "exp_continue";
}
elsif ($cmd->[0] eq 'interact') {
# enter interactive session until EOF
if ($ctx->{level} != 0) {
die "command 'interact' allowed at outmost level only";
}
$ctx->{exp}->interact();
}
elsif ($cmd->[0] eq 'if') {
my ($expr, $true, $false) = ($cmd->[1], $cmd->[2], $cmd->[3]);
my $rv = &execute_expr($ctx, $expr);
if ($rv) {
# open new scope
push(@{$ctx->{timeout}}, $ctx->{timeout}->[-1]);
$ctx->{level}++;
# perform true clause
&execute_script($ctx, $true);
# close current scope
pop(@{$ctx->{timeout}});
$ctx->{level}--;
}
if (not $rv and defined($false)) {
# open new scope
push(@{$ctx->{timeout}}, $ctx->{timeout}->[-1]);
$ctx->{level}++;
# perform true clause
&execute_script($ctx, $false);
# close current scope
pop(@{$ctx->{timeout}});
$ctx->{level}--;
}
}
else {
die "invalid command \"$cmd->[0]\"";
}
}
return '';
}
sub execute_expr {
my ($ctx, $expr) = @_;
my $rv = '';
if ($expr->[0] eq 'tok') {
# simple plain-text token
$rv = &expand_arg($ctx, $expr->[1]);
}
elsif ($expr->[0] =~ m/^op:([.*\/%+-]|==|!=|<|<=|>=|>)$/) {
# standard binary operator expression
my ($op, $e1, $e2) = ($1, $expr->[1], $expr->[2]);
$e1 = &execute_expr($ctx, $e1);
$e2 = &execute_expr($ctx, $e2);
if ( $op =~ m/^(==|!=|<|<=|>=|>)$/
and ($e1 !~ m|^\d+$| or $e2 !~ m|^\d+$|)) {
# use string comparison operators except
# if both operands are really numerical
my %op_map = (qw(== eq != ne < lt <= le > gt >= ge));
$op = $op_map{$op};
}
eval "\$rv = (\$e1 $op \$e2);";
}
elsif ($expr->[0] =~ m/^op:(=~)$/) {
# pattern matching binary operator expression
my ($op, $e1, $re) = ($1, $expr->[1], $expr->[2]);
$e1 = &execute_expr($ctx, $e1);
$re = &expand_arg($ctx, $re);
eval "\$rv = (\$e1 $op m/\$re/);";
}
elsif ($expr->[0] =~ m/^op:([!-])$/) {
# standard unary operator expression
my ($op, $e1) = ($1, $expr->[1]);
$e1 = &execute_expr($ctx, $e1);
$op = '!' if ($op eq '-' and $e1 !~ m|^\d+$|);
$e1 = ($e1 =~ m|^\s*$|s ? 0 : 1) if ($op eq '!');
eval "\$rv = ($op \$e1);";
}
else {
die "invalid expression operator \"$expr->[0]\"";
}
return $rv;
}
