[9123] in Perl-Users-Digest
Perl-Users Digest, Issue: 2742 Volume: 8
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Wed May 27 21:07:28 1998
Date: Wed, 27 May 98 18:01:34 -0700
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Wed, 27 May 1998 Volume: 8 Number: 2742
Today's topics:
Re: Listening to a modem..... (Bbirthisel)
Re: Listening to a modem..... <tatters@planet.net>
Re: Listening to a modem..... <tchrist@mox.perl.com>
Re: perl's idea of version numbers (Kevin Reid)
Re: Please help with silly problem... (Martien Verbruggen)
Re: read and write <zenin@bawdycaste.org>
Re: read and write (Martien Verbruggen)
Re: Sensing whether a script is already running... (Jonathan Stowe)
Re: Special Variables (Tad McClellan)
Re: Substitute gurus... got a better word wrap? <zenin@bawdycaste.org>
Re: Substitute gurus... got a better word wrap? (Martien Verbruggen)
Re: Why do I see the source?? <abaugher@rnet.com>
Digest Administrivia (Last modified: 8 Mar 97) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 27 May 1998 23:20:21 GMT
From: bbirthisel@aol.com (Bbirthisel)
Subject: Re: Listening to a modem.....
Message-Id: <1998052723202100.TAA10658@ladder01.news.aol.com>
Hi Tom:
>Have you seen what the FAQ has to say about using serial ports? Hope this
>helps!
This is one of the areas where the FAQ for Win32 has not kept up to date.
The method suggested is known to have reliability problems on NT and
not work at all on Win95. It is a frequent topic on Perl-Win32-Users.
It would be very nice if someone took on the Win32 FAQ to bring it up to
date (the current version is from January, 1997). It is a wonderful source for
what it DOES cover.
-bill
Making computers work in Manufacturing for over 25 years (inquiries welcome)
------------------------------
Date: Wed, 27 May 1998 18:50:59 -0400
From: Derek Tattersall <tatters@planet.net>
Subject: Re: Listening to a modem.....
Message-Id: <356C98D3.1E71221@planet.net>
Tom Phoenix wrote:
> On Wed, 27 May 1998, Stuart Grimshaw wrote:
>
> > I'm having trouble getting Perl to have a conversation with my modem...
>
> Have you seen what the FAQ has to say about using serial ports? Hope this
> helps!
>
> --
> Tom Phoenix Perl Training and Hacking Esperanto
> Randal Schwartz Case: http://www.rahul.net/jeffrey/ovs/
Actually, no I haven't. I am not the original poster, but I have a similar
problem. I want to use
the serial port, and I haven't been able to figure out how to set the serial
port parameters. I was looking at the faq, and I didn't see anything about
serial port programming. How do you do it?
--
Derek Tattersall
tatters@planet.net
tatters@lucent.com
------------------------------
Date: 28 May 1998 00:16:13 GMT
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: Listening to a modem.....
Message-Id: <6kiacd$b4j$2@csnews.cs.colorado.edu>
[courtesy cc of this posting sent to cited author via email]
In comp.lang.perl.misc,
Derek Tattersall <tatters@planet.net> writes:
:Actually, no I haven't. I am not the original poster, but I have a similar
:problem. I want to use
:the serial port, and I haven't been able to figure out how to set the serial
:port parameters. I was looking at the faq, and I didn't see anything about
:serial port programming. How do you do it?
Just open the file. You'll use the same ioctls as with C.
I have a demo program, but first, here's its /etc/keepalive.conf
file, with private bits occluded:
$PHONE = '###-####';
$ACCOUNT = 'LoginID';
$PASSWORD = 'ZYXXY';
$LOCAL = '###.###.###.###';
$REMOTE = '###.###.###.###';
$NETMASK = '255.255.255.0';
$MTU = 296;
$DEVICE = 'cua1';
$RATE = 115200;
$MODE = 'adaptive'
So here's a program that you might find interesting. Or maybe not.
No, it won't be in the book. It's too long.
--tom
#!/usr/bin/perl -w
# keepalive
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 = 40; # 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;
}
# 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);
}
--
Mark the differences, moreover,
Between mover, cover, clover;
------------------------------
Date: Wed, 27 May 1998 19:11:18 -0400
From: kpreid@ibm.net (Kevin Reid)
Subject: Re: perl's idea of version numbers
Message-Id: <1d9p4lg.qp8ugn1nyxy1aN@slip-32-100-246-16.ny.us.ibm.net>
Martin Gregory <mgregory@asc.sps.mot.com> wrote:
> I found this message suprising:
>
> rtmx version 1.3 required--this is only version 1.24 at
> /home/eda/app/share/bin/rtmx line 373.
>
> Is perl reading "1.24" as "version 1.2.4". I read it as "one - twenty four".
>
> Any comments? Is this a bug?
The Exporter module does a numeric comparison by default.
1.24 == 124 / 100;
1.3 == 130 / 100;
1.3 == 1.30;
1.30 > 1.24;
--
Kevin Reid. | Macintosh.
"I'm me." | Think different.
------------------------------
Date: 27 May 1998 23:18:19 GMT
From: mgjv@comdyn.com.au (Martien Verbruggen)
Subject: Re: Please help with silly problem...
Message-Id: <6ki6vr$p6r$6@comdyn.comdyn.com.au>
Please read the following information on how to choose a good subject
line:
http://www.perl.com/CPAN/authors/Dean_Roehrich/subjects.post
In article <356BE2A6.3021@calabama.com>,
tim@calabama.com writes:
> When I call this script from the command line a file is creatd if it
> does not already exist. It also seems to append an existing file.
>
>
> If I call the script from a browser , it does not respond the same way.
> a file is NOT creatd if it does not exist already . It also seems to NOT
> append an existing file.
First of all: You do not call a script 'from a browser'. The script
runs as a CGI application on your web server. You should try to be
precise in what you say, so that what you think will be just as
precise. Programming is about accuracy as well.
The following documentation most likely has the answer to your
question:
Perl CGI FAQ and (no offense) Idiot's guide:
http://www.perl.com/CPAN/doc/FAQs/cgi/idiots-guide.html
http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html
Section 9 of the perl FAQ:
# perldoc perlfaq9
Martien
--
Martien Verbruggen |
Webmaster www.tradingpost.com.au | 75% of the people make up 3/4 of the
Commercial Dynamics Pty. Ltd. | population.
NSW, Australia |
------------------------------
Date: 27 May 1998 23:06:51 GMT
From: Zenin <zenin@bawdycaste.org>
Subject: Re: read and write
Message-Id: <896310847.244187@thrush.omix.com>
tw96 <tw96@email.msn.com> wrote:
: hello, everybody!
: i met a problem.
: when i use :
: open(FILE,"+>".filename);
^^
Translated to the C open(), that's using the flags:
O_RDWR|O_CREAT|O_TRUNC
Notice that last one, truncate. It will truncate your
file to 0 bytes at each open that you do this.
ALWAYS test your open()'s btw...always.
: $a = <FILE>;
This is null, because since the file has been truncated in the
last call to 0 bytes, you're at the EOF, and therefor a scalar
diamond read ($var = <HANLD>) will return undef.
: print $a,"\n";
We're undef here.
: $a++;
You're treating it like a number, which it's not so Perl will
promote it to a number. Since it's null, it becomes null's equal,
0. 0 + 1 == 1, therefor $a == 1.
: print FILE $a,"\n";
And now we are at $a == 1.
You probably to open with '<+filename'. This is read + write, as
opposed to write + read. Note however, that the file must exist in
this case or the open will fail (no O_CREAT flag here).
If you're just trying to open a file without nuking it's data first
for both read and write, but still want to create it if it's not
there already, you'll have to call sysopen() with the exact flags
you want (see the C man page for open(2) for a list).
sysopen (HANDLE, "filename", O_RDWR|O_CREAT, 0644)
or die "open(): $!, stopped";
--
-Zenin
zenin@archive.rhps.org
------------------------------
Date: 27 May 1998 23:49:05 GMT
From: mgjv@comdyn.com.au (Martien Verbruggen)
Subject: Re: read and write
Message-Id: <6ki8ph$pdi$3@comdyn.comdyn.com.au>
In article <O5wY8ybi9GA.164@uppubnews03>,
"tw96" <tw96@email.msn.com> writes:
> hello, everybody!
> i met a problem.
> when i use :
> open(FILE,"+>".filename);
You should check to see if the open succeeded:
Do you mean $filename here?
You don't need the concatenation.
open(FILE,"+>$filename") || die "Couldn't open $filename: $!";
You do realise how you are opening this file, right? You open the file
for writing, clobbering it if it exists, creating it if it doesn't.
You also have read access to the file. This means that at this point,
your file is empty.
# perldoc -f open
> $a = <FILE>;
This reads the first line of an empty file, which is nothing. $a will
be undefined here.
> print $a,"\n";
> $a++;
> print FILE $a,"\n";
Now you print a line to the file.
> i always get the first line null, and the second line '1'.
Yep. I hope that the above made clear why. If you tell us what it is
you _want_ to do, maybe we can tell you which mode to use.
It might be a good idea for you to run perl with the -w flag. It would
have flagged two problems for you.
Martien
--
Martien Verbruggen |
Webmaster www.tradingpost.com.au | I took an IQ test and the results were
Commercial Dynamics Pty. Ltd. | negative.
NSW, Australia |
------------------------------
Date: Wed, 27 May 1998 23:33:07 GMT
From: Gellyfish@btinternet.com (Jonathan Stowe)
Subject: Re: Sensing whether a script is already running...
Message-Id: <356ca052.20396233@news.btinternet.com>
On Wed, 27 May 1998 18:44:27 -0400, Gus Garcia wrote :
>Is there a way for one Perl script to detect whether another (or even the
>same one for that matter) script is already running?
>
On a unix system I would be inclined to use "ps -ax" or "ps -ef"
depending on your persuasion and looking for the name of the Perl
executable(s) assuming that no-one has played silly buggers with
argv[0] or its moral equivalent of course.
On Windows however unless you have the NT resource kit and tlist or
some substitute you're basically stuffed as far as I can see unless
you get your Perl programs to co-operate in some manner of your own
devising. Of course there may be some nastiness available using one
of the Win32 modules but I havent got my Grimoire to hand just now.
/J\
Jonathan Stowe
Some of your questions answered:
<URL:http://www.btinternet.com/~gellyfish/resources/wwwfaq.htm>
------------------------------
Date: Wed, 27 May 1998 15:16:05 -0500
From: tadmc@flash.net (Tad McClellan)
Subject: Re: Special Variables
Message-Id: <5ashk6.mn5.ln@localhost>
bthak@bascom.com wrote:
: Is there a special variable that holds the value of the last failed match.
I don't think I can grok "value of the last failed match".
What did you mean there?
The "value of a match" is logical "true" (if matched) or
logical "false" (if not matched).
Maybe you meant "the characters that matched" instead?
I don't know what "value" could mean for a *failed* match...
: Consider the following code..
[snip code]
I'll ignore the fact that it doesn't compile, and is done in the "C"
style rather than the Perl style ;-)
: I would like to get the vaule of the non digit part.
So what "value" would you want for this string:
123abc456zyx789 ??
'abczyx' ?
That's easy enough:
-------------------------------
#!/usr/bin/perl -w
@array = qw(123 34455 35 4r6 8654 687688);
foreach (@array){
if (/^\d+$/){
$count++;
}
else {
($nonDigits = $_) =~ tr/0-9//d; # delete all digits
print "Not all digits [$nonDigits]\n";
last;
}
}
-------------------------------
--
Tad McClellan SGML Consulting
tadmc@metronet.com Perl programming
Fort Worth, Texas
------------------------------
Date: 27 May 1998 23:16:56 GMT
From: Zenin <zenin@bawdycaste.org>
Subject: Re: Substitute gurus... got a better word wrap?
Message-Id: <896311452.514993@thrush.omix.com>
Mid Summers Eve Festival <msef@pyramus.com> wrote:
: I've been using the following for word wrapping :
: s/(.{1,80})\s+/$1\n/g
: But this appears to remove leading tabs/spaces at the begining of each line...
: does someone have a better method?
Text::Wrap
Text::Format
--
-Zenin
zenin@archive.rhps.org
------------------------------
Date: 27 May 1998 23:51:24 GMT
From: mgjv@comdyn.com.au (Martien Verbruggen)
Subject: Re: Substitute gurus... got a better word wrap?
Message-Id: <6ki8ts$pdi$4@comdyn.comdyn.com.au>
In article <6ki5m0$8cd$1@core.savvis.net>,
msef@pyramus.com (Mid Summers Eve Festival) writes:
> I've been using the following for word wrapping :
>
> s/(.{1,80})\s+/$1\n/g
>
> But this appears to remove leading tabs/spaces at the begining of each line...
This will probably fail for other lines as well.
> does someone have a better method?
There is a module that does Text wrapping, called Text::Wrap. It's
part of the standard perl distribution. It might be exactly what you
want.
Martien
--
Martien Verbruggen |
Webmaster www.tradingpost.com.au | 75% of the people make up 3/4 of the
Commercial Dynamics Pty. Ltd. | population.
NSW, Australia |
------------------------------
Date: 27 May 1998 16:48:28 -0500
From: Aaron Baugher <abaugher@rnet.com>
Subject: Re: Why do I see the source??
Message-Id: <m24sybo05v.fsf@haruchai.rnet.com>
Patrick Ohnewein <pohnewein@prodata.it> writes:
> But when I direct my WEB-Browser (Netscape Communicator 4.02)
> to that location
> .../cgi-bin/howdy
> I don't see the HTML-Page that the script should transmit, but I see
> the scrip source.
It's your server configuration. It doesn't know files in /cgi-bin/
are scripts.
> Could be I am a fool, but I cannot get it work.
Don't be so hard on yourself, it ruins the fun for everyone else. :-)
--
Aaron Baugher
Extreme Systems Consulting
CGI, Perl, Java, and Unix Administration
http://haruchai.rnet.com/esc/
------------------------------
Date: 8 Mar 97 21:33:47 GMT (Last modified)
From: Perl-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 8 Mar 97)
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". The real FAQ, as it
appeared last in the newsgroup, can be retrieved with the request "send
perl-users FAQ". 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". It appears twice
weekly in the group, but is not distributed in the digest.
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 V8 Issue 2742
**************************************
