Path: usenet.cis.ufl.edu!usenet.eel.ufl.edu!spool.mu.edu!howland.reston.ans.net!news.sprintlink.net!psgrain!nntp.teleport.com!usenet
From:
[email protected] (Eric Arnold)
Newsgroups: comp.lang.perl.announce,comp.lang.perl.misc,comp.lang.perl
Subject: ANNOUNCE: "shelltalk" -- multi-user shell conferencing utility
Date: 11 Jun 1995 17:51:38 GMT
Organization: Sun Microsystems
Lines: 3230
Approved:
[email protected] (comp.lang.perl.announce)
Message-ID: <
[email protected]>
NNTP-Posting-Host: linda.teleport.com
Xref: usenet.cis.ufl.edu comp.lang.perl.announce:30 comp.lang.perl.misc:563 comp.lang.perl:51869
Here's a little (well, not-so-little) utility people might like.
-Eric
#
# "shelltalk"
#
# (Shell/socket multiplexor, multi-user conferencing utility)
#
#
# This has been tested on SunOS4.x and Solaris2.3-5 with Perl4.036/5.001.
#
# It has no warranty or support (it's Free!), but on the other hand, I'm
# interested in how it's used and how well it works so I can fix and
# improve it.
# Ergo, suggestions and/or comments are welcome.
#
# Email:
[email protected] or
[email protected]
#
#
# What it is:
#
# I wanted to have a way to conference a few remote users inside an
# (optionally) active shell. It's *very* useful to watch what people
# are doing, keystroke by keystroke, when you are
# supporting/training/learning from them. There is a big difference
# between what they say they are doing, and reality.
#
# I soon decided that it could have a more generalized scope because a
# utility which can accept and initiate multiple network connections,
# and copy data between all of them, is a versatile beast, whence came
# all the various options. (Although an alternative explanation is that
# the instant gratification of developing in Perl took over my brain.)
#
# It makes a nice showcase for many features of Perl programming,
# i.e. network/socket programming, asynchronous file handle IO,
# terminal modes (stty, raw, char-at-a-time), pseudo-tty handling,
# mostly portable ioctl, and lots of Perl idioms. It also demonstrates
# for any non-believers that Perl can tackle non-trival Unix programming
# tasks.
#
#
# Features (see also "-h" or "print_usage()" for detailed descriptions):
#
# - It can start a shell in a pseudo-tty, and allows you to share your
# shell with other people running "shelltalk" on other machines.
# The pseudo-tty is a full terminal driver, so "vi", "emacs", etc.
# work normally. Local window size changes are propogated via SIGWINCH.
#
# - It works well as a multi-user "talk" facility. You can have two or
# more people talking in an single window. It is pretty intelligent
# about keeping straight who is typing what, and keeps auto-refreshing
# buffers for each user. If you would rather, you can start processes
# in several windows, each containing the output from a single
# person. If you do start it in a couple windows, and use the -notify
# option, it has all the major features of split screen style BSD
# "talk", plus lots more.
#
# In talk mode, almost everything is sent across, including
# commands, error messages, etc. This allows you to help the remote
# user use shelltalk itself (and if you have the user set "-trust", you
# can actually drive his shelltalk process for him).
#
# - You can use it to create ad hoc background server processes.
# To illustrate, you could make a daemon which copies files to you, a
# little like rcp/rsh. Say you make a script called "givefile" containing:
# system "stty -echo raw";
# while($fname=<STDIN>){
# open(FH,$fname); while(read(FH,$buf,10000)){print $buf}; close(FH);
# print "\000DIE\000"; }
# Then you could start a server daemon:
# shelltalk -daemon -lit -l -sh givefile
# and retrieve files from a remote system using:
# echo filename.remote | shelltalk -quiet -lit -ex "\000DIE\000" \
# -o somehost > filename.local
#
# - You can use it like "telnet <host> <port>". E.g. connect to login:
# shelltalk -o somehost 23
#
# - The -eval is actually a real Perl "eval()", but the default
# is off for security reasons. You could probably have a lot of fun
# with downloaded "stored procedures", even rewrite a remote script
# from the inside out while it's running.
#
# - You can use it to analyze protocols if you wedge it between a client
# and a server. For example, I used it to snoop the telnet options
# negotiation protocol by:
# $ shelltalk -tr -lit -l 5050 -ctl # in the first window
# $ telnet myhost 5050 # in the second window
# command>o myhost 23 # in the first window
# Then everything I typed in the second/telnet window was scanned in
# the first, and I got to peep all the control chars and see how telnet
# worked.
#
# - I've included an answering machine script at the end. That way,
# you can leave a shelltalk process running in the background, and it
# can greet people, take calls for you, and page you on your console.
#
# Misfeatures:
#
# - Be careful if you turn on the "-trust" flag. (See "Features", above :-)
# - It's big.
# - Not very performance tuned. (E.g. each char sent in talk mode does
# a lot of stuff, but you can cut/paste a whole screenfull for the same
# cost, so it's fast for bulk.)
# Each talk char/packet has a lot of header info, which may be felt over
# slow modems.
#
# Bugs/problems:
#
# - It can be confusing connecting to/from a user on a gateway, since
# you don't easily know which hostname to connect to (E.g. a single
# machine can have two or more hostnames.."somehost" or "somehost-bb"
# if that host has two ethernet ports). The "listen" option doesn't
# have parameter to specify which ethernet to listen on.
# - There are some rare pathological race cases in the auto-connect feature.
# - There are some rare cases where it will die mysteriously in comm'print,
# maybe when the socket was newly opened, or ?
#
# Enhancements:
#
# - invite/reject functions
# - handle telnet better? It currently only does enough to get Sun's telnet
# to respond with a login prompt. Maybe just better to start a telnet
# via "-sh telnet host", if you want true telnet features.
# - There is no "utmp" entry. If you want that, maybe rlogin
# back into your host. You can use "-sh login" on SunOS, but Solaris
# won't allow it -- nasty goodie-goodie Solaris.
# - The window spawn mode doesn't work with autoconnect, because it closes
# connections as soon as it spawns a window for them. Thus, it's a
# little more work to get a conference going with > 2 people, since
# each person has to explicitly connect to every user he wants to talk to.
#
# 09/11/94 07:04:49 PM; eric: Now works on Solaris2.3 (and SunOS4.x)
# 09/12/94 01:22:54 AM; eric: client/server/local-command modes
# 09/12/94 07:13:21 AM; eric: talk mode is out-of-band for shell
# 09/12/94 03:03:21 PM; eric: added SIGWINCH handling
# 09/12/94 10:02:15 PM; eric: receiving side now does talk prompting
# 09/13/94 06:44:05 AM; eric: shell output armored. Solaris wait(WNOHANG)
# 09/13/94 08:52:59 AM; eric: -daemon, -I, -lit, -ctl
# 09/13/94 06:43:39 PM; eric: blocking, conferencing/auto-connect
# 09/14/94 02:09:26 AM; eric: chasing race conditions with auto-connect
# 09/14/94 03:01:07 PM; eric: command mode is now non-blocking, and can be
# seen remotely in talk mode
# 09/15/94 02:10:20 AM; eric: added ^Z suspend emulation
# 09/15/94 01:57:09 PM; eric: added hub mode, eval, exit_tag
# 09/16/94 06:27:39 PM; eric: cleaned up input editing & now input lines accum
# 09/17/94 03:58:56 PM; eric: -trace and better passive analyzing
# 09/18/94 03:24:32 PM; eric: -notify
# 09/19/94 04:24:47 PM; eric: smarter buffering on out accum.s
# 09/21/94 12:27:12 AM; eric: cleaner talk packet address scheme
# 09/22/94 09:11:40 PM; eric: Better host info scheme. Detect loops.
# 09/22/94 10:26:34 PM; eric: added window_spawn
# 10/10/94 03:48:22 PM; eric: TERM and size checking. Line wrap
eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
& eval 'exec perl -S $0 $argv:q'
if 0;
($dirname = $0) =~ s:/[^/]+$::;
push(@INC, $dirname );
print "Perl Version $]\n";
require "comm_utils.pl" unless defined &comm'init;
# I've included a copy of "shellwords" at the end. It's important to use
# a newer version of "shellwords", since the old ones loop badly in some
# cases.
require "shellwords.pl" unless defined &shellwords;
&telnet_defines;
if ( -f "/vmunix" ) {
$OS_type = "BSD";
} else {
$OS_type = "SVR4"; }
( $My_prog_name = $0 ) =~ s:.*/::g;
$Version="shelltalk2.7";
$Default_port = $Start_port= 5050;
$Stop_port = 5060;
$Command_char = "\035"; # ^] same as telnet
$Shell_cmd="/bin/sh";
$NO_PORT="NO_PORT";
$Prompt_char = ">";
#$Command_prompt = "cmd$Prompt_char";
$Command_prompt = "command$Prompt_char";
$Window_spawn_cmd = 'cmdtool -Wh 20 -c "shelltalk -client_window -t -o $host $port; exit" ';
$Proxy_host = ""; # special hack
@My_window_size=(); # make perl5 happy
$Debug = 0;
$Ctlecho = 0;
$Is_literal = 0;
$Is_hub = 1;
$Is_shell_proc = 0;
$Is_listen = 0;
$Is_talk_mode = 1;
$Do_real_evals = 0;
$Do_opt_evals = 0;
$Is_auto_wrap = 1;
$My_user = (getpwuid($>))[0];
chop( $My_host = `uname -n` );
$Listen_port = $NO_PORT;
$My_addr = &make_my_addr;
$Longest_prompt = length($My_addr);
$Prompt_aliases{ $My_user } = $My_addr;
$SIG{"WINCH"}="do_sig_winch";
&do_sig_winch;
sub do_sig_usr1{ $Debug = 1 }
$SIG{"USR1"}="do_sig_usr1";
$|=1;
# This is simple minded, since telnet uses characters in this range, as
# might other things like Japanese double-byte chars. But generally, the
# user won't be able to enter these, and we won't use \377, the telnet
# command char.
$BOP="\376"; # Beginning of packet
$BOT="\375"; # Talk mode packet
$BOS="\374"; # Shell output packet
$BOE="\373"; # Eval packet
$BOA="$BOP$BOT$BOS$BOE";
$Host_info{ $My_addr, "version" } = $Version;
$Host_info{ $My_addr, "user" } = $My_user;
$Host_info{ $My_addr, "port" } = $Listen_port; #? not needed
$Host_info{ $My_addr, "conn_time" } = time();
$date=&get_date;
$Host_info{ $My_addr, "conn_date" } = "[$date]";
&comm'init;
unless ( grep(/-daemon/, @ARGV ) ){# chicken and egg problem, so pre-check
open(TTY_FH, "+>/dev/tty") || print STDERR "Error opening /dev/tty:$!\r\n"; }
while( @ARGV ){
unless( &do_option_list( *ARGV ) ){ # do_option nibbles off *ARGV
print STDERR " Invalid arguments:(@ARGV)\r\n";
&print_usage("short");
exit 1;
}
}
sub print_usage{
local($verbose)=@_;
grep( (print STDERR "$_\r\n"), split(/\n/, <<EOF ) );
Usage:
Brief:
shelltalk -l # start a process listening on host1
shelltalk -o host1 # connect to host1's process from host2
# To quit: type control- ] and then "q"
Detailed:
shelltalk
*[-l(isten) [<port> [<stop port>]]]
[-o(pen) <host> [<port> [<stop port>]] [b(lock)] ]
*[-b(lock) [<host>|all]]
[-sh(ell) [<shell|command>]]
[-I(input) <input to shell>]
[-e(scape) <char>|"\oct"|^Char] | [-comm(and_char) <char>]
*[-t(alk mode)]
*[-lit(eral)]
*[-ctl(echo)]
*[-log <file>]
*[-hub]
*[-a(utoconnect)]
[-ev(al) [<address>] [opt "<options>" | <perl string>] ]
[-ex(it_tag) <string>]
[-k(ill) [<signal>] ]
*[-tr(ace) [<source>] ]
*[-trust [perl]]
[-notify [<user>|<pattern>|console] ]
*[-q(uiet)]
*[-d(ebug)]
[-dae(mon)]
[-h(elp)]
[-st(atus) [rem(ote)|<user>|<user\@host...>] ]
[-p(rint) "string"]
[-w(wap)]
*[-win(dow_spawn) ["<window_command>"] ]
* = toggle
In command mode:
(any option)
h(elp) for detailed help
q(uit)
z or ^Z # suspend
(empty line to exit command mode)
EOF
grep( (print STDERR "$_\r\n"), split(/\n/, <<EOF ) ) if $verbose eq "verbose";
Details:
-listen tries to listen on <port>, or on one of the next few
until <stop port> if <port> is busy.
-shell mode starts a shell/command. It only makes sense for one
person in a connection set should do this, or you will 1) not
see output from someone else's shell, or 2) see simultaneous
output from other shells. You can give an alternative to
/bin/sh as a parameter.
-open will attempt a connection to the given <host> and <port>.
You can block input from a connection, making it read-only from you.
If you give a <stop port>, it will seek for an active listener.
-block makes your process readonly for others. You can block "all",
or everything from a specific host/connection.
-talk mode tags your data with "user\@host>", and is transparent
to any running shells. Unless a shell is running you won't see
anything with talk mode off. Default is on.
-hub toggles the rebroadcast all incoming data (default on).
Be very careful not to set up a loop. Only connect to more than
one host if you know the new connection isn't connected to anywhere
else.
-autoconnect will try to connect to all hosts connected to hosts you
connect to. It sometimes opens/closes connections a few times, but
it usually ends up correct. Hub mode is usually preferable.
-daemon mode redirects STDIN and STDOUT to /dev/null, so you can run
as a background process.
-debug mode (ewww!)
-Input should be used after -sh, or the shell won't be alive yet.
-literal doesn't send or check for special chars. Note that if you're
not in talk mode or literal mode, other people won't see you typing.
-log creates a session log
-quiet shushes STDERR, which suppresses almost all messages. Used mostly
for -daemon mode.
-escape or -command_char is used to change the character which escapes
to command mode. The default is control-right-bracket (^]), as with
"telnet". You can enter the octal equivalent for a character using
(For example, if you want a real escape char):
esc "\033"
-eval evaluates the given command(s) on the specified host. The Default
is to disallow evals. Use the "-trust" flag to allow things like:
ev user\@host#pid opt t # toggle remote talk mode
ev user\@host#pid opt '-sh -I "who am i"' # start a shell on somehost
# be careful to close the quotes
"-trust perl" allows any Perl string to be eval'd.
You can eval the contents of a file:
ev user\@host#pid [port] < file # if "-trust perl" is set on host
ev < file to eval locally # eval into your own process
You can eval a string locally like:
ev '\@a=split(//,"somestuff")'
-kill sends the shell a default signal of -1.
-trace provides debug information about where data are coming from.
Options for source include:
all|shell|from_shell|to_shell|remote|from_remote|to_remote
Options add together.
-trust allows other people to send evals to you. "-trust perl" allows
them to download Perl code to you.
-exit_tag will cause the process to exit when it receives the
given string. This is just a hack to help background daemons.
-notify does a Unix "write" to all instances of the given <user>,
when somebody connects. You can also specify a regex pattern
instead of a user (it does a "who | grep pattern").
-status alone gives you your info. [rem(ote)|<user>|<user\@host...>] ]
Will cause all users, or a particular user, to print status.
You will only see it if the remote user is in talk mode.
-print prints the given string to all connections (and shell). It's
useful because you can send control characters like "\033[...".
-wrap allows status info to be automatically wrapped. Default on.
-window_spawn will start a new window when somebody connects to you.
The default command to spawn is:
cmdtool -I "shelltalk -client_window -o $host ; exit"
All options can be set interactively via the command-character/command-mode.
Command mode is patterned after the way "telnet"'s command mode. You
will get a command prompt after typing control-right-bracket (control ] )
and then you can give commands/options until you type an empty newline.
Options may be abbreviated, but tie breaking is arbitrary (E.g. "-li" is
"-listen", not "-literal"). The leading "-" is optional, but if you
give more than one option on a line, you should use "-" before
subsequent options.
Examples:
- One shell server,
shelltalk -sh -listen # on <somehost> (start first)
and one or more clients:
shelltalk -open somehost # first client on <otherhost1>
- Two people talking in "talk" mode:
somehost% shelltalk -l -b all # start the listener first
otherhost% shelltalk -o somehost
And optionally a second set of windows so that each person can
have their own window so they can't type over each other
(unless they're in a bellicose mood). With two or more windows,
it's a little more like split screen BSD "talk".
somehost% shelltalk -o otherhost
otherhost% shelltalk -l -b all # start first
- Or have it start the second set of windows for you:
somehost% shelltalk -l -win # start first
otherhost% shelltalk -l -win -o somehost
- Initialize a connection to "somehost", start a shell over there, and
send it some input:
shelltalk -o somehost -ev somehost "opt \"-sh -I 'echo zounds'\""
- With -notify, if you are logged in remotely or have only one
available window, and you're busy with other stuff, you can start
a background shelltalk which will field incoming connections:
somehost% shelltalk -q -daemon -notify eric -l
You can then connect to that background daemon and talk to the
other person there. E.g.
somehost% shelltalk -o somehost
Options are processed in the order given. For example,
shelltalk -l -sh -I "date" -daemon
will print start up information, while this will not:
shelltalk -daemon -l -sh -I "date"
Suggested order is:
-quiet -debug -daemon -shell -I -talk -auto -listen -hub -open -ev
See also the header on this script.
Misc: notes:
- You can "telnet <host> <port>" to a shelltalk session, but you
should set the telnet "mode char" option, and the shelltalk
"literal" option, since different control chars are used by each.
EOF
}
&option( "stat" );
print STDOUT &make_prompt( $My_addr );
&stty_raw unless $Is_daemon;
# Some notes:
#
# - Have to handle any fragment of data, regardless of line breaks, from
# handles.
#
# - In general, the assumption is made that we may read more than
# one packet on a handle at once, thus we may encounter more than
# one $BOT,$BOP,etc.
#
# - You mustn't assume any symmetry in connections (ie. user1<-->user2,
# user1<-->user3, but not user2<-->user3 ) . For example, the
# data-tags/prompts/accumulator-buffers that show which input comes from
# what source are handled by the receiving process, because the sending
# process cannot know who might be connected to the receiving process,
# thereby interjecting unaccounted data into the conversation.
while ( 1 )
{
$inp=""; #shut up -w
@handles=();
if ( $Is_listen ){
push(@handles, $Listen_handle ) }
if ( $Is_shell_proc ){
push(@handles, $Proc_handle ) }
if ( !$Is_daemon && !$Stdin_dead ){
push(@handles, STDIN ) }
push( @handles, keys( %Remote_handles ) );
unless($found){
# Do one autocon per pass; better maybe. Try to give it a chance to
# get the host info for a new connection, so it will spend less time
# thrashing.
local(@tmp)=(keys %Auto_conn );
&do_option_list( *tmp );
}
$found=0;
@read_handles = &comm'select_it( 1, @handles );
for $read_handle ( @read_handles )
{
$found++;
#print "ready=$read_handle\r\n";
if ( $Is_listen && $read_handle eq $Listen_handle )
{
($rem_handle,$host) = &comm'accept_it( $Listen_handle );
$msg = "[New connection from ($host)]\007";
&print_stdout_remote( "\r\n$msg\r\n" );
&send_host_info ($rem_handle );
$Remote_handles{ $rem_handle } = "$host:$NO_PORT";
if ( $Notify eq "console" ){
system "echo '$msg to ($My_host,$Listen_port)' `date`>/dev/console ";
}elsif ( $Notify ){
for $i ( grep( /$Notify/i, `who` ) ){
chop $i;
$i =~ s/^\s+//;
($user, $tty) = split(/\s+/,$i);
# SunOS write fails if STDOUT not a tty?
system "echo 'Shelltalk: $msg to ($My_host,$Listen_port)' `date`>/dev/$tty ";
#system "echo '$msg to ($My_host,$Listen_port)' `date`| " .
#"write $user $tty 2>/dev/null";
}
}
}
elsif ( $Is_shell_proc && $read_handle eq $Proc_handle )
{
#if ( (kill 0, $Proc_pid) && &comm'sysread( $Proc_handle, $inp, 10000 ) )
if ( &comm'sysread( $Proc_handle, $inp, 10000 ) )
{
if ( $Exit_tag ) {
if ( $inp =~ s/$Exit_tag$// ){
$Exiting = 1; }
}
if ( $Ctlecho ){
$inp =~ s/[\0-\011\013\014\016-\037\177-\377]/&ctlecho($&)/ge; }
if ( $Is_trace_mode ){
if ( $Is_trace_mode =~ /all/ ||
$Is_trace_mode =~ /(,shell|^shell)/ ||
$Is_trace_mode =~ /from_shell/
)
{
local( $tmp ) = $inp;
$tmp =~ s/[\0-\037\177-\377]/&ctlecho($&)/ge;
$tmp = "[$Shell_cmd]--->[$tmp]" if $tmp ne "";
&print_stdout( STDIN, "\r\n$tmp\r\n" );
}
}
print STDOUT $inp;
print LOG $inp if $Log_file;
unless ( $Is_literal ){
$inp = "$BOS$inp"; }
&print_remote_handles( *Remote_handles, $inp );
}
else {
&print_stdout_remote( "\r\n[proc died on read]\r\n" );
&close_proc;
}
}
#----------------------------BEGIN STDIN----------------------------------
elsif ( $read_handle eq "STDIN" )
{
# I'm (maybe too often) making assumptions that editing stuff will
# come in a packet by itself. It's a lot easier that way, though
# it could get confused if you were to dump a bunch of lines into
# the window, with embedded backspaces and stuff.
unless ( sysread( $read_handle, $inp, 10000 ) ) {
# If we are piping to the process, we can get:
&print_stdout_remote( "\r\n[STDIN EOF]\r\n" );
$Stdin_dead=1;
&my_exit unless $Exit_tag;
}
if ( $Exit_tag ) {
if ( $inp =~ s/$Exit_tag$// ){
$Exiting = 1; }
}
# It's best to get the Command_prompt into the accum., so it's seen by
# everybody everywhere. Put the newline in to flush out any junk.
if ( $inp =~ s/$Command_char/\n$Command_prompt/ ){
$Is_command_mode = 1;
$Out_accum = "";
}
local( $unharmed ) = $inp; # doesn't keep command char
if ( $Is_command_mode ){
if ( ( $last_accum eq "" || $last_accum eq $Command_prompt ) &&
$inp =~ /^[\r\n]$/ ) {
$Is_command_mode = 0;
}
elsif ( $inp =~ /^(.*)[\r\n]+$/ ) {
$last_accum .= $1; # talk processing will kill all up to \n
}
elsif ( $inp =~ /^\n?$Command_prompt(.*)[\r\n]+$/ ) {
$last_accum .= $1; # talk processing will kill all up to \n
}
# This bit is sorta buggy in one rare case: if we receive a packet
# that has "stuff\n\035command" or "command\nstuff\n", it will
# trash the command.
}
if ( $Is_talk_mode || $Is_command_mode )
{
# process STDIN as if it came from any remote handle:
($junk,$out) = &process_talk_data(
&pack_my_talk_data( "$inp" ),
STDIN );
&print_stdout( STDIN, $out );
}
# shell echo will take care of bouncing STDIN to everywhere, so
# don't send remote
if ( $Is_shell_proc && !$Is_talk_mode && !$Is_command_mode )
{
&print_to_proc( $unharmed );
}
else
{
unless ( $Is_literal ){
if ( $Is_talk_mode ) {
# talk mode is sorta out-of-band data
$inp = &pack_my_talk_data($inp);
}else{
$inp = "$BOP$inp";} # normal packet
}
if ( $Is_command_mode ){
$inp = "" unless ( $Is_talk_mode );
}
&print_remote_handles( *Remote_handles, $inp ) if $inp ne "";
}
# Do this last so that we can process normally the keystrokes before
# we see the output from do_command.
if ( $Is_command_mode )
{
if ( $unharmed =~ /\032/ ) # ^Z
{
&print_stdout_remote( "^Z" );
&do_suspend;
&print_stdout( STDIN, $Command_prompt );
}
elsif ( $unharmed =~ /[\r\n]$/ )
{
if ( $last_accum ){
&do_command($last_accum);
if ( $Is_command_mode ){ # shell mode changes it
&print_stdout_remote( $Command_prompt );
$Out_accum = $Command_prompt;
}
$last_accum = "";
}
}
else{
# Need to keep around last_accum, because newline flushes
# Out_accum in &process_talk_data
$last_accum = $Out_accum;
}
}
}
# ----------------------------END STDIN-----------------------------------
# ----------------------------BEGIN REMOTE--------------------------------
elsif ( $Remote_handles{$read_handle} )
{
if ( &comm'sysread( $read_handle, $inp, 10000 ) ) {
if ( $Block_all || $Blocked_handles{ $read_handle } ){
next; }
if ( $Exit_tag ) {
if ( $inp =~ s/$Exit_tag$// ){
$Exiting = 1; }
}
$rebroadcast = $inp;
if ( $Is_trace_mode ){
if ( $Is_trace_mode =~ /all/ ||
$Is_trace_mode =~ /(,remote|^remote)/ ||
$Is_trace_mode =~ /from_remote/
)
{
local( $tmp ) = $inp;
$tmp =~ s/[\0-\037\177-\377]/&ctlecho($&)/ge;
$tmp = "[" . &who_from_handle($read_handle) . "]--->[$tmp]";
&print_stdout( STDIN, "\r\n$tmp\r\n" );
}
}
unless ( $Is_literal ){
$inp =~ s/\000//g ; # telnet is weird, it ends all newlines with \0
# the following works for Sun telnet, but not free BSD telnet?
if ( $inp =~ /$TEL_IAC$TEL_DO$TELOPT_TTYPE/ ) {
# telnet, waiting for terminal type negotiation
$Is_telnet_mode = 1;
$Is_literal = 1; # don't send our $BOP header, amongst others
$Is_talk_mode = 0; # talk just confuses telnet, because
# it can't strip off the addr, like we do
&print_remote_handle( $read_handle,
"$TEL_IAC$TEL_WONT$TELOPT_TTYPE" );
}
$inp =~ s/$TEL_IAC..//g; # we hate telnet options chatter
$inp = &strip_eval_info( $inp, $read_handle );
# strip out talk data into $out so it we don't send it to the shell
($inp,$out) = &process_talk_data( $inp, $read_handle );
&print_stdout( $read_handle, $out ) if $out ne "";
}
if ( $Is_shell_proc ){
unless ( $Is_literal ){
$inp =~ s/$BOS[^$BOA]*//g; # strip shell data
$inp =~ s/[$BOP]//g;
}
&print_to_proc( $inp );
}
else{
unless ( $Is_literal ){
$inp =~ s/$BOP[^$BOA]*//g; # strip normal packets so we only
# see echo from a shell
$inp =~ s/[$BOA]//g; # clean any of our control chars
}
if ( $Ctlecho ){
$inp =~ s/[\0-\011\013\014\016-\037\177-\377]/&ctlecho($&)/ge; }
&print_stdout( $read_handle, $inp ) if $inp ne "";
}
if ( $Is_hub ){
&print_remote_handles( *Remote_handles, $rebroadcast, $read_handle );}
}
else {
local( $out ) = &who_from_handle( $read_handle );
&close_remote_handle( $read_handle );
&print_stdout_remote( "\r\n[($out) disconnected on read]\r\n" );
&my_exit if ( $Is_window_client && !%Remote_handles );
}
} # ----------------------------END REMOTE--------------------------------
&my_exit if $Exiting;
}# for .. select
# If we've been idle for a second, or so
if ( !@read_handles || $Last_time_to_stdout + 1 < time() ){
for $addr ( keys %Out_accums_flush )
{
print STDOUT "\r\n" . &make_prompt( $addr ) . $Out_accums{$addr};
delete $Out_accums_flush{$addr};
# if we change Last_addr_to_stdout, we must swap out accum.
# else we will push onto the wrong accum. later.
$Out_accums{$Last_addr_to_stdout} = $Out_accum;
$Out_accum = $Out_accums{$addr};
$Last_addr_to_stdout = $addr;
$Last_time_to_stdout = time();
}
}
}# while 1
&my_exit;
sub my_exit{
&print_remote_handles( *Remote_handles,
&pack_eval( qq{&host_exited("$My_addr")}), STDIN );
&stty_sane unless $Is_daemon;
kill 15, $Proc_pid if $Proc_pid;
&comm'close( $Listen_handle, keys( %Remote_handles ) );
print "\n";
exit;
}
sub print_remote_handles{
local( *handles, $inp, $source_handle )=@_;
local( $host, $port );
#$Debug1=1;
#local( $i ) = $inp;
#$i =~ s/[\0-\037\177-\377]/&ctlecho($&)/ge;
#print "[$i]" if $Debug1;
for $handle ( keys %handles ){
if ( $handle eq $source_handle ){
next;
}
&print_remote_handle( $handle, $inp );
}
}
sub print_remote_handle{
local( $handle, $inp )=@_;
if ( $Is_trace_mode ){
if ( $Is_trace_mode =~ /all/ ||
$Is_trace_mode =~ /(,remote|^remote)/ ||
$Is_trace_mode =~ /to_remote/
)
{
local( $tmp ) = $inp;
$tmp =~ s/[\0-\037\177-\377]/&ctlecho($&)/ge;
$tmp = "[" . &who_from_handle($handle) . "]<---[$tmp]";
&print_stdout( STDIN, "\r\n$tmp\r\n" );
}
}
unless ( &comm'print($handle, $inp) ){
local($out)=&who_from_handle($handle);
&close_remote_handle( $handle ); # do this first!
&print_stdout_remote( "\r\n[($out) disconnected on write]\r\n" );
&my_exit if ( $Is_window_client && !%Remote_handles );
}
}
sub close_remote_handle{
local( $handle ) = @_ ;
&delete_Host_info( $Addr_for_handle{$handle} );
delete $Remote_handles{ $handle };
&comm'close( $handle );
}
sub delete_Host_info{
local( $addr ) = @_;
return unless $addr ne "";
for $key ( keys %Host_info )
{
if ( $key =~ /^$addr/ )
{
delete $Host_info{$key};
&print_stdout( STDIN, "delete ($key)", $Host_info{$key}, "\r\n" ) if $Debug;
}
}
}
sub print_to_proc{
local( $inp )=@_;
&wait_nohang;
if ( $OS_type eq "SVR4" ){
$kill = kill 0, $Proc_pid;
}else{
# This kill 0 has a weird effect on the shell (probly causing EINTRs)
# Investigate...
$kill = kill 0, $Proc_pid;
#$kill = 1;
}
if ( $Is_trace_mode ){
if ( $Is_trace_mode =~ /all/ ||
$Is_trace_mode =~ /(,shell|^shell)/ || $Is_trace_mode =~ /to_shell/
)
{
local( $tmp ) = $inp;
$tmp =~ s/[\0-\037\177-\377]/&ctlecho($&)/ge;
$tmp = "[shell]<---[$tmp]";
&print_stdout( STDIN, "\r\n$tmp\r\n" );
}
}
unless( $kill && &comm'print( $Proc_handle, $inp) ){
&print_stdout_remote( "\r\n[proc died on write]\r\n" );
&close_proc;
}
}
sub close_proc{
&comm'close($Proc_handle);
$Proc_handle = 0;
$Is_shell_proc = 0;
$Proc_pid = 0;
}
sub print_stdout_remote{
local( @stdout )=@_;
local( $stdout ) = join("", @stdout );
return if $Quiet;
$Last_addr_to_stdout = $My_addr;
#&print_out( STDERR, STDIN, $stdout );
&print_out( STDOUT, STDIN, $stdout );
if ( $Is_talk_mode ){
&print_remote_handles(
*Remote_handles, &pack_my_talk_data($stdout)
);
}
}
sub print_stdout{
$Last_time_to_stdout = time();
&print_out( STDOUT, @_ );
}
# used for STDOUT or STDERR only:
sub print_out{
local( $out_handle, $source_handle, @stdout )=@_;
print $out_handle @stdout;
print LOG @stdout if $Log_file;
}
sub process_talk_data{
local( $inp, $source_handle )=@_;
local( $out, $tmp, $addr, $addr_to )=("","","", "");
local($not_for_shell) = undef;
return $inp if ( $Is_literal && !$Is_command_mode );
#$Debug1=1;
local( $i ) = $inp;
$i =~ s/[\0-\037\177-\377]/&ctlecho($&)/ge;
print "[$i]" if $Debug1;
# format should be:
# ${BOT}fromhost,tohost;data
# host format should be:
# user|user@host|user@host:port
#
# The idea is that each host prepends its talk-mode packets with the
# $BOT char and the addr with uniquely identifying information.
# (The default is just the user name, but it will add host/port if
# it receives an identical addr from someone else.) This is necessary
# since with -hub mode, we might get packets from several hops away,
# and we can't keep track of it by incoming handle.
#
# Next, if we think that data are flowing uninterrupted from a user
# because we are seeing unchanging headers/addrs,
# then the data should be printed on the same line.
# So, we need to remove the addr, print the data, and store the data
# in an accumulator associated with the addr. That way, if a user is
# interrupted, we can restore the line he was in the middle of typing
# when he starts typing again.
#
# All this effort is so that we can uniquely identify a talk mode
# packet that was sent from several hops away, where we have no reliable
# socket/port information to add to the packet.
while ( $inp =~ s/^$BOT([^$BOA]*)// )
{
$not_for_shell = $1;
next if ( $not_for_shell eq "" ); # compare to "", or will fail on "0"
($not_for_shell, $addr, $addr_to ) = &strip_addr( $not_for_shell );
next unless $addr;
print "not=($not_for_shell),addr=($addr)\r\n" if $Debug1;
if ( $addr eq $My_addr && $source_handle ne STDIN ){
&print_stdout_remote( "\r\n[eek I($My_addr) see a loop, this handle!]\r\n" );
&close_remote_handle( $source_handle );
return undef;
}
if ( $addr_to && $addr_to ne $My_addr ){
print STDERR "Skipping packet not for me($My_addr): " .
"[$addr,$addr_to;$not_for_shell] \r\n" if $Debug;
next;
}
$prompt = &make_prompt( $addr );
if ( $Is_command_mode && $addr eq $My_addr ){
$prompt =""; }
# Decide whether we need to put the addr back on
if ( $Last_addr_to_stdout ne $addr )
{
# buffer it for later, if STDOUT has been written to recently,
# unless it's from STDIN, which takes priority, or
# it contains a newline, and that's too complicated to buffer, so
# flush it out.
if (
$Last_time_to_stdout + 1 >= time() &&
$source_handle ne "STDIN" && $not_for_shell !~ /[\r\n]/
)
{
#print "[h=($source_handle)skipping($not_for_shell)]";
#print "[\$Out_accums{$addr} .= ($not_for_shell)]\r\n";
$Out_accums{$addr} .= $not_for_shell;
$Out_accums_flush{$addr} = 1;
$not_for_shell = "";
next;
}
{
# indicate that current line has been interrupted, and
# will continue later, by adding a backslash marker to the end
if ( $Out_accum ne "" ){
$out .= "\\"; }
# Now switch contexts, refresh to whatever the last speaker was in the
# middle of typing:
$Out_accums{$Last_addr_to_stdout} = $Out_accum;
$Out_accum = $Out_accums{$addr};
$out .= "\r\n" . $prompt;
if ( $Out_accum ne "" ){
# indicate that line continues from old;
# tack an eraseable marker onto onto the front of accum
$Out_accum =~ s/^[^\\]/\\$&/;
}
$out .= $Out_accum;
delete $Out_accums_flush{$addr};
$Last_addr_to_stdout = $addr;
}
}
if ( 0 && $not_for_shell =~ /^(\r\n|\r|\n)$/ ){
$Out_accum = "";
}
else
{
# it is possible that a packet will contain several lines of
# data (i.e. the user cut/pasted something).
for $tmp ( split(/(\r\n|\r|\n)/, $not_for_shell ) )
{
if ( $tmp =~ /^(\r\n|\r|\n)$/ ){
$Out_accum = "";
$out .= "\r\n" . $prompt;
next;
}
$Out_accum .= $tmp;
print "accum=($Out_accum)\n" if $Debug1;
( $Out_accum, $out1 ) = &expand_bksp( $Out_accum );
$tmp =~ tr/\0-\037\177//d;
$out .= $tmp . $out1;
}
}
}
return ($inp,$out);
}
sub pack_my_talk_data{
local( $s, $to ) = @_;
local( $ret ) = "$BOT$My_addr;";
$ret = "$BOT$My_addr,$to;" if $to;
return $ret . $s;
}
sub strip_addr{
local( $inp ) = @_;
local( @addrs ) = ();
local( $addr ) = "";
#if ( $inp =~ s/^([\r\n]*[^$Prompt_char]+$Prompt_char$Command_prompt)// ) {
if ( $inp =~ s/^([^;]+);// )
{
$addr = $1;
@addrs = split(/,/, $addr );
}
return ( $inp, @addrs );
}
# Remember that the address that a remote host thinks it is isn't necessary
# what we can calculate from the $handle/%Host_info, so don't use it as such.
sub who_from_handle{
local ( $handle ) = @_;
local ( $host, $alt_host, $port, $addr ) = ("","","","");
#$Debug1 = 1;
print "in who_from_handle\r\n" if $Debug1;
#( $host ) = split(/:/, $Remote_handles{$read_handle} );
if ( $Addr_for_handle{ $handle} ) {
return $Addr_for_handle{ $handle } ; }
return $Remote_handles{$handle};
}
sub make_my_addr{
print "in make_my_addr\r\n" if $Debug1;
return $My_user . "@" . $My_host . "#$$";
}
sub make_prompt{
local( $addr ) = @_;
local( $user ) = ( $addr =~ /^([^@]+)/ );
local( $prompt );
local( $prompt ) = $addr . $Prompt_char;
if ( $user )
{
if ( $Prompt_aliases{ $user } ){
if ( $Prompt_aliases{ $user } eq $addr ){
$prompt = $user . $Prompt_char; }
}
else
{
$Prompt_aliases{ $user } = $addr;
$prompt = $user . $Prompt_char;
}
}
$Longest_prompt = length($addr) if $Longest_prompt < length($addr) ;
$prompt #Return
}
sub expand_bksp{
local( $accum ) = @_;
local( $expanded_out ) = ("");
local( $prompt ) = ("");
# Refuse to back over a command prompt:
$prompt = $1 if $accum =~ s/^(.*$Command_prompt)//; # ick!
$accum =~ tr/\0-\007\011\013\014\016-\024\026\030-\037//d;
while ( $accum =~ s/.[\010\177]// ){ # ^H and ^?
$expanded_out .= "\010 \010"; }
while ( $accum =~ s/^([^\025]+)\025// ){ # ^U
$expanded_out .= "\010 \010" x length($1); }
while ( $accum =~ s/([\w]+|\W+)\027// ){ # ^W
$expanded_out .= "\010 \010" x length($1); }
$accum =~ tr/\0-\011\013\014\016-\037\177//d; #leave new lines
return ( $prompt . $accum, $expanded_out );
}
sub ctlecho{
local($c)=@_;
local($char) = unpack("C",$c);
return sprintf("\\%3.3o",$char);
}
sub ctlecho1{
local($c)=@_;
local($char) = unpack("C",$c);
return "^" . pack("C", $char + 64 ) . sprintf("=\\%3.3o",$char);
}
sub stty_raw{
# works for both SVR4 and SUNOS?BSD:
#system "stty raw -echo -icanon eol '^a' " if -t STDIN;
&comm'stty_raw(STDIN);
}
sub stty_sane{
##system "stty -raw echo icanon eol '^-' " if -t STDIN;
# works for both SVR4 and SUNOS?BSD:
#system "stty sane erase '^H' " if -t STDIN;
&comm'stty_sane(STDIN);
}
sub do_command{
local( $inp ) = @_;
$inp =~ s/$Command_prompt//;
return unless ($inp );
print STDERR "In do_command($inp)\r\n" if $Debug;
unless( &option( $inp ) )
{
&print_stdout_remote( "Invalid command($inp)\r\n" );
#&print_commands;
&print_usage();
}
}
# Takes a list, and pulls of the first option, and any parameters, from it,
# leaving a shorter list.
#
# Returns 0 if there were invalid options or parameters.
#
sub option {
local( $opt ) = @_;
#$opt =~ s/"[^"]+"/&doubleback($&)/ge; #attempt hack for shellwords
local( @args ) = &shellwords ( $opt );
print "option ($Opt) shellword \$#args=$#args=(", join(",",@args),")\r\n" if $Debug;
if ( $opt && "@args" eq "" ){
## bloody shellwords has failed probably due to embedded \
print STDERR "Parsing has failed. Try \\\\ instead of \\ \r\n";
return 0;
}
while ( @args ){
return 0 unless &do_option_list( *args ); }
return 1;
}
sub doubleback{
local( $s ) = @_;
$s =~ s/\\/\\\\/g;
return $s;
}
sub do_option_list {
local( *args ) = @_;
local( $handle, $filename );
return 0 unless @args;
print STDERR "In do_option_list (@args)#=$#args\r\n" if $Debug;
for $arg ( @args ) {
$arg = "INVALID_NULL" if $arg eq "";
}
return 0 unless $arg=shift(@args);
# We will accept options without leading "-" signs, but it is safer
# to have them to keep some options from consuming parameters blindly
# and eating other options.
# Note that the order of the cases is important using this scheme of
# abbreviation
# keep symbols like | ( ) , etc from confusing regexp.s down below:
$arg =~ s/[^a-zA-Z0-9]/\\$&/g;
"-help" =~ /^-?$arg/ && do {
&print_usage("verbose");
if ( $Is_command_mode ){
}else{
&my_exit;}
return 1;
};
"-autoconn" =~ /^-?$arg/ && do {
if ( $Autoconn ){
$Autoconn = 0;
&print_stdout_remote( "Autoconn mode off\r\n" );
}else{
$Autoconn = 1;
&print_stdout_remote( "Autoconn mode on\r\n" );
}
return 1;
};
"-block" =~ /^-?$arg/ && do {
if ( !@args ){
&print_stdout_remote( "Block all mode off\r\n" );
$Block_all = 0;
return 1;
}
return 0 if ( !@args || $args[0] =~ /^-/ );
$host = shift(@args);
if ( $host eq "all" ){
&print_stdout_remote( "Blocking all hosts\r\n" );
$Block_all = 1;
return 1;
}
&print_stdout_remote( "(un)blocking selected host(s)\r\n" );
$Block_all = 0;
$port = 0;
if ( @args && $args[0] =~ /^\d+$/ ){
$port = shift(@args);
}
$found=0;
for $handle (keys %Remote_handles ){
$addr = $Addr_for_handle{$handle};
( $host1 ) = split(/:/, $Remote_handles{$handle} );
next unless ( $host eq $host1 ||
$host eq $Host_info{ $addr, "alt_host" } );
$port1 = $Host_info{ $addr, "port" };
next if ( $port && ( $port != $port1 ) );
$found=1;
if ( $Blocked_handles{ $handle } ){
$Blocked_handles{ $handle } = 0;
&print_stdout_remote( "$host $port1 unblocked\r\n" );
} else{
$Blocked_handles{ $handle } = 1;
&print_stdout_remote( "$host $port1 blocked\r\n" );
}
}
&print_stdout_remote( "host $host port $port not found\r\n" ) unless $found;
return 1;
};
"-open" =~ /^-?$arg/ && do {
return 0 if ( !@args || $args[0] =~ /^-/ );
$host = shift(@args);
$port = $NO_PORT;
if ( @args && $args[0] =~ /^\d+$/ ){
$port = shift(@args);
if ( @args && $args[0] =~ /^\d+$/ ){
$Start_port = $port;
$Stop_port = shift(@args);
$port = $NO_PORT;
}
}
$block=0;
if ( @args && $args[0] =~ /^b/ ){ #block
$block=1; shift;}
($rem_handle,$port) = &open_port1( $host, $port );
if ( $rem_handle ){
&send_host_info ($rem_handle);
print "In open: \$Remote_handles{ $rem_handle } = $host;\r\n" if $Debug;
$Remote_handles{ $rem_handle } = "$host:$port";
if( $block ){
$Blocked_handles{ $rem_handle } = 1;
&print_stdout_remote( "$host $port blocked\r\n" );
}
}
return 1;
};
"-close" =~ /^-?$arg/ && do {
$host = "";
$host = shift(@args) if @args;
$port = 0;
if ( @args && $args[0] =~ /^\d+$/ ){
$port = shift(@args); }
if ( @args && $args[0] eq $NO_PORT ){
$port = shift(@args); }
$found_one = 0;
local($addr)="";
for $handle ( keys %Remote_handles )
{
$addr = $Addr_for_handle{$handle};
( $rem_host, $port1 ) = split(/:/, $Remote_handles{$handle} );
if ( $host eq "" || $host eq $rem_host ||
$host eq $Host_info{ $addr, "alt_host" } )
{
next if ( $port && $port1 != $port );
&print_stdout_remote( "Closing: " );
if ( $addr ){
&print_host_info( $addr );
}else{
&print_stdout_remote( " ", $Remote_handles{$handle}, "\r\n" );
}
&close_remote_handle( $handle );
$found_one = 1;
}
}
&print_stdout_remote( "Host/port not found\r\n" ) unless $found_one;
return 1;
};
"-ctlecho" =~ /^-?$arg/ && do {
if ( $Ctlecho ){
$Ctlecho = 0;
&print_stdout_remote( "Ctlecho mode off\r\n" );
}else{
$Ctlecho = 1;
&print_stdout_remote( "Ctlecho mode on\r\n" );
}
return 1;
};
"-talk" =~ /^-?$arg/ && do {
if ( $Is_talk_mode ){
&print_stdout_remote( "Talk mode off\r\n" );
$Is_talk_mode = 0;
}else{
$Is_talk_mode = 1;
&print_stdout_remote( "Talk mode on\r\n" );
}
#if ( $Is_shell_proc && $Is_talk_mode ) {
#print "Turning off talk mode for shell server mode\r\n";
#$Is_talk_mode = 0;
#}
return 1;
};
"-trace" =~ /^-?$arg/ && do {
if ( $Is_trace_mode && ( !@args || $args[0] =~ /^-/ ) ){
&print_stdout_remote( "Trace mode off\r\n" );
$Is_trace_mode = undef;
}else{
if ( @args && $args[0] !~ /^-/ ){
$arg = shift(@args);
if ( $arg !~
/^(all|shell|from_shell|to_shell|remote|from_remote|to_remote)$/
){
return 0; }
$Is_trace_mode .= "," if $Is_trace_mode ne "";
$Is_trace_mode .= $arg;
}
else{
$Is_trace_mode = "all"; }
&print_stdout_remote( "Trace mode on ($Is_trace_mode) \r\n" );
}
return 1;
};
#"-trust" =~ /^-?$arg/ && do {
( "trust" eq $arg || "-trust" eq $arg ) && do { #make 'em spell it out
if ( $args[0] eq "perl" ){
shift(@args);
if ( $Do_real_evals ){
&print_stdout_remote( "Perl code evals not OK \r\n" );
$Do_real_evals = 0;
}else{
$Do_real_evals = 1;
&print_stdout_remote( "Perl code evals OK \r\n" );
}
}else{
if ( $Do_opt_evals ){
&print_stdout_remote( "Option evals not OK \r\n" );
$Do_opt_evals = 0;
}else{
$Do_opt_evals = 1;
&print_stdout_remote( "Option evals OK \r\n" );
}
}
return 1;
};
"-shell" =~ /^-?$arg/ && do {
if ( $Is_pass_thru ){
&print_stdout_remote( "Cannot start local shell in passthru mode\r\n" ); return 1;
}
if ( $Is_shell_proc ){
&print_stdout_remote( "Already have a shell\r\n" );
return 1;
}
if ( @args && $args[0] !~ /^-/ ){
$Shell_cmd = shift(@args) ; }
($Proc_handle,$Proc_tty_handle,$Proc_pid) = &comm'open_proc($Shell_cmd);
print STDERR "Opened pid $Proc_pid\r\n" if $Debug;
#sysread($pty_handle,$buf,10000);
#&comm'sysread( $Proc_handle, $inp, 10000 );
#print STDOUT "got from fh($Proc_handle)($inp)\r\n";
&print_stdout_remote( "Started a shell pid=$Proc_pid\r\n" );
if ( $Shell_cmd =~ /sh$/ ){
&comm'system( $Proc_tty_handle, "stty sane erase '^h' " ); }
&do_sig_winch;
$Is_shell_proc = 1;
$Is_talk_mode = 0;
$Is_command_mode = 0;
return 1;
};
"-status" =~ /^-?$arg/ && do {
if ( @args && $args[0] !~ /^-/ ){
if ( ( $arg = shift(@args) ) =~ /^rem/ ){
&print_remote_handles( *Remote_handles,
&pack_eval( qq{&option("stat")} ) );
}else{
&print_remote_handles( *Remote_handles,
&pack_eval( qq{&option("stat")}, $arg ) );
#&print_stdout_remote("Invalid status option ($arg)\r\n" );
}
return 1;
}
local( $out ) = "Status: address($My_addr) ";
( $i = $Command_char ) =~ s/[\0-\037\177-\377]/&ctlecho1($&)/ge;
$out .= "command_char($i) ";
$out .= "window($ENV{TERM},@My_window_size) ";
$out .= "daemon " if $Is_daemon;
$out .= "ctlecho " if $Ctlecho;
$out .= "trace($Is_trace_mode) " if $Is_trace_mode;
$out .= "literal " if $Is_literal;
$out .= "debug " if $Debug;
$out .= "talk_mode " if $Is_talk_mode;
$out .= "shell($Shell_cmd)($Proc_pid) " if $Is_shell_proc;
$out .= "log($Log_file) " if $Log_file;
$out .= "listen($Listen_port)[$Start_port..$Stop_port] " if $Listen_port ne $NO_PORT;
$out .= "autoconn " if $Autoconn;
$out .= "hub " if $Is_hub;
$out .= "trust_option_evals " if $Do_opt_evals;
$out .= "trust_code_evals " if $Do_real_evals;
$out .= "notify($Notify) " if $Notify;
$out .= "block_all " if $Block_all;
$out .= "\r\n";
&print_stdout_remote( &wrap( $out ) );
local( %printed_addrs ) = ();
if ( %Remote_handles ){
&print_stdout_remote( "Connections:\r\n" );
for $handle ( keys %Remote_handles )
{
if ( $addr = $Addr_for_handle{$handle} ){
&print_host_info( $addr );
$printed_addrs{$addr} = 1;
}else{
&print_stdout_remote( " ", $Remote_handles{$handle}, "\r\n" );
}
}
}
local( $addr1 ) = "";
local( %print_addrs ) = ();
for $key ( keys %Host_info )
{
( $addr1 = $key ) =~ s/$;.*//;
next if $printed_addrs{$addr1};
next if $addr1 eq $My_addr;
$print_addrs{$addr1} = 1;
}
if ( %print_addrs ){
&print_stdout_remote( "Others on:\r\n" );
for $addr ( keys %print_addrs ){
&print_host_info( $addr ); }
}
return 1;
};
"-kill" =~ /^-?$arg/ && do {
unless ( $Is_shell_proc ){
&print_stdout_remote( "No shell to kill\r\n" );
return 1;
}
local( $sig ) = -1;
if ( @args && $args[0] =~ /^-?\d+$/ ){
$sig = shift(@args ); }
kill $sig, $Proc_pid;
&print_stdout_remote( "kill $sig,$Proc_pid\r\n" );
sleep 2;
if ( kill 0, $Proc_pid ){
&print_stdout_remote( "Shell ($Proc_pid) would not die.\r\n" );
}else{
&print_stdout_remote( "Shell ($Proc_pid) killed.\r\n" );
&close_proc;
}
return 1;
};
"-listen" =~ /^-?$arg/ && do {
if ( $Is_listen ){
&comm'close($Listen_handle);
&print_stdout_remote( "Listen off\r\n" );
for $handle ( keys %Remote_handles ){
&send_host_info ( $handle ); }
$Is_listen = 0;
$My_addr = &make_my_addr;
}else{
$Is_listen = 1;
$Listen_port=$NO_PORT;
undef $Listen_handle;
if ( @args && $args[0] =~ /^\d+$/ ){
$Listen_port = shift(@args);
if ( @args && $args[0] =~ /^\d+$/ ){
$Start_port = $Listen_port;
$Stop_port = shift(@args);
$Listen_port = $NO_PORT;
}
}
if ( $Listen_port ne $NO_PORT )
{
$Listen_handle = &comm'open_listen( $Listen_port );
} else {
&print_stdout_remote( "Trying to listen on " );
for( $port = $Start_port ; $port <= $Stop_port ; $port++ )
{
&print_stdout_remote( "$port " );
if ( $Listen_handle = &comm'open_listen( $port ) )
{
$Listen_port = $port;
last;
}
&print_stdout_remote( ".. " );
}
&print_stdout_remote( "\r\n" );
}
if ( !defined( $Listen_handle) ) {
&print_stdout_remote( "couldn't get a port\r\n" );
$Listen_port = $NO_PORT;
$Is_listen = 0;
return 1;
}
&print_stdout_remote( "Listening on port $Listen_port\r\n");
$My_addr = &make_my_addr;
for $handle ( keys %Remote_handles ){
&send_host_info ( $handle ); }
}
return 1;
};
"-literal" =~ /^-?$arg/ && do {
if ( $Is_literal ){
$Is_literal = 0;
&print_stdout_remote( "Is_literal mode off\r\n" );
}else{
$Is_literal = 1;
&print_stdout_remote( "Is_literal mode on\r\n" );
}
return 1;
};
"-log" =~ /^-?$arg/ && do {
if ( $Log_file ){
&print_stdout_remote( "Closing old log file \r\n" );
$Log_file = "";
close(LOG);
return 1;
}
return 0 if ( !@args || $args[0] =~ /^-/ );
$Log_file = shift(@args) ;
open(LOG,">>$Log_file");
&print_stdout_remote( "Opening log file $Log_file in pwd ",`pwd` );
select(LOG);$|=1;select(STDOUT);
return 1;
};
( "-command_char" =~ /^-?$arg/ ) || ( "-escape" =~ /^-?$arg/ ) && do {
return 0 if ( !@args || $args[0] =~ /^-/ );
local($c) = shift(@args);
if ( length( $c ) > 1 )
{
if ( $c =~ s/^\\*(\d+)$/$1/ ){ # e.g. \033
$c = pack("C", oct($c) );
#eval qq{\$c = "$c"};
} elsif ( $c =~ s/^\136*([A-Z])$/$1/ ){ # e.g. ^H
$c = unpack("C", $c );
$c = pack("C", $c - 64 );
} elsif ( $c =~ s/^\136*([a-z])$/$1/ ){ # e.g. ^h
$c = unpack("C", $c );
$c = pack("C", $c - 96 );
}else{
return 0; }
}
$Command_char=$c;
return 1;
};
"-exit_tag" =~ /^-?$arg/ && do {
return 0 if ( !@args || $args[0] =~ /^-/ );
$Exit_tag=shift(@args);
return 1;
};
"-eval" =~ /^-?$arg/ && do {
return 0 if ( !@args || $args[0] =~ /^-/ );
local( $addr ) = shift(@args);
if ( $addr =~ s/^<// ){
if ( $addr ){
$filename = $addr;
}else{
return 0 if ( !@args || $args[0] =~ /^-/ );
$filename = shift(@args);
}
do $filename;
return 1;
}
elsif ( $addr !~ /^\w+@.*#\d+/ ){
print STDERR "Evaling ($addr)\r\n" if $Debug;
eval $addr;
return 1;
}
return 0 if ( !@args || $args[0] =~ /^-/ );
local( $eval_out, $need_paren ) = ("","");
$eval_out = shift( @args );
# use q{} in case we are in real/trusted eval mode
# they more safely quote stuff
if ( $eval_out =~ s/^opt\w*/&option(q{/ ){
return 0 if ( !@args );
$eval_out .= shift( @args );
$eval_out .= '})';
}
elsif ( $eval_out =~ s/^<// ){
if ( $eval_out ){ # eval host <file
$filename = $eval_out;
}else{
return 0 if ( !@args || $args[0] =~ /^-/ );
$filename = shift(@args); # eval host < file
}
local($old) = $/; undef $/;
open(EV_FH, $filename ); $eval_out = <EV_FH> ; close(EV_FH);
$/ = $old;
print STDERR "Eval(<$filename)=($eval_out)\r\n" if $Debug;
}
&print_remote_handles( *Remote_handles,
&pack_eval("$eval_out", $addr ) );
return 1;
};
"-print" =~ /^-?$arg/ && do {
return 0 if ( !@args || $args[0] =~ /^-/ );
$i = shift(@args);
eval qq{\$i = "$i"}; # expand stuff like \377
print STDERR "sending($i)\r\n" if $Debug;
&print_remote_handles( *Remote_handles, $i );
if ( $Is_shell_proc ){
&print_to_proc( $i ); }
return 1;
};
"-Input" =~ /^-?$arg/ && do {
return 0 if ( !@args || $args[0] =~ /^-/ );
$i = shift(@args);
if ( $Is_shell_proc ){
&print_to_proc( "$i\n" ); }
return 1;
};
"-hub" =~ /^-?$arg/ && do {
if ( $Is_hub ){
$Is_hub = 0;
&print_stdout_remote( "Hub mode off\r\n" );
}else{
$Is_hub = 1;
&print_stdout_remote( "Hub mode on\r\n" );
}
return 1;
};
if ( $Is_command_mode ){
"-quit" =~ /^-?$arg/ && &my_exit; }
"-quiet" =~ /^-?$arg/ && do {
if ( $Quiet ){
$Quiet = 0;
&print_stdout_remote( "Quiet mode off\r\n" );
}else{
$Quiet = 1;
&print_stdout_remote( "Quiet mode on\r\n" ); # ha!
}
return 1;
};
"-debug" =~ /^-?$arg/ && do {
if ( $Debug ){
$Debug = 0;
&print_stdout_remote( "Debug mode off\r\n" );
}else{
$Debug = 1;
&print_stdout_remote( "Debug mode on\r\n" );
}
return 1;
};
"-daemon" =~ /^-?$arg/ && do {
close(STDIN);close(STDOUT);
# I don't know why, but if STDIN/STDOUT aren't open, the child
# shell process dies
open(STDIN,"</dev/null");
open(STDOUT,">/dev/null");
$Is_daemon = 1;
return 1;
};
"-notify" =~ /^-?$arg/ && do {
if ( $Notify ){
$Notify = 0;
&print_stdout_remote( "Notify mode off\r\n" );
}else{
return 0 if ( !@args || $args[0] =~ /^-/ );
$Notify = shift(@args);
&print_stdout_remote( "Notify $Notify with new connections\r\n" );
}
return 1;
};
"-window_spawn" =~ /^-?$arg/ && do {
if ( $Is_window_spawn ){
$Is_window_spawn = 0;
&print_stdout_remote( "Window spawn mode off\r\n" );
}else{
if ( @args && $args[0] !~ /^-/ ){
$Window_spawn_cmd = shift(@args); }
$Is_window_spawn = 1;
&print_stdout_remote( "Window spawn mode on\r\n" ); # ha!
}
return 1;
};
"-client_window" =~ /^-?$arg/ && do {
if ( $Is_window_client ){
$Is_window_client = 0;
&print_stdout_remote( "Window client mode off\r\n" );
}else{
$Is_window_client = 1;
&print_stdout_remote( "Window client mode on\r\n" ); # ha!
}
return 1;
};
"-wrap" =~ /^-?$arg/ && do {
if ( $Is_auto_wrap ){
$Is_auto_wrap = 0;
&print_stdout_remote( "Auto wrap mode off\r\n" );
}else{
$Is_auto_wrap = 1;
&print_stdout_remote( "Auto wrap mode on\r\n" );
}
return 1;
};
$arg eq "z" && do {
&do_suspend;
return 1;
};
unshift(@args,$arg);
return undef;
}
sub open_port1{
local( $host, $port ) = @_;
local( $rem_handle );
local( $is_me ) = 0;
local($addr1) = (gethostbyname($My_host))[4];
local($addr2) = (gethostbyname($host))[4];
$is_me = 1 if ( $addr1 eq $addr2 );
if ( $host !~ /^\d+\.\d+\.\d+\.\d+$/ &&
`ypmatch $host hosts 2>/dev/null` eq "" &&
`grep $host /etc/hosts 2>/dev/null` eq "" &&
!( @tmp = gethostbyname($host) ) ){
( $rem_handle = &comm'open_port( $Proxy_host, 3666 ) ) ||
die "couldn't get a port on $Proxy_host\n";
$Is_pass_thru = 1;
if( $Is_shell_proc ){
&print_stdout_remote( "Killing shell for pass-thru mode\r\n" );
&close_proc;
}
&print_remote_handle( $rem_handle, "$host $port\r\n");
#print STDERR "No such host $host $port\n" ; return undef;
}
else{
if ( $port == 0 ){
&print_stdout_remote( "Trying to connect to $host " );
for ( $port1 = $Start_port ; $port1 <= $Stop_port ; $port1++){
if ( $is_me && $port1 == $Listen_port ){
&print_stdout_remote( "me=$port1 " );
next;
}
&print_stdout_remote( "$port1 " );
if ( $rem_handle = &comm'open_port( $host, $port1 ) ){
last;
}
}
&print_stdout_remote( "\r\n" );
}else{
$port1=$port;
if ( $rem_handle = &comm'open_port( $host, $port1 ) )
{
}
}
}
if ( $rem_handle ){
&print_stdout_remote( "Connected to $host, $port1\r\n" );
}else{
&print_stdout_remote( "Failed connection to $host\r\n" );
return undef;
}
return ($rem_handle, $port1);
}
sub send_host_info{
local($rem_handle)=@_;
local($handle,$host,$port,$out,@conns, $port1, $addr);
return if ( $Is_literal );
for $handle ( keys %Remote_handles ){
( $host, $port ) = split(/:/, $Remote_handles{$handle} );
#print "send_host_info:host=$host,$port\n";
if ( $addr = $Addr_for_handle{$handle} ){
#print "send_host_info:addr=$addr\n";
if ( $port1 = $Host_info{ $addr, "port" } ){
$port = $port1;
#print "send_host_info:port1=$port1\n";
}
}
push(@conns, $host, $port );
}
local( $rem_hosts ) =join(",", @conns);
$out = "&host_info('" .
join(";",
"version=$Version",
"user=$My_user",
"host=$My_host",
"addr=$My_addr",
"port=$Listen_port",
"hub=$Is_hub",
"window_client=$Is_window_client",
"window_size=@My_window_size",
"term=$ENV{TERM}",
"rem_hosts=$rem_hosts"
) .
"')";
print STDERR "Sent my info: $out\r\n" if $Debug;
&print_remote_handle( $rem_handle, &pack_eval("$out\r\n") );
}
sub pack_eval{
local( $s, $to ) = @_;
return "$BOE$My_addr,$to;$s";
}
sub strip_eval_info{
local($inp, $read_handle)=@_;
local( $addr_from, $addr_to ) = ("","");
return $inp unless $inp =~ s/$BOE([^$BOA]*)//;
local($eval_inp) = $1;
($eval_inp, $addr_from, $addr_to ) = &strip_addr( $eval_inp );
print "Eval info: my addr=($My_addr),from=($addr_from),to=($addr_to),inp=($eval_inp)\r\n" if $Debug;
if ( $addr_to ){
return unless ( $addr_to eq $My_addr ); }
if ( $addr_from eq $My_addr ){
&print_stdout_remote( "\r\n[eek I($My_addr) see a loop, this handle!]\r\n" );
&close_remote_handle( $read_handle );
return undef;
}
print STDERR "Received eval :(fh=$read_handle)($eval_inp)\r\n" if $Debug;
$Eval_handle = $read_handle;
if ( $eval_inp =~ s/^\&option\("stat"\)// )
{
&print_stdout( STDIN, "\r\nEvaling stat from $addr_from \r\n" );
&send_host_info ($read_handle );
&option("stat");
}
elsif ( $eval_inp =~ s/^\&host_info\(['"]// )
{
# Host info not actually eval'd here
$eval_inp =~ s/['"]\)[;\s]*$//;
&host_info($eval_inp);
}
elsif ( $eval_inp =~ s/^\&host_exited\(['"]// )
{
$eval_inp =~ s/['"]\)[;\s]*$//;
&host_exited($eval_inp);
}
elsif ( $Do_real_evals )
{
&print_stdout_remote ( "Eval code ($eval_inp) from ($addr_from)\r\n" );
local( $ret ) = eval $eval_inp;
&print_stdout_remote( "eval returned=($ret),err=($@)\r\n" );
}
elsif ( $Do_opt_evals )
{
if ( $eval_inp =~ s/^\&option\(q{// ){
$eval_inp =~ s/}\)$//;
&print_stdout_remote ( "Eval option ($eval_inp) from ($addr_from)\r\n" );
unless ( &option($eval_inp) ){
&print_stdout_remote( "Eval option failed from ($addr_from)\r\n" ); }
}else{
&print_stdout_remote ( "Eval denied ($eval_inp) from ($addr_from)\r\n" ); }
} else{
&print_stdout_remote ( "Eval denied ($eval_inp) from ($addr_from)\r\n" ); }
return $inp;
}
sub host_exited{
local( $addr ) = @_;
local( $user, $addr1 );
$user = $Host_info{ $addr, "user" };
$addr1 = $Prompt_aliases{ $user };
if ( $addr1 && $addr1 eq $addr ){
delete $Prompt_aliases{ $user }; }
&delete_Host_info( $addr );
}
sub host_info{
local($host_inp )=@_;
local(@other, $port, $rem_host, $rem_port, @tmp,
$host, $host1, $port1, $alt_host, $handle, $arg, %opt, $ok,
$opt_name, $opt_val, $version, $user,$alt_host, $handle
);
return unless $host_inp;
print STDERR "Received host info:(fh=$Eval_handle)($host_inp)\r\n" if $Debug;
for $arg ( split(/[;\n]/,$host_inp) )
{
( $opt_name, $opt_val ) = split( /\=/, $arg );
$opt{$opt_name} = $opt_val;
print STDERR $opt_name," = ",$opt{$opt_name},"\r\n" if $Debug;
}
$alt_host = $opt{"alt_host"};
$port = $opt{"port"} ? $opt{"port"} : $NO_PORT ;
$host = $opt{"host"};
# Try to get the hostname with the full domain suffix, which we may not
# get via "host_info".
for $handle ( keys %Remote_handles )
{
( $host1, $port1 ) = split(/:/, $Remote_handles{$handle} );
if ( $port1 == $port && $host1 =~ /^$host/ ){
$host = $host1; }
}
if ( $Is_window_spawn && $opt{"window_client"} != 1 )
{
print STDERR "Closing non-window-client\r\n" if $Debug;
&close_remote_handle( $Eval_handle );
unless (fork) {
local( $cmd ) = $Window_spawn_cmd;
$cmd =~ s/\$host/$host/g;
$cmd =~ s/\$port/$port/g;
&print_stdout_remote( "\r\n[Running: $cmd]\r\n" );
exec $cmd;
print STDERR "Exec ($cmd) failed!\r\n";
exit;
}
}
else
{
# Here, we may have accepted a redundant connection without out knowing
# it until now, when the remote process identifies itself uniquely.
# if old eq $NO_PORT , it could be that the remote process isn't
# listening on a port, or that we accepted a socket but just now
# received the host-info
if ( $port ne $NO_PORT ){
if ( $handle = &handle_for_host_port( $Eval_host, $port ) ){
if ( $handle ne $Eval_handle )
{
print STDERR "Closing duplicate($Eval_host,$port)\r\n" if $Debug;
&close_remote_handle( $Eval_handle );
return $inp;
}
}
}
$version = $opt{"version"};
if ( $version ne $Version ){
&print_stdout_remote(
"Warning: my version is $Version, $host is $version\r\n" ); }
if ( $opt{"term"} ne $ENV{TERM} ){
&print_stdout_remote(
"Warning: my term is $ENV{TERM}, $host is $opt{term}\r\n" );
}
if ( $opt{"window_size"} ne "@My_window_size" ){
&print_stdout_remote(
"Warning: my window size is @My_window_size, $host is $opt{window_size}\r\n" );
}
$user = $opt{"user"} ? $opt{"user"} : "[user unknown]";
local( $addr ) = $opt{"addr"};
( $host1, $port1 ) = split(/:/, $Remote_handles{$Eval_handle} );
if ( $host1 eq $opt{"host"} && $port1 eq $opt{"port"} ){
# The first one to respond on a handle gets to put its information
# on that handle (it should always be the process connected to anyway).
unless ( $Addr_for_handle{$Eval_handle} ){
$Addr_for_handle{$Eval_handle} = $addr ; }
}
$Host_info{ $addr, "host" } = $opt{"host"};
$Host_info{ $addr, "version" } = $opt{"version"};
$Host_info{ $addr, "user" } = $user;
$Host_info{ $addr, "addr" } = $opt{"addr"};
$Host_info{ $addr, "port" } = $port;
$Host_info{ $addr, "conn_time" } = time();
$date = &get_date;
$Host_info{ $addr, "conn_date" } = "[$date]";
if ( $alt_host ne $Eval_host ){
$Host_info{ $addr, "alt_host" } = $alt_host; }
$Host_info{ $addr, "hub" } = $opt{"hub"};
}# end not Is_window_spawn
if ( $Autoconn && !$Is_daemon ){
local( @rem_info ) = split(",", $opt{"rem_hosts"} );
OTHER: while ( ( $rem_host, $rem_port ) = splice( @rem_info,0,2 ) )
{
next if ( $rem_port eq $NO_PORT );
next unless ( $rem_host && $rem_port );
if ( &handle_for_host_port( $rem_host, $rem_port ) ){
print STDERR "Already connected to ($rem_host,$rem_port)\r\n" if $Debug;
next;
}
# print STDERR "($Eval_host,$port)->($rem_host,$rem_port)->you? ";
# &stty_sane;
# $reply = <STDIN>;
# if ( $reply =~ /^y/i ){
print STDERR "Setting connection to ($rem_host,$rem_port)\r\n" if $Debug;
$Auto_conn{ "open", $rem_host, $rem_port } = 1 if $ok;
# }
# &stty_raw;
}
}
return $inp;
}
sub handle_for_host_port{
local( $host, $port ) = @_;
local( $handle, $host1, $port1, $alt_host1 )=("","","","");
local( $addr );
if ( $host eq $My_host && $port == $Listen_port ) {
return STDIN;
}
for $handle ( keys %Remote_handles )
{
( $host1, $port1 ) = split(/:/, $Remote_handles{$handle} );
$addr = $Addr_for_handle{ $handle };
$alt_host1 = $Host_info{ $addr, "alt_host" };
if ( ( $host eq $host1 || $host eq $alt_host1 ) &&
( $port == $port1 ) ) {
return $handle;
}
}
return undef;
}
sub print_host_info{
local($addr)=@_;
local($alt_host,$blocked)=("","");
#$blocked = "(input blocked)" if $Host_info{ $addr, "blocked" };
$alt_host = "(" . $Host_info{ $addr, "alt_host" } . ")";
$alt_host = "" if ( $alt_host ne $host);
&print_stdout_remote( &wrap(
" ",
join(" ",
$Host_info{ $addr, "host" },
$alt_host,
$Host_info{ $addr, "port"},
#$Host_info{ $addr, "user" },
$Host_info{ $addr, "addr" },
$Host_info{ $addr, "conn_date" },
$blocked,
$Host_info{ $addr, "hub" } ? "hub" : "not_hub",
#"window(" . $Host_info{$addr,"term"} . "," .
#$Host_info{$addr,"window_size"} . ")",
$Host_info{ $addr, "version" }
),
"\r\n" ) );
}
# This just makes a meager attempt to keep the screen clutter down
# by nicely wrapping commonly sent stuff like status messages.
# We must wrap on the sending side, since the receiving side doesn't
# know the difference between status messages, and something that
# is supposed to be longer than the screen width, though it would be
# better to do it the other way around.
sub wrap{
local(@in_lines)=@_;
local(@lines, $s1);
local($s) = join("", @in_lines );
return @in_lines unless $Is_auto_wrap;
local($leader)="";
if ( $s =~ /^(\s+)/ ){
$leader = $1; }
while( $s =~ s/^(\s*\S+\s*)// )
{
if ( length($s1) + length($1) >=
( $My_window_size[1] - $Longest_prompt ) )
{
$s1 .= "\\\r\n";
push(@lines,$s1);
$s1 = $leader . " ";
}
$s1 .= $1;
}
push(@lines,$s1);
return @lines;
}
sub do_sig_winch{
local( $sig ) = @_;
local( $i );
if ( $] >= 5 ){
if ( $OS_type eq "SVR4" ){
$i = `stty -a 2>&1 </dev/tty `;
@My_window_size = ( $i =~ /rows = (\d+); columns = (\d+)/ );
}else{
$i = `stty -a 2>&1 >/dev/tty `;
@My_window_size = ( $i =~ /(\d+) rows, (\d+) column/ );
}
return;
}
$SIG{"WINCH"}="do_sig_winch";
$! = 0;
#$winsize=pack("p",$winsize);
#unless ( syscall( 54, fileno(TTY_FH), 0x40087468, $winsize ) ==0){ # XXX s/b &TIOCGWINSZ
if ( $OS_type eq "SVR4" ){
$TIOCGWINSZ = 0x5468; #TIOCGWINSZ(21608)(5468)
$TIOCSWINSZ = 0x5467; #TIOCSWINSZ(21607)(5467)
}else{
$TIOCGWINSZ = 0x40087468;
$TIOCSWINSZ = 0x80087467;
}
#unless ( ioctl( TTY_FH, $TIOCGWINSZ, $winsize ) ){
# The Solaris ioctl is hosed:
#Return value overflowed string at ./shelltalk line 821.
$winsize=pack("p",$winsize);
unless ( syscall( 54, fileno(TTY_FH), $TIOCGWINSZ, $winsize ) ==0){
print STDERR "ioctl TIOCGWINSZ failed, $!\r\n" if $Debug;
return;
}
#struct winsize {
# unsigned short ws_row; /* rows, in characters */
# unsigned short ws_col; /* columns, in characters */
# unsigned short ws_xpixel; /* horizontal size, pixels-not used */
# unsigned short ws_ypixel; /* vertical size, pixels-not used */
#};
$winsize_t = "ssss"; # 4 shorts
@array = unpack( $winsize_t, $winsize );
#print "array=(@array)\r\n";
$! = 0;
if ( $Proc_tty_handle ){
unless ( &comm'ioctl( $Proc_tty_handle, $TIOCSWINSZ, $winsize ) ){
print STDERR "ioctl TIOCSWINSZ failed, $!\r\n" if $Debug;
}
}
print STDERR "sig_winch: array=", join(",",@array), "\r\n" if $Debug;
# Keep the windows from dueling when remote windows can resize us and
# visa versa.
$time = time();
if ( ( $Winch_recv_time + 2 ) >= $time ) {
if ( $Winch_retries++ > 10 ){
print STDERR "WINCH looping, turning off\r\n";
$SIG{"WINCH"}="DEFAULT";
}
return ;
}
$Winch_retries = 0;
$Winch_send_time = $time;
@My_window_size = @array[0,1];
&print_stdout_remote( "\r\n[Window size now @My_window_size]\r\n" );
$row = $array[0] + 1;
$col = $array[1] + 5;
# Grrr. They still haven't fixed this since SunOS3! You can change
# the size of the window with this string, but the resulting row/col
# size will vary depending on the window font.
#&print_stdout_remote( "\033[8;${row};${col}t" ); # row col
##print $Tty_handle "\033[4;${array[3]};${array[2]}t"; # height width
$Ignore_resize = 1;
}
sub get_date{
local($date);
chop( $date=`date '+%T %D' ` );
return $date;
}
# "Bring out your deaddddddd"
sub wait_nohang{
if ( $OS_type eq "SVR4" ) {
# syscall 7 == wait/wait4 for BSD
# syscall 107 == waitsys for Solaris, which seems to be waitid?
# int waitid(idtype_t idtype, id_t id, siginfo_t *infop, int options);
#define WNOHANG 0100/* non blocking form of wait */
#define WEXITED 0001/* wait for processes that have exited */
# See: <sys/procset.h> and <sys/wait.h>
# Arguments: 7=P_ALL=idtype_t, 64=\100=WNOHANG | 1=W
syscall(107,7,0,0,64|1);
}
else{
# No need, since the SunOS4.x version of Perl does an implicit
# wait4, apparently.
syscall(7,0,1,0);
}
}
sub do_suspend{
$SIG{"CONT"}="do_cont";
&print_stdout_remote( "[Suspended]\r\n" );
&stty_sane;
if ( $OS_type eq "SVR4" ){
kill 23, 0; # I ran into copies of Perl where the symbolic
}else{ # symbol names were wrong.
kill 17, 0;}
$SIG{"CONT"}="DEFAULT";
&print_stdout_remote( "[Resumed]\r\n" );
}
sub do_cont{
&stty_raw;
}
sub telnet_defines{
# Values taken from /usr/include/arpa/telnet.h
# Note: need double quotes for correct interpolation in future double quotes
$TEL_IAC = "\377" ;#/* interpret as command: */
$TEL_DONT = "\376" ;#/* you are not to use option */
$TEL_DO = "\375" ;#/* please, you use option */
$TEL_WONT = "\374" ;#/* I won't use option */
$TEL_WILL = "\373" ;#/* I will use option */
$TELOPT_TTYPE = "\030" ;#/* terminal type */
$TELOPT_ECHO = "\001" ;#/* echo */
# Could use decimal values, but then would have to do:
#E.g.&comm'print( $rem_handle, pack("C*", $IAC, $WILL, $ECHO ) );
#&comm'print ($rem_handle, pack("C*", $IAC, $WILL, $ECHO ) );
#&comm'print ($rem_handle, pack("C*", $IAC, $DONT, $ECHO ) );
}
# This is normally in the Perl distribution, but I'll include it anyway.
;# shellwords.pl
;#
;# Usage:
;# require 'shellwords.pl';
;# @words = &shellwords($line);
;# or
;# @words = &shellwords(@lines);
;# or
;# @words = &shellwords; # defaults to $_ (and clobbers it)
sub shellwords {
package shellwords;
local($_) = join('', @_) if @_;
local(@words,$snippet,$field);
s/^\s+//;
while ($_ ne '') {
$field = '';
for (;;) {
if (s/^"(([^"\\]|\\.)*)"//) {
#($snippet = $1) =~ s#\\(.)#$1#g;
($snippet = $1) =~ s/\\"/"/g;
}
elsif (/^"/) {
print "Unmatched double quote: $_\n";
return undef;
}
elsif (s/^'(([^'\\]|\\.)*)'//) {
#($snippet = $1) =~ s#\\(.)#$1#g;
($snippet = $1) =~ s/\\'/'/g;
}
elsif (/^'/) {
print "Unmatched single quote: $_\n";
return undef;
}
elsif (s/^\\(.)//) {
$snippet = $1;
}
elsif (s/^([^\s\\'"]+)//) {
$snippet = $1;
}
else {
s/^\s+//;
last;
}
$field .= $snippet;
}
push(@words, $field);
}
@words;
}
1;
# Here is an example of an answering machine.
# It loops through a given set of messages, and will also display
# personalized messages for particular users.
#
#eval 'exec perl -S $0 "$@"'
# if $running_under_some_shell;
#
#$|=1;
#require "open3.pl";
#
#$pid = &open3( WTR, RDR, RDR, 'shelltalk -notify "console|smcc" -log answer.out -t -l ');
## open2 would work also
#
#select WTR;$|=1;select STDOUT;
#open(LOG1, ">>answer.out1");
#select LOG1;$|=1;select STDOUT;
#
#&make_msgs;
#
#@fight_msgs = split(/ +/, "Press } to exit fight mode.\n");
##push(@fight_msgs, "\n");
#
#$*=1;
##while(<RDR>)
#{
# sysread(RDR, $_, 10000);
# print LOG1 $_;
# /New connection from \((\w+)/ && do {
# $host = $1;
# $host =~ s/\..*//g;
# @msgs = @msgs1 unless @msgs;
# $msg = shift(@msgs);
# sleep 1;
# print WTR $msg;
# push(@msgs1, $msg );
# print WTR `date`;
# };
# /(\w+)[>@]/ && do {
# $user = $1;
# unless ( $Printed_personal{ $user } )
# {
# $Printed_personal{ $user } = 1;
# $msg = $Personal{ $user };
# print WTR $msg;
# }
# };
# /\((\w+)[@>].*disconnected/ && do {
# $user = $1;
# $Printed_personal{ $user } = 0;
# };
# /{/ && do { $fight = 1; };
# /}/ && do { $fight = 0; };
#
# if ( $fight ){
# @fight_msgs = @fight_msgs1 unless @fight_msgs;
# $msg = shift(@fight_msgs);
# print WTR "$msg ";
# push(@fight_msgs1, $msg );
# }
#
# redo;
#}
#
#print STDERR "exited loop!\n";
#
#sub make_msgs{
#
# $msgs =<<EOF;
#
#Hello. You've reached the office of Eric Arnold.
#Nice of you to drop by. If you'd like to leave a
#message, go right ahead! Logging is on.
#
#This has been a recording.
#
#EOM
#
#Your call is very important to us. Please stay on the
#line ...
#
#This message will repeat. (Meanwhile, type in yours.)
#
#EOF
#
# @msgs=split(/EOM/,$msgs);
#
# $personal = <<EOF;
#eric
#
#Greetings, Eric. I hope you enjoyed making this thing.
#
#EOF
#
# for $l ( split(/EOM/,$personal) )
# {
# ( $user, $msg ) = split( /\n/, $l, 2 );
# $Personal{ $user } = $msg;
# }
#
#}
# "comm_utils.pl"
#
# This is a library of IPC goodies. There is no warrenty, but I'd
# be happy to get ideas for improvements.
#
# -
[email protected]
#
# It's been tested with Perl4/Perl5 and SunOS4.x and Solaris2.3 - 2.5.
# It's normally put into a file and "require"'d, but can also be simply
# concatinated to the end of some other perl script.
#
# A lot was borrowed from "chat2.pl", and then diverged as its goals became
# generalized client/server IPC, support for SVR4/Solaris, and to facilitate
# my "shelltalk" program.
#
# Function summary:
#
# &init();
#
# $handle = &comm'open_port($host, $port, $timeout);
# $handle = &comm'open_listen( $port );
# ( $Proc_handle, $Proc_tty_handle, $Proc_pid ) = &comm'open_proc($Shell_cmd);
#
# ( $new_handle, $rem_host ) = &comm'accept_it( $handle );
# @ready_handles = &comm'select_it( $timeout, $handle1, $handle2, ..... );
#
# $string = &comm'gets( $handle );
# &comm'sysread( $handle, $buf, $num_bytes );
# &comm'print( $handle, $buf );
# &comm'system( $Proc_tty_handle, $command );
#
# &comm'close_noshutdown( $handle );
# &comm'close( $handle )
#
# &comm'ioctl( $Proc_tty_handle, $ioctl_command, $var );
# &comm'stty_sane( $handle );
# &comm'stty_raw( $handle );
# &comm'get_ioctl_from_stty( $stty_cmd );
# &comm'dump_ioctl( $stty_cmd );
#
#
# See the end for example programs demonstrating usage.
#
# Bugs:
# - SOCK_STREAM (see comm_utils.pl) is different for SVR4/Solaris,
# but if you use a perl compiled under SunOS, then the old value is
# needed. How do I tell whether I'm running a SunOS4.x perl or Solaris2?
# I finally gave up and it first tries 1 for SOCK_STREAM, and if that
# fails, then it tries 2.
#
# 09/11/94 07:03:04 PM; eric: fixed for Solaris and /dev/tty
# 09/14/94 02:11:19 AM; eric: close correct file handle in open_listen
# 09/15/94 03:33:31 AM; eric: added sock'system
# 09/19/94 10:48:11 AM; eric: added cheapo/easy ioctl dump/do
# 10/11/94 11:07:14 AM; eric: added I_POP to clear stream on pty
# 11/08/94 03:03:19 PM; eric: changed to first try SOCK_STREAM=1, then =2
# 02/28/95 12:53:22 PM; eric: found the right place to set SO_LINGER!
# 03/18/95 08:19:46 PM; eric: added timeout arg to open_port
# 05/07/95 10:56:25 PM; eric: fixed shutdown/close order bug in close()
# added close_noshutdown
# 06/08/95 01:06:03 PM; eric: fixed Sol2.4 problem with string literal
# as last arg to syscall($SYS_ioctl
package comm;
&init;
sub init{
*Debug = *main'Debug;
if ( -f "/vmunix" )
{
$OS_type = "BSD";
$SOCK_STREAM=1;
}
else
{
$OS_type = "SVR4";
if ( $] >= 5 ){
$SOCK_STREAM=1;
}else{
$SOCK_STREAM=2;}
}
print STDERR "OS_type=$OS_type\n" if $Debug;
chop( $thishost = `uname -n ` );
$next_handle="stuff000000";
$sockaddr = 'S n a4 x8';
$thisaddr = (gethostbyname($thishost))[4];
$thisproc = pack($sockaddr, 2, 0, $thisaddr);
$SYS_ioctl = 54;
if ( $OS_type eq "SVR4" ){
# These must be syscalls because Perl's ioctl doesn't know about I_PUSH
#syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, "ptem" );
#syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, "ldterm");
# from /usr/include/sys/termios.h
$tIOC =( unpack("C", 't') << 8);
$TIOCGETP =($tIOC|8);
$TIOCSETP =($tIOC|9);
$TIOC =( unpack("C", 'T' ) <<8);
$TCGETS =($TIOC|13);
$TCSETS =($TIOC|14);
$TCSANOW =(( unpack("C",'T')<<8)|14); #/* same as TCSETS */
$TCGETA =($TIOC|1);
$TCSETA =($TIOC|2);
# From /usr/include/sys/stropts.h
$STR = ( unpack("C", "S") <<8 );
$I_PUSH = ($STR|02); #$I_PUSH = 21250;
$I_POP = ($STR|03);
$I_LOOK = ($STR|04);
#define I_FLUSH (STR|05)
}else{
$TIOCGETP=0x40067408; #d(1074164744)
$TIOCSETP=0x80067409; #d(-2147060727)
}
$SOL_SOCKET =0xffff ;#/* options for socket level */
$SO_DEBUG =0x0001 ;#* turn on debugging info recording */
$SO_ACCEPTCONN =0x0002 ;#* socket has had listen() */
$SO_REUSEADDR =0x0004 ;#* allow local address reuse */
$SO_KEEPALIVE =0x0008 ;#* keep connections alive */
$SO_DONTROUTE =0x0010 ;#* just use interface addresses */
$SO_BROADCAST =0x0020 ;#* permit sending of broadcast msgs */
$SO_USELOOPBACK =0x0040 ;#* bypass hardware when possible */
$SO_LINGER =0x0080 ;#* linger on close if data present */
$SO_OOBINLINE =0x0100 ;#* leave received OOB data in line */
}
sub open_port{
local( $server, $port, $timeout ) = @_;
local( $new_handle ) = ++$next_handle;
local( %saveSIG, $ret );
if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
$serveraddr = pack('C4', $1, $2, $3, $4);
} else {
local(@x) = gethostbyname($server);
return undef unless @x;
$serveraddr = $x[4];
printf( "server=$server,serveraddr=%x\n", $serveraddr) if $Debug;
}
$serverproc = pack($sockaddr, 2, $port, $serveraddr);
print STDERR "\$serverproc = pack($sockaddr, 2, $port, ",
join(".", unpack("C*", $serveraddr)), ");\n" if $Debug;
unless (socket( $new_handle, 2, 1, 6)) {
unless (socket( $new_handle, 2, 2, 6)) {
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? (:-)
($!) = ($!, close( $new_handle)); # close new_handle while saving $!
#die "socket failed";
print STDERR "Socket error $!\n" if $Debug;
return undef;
}
}
unless (bind( $new_handle, $thisproc)) {
($!) = ($!, close( $new_handle)); # close new_handle while saving $!
#die "bind failed";
print STDERR "bind error $!\n" if $Debug;
return undef;
}
%saveSIG=%SIG;
if ( $timeout )
{
$SIG{ALRM} = "timedout";
alarm($timeout);
}
eval { $ret = connect( $new_handle, $serverproc) };
if ( !$ret || ($@ =~ /^timedout/) ) {
($!) = ($!, close( $new_handle)); # close new_handle while saving $!
#die "connect failed, $!";
print STDERR "connect error eval=($@)$!\n" if $Debug;
if ( $@ =~ /^timedout/ ) {
$! .= ", timeout after $timeout seconds";}
return undef;
}
if ( $timeout )
{
%SIG = %saveSIG;
alarm(0);
}
select((select( $new_handle), $| = 1)[0]);
return $new_handle;
}
sub timedout {
die "timedout";
}
sub open_listen{
local( $port ) = @_;
( $thisproc_local ) = pack( $sockaddr, 2, $port, $thisaddr );
#print "( $thisproc_local ) = pack( $sockaddr, 2, $port, $thisaddr );\n";
$new_handle = ++$next_handle;
unless (socket( $new_handle, 2, 1, 6)) {
unless (socket( $new_handle, 2, 2, 6)) {
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? ( :- )
#die "socket failed: $!";
print STDERR "socket failed: $!\n" if $Debug;
($!) = ($!, close($new_handle)); # close S while saving $!
return undef;
}
}
# We want it it release the socket for immediate reuse if the server is
# shutdown/restarted. It seems that SO_LINGER and SO_REUSEADDR are most
# pertinant, but SO_KEEPALIVE seems like it might be nice too, for
# notification of peer disappearance.
$linger = pack("II", 0, 0 ); # linger is a C struct in socket.h
setsockopt( $new_handle, $SOL_SOCKET, $SO_LINGER, $linger);
setsockopt( $new_handle, $SOL_SOCKET, $SO_KEEPALIVE, 1);
setsockopt( $new_handle, $SOL_SOCKET, $SO_REUSEADDR, 1);
unless ( bind( $new_handle, $thisproc_local )) {
#die "bind failed: $!";
print STDERR "bind failed: $!\n" if $Debug;
($!) = ($!, close($new_handle)); # close S while saving $!
return undef;
}
unless ( listen( $new_handle, 1 )) {
#die "listen failed: $!";
print STDERR "listen failed: $!\n" if $Debug;
($!) = ($!, close($new_handle)); # close S while saving $!
return undef;
}
select( (select( $new_handle ), $| = 1 )[0] );
local( $family, $port, @myaddr ) = unpack( "S n C C C C x8",
getsockname( $new_handle ));
#print " local( family, port, myaddr ) = local( $family, $port, @myaddr) \n";
return $new_handle;
}
sub accept_it{ local( $handle ) = @_; local( $addr, $af, $port,
$inetaddr, $acceptaddr ) = ();
$new_handle = ++$next_handle;
unless( ( $addr = accept( $new_handle, $handle ) ) ) {
print STDERR "accept failed: $!";
}
( $af, $port, $inetaddr ) = unpack( $sockaddr, $addr );
@inetaddr = unpack( 'C4', $inetaddr );
#print "accept: $af $port @inetaddr(", join('.', @inetaddr), ")\n";
#print "host=", gethostbyaddr( join('.', @inetaddr), 2 ), "\n";
#print "host=", gethostbyaddr( join(' ', @inetaddr), 2 ), "\n";
($name, $aliases, $type, $len, $acceptaddr) =
gethostbyaddr( pack( 'C4', @inetaddr ), 2 );
#print "accept: host=$name, port=$port\n";
select( ( select( $new_handle ), $| = 1 )[0] );
$name = join(".", @inetaddr ) unless $name;
return $new_handle,$name;
}
sub select_it {
local( $timeout, @handles ) = @_;
local( @ready ) = ( );
local( $rout, $rmask, $handle, $eout, $emask );
for $handle ( @handles ) {
vec( $rmask, fileno( $handle ), 1 ) = 1;
vec( $emask, fileno( $handle ), 1 ) = 1;
}
( $nfound, $timeleft ) = select( $rout=$rmask, undef, $eout=$emask, $timeout );
print "nfound=$nfound\n" if $DEBUG;
if ( $nfound < 1 ){
if ( $nfound < 0 ){
print "error=$!\n" if $DEBUG; }
return @ready;
}
# You could also do:
# @bit = split(//,unpack('b*',$rout));
# if ($bit[fileno(STDIN)] == 1){ ... };
for $handle ( @handles ) {
if ( vec( $rout, fileno( $handle ), 1 ) == 1 ) {
print "fh=$handle is ready\n" if $DEBUG;
push( @ready, $handle ); }
if ( vec( $eout, fileno( $handle ), 1 ) == 1 ) {
print "Exception on read_handle=$handle\n" if $DEBUG; }
}
return @ready;
}
1;
## $handle = &chat'open_proc("command","arg1","arg2",...);
## opens a /bin/sh on a pseudo-tty
sub open_proc { ## public
local(@cmd) = @_;
#local(*TTY,*PTY); # PTY must not die when sub returns
local( $pty_handle, $tty_handle );
$pty_handle = "proc" . ++$next_handle;
*PTY = $pty_handle;
$tty_handle = "proc" . ++$next_handle;
*TTY = $tty_handle;
local($pty,$tty) = &_getpty(PTY,TTY);
die "Cannot find a new pty" unless defined $pty;
local($pid) = fork;
die "Cannot fork: $!" unless defined $pid;
unless ($pid) {
close STDIN; close STDOUT; close STDERR;
if ( $OS_type eq "SVR4" ){
syscall(39,3); #* setsid():: syscall(39,3)
}else{
#syscall(175);#setsid , doesn't seem to work well
setpgrp(0,$$);
# this ioctl is necessary for "isig" to work right,
# and otherwise "csh" freaks out and hangs:
if (open(DEVTTY, "/dev/tty")) {
ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
close DEVTTY;
}
}
open(STDIN,"<$tty");
#open(STDIN,"<&TTY"); # fails to assign controlling tty!
if ( $OS_type eq "BSD" ){
# doesn't seem to be necessary if open by filename
#TIOCSCTTY,d(536900740)0x(20007484)
#syscall(54, fileno(STDIN), 0x20007484, 1 );
}
open(STDOUT,">$tty");
open(STDERR,">&STDOUT");
die "Oops" unless fileno(STDERR) == 2; # sanity
close(PTY) || print "error closing master handle:$!\n";
exec @cmd;
die "Cannot exec @cmd: $!";
}
#close(TTY);
return ($pty_handle,$tty_handle,$pid); # return symbol for switcharound
}
sub _getpty { ## private
local($_PTY,$_TTY)=@_;
local($pty,$tty);
$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
for $bank (112..127) {
next unless -e sprintf("/dev/pty%c0", $bank);
for $unit (48..57) {
$pty = sprintf("/dev/pty%c%c", $bank, $unit);
open($_PTY,"+>$pty") || next;
select((select($_PTY), $| = 1)[0]);
($tty = $pty) =~ s/pty/tty/;
# some stupid magic says I can't use a variable
# name in the open for a TTY open
open($_TTY,"+>$tty") || next;
select((select($_TTY), $| = 1)[0]);
if ( $OS_type eq "SVR4" )
{
local( $pop ) = pack( "p", $pop );
syscall($SYS_ioctl, fileno($_TTY), $I_POP, 0 );
syscall($SYS_ioctl, fileno($_TTY), $I_POP, 0 );
#syscall($SYS_ioctl, fileno($_TTY), $I_LOOK, $pop );
#print "looked: len=", length($pop),"($pop)\n";
#$pop = pack( "p", $pop );
#syscall($SYS_ioctl, fileno($_TTY), $I_LOOK, $pop );
#print "looked: len=", length($pop),"($pop)\n";
local($tmp);
# $tmp needed because Solaris2.4,2.5 complains:
# Modification of a read-only value attempted at
# comm_utils.pl line ...
# if you use a string literal instead
syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, $tmp="ptem" );
syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, $tmp="ldterm");
}
system "stty nl>$tty <$tty";
return ($pty,$tty);
}
}
undef;
}
sub gets{
local(*FH)=shift;
scalar(<FH>);
}
sub sysread{
local(*FH)=shift;
sysread(FH, $_[0], $_[1]);
}
sub ioctl{
local($fh)=shift;
syscall( 54, fileno($fh), @_ ) == 0;
}
sub print{
local($fh)=shift;
local($ret)= print $fh @_;
unless ( $ret ){
print STDERR "Error printing to fh($fh),$!\n"; }
return $ret;
}
# This is useful when there a parent and child share the file descriptor,
# because the shutdown affects both.
sub close_noshutdown{
for (@_){
next unless $_;
close( $_ );
}
}
sub close{
for (@_){
next unless $_;
unless ( /^proc/ ){
print STDERR "Doing shutdown on $_\n" if $DEBUG;
shutdown($_,2) ; # must happen before close
}
#print "comm'close: $_\n";
#local( *fh ) = $_; # some god-aweful magic
#close( $fh ); # some god-aweful magic
close( $_ );
}
}
# This is so you can run commands in the pty process without routing
# through the shell, which is ugly
sub system{
local( $handle, @args ) = @_;
unless ( fork() ){
close(STDIN);close(STDOUT);
open(STDIN,"<&$handle" );
open(STDOUT,">&$handle" );
exec ( @args );
exit;
}
}
sub stty_sane{
local( $handle ) = @_;
local( $packed ) = ();
#&dump_ioctl( "stty sane erase '^H' " );
if ( $OS_type eq "SVR4" ){
$packed = pack("C*", 37,38,0,5,5,173,138,59,0,3,28,8,21,4 );
ioctl( $handle, $TCSETA, $packed);
}else{
$packed = pack("C*", 15,15,8,21,0,216 );
#$packed = &get_ioctl_from_stty( "stty sane erase '^H' " );
ioctl( $handle, $TIOCSETP, $packed);
}
}
sub stty_raw{
local( $handle ) = @_;
local( $packed ) = ();
#&dump_ioctl( "stty raw -echo -icanon eol '^a'" );
if ( $OS_type eq "SVR4" ){
$packed = pack("C*", 0,0,0,4,4,189,138,48,0,3,28,8,21,1,1,0,0,22 );
ioctl( $handle, $TCSETA, $packed);
}else{
$packed = pack("C*", 15,15,8,21,0,240 );
#$packed = &get_ioctl_from_stty( "stty raw -echo -icanon eol '^a'" );
ioctl( $handle, $TIOCSETP, $packed);
}
}
sub get_ioctl_from_stty{
local( $stty_cmd ) = @_;
local( $ioctl_struct, $get_cmd, $set_cmd, $out, $ret ) = ();
#print $stty_cmd,"\n";
system $stty_cmd;
# These only return 4 bytes. Why?
# $p = pack("p", $ioctl_struct );
#$ret = syscall($SYS_ioctl, fileno(STDIN), $TIOCGETP, $p);
#$ret = syscall($SYS_ioctl, fileno(STDIN), $TCGETA, $p);
if ( $OS_type eq "SVR4" ){
$get_cmd = $TCGETA;
}else{
$get_cmd = $TIOCGETP;
}
$!=0;
$ret = ioctl(STDIN, $get_cmd, $ioctl_struct );
return $ioctl_struct;
#return ( $ioctl_struct, $ret ); # blows up $ioctl_struct on the stack
}
sub dump_ioctl{
local( $stty_cmd ) = @_;
local( $ioctl_struct, $c, $out ) = ();
$ioctl_struct = &get_ioctl_from_stty( $stty_cmd );
for $c ( unpack("C*", $ioctl_struct) ){
#$out .= sprintf("0x%2.2x,", $c );
$out .= sprintf("%d,", $c );
}
print "$stty_cmd = $out \n";
# I don't know off hand how much of the returned buffer is actually
# significant; certainly less than the full 256 bytes.
return $ioctl_struct;
}
1;
__END__
#--------------------------------Example server---------------------------------
#
# Allows multiple client connections, and rebroadcasts data between them.
eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
& eval 'exec perl -S $0 $argv:q'
if 0;
require "comm_utils.pl" unless defined &comm'init;
$Listen_port = 5050;
$Listen_port = $ARGV[0] if $ARGV[0];
$SIG{'HUP'} = "my_exit";
$SIG{'INT'} = "my_exit";
$SIG{'QUIT'} = "my_exit";
$DEBUG = 1;
$|=1;
&comm'init;
if(1)
{
$Listen_handle = &comm'open_listen( $Listen_port );
die "open_listen failed on port $Listen_port" unless $Listen_handle;
}
else
{
# This is optional; it can be useful to use a range of ports
# if your sockets don't always release a port right away when you kill
# a process. However, the "setsockopt()" calls should release the ports
# for you, so this should no longer be necessary.
$start_port = $Listen_port;
{
if ( ! ( $Listen_handle = &comm'open_listen( $Listen_port ) ) )
{
redo unless ( ++$Listen_port <= $start_port + 10 );
die "open_listen failed on port $Listen_port";
}
}
}
print "Listening on port $Listen_port\n" if $DEBUG;
while (1)
{
@ready_handles = &comm'select_it(1, keys(%Client_handles), $Listen_handle );
print "Handles ready: @ready_handles\n" if $DEBUG && @ready_handles;
foreach $handle (@ready_handles)
{
if ($handle eq $Listen_handle)
{
($new_handle, $rem_host) = &comm'accept_it($handle);
$Client_handles{$new_handle} = $rem_host;
print "New connection from $rem_host\n" if $DEBUG;
}
else
{
#print &comm'gets($handle); # if new-line oriented
if ( &comm'sysread($handle, $buf, 10000) )
{
$buf = $Client_handles{$handle} . ": $buf";
$buf =~ s/[\n]*$/\n/;
print $buf;
# rebroadcast data to all clients:
for $client_handle ( keys %Client_handles ) {
&comm'print( $client_handle, $buf ); }
}
else
{
print "Closing handle $handle, host $rem_host\n";
&comm'close( $handle );
delete $Client_handles{ $handle };
}
}
}
}
sub my_exit
{
&comm'close( $Listen_handle );
print "Closing listen port\n" if $DEBUG;
exit;
}
#--------------------------------Example client---------------------------------
# Connect to a server, and send STDIN data to it.
# Usage: tstclient <host> <port>
eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
& eval 'exec perl -S $0 $argv:q'
if 0;
require "comm_utils.pl" unless defined &comm'init;
$Server_port = 5050;
$Server_host = "serverhost.domain";
( $Server_host, $Server_port ) = @ARGV if @ARGV;
$SIG{'HUP'} = "my_exit";
$SIG{'INT'} = "my_exit";
$SIG{'QUIT'} = "my_exit";
$|=1;
$DEBUG = 1;
&comm'init;
if ( ! ( $Server_handle = &comm'open_port($Server_host, $Server_port, 5) ) )
{
die "open_port failed on host $Server_host, port $Server_port";
}
print "Connected to host $Server_host, port $Server_port\n" if $DEBUG;
while (1)
{
@ready_handles = &comm'select_it(1, $Server_handle, STDIN);
foreach $handle (@ready_handles)
{
if ($handle eq "STDIN")
{
$buf = <STDIN>;
&comm'print( $Server_handle, $buf );
}
else # server
{
unless ( &comm'sysread($handle, $buf, 1000) )
{
print "Server connection broken\n";
&my_exit;
}
print $buf;
}
}
}
sub my_exit
{
&comm'close($HANDLE);
exit;
}
