# # Conmux.pm -- core console multiplexor package # # Implements the core multiplexor functionality such as resolution of # names and connecting to the conmux server. # # (C) Copyright IBM Corp. 2004, 2005, 2006 # Author: Andy Whitcroft # # The Console Multiplexor is released under the GNU Public License V2 # package Conmux; use URI::Escape; use File::Basename; use Cwd 'abs_path'; our $Config; BEGIN { my $abs_path = abs_path($0); my $dir_path = dirname($abs_path); my $cf = '/usr/local/conmux/etc/config'; if (-e "$dir_path/etc/config") { $cf = "$dir_path/etc/config"; } elsif (-e "$dir_path/../etc/config") { $cf = "$dir_path/../etc/config"; } if (-f $cf) { open(CFG, "<$cf") || die "Conmux: $cf: open failed - $!\n"; while() { chomp; next if (/^#/ || /^\s*$/ || !/=/); my ($name, $value) = split(/=/, $_, 2); $value =~ s/^"//; $value =~ s/"$//; # Substitute variables. while ($value =~ /\$([A-Za-z0-9_]+)/) { my $v = $Config->{$1}; $value =~ s/\$$1/$v/; } $Config->{$name} = $value; } close(CFG); } } sub encodeArgs { my (%a) = @_; my ($a, $n, $s); ##print "0<$_[0]> ref<" . ref($_[0]) . ">\n"; # Handle being passed references to hashes too ... $a = \%a; $a = $_[0] if (ref($_[0]) eq "HASH"); for $n (sort keys %{$a}) { $s .= uri_escape($n) . '=' . uri_escape($a->{$n}) . ' '; } chop($s); $s; } sub decodeArgs { my ($s) = @_; my (%a, $nv, $n, $v); # Decode the standard argument stream. for $nv (split(' ', $s)) { ($n, $v) = split('=', $nv, 2); $a{uri_unescape($n)} = uri_unescape($v); } %a; } sub sendCmd { my ($fh, $c, $a) = @_; my ($rs); # Send the encoded command ... print $fh $c . " " . encodeArgs($a) . "\n"; # Read the reply. $rs = <$fh>; chomp($rs); decodeArgs($rs); } sub sendRequest { my ($fh, $c, $a) = @_; my %a = { 'result' => 'more' }; # Send the encoded command ... print $fh $c . " " . encodeArgs($a) . "\n"; %a; } sub revcResult { my ($fh) = @_; my ($rs); # Read the reply. $rs = <$fh>; chomp($rs); decodeArgs($rs); } # # Configuration. # sub configRegistry { my $reg = $Config->{'registry'}; $reg = "localhost" if (!$reg); $reg; } # Connect to the host/port specified on the command line, # or localhost:23 sub connect { my ($to) = @_; my ($reg, $sock); # host:port if ($to =~ /:/) { # Already in the right form. # registry/service } elsif ($to =~ m@(.*)/(.*)@) { my ($host, $service) = ($1, $2); $to = Conmux::Registry::lookup($host, $service); # service } else { $to = Conmux::Registry::lookup('-', $to); } $sock = new IO::Socket::INET(Proto => 'tcp', PeerAddr => $to) or die "Conmux::connect $to: connect failed - $@\n"; # Turn on keep alives by default. $sock->sockopt(SO_KEEPALIVE, 1); $sock; } package Conmux::Registry; sub lookup { my ($host, $service) = @_; $host = Conmux::configRegistry() if ($host eq '-'); # Connect to the registry service and lookup the requested service. my $reg = new IO::Socket::INET(Proto => 'tcp', PeerAddr => "$host", PeerPort => 63000) or die "Conmux::connect: registry not available - $@\n"; my %r = Conmux::sendCmd($reg, 'LOOKUP', { 'service' => $service }); die "Conmux::Registry::lookup: $service: error - $r{'status'}\n" if ($r{status} ne "OK"); close($reg); $r{'result'}; } sub add { my ($host, $service, $location) = @_; $host = Conmux::configRegistry() if ($host eq '-'); # Connect to the registry service and lookup the requested service. my $reg = new IO::Socket::INET(Proto => 'tcp', PeerAddr => "$host", PeerPort => 63000) or die "Conmux::connect: registry not available - $@\n"; my %r = Conmux::sendCmd($reg, 'ADD', { 'service' => $service, 'location' => $location }); die "Conmux::Registry::add: $service: error - $r{'status'}\n" if ($r{status} ne "OK"); close($reg); 1; } sub list { my ($host, $service, $location) = @_; my (@results, %r); $host = Conmux::configRegistry() if ($host eq '-'); # Connect to the registry service and ask for a list. my $reg = new IO::Socket::INET(Proto => 'tcp', PeerAddr => "$host", PeerPort => 63000) or die "Conmux::connect: registry not available - $@\n"; %r = Conmux::sendCmd($reg, 'LIST', { }); ## while ($r{'status'} eq 'more') { ## %r = receiveResult($reg); ## push(@results, $r{'result'}); ## } die "Conmux::Registry::list: error - $r{'status'}\n" if ($r{'status'} ne "OK"); close($reg); $r{'result'}; } 1;