[13298] in Perl-Users-Digest
Perl-Users Digest, Issue: 708 Volume: 9
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Fri Sep 3 01:07:41 1999
Date: Thu, 2 Sep 1999 22:05:06 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Thu, 2 Sep 1999 Volume: 9 Number: 708
Today's topics:
Re: CGI DownLoad File on the PC Client (David Efflandt)
Re: CGI question: CGI output being mixed with older out (David Efflandt)
Re: darndest regex thing (elephant)
Re: darndest regex thing (elephant)
Re: darndest regex thing (elephant)
Re: null character kills CGI script on NT (David Efflandt)
Re: Password Protection? (David Efflandt)
Perl/Win32 and current users. <byeoh@p*nix.com>
Re: Q: How to communicate with the serial port? <tchrist@mox.perl.com>
Question about installing modules <lincwils@teleport.com>
R: How to get Widows version? <nando@tetecma.com>
R: Ports <nando@tetecma.com>
Re: shebang question for Win32 Perl/Apache <s3100411@student.anu.edu.au>
Re: sticky undef $/ <admin@futuristic.net>
Digest Administrivia (Last modified: 1 Jul 99) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 3 Sep 1999 03:27:34 GMT
From: efflandt@xnet.com (David Efflandt)
Subject: Re: CGI DownLoad File on the PC Client
Message-Id: <slrn7sug9f.k8.efflandt@efflandt.xnet.com>
On Wed, 1 Sep 1999 13:51:22 -0700, Larry Rosler <lr@hpl.hp.com> wrote:
>In article <37CD5C0D.CB1DCC62@tinet.ie> on Wed, 01 Sep 1999 17:02:05
>+0000, Edouard Ouin <Edouard.Ouin@tinet.ie> says...
>> Is it a way to download a file directly to the client via the "save as"
>> generic window to save a file on the local machine.
>>
>> PS: in perl of course, via CGI if it's possible.
>
>The only reliable way I know of is to send the file with Content-Type
>'application/octet-stream'. Then the client browser will ask the user
>what to do with the file.
That may be reliable with MIME compliant browsers. But it will not work
with MSIE, which ignores most headers and instead relies on filename
extension.
>--
>(Just Another Larry) Rosler
>Hewlett-Packard Laboratories
>http://www.hpl.hp.com/personal/Larry_Rosler/
>lr@hpl.hp.com
--
David Efflandt efflandt@xnet.com http://www.xnet.com/~efflandt/
http://www.de-srv.com/ http://cgi-help.virtualave.net/
------------------------------
Date: 3 Sep 1999 03:46:58 GMT
From: efflandt@xnet.com (David Efflandt)
Subject: Re: CGI question: CGI output being mixed with older output, how to avoid?
Message-Id: <slrn7suhdq.k8.efflandt@efflandt.xnet.com>
On Wed, 1 Sep 1999 00:09:12 -0400, The News <cshannon@mdo.net> wrote:
>Hi,
>
>I just made a script that sends mail to my address from a form.
>
>When I originally made the script, I I wrote it so that the form page, the
>thank you page, and the error page would all be generated by the script.
>The code for each page were kept as here-docs in separate subroutines which
>were called by the main program.
>
>This is what happened:
>
>(1) 2 e-mails, not one, were sent to my address. The first one was
>completely blank, and the second one was the actual message.
>
>(2) The thank you message or the error message would alwas be appended to
>the bottom of the orginial form, which after pressing the submit button was
>cleared of it's values. In short, I had both the submission form and the
>thank you form on the same page!
Not sure where you went wrong in your logic. But I use a single script
all the time to handle the form, sometimes a preview of submitted data and
final e-mail submission and response (using different submit button names
for preview or send). If the data was something that would appear as
html, then the preview would display it as html along with the form with
previous values for editing. The final submission would skip the form and
provide links or buttons back to some place useful.
However, without the ESP module, it is somewhat difficult to troubleshoot
your code without a link to a plain text version of your errant script.
--
David Efflandt efflandt@xnet.com http://www.xnet.com/~efflandt/
http://www.de-srv.com/ http://cgi-help.virtualave.net/
------------------------------
Date: Fri, 3 Sep 1999 13:27:11 +1000
From: elephant@squirrelgroup.com (elephant)
Subject: Re: darndest regex thing
Message-Id: <MPG.1239eb179bfe02ac989cad@news-server>
Jonathan Mayer writes ..
>I'm trying to make a smart parser that tokenizes a string, but treats
>anything between two quotes as a single token. You would think this
>would do the trick:
>
>$_ = qq!first second "the third token" fourth!;
>@a = m/(?:\"(.+?)\")|(\S+)/g;
each time this matches it fills up TWO backreferences .. ie. the first
time it sees \"(.+?)\" OR (\S+) it fills up $1 and $2 .. the second time
it fills up $3 and $4 .. the third $5 and $6 and the fourth $7 and $8
on each match only one of those has a value .. hence the values of the
array
you'd want something like this
#!/usr/bin/perl -w
use strict;
$_ = q(first second "the third token" fourth);
my @x;
while ( /\G"(.+?)"\s*/gc || /\G(\S+)\s*/gc)
{
push @x, $1;
}
print "$_: <$x[$_]>\n" for 0..$#x;
__END__
>Any ideas? Please cc: your response to me in email -- USENET is big and
>scary.
post here - read here
--
jason - elephant@squirrelgroup.com -
------------------------------
Date: Fri, 3 Sep 1999 13:48:01 +1000
From: elephant@squirrelgroup.com (elephant)
Subject: Re: darndest regex thing
Message-Id: <MPG.1239effd3b3091ac989caf@news-server>
Rick Delaney writes ..
>[posted & mailed]
you're too nice
>Jonathan Mayer wrote:
>>
>> $_ = qq!first second "the third token" fourth!;
>> @a = m/(?:\"(.+?)\")|(\S+)/g;
>> for ($i = 0; $i <= $#a; $i++) { print "$i: <$a[$i]>\n"; }
>
>Bob Walton has already explained why you get the output you do. One
>other way to fix it would be to change the second line to
>
> push @a, $+ while m/(?:\"(.+?)\")|(\S+)/g;
thanks for posting this Rick .. I'd never noticed that little $+
--
jason - elephant@squirrelgroup.com -
------------------------------
Date: Fri, 3 Sep 1999 13:45:11 +1000
From: elephant@squirrelgroup.com (elephant)
Subject: Re: darndest regex thing
Message-Id: <MPG.1239ef5635b7c517989cae@news-server>
lt lindley writes ..
>This regexp does much of what you want, but neither your solution
>nor mine are really very good.
>
> @a=m/((?<=").+?(?=")|[^" ]+)/g;
especially not really good for
$_ = q(first second "the third token" fourth fifth "sixth token");
try it .. blergh
--
jason - elephant@squirrelgroup.com -
------------------------------
Date: 3 Sep 1999 04:06:38 GMT
From: efflandt@xnet.com (David Efflandt)
Subject: Re: null character kills CGI script on NT
Message-Id: <slrn7suiim.k8.efflandt@efflandt.xnet.com>
On Thu, 02 Sep 1999, Corey Edwards paranoid_of_spam wrote:
>I have written a CGI script which opens a file, often times an image,
>and prints that data out to the browser. First, I wrote it on UNIX, and
>it worked great. No problems. Then they wanted me to port it to NT, so I
>did. Then comes the problem of null characters in the file. Whenever one
>is reached and I try to print it, the script will die as in:
>open (FILE, "sample.gif");
>while (<FILE>) {
> print;
>}
>#won't get here
>close(FILE);
This could be more simply written
open (FILE, "sample.gif");
binmode FILE; # needed for DOS/Win binary, ignored if not needed
print <FILE>;
#should get here
close FILE;
See 'perldoc binmode', and you should really test the open() and send
proper headers first (I hear that IIS defaults to nph).
--
David Efflandt efflandt@xnet.com http://www.xnet.com/~efflandt/
http://www.de-srv.com/ http://cgi-help.virtualave.net/
------------------------------
Date: 3 Sep 1999 04:33:32 GMT
From: efflandt@xnet.com (David Efflandt)
Subject: Re: Password Protection?
Message-Id: <slrn7suk54.k8.efflandt@efflandt.xnet.com>
On Thu, 2 Sep 1999 18:50:36 -0300, Yellow Beetle <firebrand@mail.usa.com> wrote:
>I would like to make it so you that you can't go to
>index3.html without going to index.html. Unfortunitly I
>don't have a cgi-bin, is there any other way to do it, or
>can I link it to another cgi-bin that I could get for free?
>
>Thank You For Your Help,
>
>Jimmy
>theromroom@hotmail.com
The best way to do this is at the server level using directives in an
.htaccess file. Since tripod appears to be using apache, go to
http://www.apache.org/docs/mod/directives.html and review: AuthType,
AuthName, AuthUserFile, and require. For an example of how to crypt
passwords for the password file see
http://cgi-help.virtualave.net/pub/crypt.cgi (or the script as crypt.txt)
Further questions on this particular method should be directed to the
comp.infosystems.www.servers.unix newsgroup.
--
David Efflandt efflandt@xnet.com http://www.xnet.com/~efflandt/
http://www.de-srv.com/ http://cgi-help.virtualave.net/
------------------------------
Date: Fri, 3 Sep 1999 00:36:02 -0400
From: Brian Yeoh <byeoh@p*nix.com>
Subject: Perl/Win32 and current users.
Message-Id: <Pine.NEB.4.10.9909030019070.26506-100000@panix7.panix.com>
Is there a reliable way to check for users currently logged on to an NT4
network? I'm trying to build a list of all current users logged on by
querying the primary domain controller and all backup domain controllers
using Win32::NetAdmin and Win32::AdminMisc. I'm currently using
Win32::AdminMisc::UserGetMiscAtttributes to collect the USER_LAST_LOGON
and USER_LAST_LOGOFF values, decide if USER_LAST_LOGON is greater than
USER_LAST_LOGOFF and if so, then the user is logged on.
I don't have the actual source with me, since I can't bring it out of work
(and I'm restricted from getting news access in work -- yes, that includes
Deja) but it looks something like this:
use Win32::AdminMisc;
use Win32::NetAdmin
<snip loading of user list into big hash-of-hash-of-hash-of-hash (not a
typo)>
# Get the domain controllers
Win32::NetAdmin::GetDomainController("","",$pdc);
Win32::NetAdmin::GetServerNames("","",SV_TYPE_DOMAIN_BAKCTRL,\@machinelist);
# Check the primary domain controller
foreach $user (sort keys %hash)
{
Win32::AdminMisc::UserGetMiscAttributes($pdc,$user,\%attribs);
$hash{$user}{USERATTRIBUTES}{USER_LAST_LOGON} =
$attribs{USER_LAST_LOGON};
$hash{$user}{USERATTRIBUTES}{USER_LAST_LOGOFF} =
$attribs{USER_LAST_LOGOFF};
}
# Check each backup-domain controller for different values
foreach $machine (@machinelist)
{
foreach $user (sort keys %hash)
{
Win32::AdminMisc::UserGetMiscAttributes($pdc,$user,\%attribs);
if ($hash{$user}{USERATTRIBUTES}{USER_LAST_LOGON} <
$attribs{USER_LAST_LOGON})
{
$hash{$user}{USERATTRIBUTES}{USER_LAST_LOGON} =
$attribs{USER_LAST_LOGON};
}
<repeat for USER_LAST_LOGOFF>
}
}
HashDUMP(%hash); #i.e. print the hash out to a file for perusal.
My problem is that even if certain users logoff, _it's not reflected in
the attributes_. I have one user whose last logoff was in 1998, but whose
last logon was today! Is this an NT "feature" I'm not aware of?
Oh, for a good, free implementation of _who_...
Please respond at brianyeoh@h*tm*il.com. The filter is pretty obvious. I
hate to ask this, but I simply can't keep up (though I try). Thanks.
Clear, unscaleable, ahead |
Rise the Mountains of Instead | -- WH Auden, "Autumn Song"
From whose cold cascading streams |
None may drink except in dreams. |
------------------------------
Date: 2 Sep 1999 21:14:30 -0700
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: Q: How to communicate with the serial port?
Message-Id: <37cf3d16@cs.colorado.edu>
[courtesy cc of this posting mailed to cited author]
In comp.lang.perl.misc,
"Marcus Hudritsch" <mhudritsch@processlink.ch> writes:
:How can I communicate with the serail port ?
:If possible in a platform independent way.
This was for Linux, but since we all know that "platform independent"
means "runs on both BSD and Linux", this should be ok. :-)
--tom
#!/usr/bin/perl -w
use strict;
use Carp;
# GLOBALS for this program
use vars qw{
$PING_COUNT
$PING_INTERVAL
$PING_TIMEOUT
$PING_SLEEP
$KILL_TIMEOUT
$START_RETRY_MAX
$START_RETRY_INITIAL
$DIAL_SLEEP_MAX
$DIAL_TIMEOUT
$REQUIRED_PING_PERCENTAGE
$DIAL_SLEEP_INITIAL
$DTR_DROP
$PID_FILE
$LOCK_PREFIX
%SUPRA_ERRORS
$PROGNAME
$verbose
$debug
$no_daemon
$state
$am_supra
$use_modules
$PID_FILE
$LCK_PREFIX
};
$PROGNAME = $0;
# i don't like these globals
use vars qw{
$timeout
$str
$start_retry_current
$have_started
$forked
$known_alive
$tty
};
# GLOBALS from /etc/keepalive.conf
use vars qw{
$PHONE
$ACCOUNT
$PASSWORD
$LOCAL
$REMOTE
$NETMASK
$MTU
$DEVICE
$RATE
$MODE
};
# Configuration defaults; in seconds
$PING_COUNT = 10; # How many ping packets to send
$PING_INTERVAL = 1; # How frequently should we send a new packet
# How long is too long to have had no response; ping will wait for 10 seconds
# after it sends out its last packet. We'll give it 50 extra beyond that,
# because for some reason it seems to require this. ping takes a non-deterministic
# time to timeout!! this is a bug.
$PING_TIMEOUT = 60 + ($PING_COUNT * (1+$PING_INTERVAL));
$PING_SLEEP = 60; # How long should we sleep between bings
$REQUIRED_PING_PERCENTAGE = 20; # should be 90?
$KILL_TIMEOUT = 5; # How long should kill_pid wait before using
# the next signal
$START_RETRY_MAX = 600; # Maximum time for exponential backoff for
# establishing the SLIP connection.
$START_RETRY_INITIAL = 15; # Starting value for same.
$DIAL_SLEEP_MAX = 600; # Maximum time for exponential backoff
# for dialing in.
$DIAL_TIMEOUT = 60;
$DIAL_SLEEP_INITIAL = 15; # Initial value for same
$DTR_DROP = 2; # How long to drop DTR for to get modem
# $verbose = "";
$verbose = 1;
# $debug = "";
$debug = 1;
$no_daemon = 1;
# $have_started = "";
$str = "";
$| = 1;
#require 'syscall.ph';
#require 'sys/file.ph';
#require 'termios.ph';
use FileHandle;
use Fcntl;
sub TIOCEXCL() { 0x540C }
$SIG{ALRM} = 'DEFAULT';
# Various 'constants'
$PID_FILE = '/var/run/keepalive.pid';
$LCK_PREFIX = '/var/spool/uucp/LCK..'; # Lock file prefix
# S86 error codes for SUPRA (and presumably other Rockwell chipset
# based modmes)
%SUPRA_ERRORS = (
0 => 'Normal hangup initiated by local',
4 => 'Carrier loss',
5 => 'No error correction at other end',
6 => 'No response to feature negotiation',
7 => 'This modem is ASYNC only, other is SYNC',
8 => 'No framing technique in common',
9 => 'No protocol in common',
10 => 'Bad response to feature negotiation',
11 => 'No sync information from remote',
12 => 'Normal hangup initiated by remote',
13 => 'Retransmission limit reached',
14 => 'Protocol violation occured'
);
# Globals
use vars qw(%have_lck $ping_pid %added_modules);
%have_lck = ();
$ping_pid = 0;
%added_modules = ();
# FUNCTIONS
sub configure_serial($$);
sub debug($);
sub fatal_signal($);
sub get_char();
sub get_error($);
sub get_lck($);
sub get_pid;
sub have_module($);
sub is_reachable($);
sub kill_pid($);
sub logger($);
sub mysleep($);
sub pass_lck($$);
sub pass_pid($);
sub release_lck($);
sub release_pid();
sub remove_modules(@);
sub require_modules(@);
sub send_modem($);
sub set_state($);
sub start_slip($$$$$$$$);
sub stop_slip();
sub timeout_handler($);
sub wait_for($);
sub wait_pat($);
#logger($message) - loggers $message as coming from $serivce. Returns
#-1 on failure, 0 on success.
# TESTED
sub logger($) {
my($message) = @_;
print STDERR localtime() . " LOG: " . $message . "\n";
open(LOG, "|/usr/bin/logger -t $0") || return -1;
print LOG $message;
close(LOG);
return 0;
}
sub set_state($) {
$state = shift;
$0 = "$PROGNAME [$state]";
# print STDERR "[STATE => $state]\n" if $verbose;
}
sub debug($) {
if ($debug) {
my $msg = shift;
$msg .= "\n" unless $msg =~ /\n$/;
print STDERR localtime() . " DEBUG: " . $msg;
}
}
sub verbose($) {
if ($verbose) {
my $msg = shift;
$msg .= "\n" unless $msg =~ /\n$/;
print STDERR $msg;
}
}
sub mysleep($) {
my $sex = shift;
# debug("sleeping $sex");
unless($SIG{ALRM} eq 'DEFAULT') {
confess("SLEEPING WHILE AWAITING ALARM $SIG{ALRM}");
}
sleep($sex);
}
sub vsystem($) {
verbose($debug && "SYSTEM " . "@_") if $verbose;
return system(@_);
}
# Handle fatal signal by doing clean shutdown
# TESTED
sub fatal_signal($) {
logger("got SIG$_[0]");
logger("killing $ping_pid") if ($debug && $ping_pid);
kill_pid($ping_pid) if ($ping_pid);
logger("removing modules") if ($debug);
remove_modules(keys %added_modules);
release_lck($DEVICE);
release_pid();
exit;
}
# Handle timeout on ping(ALRM) by killing PING process. Pending read in
# while (<PING>) should return -1 errno = EPIPE causing that loop to terminate.
sub timeout_handler($) {
logger("TIMEOUT");
kill_pid($ping_pid) if $ping_pid;
}
# Kill process using increasingly insistant signals.
# kill_pid($pid) returns undef on failure; non-zero on success.
# TESTED
sub kill_pid($) {
my($pid) = @_;
local $timeout;
my $signal;
logger("Attempting to kill $pid");
if ($$ == $pid) {
logger("I'm $$; committing suicide\n");
return 0;
} elsif ($pid < 0) {
logger("I'm $$; trying to kill process group $pid\n");
return 0;
} elsif ($pid == 0) {
logger("I'm $$; trying to kill all my processes\n");
return 0;
}
ZAP: foreach $signal ( qw(TERM INT HUP KILL) ) {
logger("zapping $pid with $signal");
kill($signal, $pid);
my $time = time();
for ($timeout = $KILL_TIMEOUT; $timeout > 0; --$timeout) {
kill(0, $pid) || last ZAP;
###########################################
### sleep(1); CANNOT SLEEP IN HANDLER ###
###########################################
1 until time() > (1 + $time);
}
}
logger("zapped $pid");
return kill(0, $pid);
}
sub is_reachable($) {
my($host) = @_;
set_state("pinging $host");
my $ret = 0;
# need the exec because the 2> causes a shell to get in the way of the ping pid!
# print STDERR "ping -i $PING_INTERVAL -c $PING_COUNT $host\n" if $debug;
$ping_pid =
open(PING, "exec ping -i $PING_INTERVAL -c $PING_COUNT $host 2>&1 |");
unless (defined $ping_pid) {
logger("can not fork ping");
} else {
local $_;
local $SIG{ALRM} = \&timeout_handler;
# debug("alarm $PING_TIMEOUT");
alarm($PING_TIMEOUT);
while (<PING>) {
# debug("PING LINE: $_");
if (/(\d+) packets transmitted, (\d+)/) {
my $percent = sprintf "%d", 100 * ($2/$1) + 0.001;
if ($percent != 100) {
my $time = localtime;
verbose("$time: PINGED $percent% of $PING_COUNT packets");
}
if ($percent < $REQUIRED_PING_PERCENTAGE) {
logger("only pinged $percent (want $REQUIRED_PING_PERCENTAGE)");
$ret = 0;
} else {
$ret = 1;
}
last;
} elsif (/Network is unreachable/) {
logger("Network down");
$ret = 0;
last;
}
}
kill(9, $ping_pid);
alarm(0);
# debug("alarm CLEARED");
close(PING);
$ping_pid = 0;
}
set_state("running slip");
return $ret;
}
# get_lck(device) gets the lock file for device, returning 0 on success,
# -1 on failure. Note that $have_lck{$device} will be modified on
# success.
# TESTED
sub get_lck($) {
my($device) = @_;
my($lck, $file, $pid, $is_stale);
$file = $LCK_PREFIX.$device;
# FIXME : should probably do something to avoid an infinite loop here
while (1) {
if (defined sysopen(LCK, $file, O_CREAT|O_WRONLY|O_EXCL, 0644)){
# To start with, we will set it up so that the current process
# owns the lock file. When we fork, we'll reopen the lock
# file and write the child's PID into it.
$pid = pack('L', $$);
# FIXME - should be atomic here w.r.t signals
print LCK $pid;
$have_lck{$device} = 1;
close(LCK);
return 0;
# FIXME - we should look at errno here too; and see WHY the open
# failed. EEXIST is OK; EPERM, etc. would be bad.
} elsif (open(LCK, "<$file")) {
$pid = '';
if (sysread(LCK, $pid, 4) == 4) {
$pid = unpack('L', $pid);
kill(0, $pid) || ($is_stale = 1);
} else {
$is_stale = 1;
}
if ($is_stale) {
logger("removing stale lock file $file");
if (!unlink($file)) {
logger("can not remove stale lock file $file $!");
return -1;
}
} else {
logger("lockfile $file owned by process $pid exists");
return -1;
}
}
}
}
# pass_lck ($device, $newpid) changes ownership of the lock file; ie when
# we have a daemon which forks and the child should inherit the file. Returns
# 0 on success, -1 on error.
sub pass_lck($$) {
my($device, $newpid) = @_;
my($file) = $LCK_PREFIX.$device;
$newpid = pack('L', $newpid);
open(LCK, ">$file") || return -1;
print LCK $newpid;
close(LCK);
return 0;
}
# release_lck(device) releases the lock file for the named file.
sub release_lck($) {
my($device) = @_;
my($lock_file);
if($have_lck{$device}) {
$lock_file = $LCK_PREFIX.$device;
unlink $lock_file;
$have_lck{$device} = 0;
}
}
sub get_pid {
}
sub pass_pid($) {
my($newpid) = @_;
open(PID, ">$PID_FILE") || return -1;
print PID "$newpid\n";
close(PID);
return 0;
}
sub release_pid() {
unlink $PID_FILE;
}
# have_module($module) returns non-zero if we have the module
# TESTED
sub have_module($) {
my($search_for) = @_;
my($have_it) = 0;
open(MODULES, "</proc/modules") ||
die "$0 can't open /proc/modules : $!\n";
$have_it = -1;
while(<MODULES>) {
if(/^$search_for/) {
$have_it = 0;
last;
}
}
close(MODULES);
return $have_it;
}
# nuke_modules(@modules) removes the named modules, returning a
# list of the modules we could not remove. The global variable added_modules
# is updated to reflect the modules currently loaded.
sub remove_modules(@) {
my($module, @failures);
foreach $module (@_) {
vsystem("/sbin/rmmod $module");
if (have_module($module) == -1) {
push(@failures, $module);
} else {
delete $added_modules{$module};
}
}
return sort @failures;
}
# require_modules(@modules) adds the named modules, returning -1 on failure,
# 0 on success. The global variable added_modules is updated to reflect the
# modules currently loaded.
sub require_modules(@) {
my($module);
foreach $module (@_) {
if(have_module($module) == -1) {
vsystem("/sbin/modprobe $module");
if (have_module($module) != -1) {
$added_modules{$module} = 1;
} else {
return -1;
}
}
}
return 0;
}
# configure_serial($device, $bps) configures the named device in a manner
# compatable with a SLIP connection (rts/cts flow control, no soft flow,
# 8 data bits, no parity) at the selceted data rate. Returns -1 on failure,
# 0 on success.
sub configure_serial($$) {
my($device, $bps) = @_;
vsystem("/bin/stty raw -echo -echonl cs8 -clocal crtscts $bps < /dev/$device") == 0;
#vsystem("/bin/stty raw -echo -echonl cs8 -clocal crtscts < /dev/$device") == 0;
}
# start_slip($device, $phone, $account, $password, $local,
# $remote, $netmask, $mtu). Returns undef on failure, MODEM on success.
sub start_slip($$$$$$$$) {
my($device, $phone, $account, $password, $local, $remote,
$netmask, $mtu) = @_;
set_state('initial');
local($timeout);
my($redial_timeout) = $DIAL_SLEEP_INITIAL;
my(%initial) = (
'TIMEOUT' => 'reset',
'OK' => 'dial',
'ERROR' => 'reset',
);
$initial{'regex'} = join('|', keys(%initial));
my(%dial) = (
'CONNECT' => 'connect',
'NO CARRIER' => 'disconnect',
'NO ANSWER' => 'redial',
'NO DIAL TONE' => 'redial',
'NO DIALTONE' => 'redial',
'BUSY' => 'redial',
'OK' => 'dial',
'ERROR' => 'reset',
'TIMEOUT' => 'reset',
);
$dial{'regex'} = join('|', keys(%dial));
my(%connect) = (
'login:' => 'login',
'NO CARRIER' => 'disconnect',
'ERROR' => 'reset',
'TIMEOUT' => 'reset',
);
$connect{'regex'} = join('|', keys(%connect));
my(%login) = (
'Password:' => 'password',
'NO CARRIER' => 'disconnect',
'ERROR' => 'reset',
'TIMEOUT' => 'reset',
);
$login{'regex'} = join('|', keys(%login));
my(%password) = (
'SL/IP session' => 'slip',
'Packet mode enabled' => 'slip',
'NO CARRIER' => 'disconnect',
'ERROR' => 'reset',
'TIMEOUT' => 'reset',
);
$password{'regex'} = join('|', keys(%password));
my(%disconnect) = (
'^\d+' => 'got_answer',
'ERROR' => 'reset',
'TIMEOUT' => 'reset',
);
$disconnect{'regex'} = join('|', keys(%disconnect));
while (1) {
if ($state eq 'initial') {
$timeout = 10;
open(STDOUT, "+>/dev/$device") || do {
logger("cannot open /dev/$device : $!");
die ;
return undef;
};
$| = 1;
unless (open(STDIN, "+<&STDOUT")) {
logger("cannot DUP $tty STDOUT to STDIN : $!");
die;
# NOT REACHED
return undef;
}
send_modem("atz\r");
set_state ( $initial{ wait_pat("($initial{'regex'})") } );
}
if ($state eq 'dial') {
$timeout = $DIAL_TIMEOUT;
send_modem("atdt$phone\r");
set_state ( $dial{wait_pat("($dial{'regex'})")} );
}
if ($state eq 'redial') {
$redial_timeout *= 2 if ($redial_timeout < $DIAL_SLEEP_MAX);
mysleep($redial_timeout);
set_state ('dial');
}
if ($state eq 'connect') {
$redial_timeout = $DIAL_SLEEP_INITIAL;
$timeout = 10;
set_state ($connect{wait_pat("($connect{'regex'})")} );
}
if ($state eq 'login') {
$timeout = 10;
send_modem ("$account\n");
set_state( $login{wait_pat("($login{'regex'})")} );
}
if ($state eq 'password') {
$timeout = 10;
send_modem("$password\n");
set_state($password{wait_pat("($password{'regex'})")});
}
if ($state eq 'slip') {
vsystem("/sbin/slattach -e -p cslip /dev/$device");
#vsystem("/sbin/ifconfig sl0 pointopoint $remote mtu $mtu $local");
vsystem("/sbin/ifconfig sl0 mtu $mtu $local");
#vsystem("/sbin/route add -host $remote gw $local dev sl0");
vsystem("/sbin/route add -net default sl0");
last;
}
if ($state eq 'disconnect') {
if (defined $am_supra)
{
$timeout = 10;
send_modem("ats86?\r");
my $answer = wait_pat("($disconnect{'regex'})");
if ($answer =~ /\d+/) {
set_state('got_answer');
} else {
set_state($disconnect{$answer});
}
}
else
{
set_state('dial');
}
}
if ($state eq 'got_answer') {
logger('connection failed: $SUPRA_ERRORS{$answer+0}');
set_state('dial');
}
if ($state eq 'reset') {#
slip_close();
set_state('initial');
}
}
return "MODEM";
}
sub wait_for($) {
my($pattern) = @_;
debug("WAITING FOR STRING:\n\t$pattern\n");
while (1) {
if ($str =~ /\Q$pattern\E/) {
$str = $';
return $&;
}
return 'TIMEOUT' unless defined get_char();
}
}
sub wait_pat($) {
my($pattern) = @_;
debug("WAITING FOR PATTERN:\n\t$pattern\n");
while (1) {
if ($str =~ /$pattern/) {
debug("GOT PATTERN $1");
$str = $';
return $&;
}
get_char();
}
}
sub get_char() {
my($rmask, $nfound, $timeleft, $thisbuf, $endtime);
$endtime = time + $timeout;
$rmask = "";
vec($rmask,fileno(STDIN),1) = 1;
($nfound, $timeleft) = select($rmask, undef, undef, $endtime - time);
if ((0 + $endtime - time) <= 0) {
return undef;
}
if ($nfound) {
my $nread = sysread(STDIN, $thisbuf, 1024);
if (defined($nread)) {
print STDERR $thisbuf if $debug;
$str .= $thisbuf;
return "" if $nread == 0; # eof
}
} else {
return undef; # timeout ?
}
}
sub send_modem($) {
my $string = $_[0];
debug("SENDING MODEM: \n\t$string\n\n");
print $string;
}
sub stop_slip() {
close (STDIN);
close(STDOUT);
mysleep($DTR_DROP);
}
sub get_error($) {
my($device) = @_;
my($match, $char);
local $timeout;
stop_slip();
$tty = "/dev/$device";
open (STDOUT, "+>$tty") || do {
logger("cannot open $tty: $!");
die ;
return undef;
};
$| = 1;
open(STDIN, "+<&STDOUT") || do {
logger("cannot DUP STDOUT to STDIN : $!");
die ;
return undef;
};
mysleep(1);
$timeout = 1;
send_modem("ats86?\r");
$match = wait_pat('(ERROR|TIMEOUT|^\d+)');
stop_slip();
return($match =~ /\d+/) ? $SUPRA_ERRORS{$match+0} : 'Unknown reason';
}
# main program
do '/etc/keepalive.conf' || do {
logger('can not source /etc/keepalive.conf');
exit 1;
};
{
my $sig;
foreach $sig (qw/INT HUP TERM/) {
$SIG{$sig} = \&fatal_signal;
}
}
if (get_lck($DEVICE) == -1) {
logger('can not get lock; aborting');
exit 1;
}
if (defined $use_modules)
{
if (require_modules('slhc', 'slip') == -1) {
logger ('can not install slhc and slip kernel modules; aborting');
remove_modules(keys %added_modules);
exit 1;
}
}
if (configure_serial($DEVICE, $RATE) == -1) {
logger("can not configure $DEVICE; aborting");
remove_modules(keys %added_modules);
exit 1;
}
$start_retry_current = $START_RETRY_INITIAL;
$have_started = 0;
$forked = 0;
$known_alive = 0;
while (1) {
if (!$have_started || (is_reachable($REMOTE) == 0)) {
if ($have_started) {
my $terminated = get_error($DEVICE);
logger("slip connection died at ".localtime()."$terminated");
stop_slip();
$known_alive = 0;
}
for ($start_retry_current = $START_RETRY_INITIAL;
!defined(start_slip($DEVICE, $PHONE, $ACCOUNT,
$PASSWORD, $LOCAL, $REMOTE,
$NETMASK, $MTU));
# VOID continue clause
)
{
$start_retry_current *= 2
if ($start_retry_current < $START_RETRY_MAX);
}
debug("started slip");
$have_started = 1;
next;
}
if (! $known_alive) {
logger("$REMOTE is alive, will send $PING_COUNT $PING_INTERVAL-second pings every $PING_SLEEP seconds");
$known_alive = 1;
}
if (!$no_daemon && !$forked++) {
logger("Can't ioctl(TIOCEXCL) on STDOUT: $!")
unless ioctl(STDOUT, &TIOCEXCL, 0);
my $child_pid;
unless (defined ($child_pid = fork)) {
logger('can not fork; aborting');
exit 1;
} elsif ($child_pid) {
if (pass_lck($DEVICE, $child_pid) == -1) {
logger("can not pass lock for $tty to pid $child_pid");
exit 1;
}
logger("now in daemon mode, pid is $child_pid");
exit 0;
}
}
mysleep($PING_SLEEP);
}
--
The use of COBOL criples the mind; its teaching should, therefore, be
regarded as a criminal offense. -- E. W. Dijkstra
------------------------------
Date: Thu, 2 Sep 1999 20:33:31 -0700
From: "Dennis Wilson" <lincwils@teleport.com>
Subject: Question about installing modules
Message-Id: <DpHz3.23004$FG4.1002315@news1.teleport.com>
I have a question about using ppm. I am not sure if this is the right forum,
or should I be asking the question of activestate.
I used ppm to install Mail::POP3Client. It seemed like everything went
alright until I tried to run the perl script I had written. I got the
following message:
Can't locate MD5.pm in @INC (@INC contains: C:/Perl/lib C:/Perl/site/lib .)
at C
:/Perl/site/lib/Mail/POP3Client.pm line 357. <GEN0> chunk 1.
I obviously did not either run ppm correctly or I don't understand what
other things I need to install to get this to work.
Any help would be appreciate.
Thanks
------------------------------
Date: Fri, 3 Sep 1999 04:34:23 +0200
From: "Nando" <nando@tetecma.com>
Subject: R: How to get Widows version?
Message-Id: <erGz3.17634$6C.58780@typhoon.libero.it>
<tsackett@iname.com> wrote in message 7qmq8k$5qc$1@nnrp1.deja.com...
> Is there some way that my perl script can find out which version of
> windows it's running on?
>
> I have a script that runs on Win 95, 98, NT4, and Windows 2000
> (pre-release). Among other things, it copies folders using xcopy. Win
> 95, 98 and Windows 2000 require that I use xcopy with the "/y" switch,
> so that it will suppress any "file already exists" messages. However,
> not only does NT4 not require this switch, it chokes on it, refusing to
> execute xcopy.
>
I would use File::Copy, or ExtUtils::Command (used by makemaker).
Perl modules have the advantage to be either machine independent by using
built-in functions, or they handle all the fuzz themselves.
--
Fernando
------------------------------
Date: Fri, 3 Sep 1999 05:07:30 +0200
From: "Nando" <nando@tetecma.com>
Subject: R: Ports
Message-Id: <hWGz3.17641$6C.58810@typhoon.libero.it>
Jay Elliott <jelliott@baymedical.org> wrote in message
7qmnd8$gu3$1@isrv1.hbocvan.com...
> All,
>
> I am new to perl and I use HP 10.20. My objective is to write a perl
program
> that will send unix files to a pc's ip address and port. Once it gets
there
> it will automatically be printed out. I'm only concerned with getting the
> files over to that port because the pc is setup to be a printer. Does
anyone
> have any programming suggestions or script examples using perl, csh, or
ksh
> for this scenario?
>
> Thanks,
> Jay
>
The easiest way is to use Net::Telnet module. Despite its name, it allows
you to 'talk' to any port even disabling telnet capabilities.
For example (not working as it is):
#!/usr/local/bin/perl
use Net::Telnet;
my $prn = new Net::Telnet;
$prn->open(Host => 'myprinterhost', Port => 33 , Timeout => 30);
open(FILE, '/etc/hosts') || die "Cannot open file.\n";
while(<FILE>) {
$prn->print($_);
}
$prn->close();
close(FILE);
You figure out the rest......
--
Fernando
------------------------------
Date: Fri, 03 Sep 1999 13:13:15 +1000
From: M van Oosterhout <s3100411@student.anu.edu.au>
To: "Allan M. Due" <Allan@due.net>
Subject: Re: shebang question for Win32 Perl/Apache
Message-Id: <37CF3CCB.1632@student.anu.edu.au>
Allan M. Due wrote:
>
> As you note, neither Perl nor Apache care about the
> direction of your slashes...
FYI, DOS didn't care either, I used it extensively.
It wouldn't suprise me if that 'not caring' was not
even a special case but simply worked because Windows
understands it.
Martijn van Oosterhout
Australia
------------------------------
Date: Fri, 3 Sep 1999 00:37:05 -0400
From: "James A Culp III" <admin@futuristic.net>
Subject: Re: sticky undef $/
Message-Id: <7qnj11$rps$1@ffx2nh3.news.uu.net>
Radu Greab <radu@netsoft.ro> wrote in message
news:m3g10xdrne.fsf@busy.netsoft.ro...
: "James A Culp III" <admin@futuristic.net> writes:
:
: > Eric Smith <eric@fruitcom.com> wrote in message
: > news:slrn7ssjqg.k25.eric@plum.fruitcom.com...
: > :
: > : Hi
: > :
: > : I have a for loop that nest two file reads thus:
: > :
: > : #!/usr/bin/perl -w
: >
: > use strict; ## should probably be here I came up with a few errors
: > which i will try to correct in my comments for you but i might miss
one
: > or 2.
: >
: > : for $var(1..3){
: > ^
: > my
: > :
: > : open ONE, "/home/eric/fill";
: > : while (<ONE>) {
: > : undef $/;
: >
: > local $/ = undef; ### this will only undef $/; within
this
: > block I think that's what you want.
: >
: > : print "This is a line $_";
: > : }
: > : close ONE;
: > :
:
: Pointless to use local in this case. Reading from the file happens
: outside the scope of that local, so $/ will not be undefined but will
: have the original value...
:
Thank you for correcting that I wouldn't have realized my mistake until
I came across the same situation again. My apologies to Eric for the
misinformation also.
--
James A Culp III
Famous last words... "NT is just as stable as Linux"
------------------------------
Date: 1 Jul 99 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 1 Jul 99)
Message-Id: <null>
Administrivia:
The Perl-Users Digest is a retransmission of the USENET newsgroup
comp.lang.perl.misc. For subscription or unsubscription requests, send
the single line:
subscribe perl-users
or:
unsubscribe perl-users
to almanac@ruby.oce.orst.edu.
To submit articles to comp.lang.perl.misc (and this Digest), send your
article to perl-users@ruby.oce.orst.edu.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
To request back copies (available for a week or so), send your request
to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
where x is the volume number and y is the issue number.
The Meta-FAQ, an article containing information about the FAQ, is
available by requesting "send perl-users meta-faq" from
almanac@ruby.oce.orst.edu. The real FAQ, as it appeared last in the
newsgroup, can be retrieved with the request "send perl-users FAQ" from
almanac@ruby.oce.orst.edu. Due to their sizes, neither the Meta-FAQ nor
the FAQ are included in the digest.
The "mini-FAQ", which is an updated version of the Meta-FAQ, is
available by requesting "send perl-users mini-faq" from
almanac@ruby.oce.orst.edu.
For other requests pertaining to the digest, send mail to
perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
sending perl questions to the -request address, I don't have time to
answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V9 Issue 708
*************************************
