[13418] in Perl-Users-Digest
Perl-Users Digest, Issue: 828 Volume: 9
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Fri Sep 17 09:07:26 1999
Date: Fri, 17 Sep 1999 06:05:11 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Message-Id: <937573511-v9-i828@ruby.oce.orst.edu>
Content-Type: text
Perl-Users Digest Fri, 17 Sep 1999 Volume: 9 Number: 828
Today's topics:
Re: A question about some functions from CGI.pm. <madebeer@igc.apc.org>
Re: Are threads the way to go? Design Advice (Anno Siegel)
Re: CGI cannot open relative path (Bart Lateur)
Re: Closing a pipeline before the command is done (M.J.T. Guy)
Re: Code examples of threads in Perl <tchrist@mox.perl.com>
Re: CONTEST: Range Searching <tchrist@mox.perl.com>
Re: CONTEST: Range Searching <rick.delaney@home.com>
Re: CPAN modules for Windows <guy@firstcreative.com>
Re: CPAN modules for Windows <gellyfish@gellyfish.com>
Re: Empty key in Berkeley DB Hash (Anno Siegel)
Re: ENOWORD: Referer (Eric Bohlman)
Re: Error in "Learning Perl, 2nd Edition" or Error in P (Bart Lateur)
Error with DBI <antonio_danger@yahoo.com>
Error with DBI <antonio_danger@yahoo.com>
Digest Administrivia (Last modified: 16 Sep 99) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Fri, 17 Sep 1999 01:05:45 -0700 (PDT)
From: Michael de Beer <madebeer@igc.apc.org>
Subject: Re: A question about some functions from CGI.pm.
Message-Id: <APC&1'0'50775db2'16d@igc.apc.org>
Perl scripts generate HTML. Browswers display HTML.
perl scripts using CGI.pm (and not) can generate HTML that indicates
the browser should change fonts/colors.
This question is so basic I hope you'll read some more documentation
before trying to write a CGI script. Maybe start here:
http://www.perl.com/reference/query.cgi?tutorials
Cheers,
-Michael
------------------------------
Date: 17 Sep 1999 10:32:07 -0000
From: anno4000@lublin.zrz.tu-berlin.de (Anno Siegel)
Subject: Re: Are threads the way to go? Design Advice
Message-Id: <7rt5b7$lpe$1@lublin.zrz.tu-berlin.de>
Ilya Zakharevich <ilya@math.ohio-state.edu> wrote in comp.lang.perl.misc:
>[A complimentary Cc of this posting was sent to Dan Sugalski
><dan@tuatha.sidhe.org>],
>who wrote in article <D9OD3.13641$wW2.13459@news.rdc1.ct.home.com>:
>> > Is there another way to do this without threads? (Since I have no
>> > experience in perl threads).
>>
>> Fork is probably the better way to do this.
>
>Keep in mind memory considerations as well. As experiments show,
>memorywise fork() gives almost no advantage over running separate Perl
>processes (14% difference reported on Solaris - with total footprint
>circa 9G).
Why *should* fork give a memory advantage? Where does the 14% savings
come from anyway?
Anno
------------------------------
Date: Fri, 17 Sep 1999 10:11:31 GMT
From: bart.lateur@skynet.be (Bart Lateur)
Subject: Re: CGI cannot open relative path
Message-Id: <37e2097b.2788322@news.skynet.be>
JduPayrat wrote:
>When I try to open a
>file with a relative path, it fails saying 'No such file or directory'. When
>I try to open the same file with an absolute path it works.
I'm sorry to say, but your relative path probably isn't correct. :-)
>I think that the benefits of being able to move or duplicate my cgi and
>having them work without
>modification worths a little more paintfull debugging process. Of course I
>could modify all my scripts
>but it would be a lot of work . I'd really prefer to avoid that.
Good thinking. You could construct your full path, based on the cwd or
on the scrip's path.
Test your %ENV variables in a CGI script. One of them MUST contain the
script's full path. Especially $ENV{SCRIPT_FILENAME} looks interesting.
But, as Randal says somewhere else in this thread: it is only a hint. A
hacker could change the setting for this variable before calling your
script, so don't rely on it for *too* sensitive data.
In that case, just SAY in your script where it's supposed to start from.
A line at the very front of your script is a good place for
maintainance.
$cwd = '/im/supposed/to/start/from/here';
open(FILE,"$cwd/data/somefile.txt");
--
Bart.
------------------------------
Date: 17 Sep 1999 10:12:43 GMT
From: mjtg@cus.cam.ac.uk (M.J.T. Guy)
Subject: Re: Closing a pipeline before the command is done
Message-Id: <7rt46r$e5s$1@pegasus.csx.cam.ac.uk>
Tom Phoenix <rootbeer@redcat.com> wrote:
>
>You may wish to avoid the shell by opening "-|" and exec()ing the child
>directly with a list of arguments. See the entry on open in the perlfunc
>manpage.
Note that perl will avoid the shell anyway, provided the command contains
no shell metacharacters.
Mike Guy
------------------------------
Date: 17 Sep 1999 06:28:02 -0700
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: Code examples of threads in Perl
Message-Id: <37e233d2@cs.colorado.edu>
[courtesy cc of this posting mailed to cited author]
In comp.lang.perl.misc,
Brundle <brundlefly76@hotmail.com> writes:
:Does anyone have any good code examples in Perl of thread usage?
:
:I need to multithread a TCP/IP client in order to saturate a remote
:server.
:
:Right now I open 5 socket connections to the server and send to them
:round-robin, but this does not work as it is still serial.
:
:Given a list of messages to deliver, I need to send the list to all 5
:and not wait for the response on each before moving to the next.
:
:I am open to alternative reccommendations or suggestions as well.
You should consider whether to be forking processes not spawning threads.
Threads are not really very portable/robust at this time.
Here are various examples.
--tom
# This is a shell archive. Save it in a file, remove anything before
# this line, and then unpack it by entering "sh file". Note, it may
# create directories; files and directories will be owned by you and
# have default permissions.
#
# This archive contains:
#
# dns-fork
# dns-queue
# dns-sema
# procpool
# thrpool
# fwdport
#
echo x - dns-fork
sed 's/^X//' >dns-fork << 'END-of-dns-fork'
X#!/usr/bin/perl
X# dns-fork -- dvk@lonewolf.com
X
Xuse FileHandle;
Xuse Socket;
X
X# Don't "use strict 'vars'" - we'll be using soft references
X
X$parallel = 10;
X@ip_need = read_unknown_ips(); # Not shown here, part of a larger program...
Xinit_resolvers();
Xresolve_ip();
Xexit;
X
Xsub init_resolvers { # Create the background processes
X my ($fd, $ipn, $host);
X print "Parallelizing $parallel IP lookup processes...\n";
X for $fd (1..$parallel) {
X pipe "read$fd", OUT;
X if ($pid[$fd] = open ("feed$fd", "|-")) { # In parent
X close OUT;
X }
X else { # In child
X close "read$fd";
X if (!defined($pid[$fd])) {
X # If here, then fork failed, and we're in parent!
X close OUT;
X $parallel = $fd - 1;
X warn "Only able to fork $parallel processes\n";
X last; # Don't try any more forks
X }
X #
X # The rest of this is the child - do lookups until
X # done by reading 4 bytes (an IPv4 address sent to
X # the child by parent) and writing 3 bytes of length
X # followed by the looked-up name.
X #
X OUT->autoflush(1);
X while (sysread (STDIN, $ipn, 4)) {
X $host = lc (gethostbyaddr ($ipn, AF_INET)) || "-";
X printf OUT "%03d%s", length($host), $host;
X }
X exit 0;
X }
X }
X}
X
Xsub resolve_ip {
X my ($counter, $ip, $ipn, $host, $cnt, $fd, $Npar, @query);
X
X # Prime the pump and set up the select vector
X $rin = "";
X $Npar = 0;
X for $fd (1..$parallel) {
X if ($query[$fd] = shift @ip_need) {
X syswrite ("feed$fd", pack("N", $query[$fd]), 4);
X vec ($rin, fileno("read$fd"), 1) = 1;
X $Npar++;
X }
X else {
X kill 'TERM', $pid[$fd];
X close ("feed$fd");
X }
X }
X return if $Npar == 0; # Done (all fd's closed)
X $parallel = $Npar;
X # Cycle the background processes with names to lookup
X IP: while (select ($rout = $rin, undef, undef, undef)) {
X for $fd (1..$parallel) {
X if (vec ($rout, fileno ("read$fd"), 1)) {
X ($nbytes=sysread ("read$fd", $cnt, 3)) == 3
X || die "Size error ($cnt=$nbytes) on read$fd";
X ($nbytes=sysread ("read$fd", $host, $cnt)) == $cnt
X || die "Name error ($host=$nbytes) on read$fd";
X printf "%s\t%s\n",
X join (".",unpack("C4",pack("N",$query[$fd]))), $host;
X if ($query[$fd] = shift @ip_need) {
X syswrite ("feed$fd", pack("N", $query[$fd]), 4);
X }
X else {
X vec ($rin, fileno("read$fd"), 1) = 0;
X kill 'TERM', $pid[$fd];
X close ("feed$fd");
X last IP if --$Npar == 0;
X }
X }
X }
X }
X}
X
END-of-dns-fork
echo x - dns-queue
sed 's/^X//' >dns-queue << 'END-of-dns-queue'
X#!/usr/local/bin/filsperl -w
X
Xuse strict;
Xuse Thread qw/async/;
Xuse Thread::Queue;
X
Xuse constant BUFMAX => 20;
X
Xmy $LOGFILE = "/var/log/httpd/access_log";
X
Xmy $time_to_die = 0;
X
Xmy $DELAY = 0; # sleep time
X
X$| = 1;
X
Xmy $DEBUG = 0;
X
X$SIG{INT} = sub { kill "HUP" => -$$ }; # kill whole pgrp
X
Xrun_all();
X
Xexit;
X
X###########################
X
XBEGIN {
X
X use constant MAX_PRODUCERS => 3;
X use constant MAX_CONSUMERS => 10;
X
X my $Q = Thread::Queue->new();
X
X sub producer {
X my $item;
X my $tid = Thread->self->tid();
X
X my $handled = 0;
X
X debug("Beginning producer");
X
X while ($item = next_line()) {
X $handled++;
X $Q->enqueue($item);
X last if $time_to_die;
X }
X
X debug("PRODUCER DYING");
X
X return $handled;
X }
X
X sub consumer {
X my $item;
X my $tid = Thread->self->tid();
X
X my $handled = 0;
X
X debug("Beginning consumer");
X
X while ($item = $Q->dequeue() ) {
X $handled++;
X $item =~ s{ ( \b \d+\.\d+\.\d+\.\d+ \b ) }
X { num2name($1) }ex;
X debug("consuming $item");
X print "$item\n";
X dawdle();
X last if $time_to_die;
X }
X debug("CONSUMER DYING");
X return $handled;
X }
X
X
X sub run_all {
X
X my (@consumers, @producers);
X
X for (1 .. MAX_CONSUMERS) {
X push @consumers, Thread->new(\&consumer);
X }
X
X for (1 .. MAX_PRODUCERS) {
X push @producers, Thread->new(\&producer);
X }
X
X for my $task (@producers, @consumers) {
X my $tid = $task->tid();
X my $count = $task->join();
X print "Task $tid handled $count items\n";
X }
X
X }
X
X}
X
Xsub next_line {
X use attrs qw/locked/;
X unless (defined fileno(LOGFILE)) {
X my $flags = $DEBUG ? "" : "+0f";
X open(LOGFILE, "tail $flags $LOGFILE |")
X || die "can't tail $LOGFILE: $!";
X }
X my $line = <LOGFILE>;
X if (!defined $line) {
X $time_to_die++; # whole sub locked
X return;
X }
X chomp $line;
X return $line;
X}
X
Xsub debug {
X my $tid = Thread->self->tid();
X print "TID $tid: @_\n" if $DEBUG;
X}
X
Xsub dawdle {
X sleep int rand $DELAY if $DEBUG;
X}
X
Xuse Socket;
Xsub num2name {
X my $addr = shift;
X my $name;
X
X if ($name = lru_decache($addr)) {
X return $name;
X }
X
X my $binaddr = pack("C4", split (/\./, $addr));
X $name = gethostbyaddr($binaddr, AF_INET) || $addr;
X
X lru_encache($addr, $name);
X return $name;
X}
X
X{
X my %cache;
X use constant CACHE_MAX => 20;
X
X sub lru_decache {
X lock %cache;
X my $key = $_[0];
X my $pair;
X return unless $pair = $cache{$key};
X $pair->[1]++;
X return $pair->[0];
X }
X
X sub lru_encache {
X lock %cache;
X my ($key, $value) = @_;
X $cache{$key} = [ $value, 0 ];
X purge_cache() if CACHE_MAX < keys %cache;
X }
X
X sub purge_cache {
X lock %cache;
X debug("PURGING CACHE");
X # WARNING: sort() not thread safe!
X my @keys = sort { $cache{$a}[1] <=> $cache{$b}[1] } keys %cache;
X $#keys /= 2;
X delete @cache{@keys};
X }
X
X
X}
END-of-dns-queue
echo x - dns-sema
sed 's/^X//' >dns-sema << 'END-of-dns-sema'
X#!/usr/local/bin/filsperl -w
X
Xuse strict;
Xuse Thread qw/async/;
Xuse Thread::Semaphore;
X
Xuse constant BUFMAX => 20;
X
Xmy $LOGFILE = "/var/log/httpd/access_log";
X
Xmy $time_to_die = 0;
X
Xmy $DELAY = 0; # sleep time
X
X$| = 1;
X
Xmy $DEBUG = 0;
X
X$SIG{INT} = sub { kill "HUP" => -$$ }; # kill whole pgrp
X
Xrun_all();
X
Xexit;
X
X###########################
X
XBEGIN {
X
X use constant MAX_PRODUCERS => 3;
X use constant MAX_CONSUMERS => 10;
X
X my($mutex, $empty, $full); # three semaphores
X
X $mutex = Thread::Semaphore->new(1);
X $empty = Thread::Semaphore->new(BUFMAX);
X $full = Thread::Semaphore->new(0);
X
X my @buffer;
X my ($in, $out, $count);
X
X $in = 0;
X $count = 0;
X $out = 0;
X
X sub producer {
X my $item;
X my $tid = Thread->self->tid();
X
X my $handled = 0;
X
X debug("Beginning producer");
X
X do {
X
X # produce something
X if ($item = produce()) {
X $handled++;
X
X debug("producer waits for empty space");
X $empty->down();
X
X # store the item
X $mutex->down();
X $buffer[$in] = $item;
X $in = ($in + 1) % BUFMAX;
X $count++;
X $mutex->up();
X
X debug("producer reports new full slot");
X $full->up();
X }
X
X } until $time_to_die;
X
X debug("PRODUCER DYING");
X
X return $handled;
X }
X
X sub consumer {
X my $item;
X my $tid = Thread->self->tid();
X
X my $handled = 0;
X
X debug("Beginning consumer");
X
X do {
X
X debug("consumer waits for stored item");
X $full->down();
X
X # remove the item
X $mutex->down();
X $item = $buffer[$out];
X $out = ($out + 1) % BUFMAX;
X $count--;
X $mutex->up();
X
X debug("consumer reports new empty slot");
X $empty->up();
X
X # consume it
X if ($item) {
X consume($item);
X $handled++;
X }
X
X } until $time_to_die;
X
X debug("CONSUMER DYING");
X
X return $handled;
X }
X
X
X sub run_all {
X
X my (@consumers, @producers);
X
X for (1 .. MAX_CONSUMERS) {
X push @consumers, Thread->new(\&consumer);
X }
X
X for (1 .. MAX_PRODUCERS) {
X push @producers, Thread->new(\&producer);
X }
X
X for my $task (@producers, @consumers) {
X my $tid = $task->tid();
X my $count = $task->join();
X print "Task $tid handled $count items\n";
X }
X
X }
X
X}
X
Xsub consume {
X my $tid = Thread->self->tid();
X my $item = $_[0];
X $item =~ s{ ( \b \d+\.\d+\.\d+\.\d+ \b ) }
X { num2name($1) }ex;
X debug("consuming $item");
X print "$item\n";
X dawdle();
X}
X
Xsub produce {
X my $tid = Thread->self->tid();
X my $item = next_line() || return;
X debug("producing $item");
X dawdle();
X return $item;
X}
X
Xsub next_line {
X use attrs qw/locked/;
X unless (defined fileno(LOGFILE)) {
X my $flags = $DEBUG ? "" : "+0f";
X open(LOGFILE, "tail $flags $LOGFILE |")
X open(LOGFILE, "tail $LOGFILE |")
X || die "can't tail $LOGFILE: $!";
X }
X my $line = <LOGFILE>;
X if (!defined $line) {
X $time_to_die++; # whole sub locked
X return;
X }
X chomp $line;
X return $line;
X}
X
Xsub debug {
X my $tid = Thread->self->tid();
X print "TID $tid: @_\n" if $DEBUG;
X}
X
Xsub dawdle {
X sleep int rand $DELAY if $DEBUG;
X}
X
Xuse Socket;
Xsub num2name {
X my $addr = shift;
X my $name;
X
X if ($name = lru_decache($addr)) {
X return $name;
X }
X
X my $binaddr = pack("C4", split (/\./, $addr));
X $name = gethostbyaddr($binaddr, AF_INET) || $addr;
X
X lru_encache($addr, $name);
X return $name;
X}
X
X{
X my %cache;
X use constant CACHE_MAX => 20;
X
X sub lru_decache {
X lock %cache;
X my $key = $_[0];
X my $pair;
X return unless $pair = $cache{$key};
X $pair->[1]++;
X return $pair->[0];
X }
X
X sub lru_encache {
X lock %cache;
X my ($key, $value) = @_;
X $cache{$key} = [ $value, 0 ];
X purge_cache() if CACHE_MAX < keys %cache;
X }
X
X sub purge_cache {
X lock %cache;
X debug("PURGING CACHE");
X # WARNING: sort() not thread safe!
X my @keys = sort { $cache{$a}[1] <=> $cache{$b}[1] } keys %cache;
X $#keys /= 2;
X delete @cache{@keys};
X }
X
X
X}
END-of-dns-sema
echo x - procpool
sed 's/^X//' >procpool << 'END-of-procpool'
X#!/usr/bin/perl -w
X# process pool demo
Xuse strict;
X
X$| = 1; # fork can really make for stdio surprises
X
Xmy $TOTAL = 100;
Xmy $CONCUR_MAX = 10;
X
Xmy $FORK_RETRIES = 5;
Xmy $RETRY_SLEEP = 5;
X
Xmy $DAWDLE = 10; # kid spins jets for 1+rand this
X
Xmy %Launched = ();
X
Xrun_queue();
Xexit;
X
X##################
X
Xsub run_queue {
X
X my $started = 0;
X my $done = 0;
X my $running = 0;
X
XJOB:
X while ($TOTAL > ($done+$running) || $running > 0) {
X
X # sort by date in case pids wrap
X print "Run queue: ", join(" ",
X sort { $Launched{$a} <=> $Launched{$b} } keys %Launched),
X "\n";
X
X if ($running >= $CONCUR_MAX || $started >= $TOTAL) {
X print "$$: waiting R=$running, S=$started D=$done\n";
X my $child = wait;
X die "REAPED WRONG CHILD: $child ($?)" unless $Launched{$child};
X my $runtime = time() - $Launched{$child};
X delete $Launched{$child};
X print "Child $child has completed, after $runtime seconds\n";
X print "Child $child exited " . ($? << 8) . "\n" if $?;
X $done++;
X --$running;
X next JOB;
X }
X
X next if ($done+$running) >= $TOTAL;
X
X my $tries = 0;
X my $kid;
XRETRY: {
X $kid = fork();
X unless (defined $kid) {
X warn "$0 $$: cannot fork: $!";
X if ($tries++ < $FORK_RETRIES) {
X warn "$0 $$: sleep and retry\n";
X sleep 5;
X redo RETRY;
X }
X }
X }
X if ($kid) {
X $running++;
X $started++;
X $Launched{ $kid } = time();
X }
X else {
X run_job();
X exit;
X # NOT REACHED
X }
X
X }
X
X}
X
Xsub run_job {
X print "$$ is napping\n";
X sleep(1 + int(rand($DAWDLE)));
X print "$$ had a nice nap.\n";
X}
X
END-of-procpool
echo x - thrpool
sed 's/^X//' >thrpool << 'END-of-thrpool'
X
X use Thread;
X use Thread::Pool;
X
X my $pool = Thread::Pool->new(Max => $CONCUR_MAX);
X for (my $i = 0; $i < $TOTAL; $i++) {
X $pool->enqueue(\&run_job);
X }
END-of-thrpool
echo x - fwdport
sed 's/^X//' >fwdport << 'END-of-fwdport'
X#!/usr/bin/perl -w
X# fwdport -- act as proxy forwarder for dedicated services
X
Xuse strict; # require declarations
Xuse Getopt::Long; # for option processing
Xuse Net::hostent; # by-name interface for host info
Xuse IO::Socket; # for creating server and client sockets
Xuse POSIX ":sys_wait_h"; # for reaping our dead children
X
Xmy (
X %Children, # hash of outstanding child processes
X $REMOTE, # whom we connect to on the outside
X $LOCAL, # where we listen to on the inside
X $SERVICE, # our service name or port number
X $proxy_server, # the socket we accept() from
X $ME, # basename of this program
X);
X
X($ME = $0) =~ s,.*/,,; # retain just basename of script name
X
Xcheck_args(); # processing switches
Xstart_proxy(); # launch our own server
Xservice_clients(); # wait for incoming
Xdie "NOT REACHED"; # you can't get here from there
X
X# process command line switches using the extended
X# version of the getopts library.
Xsub check_args {
X GetOptions(
X "remote=s" => \$REMOTE,
X "local=s" => \$LOCAL,
X "service=s" => \$SERVICE,
X ) or die <<EOUSAGE;
X usage: $0 [ --remote host ] [ --local interface ] [ --service service ]
XEOUSAGE
X die "Need remote" unless $REMOTE;
X die "Need local or service" unless $LOCAL || $SERVICE;
X}
X
X# begin our server
Xsub start_proxy {
X my @proxy_server_config = (
X Proto => 'tcp',
X Reuse => 1,
X Listen => SOMAXCONN,
X );
X push @proxy_server_config, LocalPort => $SERVICE if $SERVICE;
X push @proxy_server_config, LocalAddr => $LOCAL if $LOCAL;
X $proxy_server = IO::Socket::INET->new(@proxy_server_config)
X or die "can't create proxy server: $@";
X print "[Proxy server on ", ($LOCAL || $SERVICE), " initialized.]\n";
X}
X
X
Xsub service_clients {
X my (
X $local_client, # someone internal wanting out
X $lc_info, # local client's name/port information
X $remote_server, # the socket for escaping out
X @rs_config, # temp array for remote socket options
X $rs_info, # remote server's name/port information
X $kidpid, # spawned child for each connection
X );
X
X $SIG{CHLD} = \&REAPER; # harvest the moribund
X
X accepting();
X
X # an accepted connection here means someone inside wants out
X while ($local_client = $proxy_server->accept()) {
X $lc_info = peerinfo($local_client);
X set_state("servicing local $lc_info");
X printf "[Connect from $lc_info]\n";
X
X @rs_config = (
X Proto => 'tcp',
X PeerAddr => $REMOTE,
X );
X push(@rs_config, PeerPort => $SERVICE) if $SERVICE;
X
X print "[Connecting to $REMOTE...";
X set_state("connecting to $REMOTE"); # see below
X $remote_server = IO::Socket::INET->new(@rs_config)
X or die "remote server: $@";
X print "done]\n";
X
X $rs_info = peerinfo($remote_server);
X set_state("connected to $rs_info");
X
X $kidpid = fork();
X die "Cannot fork" unless defined $kidpid;
X if ($kidpid) {
X $Children{$kidpid} = time(); # remember his start time
X close $remote_server; # no use to master
X close $local_client; # likewise
X next; # go get another client
X }
X
X # at this point, we are the forked child process dedicated
X # to the incoming client. but we want a twin to make i/o
X # easier.
X
X close $proxy_server; # no use to slave
X
X $kidpid = fork();
X die "Cannot fork" unless defined $kidpid;
X
X # now each twin sits around and ferries lines of data.
X # see how simple the algorithm is when you can have
X # multiple threads of control?
X
X # this is the fork's parent, the master's child
X if ($kidpid) {
X set_state("$rs_info --> $lc_info");
X select($local_client); $| = 1;
X print while <$remote_server>;
X kill('TERM', $kidpid); # kill my twin cause we're done
X }
X # this is the fork's child, the master's grandchild
X else {
X set_state("$rs_info <-- $lc_info");
X select($remote_server); $| = 1;
X print while <$local_client>;
X kill('TERM', getppid()); # kill my twin cause we're done
X }
X exit; # whoever's still alive bites it
X } continue {
X accepting();
X }
X}
X
X# helper function to produce a nice string in the form HOST:PORT
Xsub peerinfo {
X my $sock = shift;
X my $hostinfo = gethostbyaddr($sock->peeraddr);
X return sprintf("%s:%s",
X $hostinfo->name || $sock->peerhost,
X $sock->peerport);
X}
X
X# reset our $0, which on some systems make "ps" report
X# something interesting: the string we set $0 to!
Xsub set_state { $0 = "$ME [@_]" }
X
X# helper function to call set_state
Xsub accepting {
X set_state("accepting proxy for " . ($REMOTE || $SERVICE));
X}
X
X# somebody just died. keep harvesting the dead until
X# we run out of them. check how long they ran.
Xsub REAPER {
X my $child;
X my $start;
X while (($child = waitpid(-1,WNOHANG)) > 0) {
X if ($start = $Children{$child}) {
X my $runtime = time() - $start;
X printf "Child $child ran %dm%ss\n",
X $runtime / 60, $runtime % 60;
X delete $Children{$child};
X } else {
X print "Bizarre kid $child exited $?\n";
X }
X }
X # If I had to choose between System V and 4.2, I'd resign. --Peter Honeyman
X $SIG{CHLD} = \&REAPER;
X};
END-of-fwdport
exit
--
"It is very hard to get things both right (coherent and correct) and usable
(consistent enough, attractive enough)." --Dennis Ritchie
------------------------------
Date: 16 Sep 1999 22:48:45 -0700
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: CONTEST: Range Searching
Message-Id: <37e1c82d@cs.colorado.edu>
[courtesy cc of this posting mailed to cited author]
In comp.lang.perl.misc,
snowhare@long-lake.nihongo.org (Benjamin Franz) writes:
:if (0 == @file_list) {
: push (@file_list,'-')
:}
:$last_n++;
:while (my $file_name = shift @file_list) {
: my $open_name = $file_name;
: if ($file_name eq '-') {
: $open_name = "<&STDIN";
: $file_name = '';
Is there some reason why normal <ARGV> isn't what you want?
You seem to be emulating what it already does.
unshift(@ARGV, '-') unless @ARGV;
while ($ARGV = shift) {
open(ARGV, $ARGV) || do {
warn "cannot open $ARGV: $!\n";
next;
};
while (<ARGV>) {
... # code for each line
}
}
--tom
--
If you want capitalism, go to Russia!
------------------------------
Date: Fri, 17 Sep 1999 03:05:07 GMT
From: Rick Delaney <rick.delaney@home.com>
Subject: Re: CONTEST: Range Searching
Message-Id: <37E1AFDB.5FACFCBC@home.com>
Tom Christiansen wrote:
>
> pataft [-A N] pattern [files ...]
To which I said,
perl -ne 'print if ($c=0, /pat/) .. $c++ == 3' files
and then I complained that I didn't have a nice extra credit one-liner.
(I'm not following-up to that post since I don't see it).
I should point out that there are still one-liners for this, even if not
as nice.
perl -ne 'print if /pat/ .. (/pat/ ? $c = 0 : ++$c) == 3' files
I didn't really like this since /pat/ appears in the code twice and is
actually tested twice for some lines.
perl -ne 'print if ($c=0, /pat/) ... (/pat/ ? $c = 0 : ++$c) == 3' \
files
/pat/ is only tested once for each line here but now it's just getting
ugly.
--
Rick Delaney
rick.delaney@home.com
------------------------------
Date: Fri, 17 Sep 1999 11:31:57 +0100
From: "Guy Fraser" <guy@firstcreative.com>
Subject: Re: CPAN modules for Windows
Message-Id: <7rt4pv$bhn$1@plutonium.compulink.co.uk>
There is a repository on www.activestate.com - these have all been tested
under windoze and the ActiveState perl system seems to have ported most of
the common *nix commands well.
--
Regards,
Guy Fraser
Internet Services
First Creative Ltd.
Tel: +44 (0)1772 651 555
Fax: +44 (0)1772 651 777
mailto:guy@firstcreative.com
Web: http://www.firstcreative.com
Shardendu Pandey <pandey@my-deja.com> wrote in message
news:7rsov7$nae$1@nnrp1.deja.com...
> Hi,
> I am exploring perl on Windows and am
> interested in knowing whether there
> is equivalent of CPAN libraries on
> Windows.
>
>
> Best wishes
> Pandey
>
> --
> ==============================================
>
>
> Sent via Deja.com http://www.deja.com/
> Share what you know. Learn what you don't.
------------------------------
Date: 17 Sep 1999 11:39:18 +0100
From: Jonathan Stowe <gellyfish@gellyfish.com>
Subject: Re: CPAN modules for Windows
Message-Id: <37e21a56_1@newsread3.dircon.co.uk>
Shardendu Pandey <pandey@my-deja.com> wrote:
> Hi,
> I am exploring perl on Windows and am
> interested in knowing whether there
> is equivalent of CPAN libraries on
> Windows.
>
If you are using the Activestate Perl then you can get a large of number
of the most useful Modules using the PPM (Perl Package Manager) utility
which will take care of the downloading and installation of the modules -
there are also alternative repositories with one or two more modules
available.
You can read about PPM in the Activestate documentation.
/J\
--
"If they want a circus, they have come to the right person" - Neil
Hamilton
------------------------------
Date: 17 Sep 1999 12:46:33 -0000
From: anno4000@lublin.zrz.tu-berlin.de (Anno Siegel)
Subject: Re: Empty key in Berkeley DB Hash
Message-Id: <7rtd79$m07$1@lublin.zrz.tu-berlin.de>
Andreas Tanner <tanner@ultra.math.uni-potsdam.de> wrote in comp.lang.perl.misc:
>
>Thanks to everyone answering my previous question.
>
>I understood that Berkeley Db is good for storing hashes with long
>values.
>
>So what is wrong with the following script?
>
>use DB_File;
>use diagnostics;
>
>tie %a,"DB_File","a";
>%a=();
>$a{''}='zzz'x10000;
>
>foreach (keys %a) {print;}
>untie %a;
>
>It produces lots if 'z's..
>
>Any help appreciated.
What version of Berkeley DB are you running? V 1.86 is buggy; I seem
to remember empty keys were explicitly mentioned.
Anno
------------------------------
Date: 17 Sep 1999 12:25:44 GMT
From: ebohlman@netcom.com (Eric Bohlman)
Subject: Re: ENOWORD: Referer
Message-Id: <7rtc08$1fk@dfw-ixnews9.ix.netcom.com>
Steven Smolinski (sjs@yorku.ca) wrote:
: Your professor should be aware that tokens which are easy to link to
: the function of the token are better than those that are not. Perhaps
: worse than an arbitrary token is one which is almost exactly -- but not
: quite entirely -- the same as a familiar word. This way one's mind is
: constantly tempted to fill in the proper English spelling, thereby
: breaking the code. It is also harder to find such errors by reading the
: code, as our minds do much of this filling-in automatically and by
: default.
"For example, no matter how carefully one writes the zero in the symbol
'ST0P,' it will be mistaken for an 'oh' all along the line." --Gerald
Weinberg, _The Psychology of Computer Programming_
Some horror stories from the same chapter:
1) A program with two different variables called 'SYSTSTS' and 'SYSSTSTS.'
2) A constant had to be changed from 5 to 4. The symbolic name of the
constant was 'FIVE.'
Weinberg also points out that an incorrect comment makes it harder to
track down a bug than no comment at all because it biases the mind toward
the comment and away from the code.
------------------------------
Date: Fri, 17 Sep 1999 10:11:33 GMT
From: bart.lateur@skynet.be (Bart Lateur)
Subject: Re: Error in "Learning Perl, 2nd Edition" or Error in Perl port specific to Windows or ?
Message-Id: <37e40e6e.4055552@news.skynet.be>
Uri Guttman wrote:
>END {push @l, sprint "$w was seen $c times!\n" while ($w, $c) = each %c;
> print sort @l}
>
>saves all those pesky little hash lookups.
Uh. I don't like it.
Although the script text suggests that $w (originally $word) is a
"word", it needn't be. If you use a frase instead of words, it will sort
incorrectly...
%c = ('Bonzo' => 1, 'Bonzo was here' => 2);
push @l, "$w was seen $c times!\n" while ($w, $c) = each %c;
print sort @l
-->
Bonzo was here was seen 2 times!
Bonzo was seen 1 times!
As you can see, it sorts 'Bonzo was here' in front of 'Bonzo'.
Relying on assumed contained characters for sorting variable length
strings, sounds like a script kiddie approach to me. ;-)
--
Bart.
------------------------------
Date: Fri, 17 Sep 1999 11:43:55 -0700
From: "antonio" <antonio_danger@yahoo.com>
Subject: Error with DBI
Message-Id: <7rtqll$5a8$2@news.vsnl.net.in>
Hi Guys ,
I'm a novice at installing packages on Linux ....
I'm trying to use Apache Web Server, Perl 5.004, mod_perl and
MySQL server but having trouble in the installation at every step almost !
As of now my status is that ....
1. I have Apache Server Alive and Kicking .... which means I'm able to
dispaly HTMLS and perl programs on the lynx browser .
2. Also installed is mod_perl module on Apache .I have a little clue as to
how to use mod_perl !
3. The following modules as far as MySQL is concerned ....
+ MySQL server 3.22.22.1
+ MySQL - 3.22.22-1.i386.rpm
+ mysql - client-3.22.19a.1. i386.rpm
+ MySQL -devel - 3.22.22.1.i386.rpm
I have these modules except for MySQL -devel3.22.25.1.rpm
+ MySQL - 3.22.25-1.i386.rpm
+ MySQL - client-3.22.25.1.rpm
Planning to replace the ones alderady installed with these ...
4. Insalled also DBI-1_02-1_i386.rpm
Right now am using MySQL & mSQL by Orielly publication ....
I'm Desperately trying to connect to the database thru a perl script ....
A small test program I tried is as follows ...
#!usr/bin/perl -w
use DBI;
my @drivers = DBI->available_drivers;
print "Available Drivers :\n" .join("\n",@drivers).
"Require MySQL Drivers \n";
testing at prompt gives an error that says ....
[Date :Time]datashow.cgi :
[Date:Time]DBI.pm : can't locate DBI.pm in @INC
(@INC contains : /usr/lib/perl5/5.00503/i386
/usr/lib/perl5/5.00503
/usr/lib/perl5/site_perl/5.005/i386_linux
/usr/lib/perl5/site_perl/5.005)
I think the DBI hasnt been installed properly ...
Plan to uninstall and reinstall all the MySQL packages ...
Need help on packages and order of installation required to
run good perl programs connecting to MySQL ....
Hi to all the Guys working on stuff like this !!!!
Please post ur replies ASAP .
antonio_danger@yahoo.com
------------------------------
Date: Fri, 17 Sep 1999 10:04:52 -0700
From: "antonio" <antonio_danger@yahoo.com>
Subject: Error with DBI
Message-Id: <7rtqlj$5a8$1@news.vsnl.net.in>
Hi Guys ,
I'm a novice at installing packages on Linux ....
I'm trying to use Apache Web Server, Perl 5.004, mod_perl and
MySQL server but having trouble in the installation at every step almost !
As of now my status is that ....
1. I have Apache Server Alive and Kicking .... which means I'm able to
dispaly HTMLS and perl programs on the lynx browser .
2. Also installed is mod_perl module on Apache .I have a little clue as to
how to use mod_perl !
3. The following modules as far as MySQL is concerned ....
+ MySQL server 3.22.22.1
+ MySQL - 3.22.22-1.i386.rpm
+ mysql - client-3.22.19a.1. i386.rpm
+ MySQL -devel - 3.22.22.1.i386.rpm
I have these modules except for MySQL -devel3.22.25.1.rpm
+ MySQL - 3.22.25-1.i386.rpm
+ MySQL - client-3.22.25.1.rpm
Planning to replace the ones alderady installed with these ...
4. Insalled also DBI-1_02-1_i386.rpm
Right now am using MySQL & mSQL by Orielly publication ....
I'm Desperately trying to connect to the database thru a perl script ....
A small test program I tried is as follows ...
#!usr/bin/perl -w
use DBI;
my @drivers = DBI->available_drivers;
print "Available Drivers :\n" .join("\n",@drivers).
"Require MySQL Drivers \n";
testing at prompt gives an error that says ....
[Date :Time]datashow.cgi :
[Date:Time]DBI.pm : can't locate DBI.pm in @INC
(@INC contains : /usr/lib/perl5/5.00503/i386
/usr/lib/perl5/5.00503
/usr/lib/perl5/site_perl/5.005/i386_linux
/usr/lib/perl5/site_perl/5.005)
I think the DBI hasnt been installed properly ...
Plan to uninstall and reinstall all the MySQL packages ...
Need help on packages and order of installation required to
run good perl programs connecting to MySQL ....
Hi to all the Guys working on stuff like this !!!!
Please post ur replies ASAP .
antonio_danger@yahoo.com
------------------------------
Date: 16 Sep 99 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 16 Sep 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.
| NOTE: The mail to news gateway, and thus the ability to submit articles
| through this service to the newsgroup, has been removed. I do not have
| time to individually vet each article to make sure that you aren't
| abusing the service, and I no longer have any desire to waste my time
| dealing with the campus admins when some fool complains to them about an
| article that has come through the gateway instead of complaining
| to the source.
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.
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 828
*************************************
