*** /dev/null Sat Apr 27 16:37:11 2024
--- - Sat Apr 27 16:43:01 2024
***************
*** 0 ****
--- 1,1457 ----
+ #!/usr/opkg/bin/perl -w
+ ##
+ ## OSSP ac -- Auto Connection
+ ## Copyright (c) 2003 The OSSP Project <http://www.ossp.org/>
+ ## Copyright (c) 2003 Cable & Wireless Germany <http://www.cw.com/de>
+ ## Copyright (c) 2003 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
+ # (this really requires OpenPKG because of
+ # patches in perl-curses for Curses::UI!)
+ use IO; # 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" (loaded deferred)
+ #use Term::ReadLine::Gnu; # from OpenPKG "perl-term" (loaded deferred)
+ #use Curses; # from OpenPKG "perl-curses" (loaded deferred)
+ #use Curses::UI; # from OpenPKG "perl-curses" (loaded deferred)
+ #use Expect; # from OpenPKG "perl-sys" (loaded deferred)
+
+ # 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 sychronous 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;
+ }
+
|
