Return to BSD News archive
Xref: sserve comp.os.386bsd.questions:15291 comp.lang.perl:35878
Path: sserve!newshost.anu.edu.au!harbinger.cc.monash.edu.au!msunews!uwm.edu!cs.utexas.edu!geraldo.cc.utexas.edu!sylvester.cc.utexas.edu!not-for-mail
From: vax@sylvester.cc.utexas.edu (Vax)
Newsgroups: comp.os.386bsd.questions,comp.lang.perl
Subject: [NetBSD,*BSD] free slipmaint script
Date: 17 Dec 1994 16:54:20 -0600
Organization: The University of Texas at Austin; Austin, Texas
Lines: 610
Message-ID: <3cvq6s$ln@sylvester.cc.utexas.edu>
NNTP-Posting-Host: sylvester.cc.utexas.edu
I wrote this script; it's based loosely on "slipup", but it's a re-write
so I changed the name. I tried to make it do everything in a modular
way. It works very well under NetBSD-1.0.
However, I can't get it to hang up the darned phone. It says (in debug mode)
that it's hanging up the phone but it doesn't work. Try sending a HUP
signal to the child (watching line..) to see what I mean. I'm stumped.
Also, if you can tell me how to get a HUP signal to the child if the modem
hangs up, that'd be great.
PLEASE HELP! I've spent weeks on this program.
===================code follows===================----cut-here-----========
#!/usr/foreign/bin/perl
# $Id: slipmaint,v 1.16 1994/12/14 10:36:19 vax Exp $
# $Log: slipmaint,v $
# Revision 1.16 1994/12/14 10:36:19 vax
# fixed syntax errors, also last rev fixed hostname properly
#
# Revision 1.15 1994/12/14 10:35:00 vax
# modem hangup stuff added, killing dummy-child used on configure
#
# Revision 1.14 1994/12/10 12:05:41 vax
# Added ability to set and restore the hostname
#
# Revision 1.13 1994/12/10 11:41:48 vax
# Program now kills off slattach properly if signalled.
#
# Revision 1.12 1994/12/10 11:25:45 vax
# Fixed it so that everything will die off properly when HUP'ed
#
# Revision 1.11 1994/12/07 12:13:39 vax
# Rearrangement of constants, implementation of signal handler,
# use of indirect filehandles rather than literal names, non-buffering, etc.
#
# Revision 1.10 1994/12/06 12:07:07 vax
# Added a lot of error handling, robustness, stty flags, etc
#
# Revision 1.9 1994/12/06 10:21:23 vax
# Added a makefile to install slipmaint, and added some debug stuff to
# the slipmaint program itself.
#
# Revision 1.8 1994/12/05 09:48:10 vax
# First version that can start all the stuff
#
# Revision 1.7 1994/12/03 10:47:45 vax
# This is the first version of slipmaint that really can log in.
#
# Revision 1.6 1994/12/03 08:24:22 vax
# Added small error catching code in open call
#
# Revision 1.5 1994/12/03 08:15:45 vax
# Changed name from $network to $remote_ip_address and added network
# start code.
#
# Revision 1.4 1994/12/02 09:00:17 vax
# Added some comments, sleep_on_open, and some lock stuff
#
# Revision 1.3 1994/11/30 01:47:05 vax
# re-arranged so that open/configure will work
#
# Revision 1.2 1994/11/29 18:44:10 vax
# An actual, error-free skeleton
#
# set up the signal handler first
# NOTE: that handled signals are not preserved across an exec,
# but are preserved across forks!
$SIG{'HUP'} = 'signal_handler';
# CONSTANTS
###########
# progname
# this sets the program name to something reasonable based on command line
$_ = $0;
s!.*/([^/]*)!$1!;
$progname = $_;
$devfh = 'DEV'; # a constant holding the device filehandle name
# CLEANUP (SIGNAL) CONSTANTS
$clean_flags_unlock = 1;
$clean_flags_ifconfig = 2;
$clean_flags_route = 4;
$clean_flags_online = 8;
# STTY CONSTANTS
$stty_baud = '38400';
# PAUSE LENGTHS
$pause_for_open = 5;
$pause_for_network = 5;
# MODEM CONSTANTS
# Input
$modem_attention = 'AT';
$modem_end_line = "\r";
$modem_init_string = $modem_attention . ' Z S2=43 S12=20 M0' . $modem_end_line;
$modem_dial_string = $modem_attention . 'DT';
$modem_hangup_string = $modem_attention . 'H' . $modem_end_line;
# Output
$modem_ok = 'OK';
$modem_success = 'CONNECT';
$modem_wait = '(' . $modem_success . '|BUSY|CARRIER)';
$modem_timeout_char = 60; # time to wait for an expected character
# DIALING CONSTANTS
$busy_retries = 5;
# OS/SYSTEM CONFIGURATION
$interface = 'sl0';
$slattach_baud = $stty_baud;
# NOTE: don't interpolate here; enclose in single quotes
$slattach_cmd = 'slattach -h -s $slattach_baud $device';
$slip_file_dir = "/usr/foreign/runtime/$progname";
$slip_num_file = $slip_file_dir . '/number';
$slip_name_file = $slip_file_dir . '/name';
# global variables:
# config_file # The configuration file from which to read (a database)
# config_entry # The entry in the configuration file
# device # The I/O device to use
# network # Network number of the remote host
# phone # The phone number of the remote host
# verbose
# debug
# daemon
# remote_chat # Chat string to log in to remote host
# @children # array of child pids to kill
# @unlink_files # array of files to unlink
# include required perl-files (if any)
require 'getopts.pl'; # required for Getopts call to parse arguments
# parse arguments
# allows p,n,t,f,h options with args, vxd without.
defined &Getopts ? &Getopts('f:h:t:n:p:c:vxd')
: die 'No getopts';
# here are the command-line only flags - NOTE: we must set them first
# (esp. debug!)
$verbose = defined($opt_v) ? 1 : 0;
$debug = defined($opt_x) ? 1 : 0;
$daemon = defined($opt_d) ? 1 : 0;
# first we parse the config file from which to read the other variables
# if it is defined from Getopts, then use that
# otherwise, use /etc/{program name}.hosts (default)
$config_file = defined($opt_f) ? $opt_f : "/etc/$progname.hosts";
# next we parse out the specific entry in the config file
# if it is defined on the command line, use it, else use default
# NOTE: that this could mask some errors, but is useful
$config_entry = defined($opt_h) ? $opt_h : 'default';
# now we can go and read the info from the config file.
($config_entry,$device,$remote_ip_address,$phone,$remote_chat)
= &config_read($config_file,$config_entry,$debug);
# next we adjust other defaults...
# here is the device to use
$device = defined($opt_t) ? $opt_t : defined($device) ? $device : '/dev/tty00';
# and the network number of the remote host
$remote_ip_address = defined($opt_n) ? $opt_n
: defined($remote_ip_address) ? $remote_ip_address : '127.0.0.1';
# and the phone number
$phone = defined($opt_p) ? $opt_p
: defined($phone) ? $phone : '5555555';
# the chat string to log us in
$remote_chat = defined($opt_c) ? $opt_c : defined($remote_chat)
? $remote_chat : 'gin:|guest\r|ord:|guest\r|>|slip default\r';
# fork off as daemon process if necessary
# this is so that it will not stay on as a "zombie" of /etc/rc or whatever.
# NOTE: this works - see the perl manual, under forking a daemon process.
if ($daemon) { fork && exit; setpgrp(0,$$); }
require 'syslog.pl'; # required for the openlog call
&openlog($progname . ' ' . (getpwuid($<))[0], 'pid,cons', 'daemon');
# check if network is already up
if (`netstat -i -n | cut -c25-40 | tail +2` =~ /^$remote_ip_address/)
{ die "Network to $remote_ip_address is already up\n"; }
if (`netstat -rn | cut -c61- | tail +5` =~ /^$interface/)
{ die "Network interface $interface is already up\n"; }
# configure the I/O device
&configure_device($device,$stty_baud,$pause_for_open);
# open the correct I/O device
# NOTE: to (properly) open the device, we must configure it first.
&open_device($device,$devfh) && push(@closelist,$devfh);
# NOTE: to do flock-style locking, you must open the device first.
# lock the correct I/O device
&lock_device() && ($clean_flags |= $clean_flags_unlock);
# Now we can open it for write.
&finish_opening_device($device,$devfh)
|| warn "Unable to open device for r/w\n";
&finish_configuring_device($devfh)
|| warn "Unable to finish configuring device\n";
warn "selected filehandle is " . select . "\n" if $debug;
require 'sys/wait.ph'; # required for WIF* calls below waitpid, below.
# fork and run the main loop
# if we get a recoverable error, allow the child to exit and repeat
for (;;)
{ local($childpid,$retval);
unless ($childpid = fork())
{ # fix signal handler - preserved across forks
# fix global vars
undef(@children);
$cleanup_flags = 0;
$0 = "$progname (child)";
exit &main($phone,$remote_ip_address,$verbose,$debug,$busy_retries,
$busy_sleep,$modem_timeout_char,$remote_chat,$slattach_cmd,
$device,$pause_for_network,$slip_num_file,$slip_name_file,
$devfh);
}
push(@children,$childpid);
$0 = "$progname (parent)";
$retval = waitpid($childpid,0);
@children -= $childpid;
last if ($retval == -1);
# last if (&WIFSIGNALED($?));
}
# unlock the I/O device
# NOTE: flock must have a device handle to unlock it, so we have to
# close after unlocking
# NOTE: we unset the unlock flag, since we've unlocked it already
&unlock_device($devfh) && ($clean_flags &= (~$clean_flags_unlock));
# close the I/O device
&close_device($devfh) && shift(@closelist);
# close log files
&closelog();
##### End of main code; subroutines follow #####
sub config_read
{ local($file,$entry,$debug) = @_;
local(@data);
warn "config file is $file, entry is $entry\n" if $debug;
open(CONFIG_FILE,$file) || warn "Could not open config file $file: $!\n";
CFILE:
while(<CONFIG_FILE>)
{ # get rid of the newline
chop;
# ignore blank and comment lines in config file
next if (/^[ \t]*(#|)$/);
# convert all occurences of spaces to tabs - ICK!
# s/ +/\t/g;
# squish multiple tabs into one tab
s/\t[ \t]+/\t/g;
warn "Current entry is $_\n" if $debug;
# if we've found the info, break out
if (/^$entry\t/)
{ # assign the tab-divided columns to the data array
@data = split('\t');
warn "data is " . join(':',@data) . "\n" if $debug;
last CFILE;
}
}
# close the fdesc for the config file, to clean up
close(CONFIG_FILE);
# return the found data
@data;
}
# In the configuration routine, we must hold the tty open with a (blocked)
# process. Hence the fork below.
sub configure_device
{ local($device,$stty_baud,$pause_for_open) = @_;
local($childpid);
unless ($childpid=fork())
{ # NOTE: the fork call; must reset the signal handler.
$SIG{'HUP'} = 'DEFAULT';
$0 = "$progname (holding $device open)";
# try to open the port - it won't work, but we'll hold it open so that
# the parent process can run stty on it
# Normally, we would block, but if clocal is set, open will complete
local($ret) = open(TEMP,$device);
warn
"Warning-open exited with value $ret (clocal probably set on $device)\n";
# sleep forever
sleep;
# execution never gets here
exit $ret;
}
push(@children,$childpid);
$0 = "$progname (configuring $device)";
sleep $pause_for_open;
system('stty', '-f', $device, '-parenb', 'cs8', $stty_baud, 'clocal', 'hupcl',
'raw', 'ignbrk', '-brkint', '-istrip', '-inlcr', '-icrnl', '-ixon',
'-ixoff', '-opost', '-isig', '-icanon', '-iexten', '-echo', '-echoe',
'-echok', '-echonl', 'noflsh', 'min', '0', 'time', '5', 'crtscts');
}
sub open_device
{ local($device,$devfh) = @_;
$0 = "$progname (opening $device)";
open($devfh,$device);
}
sub lock_device
{ local($devfh) = @_;
$0 = "$progname (locking device)";
flock($devfh,2);
}
sub finish_opening_device
{ local($device,$devfh) = @_;
$0 = "$progname (opening $device for write)";
open($devfh,"+<$device");
local($childpid) = pop(@children);
# Now that we've opened the device, we can kill off that dumb process
# we started in configure:
kill 'HUP', $childpid;
waitpid($childpid,0);
}
sub finish_configuring_device
{ local($devfh) = @_;
warn "selecting $devfh\n" if $debug;
# This selects devfh's value as the default filehandle,
# makes it unbuffered, and restores default filehandle - sorry :)
select((select($devfh), $| = 1)[$[]);
}
sub main
{ local($phone,$remote_ip_address,$verbose,$debug,$busy_retries,$busy_sleep,
$timeout_char,$chat,$slattach_cmd,$device,$pause_for_network,
$slip_num_file,$slip_name_file,$devfh) = @_;
warn "Signal handler is $SIG{'HUP'}\n" if $debug;
# Here we dial the modem and check for busy, etc.
if (&dial_modem($phone,$modem_init_string,$modem_ok,$modem_success,
$modem_wait,$modem_end_line,$busy_retries,$busy_sleep,
$debug,$timeout_char,$modem_dial_string,$devfh))
{ # configure the device for carrier-mode
# &acquired_carrier($device);
$clean_flags |= $clean_flags_online;
warn "Chat string is $chat\n" if $debug;
# Log on to the remote system and get our ip address.
local($local_ip_address) =
&chat_with_remote($chat,$modem_end_line,$debug,$timeout_char,$devfh);
# Start programs to activate network stuff
&start_network($local_ip_address,$remote_ip_address,$slattach_cmd,
$device,$debug,$slip_num_file,$slip_name_file);
# Watch the line forever and ever and return its retval
&watch_line($local_ip_address);
}
# dialing failed:
else { 0; }
}
# Dial the modem
# returns non-zero if busy_retries > 0 (initially) and dial succeeded
# returns zero if the line has stayed busy
sub dial_modem
{ $0 = "$progname (dialing)";
# params
local($phone,$init_string,$ok,$success,$wait_pattern,$end_line,
$busy_retries,$busy_sleep,$debug,$timeout_char,$dial_string,$devfh)
= @_;
warn "dialing - devfh is $devfh\n" if $debug;
# initialize the modem
&tty_send($init_string,$debug,$devfh);
# wait for acknowledgement
&tty_wait_for($ok,$debug,$timeout_char,$devfh);
# dial until some condition is fulfilled
do { &tty_send($dial_string . $phone . $end_line,$debug,$devfh); }
while ((&tty_wait_pat($wait_pattern,$debug,$timeout_char,$devfh) ne $success)
# NOTE: don't think this is necessary && &hangup_modem($devfh,$debug)
&& ($busy_retries--)
&& (sleep $busy_sleep == $busy_sleep));
$busy_retries;
}
# Send a string over the device
sub tty_send
{ local ($send,$debug,$devfh) = @_;
warn "Sending: $send to $devfh\n" if $debug;
# NOTE: devfh is now unbuffered.
print $devfh $send;
}
# Wait for a string from the device
sub tty_wait_for
{ local($pattern);
local($wait,$debug,$timeout_char,$devfh) = @_;
warn "Waiting for: $wait on $devfh\n" if $debug;
($pattern = $wait) =~ s/(\W)/\\$1/g;
# NOTE: str is a static variable (or global)
while ($str !~ /$pattern/) { $str .= &get_char($timeout_char,$debug,$devfh); }
$str = $';
$&;
}
sub get_char
{ local($timeout_char,$debug,$devfh) = @_;
local($rmask, $nfound, $endtime, $timeleft, $nread, $thisbuf);
warn "getting characters from $devfh\n" if $debug;
$endtime = time + $timeout_char;
$rmask = '';
vec($rmask,fileno($devfh),1) = 1;
($nfound, $timeleft) = select($rmask, undef, undef, $endtime - time);
warn "nfound=$nfound,timeleft=$timeleft,rmask=$rmask\n" if $debug;
# if the number of ready filehandles "found" was not zero
if ($nfound)
{ # NOTE: devfh is unbuffered
# NOTE: !! read() will not work here, only sysread() - :-?
$nread = sysread($devfh, $thisbuf, 1024);
warn "read $nread bytes: \"$thisbuf\"\n" if $debug;
$thisbuf;
# return '' if !$nread; # eof
}
$thisbuf;
}
sub tty_wait_pat
{ local($wait,$debug,$timeout_char,$devfh) = @_;
warn "Waiting for pattern $wait on $devfh\n" if $debug;
while ($str !~ /$wait/)
{ warn "str is \"$str\"\n" if $debug;
$str .= &get_char($timeout_char,$debug,$devfh);
}
# Redundant but necessary for the $&,$' below
$str =~ /$wait/;
warn "Found string \"$&\" in \"$str\"\n" if $debug;
$str = $';
$&;
}
# Set local-mode OFF now that we have carrier.
# TODO: do this, but make sure it's set back on in loop.
# NOTE: this seems contradictory to the idea of having the parent hold
# the modem line open the whole time - after all, why have -clocal if
# you don't intend a hangup to cause a HUP signal?
sub acquired_carrier
{ local($device) = @_;
system('stty', '-f', $device, '-clocal');
}
# log-in to the remote system
sub chat_with_remote
{ $0 = "$progname (chatting)";
local($chat,$end_line,$debug,$timeout_char,$devfh) = @_;
warn "Chat string is $chat\n" if $debug;
# unless the chat string is empty, process it.
unless ($chat eq '')
{ # split the chat string up by vertical bars.
local(@chat) = split('\|', $chat);
local($i) = 0;
# loop through each item
foreach (@chat)
{ warn "Considering item $_, i = $i\n" if $debug;
# allow modem newlines in the chat strings
s/\\r/$end_line/;
if ($i & 1) { &tty_send($_,$debug,$devfh); }
else { &tty_wait_for($_,$debug,$timeout_char,$devfh); }
$i = !$i;
}
}
warn "Looking for IP pattern\n" if $debug;
$_ = &tty_wait_pat('Your (IP |)address is (\d+\.\d+\.\d+\.\d+)\D',
$debug,$timeout_char,$devfh);
/Your (IP |)address is (\d+\.\d+\.\d+\.\d+)\D/;
$addr = $2;
warn "Output was \'$_\', addr is $addr\n" if $debug;
$2;
}
sub start_network
{ $0 = "$progname (starting network)";
local($local_ip_address,$remote_ip_address,$cmd,
$device,$debug,$slip_num_file,$slip_name_file) = @_;
local($childpid,$inet_hostname);
# this madness allows us to interpret variable references in the command
# string at run-time - see "Programming Perl", p217
$_ = $cmd;
s/"/\\"/g;
$cmd = eval qq/"$_"/;
warn "command is $cmd\n" if $debug;
# NOTE: for older NetBSD/386BSD systems, ignore hup and quit signals
# during slattach. You can do this by setting a signal handler and
# exec'ing slattach, I think.
# TODO: slattach forks itself, leaving a zombie :( so why don't you clean
# up this nasty code and do it right.
unless ($childpid=fork()) { exec $cmd; }
warn "slattach pid was $childpid\n" if $debug;
# this is the nasty part
push(@children,($childpid + 1));
# wait for the slattach program to fork
waitpid($childpid,0);
# ifconfig
system ('ifconfig sl0 inet ' . $local_ip_address . ' ' . $remote_ip_address);
$clean_flags |= $clean_flags_ifconfig;
# route
system ('route add default ' . $remote_ip_address);
$clean_flags |= $clean_flags_route;
# TODO: use named if wanted
# put net addresses into files
$inet_hostname = &write_net_addresses($local_ip_address,$slip_num_file,
$slip_name_file,$debug);
# save the old hostname
$old_hostname = `hostname`;
# set the new hostname
system("hostname $inet_hostname");
# call utsetrhost or moral equivalent
system('utsetrhost');
}
# Returns the internet-style name of this system
sub write_net_addresses
{ local($ipaddr,$numfile,$namefile,$debug) = @_;
# Set the umask to make this world-readable
umask(022);
open(SLIPNUM,'>' . $numfile) || warn "Could not open num file $numfile: $!\n";
print SLIPNUM $ipaddr;
close SLIPNUM;
push(@unlink_files,$numfile);
$_ = `nslookup $ipaddr | tail +4 | head -n 1`;
warn "output was \"$_\"\n" if $debug;
/\s(\S+)\s/;
warn "name was \"$1\"\n" if $debug;
open(SLIPNAME,'>' . $namefile)
|| warn "Could not open name file $namefile: $!\n";
print SLIPNAME $1 . "\n";
close SLIPNAME;
push(@unlink_files,$namefile);
$1;
}
# Just sleep forever (for now)
# TODO: add more checks
sub watch_line { $0 = "$progname (watching line)"; sleep; }
sub unlock_device { local($devfh) = @_; flock($devfh,8); }
sub close_device { local($devfh) = @_; close $devfh; }
# NOTE: signal handler is SHARED by parent and child processes!
# Hence, my bending over backwards to maintain the global vars
# NOTE: (TODO) child process never gets sighdl called, prob b/c
# parent sends a TERM and not a HUP.
sub signal_handler
{ local($sig) = @_;
$_ = $sig;
SIGNALS:
{ if (/^HUP$/)
{ # if the parent terminates, HUP will automagically be sent to children
# TODO: this appears to be incorrect - comment out the undef
# c.f. Rochkind, "Advanced Unix Programming"
# undef @children;
exit &clean_exit("Signal SIG$sig caught, shutting down\n")
};
exit &clean_exit("Unknown signal SIG$sig caught, shutting down\n");
}
# Execution never gets here
}
sub clean_exit
{ local($arg) = @_;
local($fh);
$0 = "$progname (cleaning up: $arg)";
warn $arg;
&syslog(WARNING,$arg);
&hangup_modem($devfh,$debug) if ($clean_flags & $clean_flags_online);
# kill any children created by this program (c.f. signal_handler!)
warn "Killing children " . join(' ',@children) . "\n" if $debug;
kill 'HUP', @children;
# don't bother to mask off flags as we take care of them
&unlock_device($devfh) if ($clean_flags & $clean_flags_unlock);
# NOTE: this will remove the gateway route, if any
system("ifconfig $interface delete")
if ($clean_flags & $clean_flags_ifconfig);
# NOTE: since ifconfig delete must always be done if route delete is,
# we don't have to delete the gateway (remote host) route
system("route delete default")
if ($clean_flags & $clean_flags_route);
warn "Unlinking files " . join(' ',@unlink_files) . "\n" if $debug;
unlink @unlink_files;
# restore the old hostname if needed
system("hostname $old_hostname") if (defined($old_hostname));
while ($fh = shift @closelist) { close $fh; }
}
# NOTE: kluge
ub hangup_modem
{ local($devfh,$debug) = @_;
warn "Attempting to hang up\n";
&tty_send('+',$debug,$devfh);
sleep(1);
&tty_send('+',$debug,$devfh);
sleep(1);
&tty_send('+',$debug,$devfh);
sleep(1);
&tty_send($modem_hangup_string,$debug,$devfh);
}
--
Internet is not a medium for self-expression, but rather for self-education.
VaX#n8 vax@ccwf.cc.utexas.edu - Don't believe the hype