[8409] in Perl-Users-Digest
Perl-Users Digest, Issue: 2027 Volume: 8
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Wed Mar 4 21:07:28 1998
Date: Wed, 4 Mar 98 18:01:32 -0800
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, 4 Mar 1998 Volume: 8 Number: 2027
Today's topics:
Re: What is PERL? Learn JAVA instead? schwern@starmedia.net
Re: What is PERL? Learn JAVA instead? (Abigail)
Re: What is PERL? Learn JAVA instead? (Abigail)
Re: What is PERL? Learn JAVA instead? <tchrist@mox.perl.com>
Re: What is PERL? Learn JAVA instead? <tchrist@mox.perl.com>
Re: What is PERL? Learn JAVA instead? <tchrist@mox.perl.com>
Digest Administrivia (Last modified: 8 Mar 97) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Wed, 04 Mar 1998 18:31:33 -0600
From: schwern@starmedia.net
To: bslone@earthlink.net
Subject: Re: What is PERL? Learn JAVA instead?
Message-Id: <6dkrnt$bh8$1@nnrp1.dejanews.com>
In article <34FC5A59.5F2EB29D@earthlink.net>,
Brian Slone <bslone@earthlink.net> wrote:
>
> I really don't know crap about PERL. How is it different from JAVA?
Alot.
> Which one is better?
Impossible to say. Which is better, a Range Rover or a Formula 1 Racer?
Which is better, a raincoat or a blouse? Which is better, blue or pink?
Its totally subjective and it depends on what job needs to be done. One
cannot say that one language is 'better' than other, carte blanche.
> What can I use it for?
Everything.
Some useful recourses:
What is Perl?
http://language.perl.com/info/synopsis.html
perlfaq1: General Questions About Perl
ftp://ftp.duke.edu/pub/perl/doc/FAQs/FAQ/PerlFAQ.html#perlfaq1_General_Questi
ons_Abo
Perl versus...
http://language.perl.com/versus/index.html
-----== Posted via Deja News, The Leader in Internet Discussion ==-----
http://www.dejanews.com/ Now offering spam-free web-based newsreading
------------------------------
Date: 5 Mar 1998 00:48:19 GMT
From: abigail@fnx.com (Abigail)
Subject: Re: What is PERL? Learn JAVA instead?
Message-Id: <6dksoj$sj3$6@client2.news.psi.net>
Frank (FHeasley@chemistry.com) wrote on 1646 September 1993 in
<URL: news:34fdbc61.4729093@news.halcyon.com>:
++ On Wed, 04 Mar 1998 12:09:57 -0500, John Porter <jdporter@min.net>
++ wrote:
++
++ >Frank wrote:
++ >>
++ >> There's stuff you can do in PERL that would be difficult, or
++ >> impossible, to do with JAVA. And vice versa.
++ >
++ >(I bet you knew this was coming:)
++ >Name two things that you can do in Java, which would be
++ >impossible, or even difficult (by general agreement), to
++ >do in Perl.
++ >
++ Being an expert in neither, I will plead ignorance and give you half
++ an answer:
++
++ 1. Try running a perl script in your user's web browser.
And this proves what? I can run Python applets in someones webbrowser.
It's just that noone bothered to write a browser that can do Perl
applets. That's probably because Perl isn't a toy language.
++ Is this an advantage? Seems to me that it could be, especially if you
++ are running a web site with a lot of traffic that could burden your
++ server with operations that might be better performed elsewhere.
I won't let my browser run anything from a alien site. Not Java, not
Python, and not Perl either.
Abigail
--
perl5.004 -wMMath::BigInt -e'$^V=new Math::BigInt+qq;$^F$^W783$[$%9889$^F47$|88768$^W596577669$%$^W5$^F3364$[$^W$^F$|838747$[8889739$%$|$^F673$%$^W98$^F76777$=56;;$^U=substr($]=>$|=>5)*(q.25..($^W=@^V))=>do{print+chr$^V%$^U;$^V/=$^U}while$^V!=$^W'
------------------------------
Date: 5 Mar 1998 00:50:58 GMT
From: abigail@fnx.com (Abigail)
Subject: Re: What is PERL? Learn JAVA instead?
Message-Id: <6dksti$sj3$7@client2.news.psi.net>
Evan Kirshenbaum (evan@garrett.hpl.hp.com) wrote on 1646 September 1993
in <URL: news:v9hogzmm84n.fsf@garrett.hpl.hp.com>:
++
++ I do a lot more Perl programming than Java programming (and both are
++ dwarfed recently by C++), but I think I've done enough of both to be
++ qualified to hold an opinion.
++
++ That being said, two things that are easy to do in Java but
++ exceedingly difficult to do in Perl include:
++
++ - Work with cyclic structures. (AFAIK, Perl still uses
++ reference counting rather than true garbage collection, and so
++ cannot reclaim them automatically.)
Bullocks. Perl does have true garbage collection, and more precisely,
you know exactly when it kicks in.
++ - Anything involving multiple threads of control.
++
++ I understand that this last will *finally* be addressed in Perl in the
++ near future..
Yes, but threads are overhyped (just like Java). Many things don't
really need threads.
Abigail
--
perl -wle 'print "Prime" if (1 x shift) !~ /^1?$|^(11+?)\1+$/'
------------------------------
Date: 5 Mar 1998 00:55:13 GMT
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: What is PERL? Learn JAVA instead?
Message-Id: <6dkt5h$2s5$1@csnews.cs.colorado.edu>
[courtesy cc of this posting sent to cited author via email]
In comp.lang.perl.misc, Evan Kirshenbaum <evan@garrett.hpl.hp.com> writes:
: - Work with cyclic structures. (AFAIK, Perl still uses
: reference counting rather than true garbage collection, and so
: cannot reclaim them automatically.)
I'll let Abigail's answer to this one stand.
: - Anything involving multiple threads of control.
Sure it does, unless you define redefine what thread of control means.
I really hate this myth.
The programmer who doesn't understand fork, select, shared memory, file
locking, or semaphores should not be allowed access to use (so called)
light-weight threading. I dread the future.
--tom
--
Tom Christiansen tchrist@jhereg.perl.com
*** The previous line contains the naughty word "$&".\n
if /(ibm|apple|awk)/; # :-)
--Larry Wall in the perl man page
------------------------------
Date: 5 Mar 1998 01:17:56 GMT
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: What is PERL? Learn JAVA instead?
Message-Id: <6dkug4$4ni$1@csnews.cs.colorado.edu>
[courtesy cc of this posting sent to cited author via email]
In comp.lang.perl.misc, Evan Kirshenbaum <evan@garrett.hpl.hp.com> writes:
: - Anything involving multiple threads of control.
First off, I get about 750 forks per second on my system. Not
too shabby, eh?
Second off, have you seen the following?
--tom
NAME
IPC::Shareable - share Perl variables between processes
SYNOPSIS
use IPC::Shareable;
tie($scalar, IPC::Shareable, $glue, { %options });
tie(%hash, IPC::Shareable, $glue, { %options });
(tied %hash)->shlock;
(tied %hash)->shunlock;
CONVENTIONS
The occurrence of a number in square brackets, as in [N], in the
text of this document refers to a numbered note in the the NOTES
entry elsewhere in this document .
DESCRIPTION
IPC::Shareable allows you to tie a a variable to shared memory
making it easy to share the contents of that variable with other
Perl processes. Currently either scalars or hashes can be tied;
tying of arrays remains a work in progress. However, the
variable being tied may contain arbitrarily complex data
structures - including references to arrays, hashes of hashes,
etc. See the REFERENCES entry elsewhere in this document below
for more information.
The association between variables in distinct processes is
provided by *$glue*. This is an integer number or 4 character
string[1] that serves as a common identifier for data across
process space. Hence the statement
tie($scalar, IPC::Shareable, 'data');
in program one and the statement
tie($variable, IPC::Shareable, 'data');
in program two will bind $scalar in program one and $variable in
program two. There is no pre-set limit to the number of
processes that can bind to data; nor is there a pre-set limit to
the size or complexity of the underlying data of the tied
variables[2].
The bound data structures are all linearized (using Raphael
Manfredi's Storable module) before being slurped into shared
memory. Upon retrieval, the original format of the data
structure is recovered. Semaphore flags are used for versioning
and managing a per-process cache, allowing quick retrieval of
data when, for instance, operating on a tie()d variable in a
tight loop.
OPTIONS
Options are specified by passing a reference to a hash as the
fourth argument to the tie function that enchants a variable.
Alternatively you can pass a reference to a hash as the third
argument; IPC::Shareable will then look at the field named
*'key'* in this hash for the value of *$glue*. So,
tie($variable, IPC::Shareable, 'data', \%options);
is equivalent to
tie($variable, IPC::Shareable,
{ 'key' => 'data', ... });
When defining an options hash, values that match the word *'no'*
in a case-insensitive manner are treated as false. Therefore,
setting `$options{'create'} = 'No';' is the same as
C<$options{'create'} = 0;>.
The following fields are recognized in the options hash.
key The *'key'* field is used to determine the *$glue* if *$glue*
was not present in the call to tie(). This argument is then,
in turn, used as the KEY argument in subsequent calls to
shmget() and semget(). If this field is not provided, a
value of IPC_PRIVATE is assumed, meaning that your variables
cannot be shared with other processes. (Note that setting
*$glue* to 0 is the same as using IPC_PRIVATE.)
create
If *'create'* is set to a true value, IPC::Shareable will
create a new binding associated with *$glue* if such a
binding does not already exist. If *'create'* is false,
calls to tie() will fail (returning undef) if such a binding
does not already exist. This is achieved by ORing
IPC_PRIVATE into FLAGS argument of calls to shmget() when
*create* is true.
exclusive
If *'exclusive'* field is set to a true value, calls to
tie() will fail (returning undef) if a data binding
associated with *$glue* already exists. This is achieved by
ORing IPC_ IPC_EXCL into the FLAGS argument of calls to
shmget() when *'exclusive'* is true.
mode
The *mode* argument is an octal number specifying the access
permissions when a new data binding is being created. These
access permission are the same as file access permissions in
that 0666 is world readable, 0600 is readable only by the
effective UID of the process creating the shared variable,
etc. If not provided, a default of 0666 (world readable and
writable) will be assumed.
destroy
If set to a true value, the data binding will be destroyed
when the process calling tie() exits (gracefully)[3].
LOCKING
Shareable provides methods to implement application-level
locking of the shared data structures. These methods are called
shlock() and shunlock(). To use them you must first get the tied
object, either by saving the return value of the original call
to tie() or by using the built-in tied() function.
To lock a variable, do this:
$knot = tie($scalar, IPC::Shareable, $glue, { %options });
...
$knot->shlock;
or equivalently
tie($scalar, IPC::Shareable, $glue, { %options });
(tied $scalar)->shlock;
This will place an exclusive lock on the data of $scalar.
To unlock a variable do this:
$knot->shunlock;
or
(tied $scalar)->shunlock;
Note that there is no mechanism for shared locks, but you're
probably safe to rely on Shareable's internal locking mechanism
in situations that would normally call for a shared lock so
that's not a big drawback. In general, a lock only needs to be
applied during a non-atomic write operation. For instance, a
statement like
$scalar = 10;
doesn't really need a lock since it's atomic. However, if you
want to increment, you really should do
(tied $scalar)->shlock;
++$scalar;
(tied $scalar)->shunlock;
since ++$scalar is non-atomic.
Read-only operations are (I think) atomic so you don't really
need to lock for them.
There are some pitfalls regarding locking and signals that you
should make yourself aware of; these are discussed in the NOTES
entry elsewhere in this document .
REFERENCES
If a variable tie()d to Shareable contains references, Shareable
acts in different ways depending upon the initial state of the
thingy being referenced.
The Thingy Referenced Is Initially False
If Shareable encounters in a tie()d variable a reference to an
empty hash or a scalar with a false value, Shareable will
attempt to tie() the hash or scalar being referenced. If a
reference is to an empty array, Shareable defaults to its other
behaviour described below since Shareable cannot tie() arrays.
References to empty hashes can occur whenever a tie()d variable
is cast in a context that forces references to "spring into
existence". Consider, for instance, the following assignment to
a tie()d %hash:
$hash{'foo'}{'bar'} = 'xyzzy';
This statement assigns assigns to $hash{'foo'} a reference to an
anonymous hash. In the anonymous hash it assigns to the key
'bar' the value 'xyzzy'. Since %hash is tie()d, the assignment
triggers Shareable, but when Shareable is called, the anonymous
hash is still empty. Shareable then immediately tie()s the
anonymous hash so that when the assignment { 'bar' = 'xyzzy' }
is made, Shareable can catch it.
One consequence of this behaviour is a statement like
$scalar = {};
will, for a tie()d $scalar, Shareable to tie() the anonymous
hash. Consider this a supported bug. It does, however mean that
statements like
$scalar->{'foo'} = 'bar';
should work as expected.
Be warned, however, that each variable tie()d to Shareable
requires (at least) one shared memory segment and one set of
three semaphores. If you use this feature too liberally, you can
find yourself running out of semaphores quickly. If that happens
to you, consider resorting to Shareable other behaviour
described in the following section.
Another potential problem at the time of writing with using this
behaviour is that locking using shlock() and shunlock() is
unreliable. This is because a data structure spans more than one
tie()d variable. It is advisable to implement your own locking
mechanism if you plan on using this behaviour of Shareable.
The Thingy Referenced Is Initially True
If Shareable encounters in a tie()d variable a reference to a
hash with any key/value pairs, a reference to a true scalar, or
a reference to any array, the contents of the referenced thingy
are slurped into the same shared memory segment as the original
tie()d variable. What that means is that a statement like
$scalar = [ 0 .. 9 ];
makes the contents of the anonymous array referenced by a tie()d
$scalar visible to other processes.
The good side of this behaviour is that a data structure can be
arbitrarily complex and still only require one set of three
semaphores. The downside becomes evident when you try to modify
the contents of such a referenced thingy, either in the original
process or elsewhere. A statement like
push(@$scalar, 10, 11, 12);
modifies only the untied anonymous array referenced by $scalar
and not the tie()d $scalar itself. Subsequently, the change to
the anonymous array would be visible only in the process making
this statement.
A workaround is to remember which variable is really tie()d and
to make sure you assign into that variable every time you change
a thingy that it references. An alternative to the above
statement that works is
$scalar = [ (@$scalar, 10, 11, 12) ];
EXAMPLES
In a file called server:
#!/usr/bin/perl -w
use IPC::Shareable;
$glue = 'data';
%options = (
'create' => 'yes',
'exclusive' => 'no',
'mode' => 0644,
'destroy' => 'yes',
);
tie(%colours, IPC::Shareable, $glue, { %options }) or
die "server: tie failed\n";
%colours = (
'red' => [
'fire truck',
'leaves in the fall',
],
'blue' => [
'sky',
'police cars',
],
);
(print("server: there are 2 colours\n"), sleep 5)
while scalar keys %colours == 2;
print "server: here are all my colours:\n";
foreach $colour (keys %colours) {
print "server: these are $colour: ",
join(', ', @{$colours{$colour}}), "\n";
}
exit;
In a file called client
#!/usr/bin/perl -w
use IPC::Shareable;
$glue = 'data';
%options = (
'key' => 'paint',
'create' => 'no',
'exclusive' => 'no',
'mode' => 0644,
'destroy' => 'no',
);
tie(%colours, IPC::Shareable, $glue, { %options }) or
die "client: tie failed\n";
foreach $colour (keys %colours) {
print "client: these are $colour: ",
join(', ', @{$colours{$colour}}), "\n";
}
delete $colours{'red'};
exit;
And here is the output (the sleep commands in the command line
prevent the output from being interrupted by shell prompts):
bash$ ( ./server & ) ; sleep 10 ; ./client ; sleep 10
server: there are 2 colours
server: there are 2 colours
server: there are 2 colours
client: these are blue: sky, police cars
client: these are red: fire truck, leaves in the fall
server: here are all my colours:
server: these are blue: sky, police cars
RETURN VALUES
Calls to tie() that try to implement IPC::Shareable will return
true if successful, *undef* otherwise. The value returned is an
instance of the IPC::Shareable class.
INTERNALS
When a variable is tie()d, a blessed reference to a SCALAR is
created. (This is true even if it is a HASH being tie()d.) The
value thereby referred is an integer[4] ID that is used as a key
in a hash called *%IPC::Shareable::Shm_Info*; this hash is
created and maintained by IPC::Shareable to manage the variables
it has tie()d. When IPC::Shareable needs to perform an operation
on a tie()d variable, it dereferences the blessed reference to
perform a lookup in *%IPC::Shareable::Shm_Info* for the
information needed to proceed.
*%IPC::Shareable::Shm_Info* has the following structure:
%IPC::Shareable::Shm_Info = (
# - The ID of an enchanted variable
$id => {
# - A literal indicating the variable type
'type' => 'SCALAR' || 'HASH',
# - The I<$glue> used when tie() was called
'key' => $glue,
# - Shm segment IDs for this variable
'frag_id' => {
'0' => $id_1, # - ID of first shm segment
'1' => $id_2, # - ID of next shm segment
... # - etc
},
# - ID of associated semaphores
'sem_id' => $semid,
# - The options passed when tie() was called
'options' => { %options },
# - The value of FLAGS for shmget() calls.
'flags' => $flags,
# - Destroy shm segements on exit?
'destroy' => $destroy,
;
# - The version number of the cached data
'version' => $version,
# - A flag that indicates if this process
# - has a lock on this variable
'lock' => $lock_flag,
# - A flag that indicates whether an
# - iteration of this variable is in
# - progress and we should use the local
# - cache only until the iteration is over.
# - Meaningless for scalars.
'hash_iterating' => $iteration_flag,
# - Data cache; data will be retrieved from
# - here when this process's version is the
# - same as the public version, or when we
# - have a hash in the middle of some kind
# - of iteration
'DATA' => {
# - User data; where the real
# - information is stored
'user' => \$data || \%data,
# - Internal data used by Shareable to
# - attach to any thingies referenced
# - by this variable; see REFERENCES
# - above
'internal => {
# - Identifier of a thingy attached
# - to this variable
$string_1 => {
# - The shared memory id of the
# - attached thingy
'shm_id' => $attached_shmid,
# - The $glue used when tie()ing
# - to this thingy
'key' => $glue,
# - Type of thingy to attach to
'ref_type' => $type,
# - Where to store the reference
# - to this thingy
'hash_key' => $hash_key,
},
$string_2 => {
... # - Another set of keys like
# - $string_1
},
... # - Additional $string_n's if
# - need be.
},
},
# - List of associated data structures, and
# - flags that indicate if this process has
# - successfully attached to them
'attached' => {
$string_1 => $attached_flag1,
$string_2 => $attached_flag2,
},
},
... # - IDs of additional tie()d variables
);
Perhaps the most important thing to note the existence of the
*'DATA'* and *'version'* fields: data for all tie()d variables
is stored locally in a per-process cache. When storing data, the
values of the semaphores referred to by
*$Shm_Info{$id}{'sem_id'}* are changed to indicate to the world
a new version of the data is available. When retrieving data for
a tie()d variables, the values of these semaphores are examined
to see if another process has created a more recent version than
the cached version. If a more recent version is available, it
will be retrieved from shared memory and used. If no more recent
version has been created, the cached version is used.
Also stored in the *'DATA'* field is a structure that identifies
any "magically created" tie()d variables associated with this
variable. These variables are created by assignments like the
following:
$hash{'foo'}{'bar'} = 'xyzzy';
See the REFERENCES entry elsewhere in this document for a
complete explanation.
Another important thing to know is that IPC::Shareable allocates
shared memory of a constant size SHM_BUFSIZ, where SHM_BUFSIZ is
defined in this module. If the amount of (serialized) data
exceeds this value, it will be fragmented into multiple segments
during a write operation and reassembled during a read
operation.
Lastly, if notice that if you tie() a hash and begin iterating
over it, you will get data from and write to your local cache
until Shareable thinks you've reached the end of the iteration.
At this point Shareable writes out the entire contents of your
hash to shared memory. This is done so you can safely iterate
via keys(), values(), and each() without having to worry about
somebody else clobbering a key in the middle of the loop.
AUTHORS
Benjamin Sugars <bsugars@canoe.ca>
Maurice Aubrey <maurice@hevanet.com>
NOTES
Footnotes from the above sections
1 If *$glue* is longer than 4 characters, only the 4 most
significant characters are used. These characters are turned
into integers by unpack()ing them. If *$glue* is less than 4
characters, it is space padded.
2 IPC::Shareable provides no pre-set limits, but the system does.
Namely, there are limits on the number of shared memory
segments that can be allocated and the total amount of
memory usable by shared memory.
3. If the process has been smoked by an untrapped signal, the
binding will remain in shared memory. If you're cautious,
you might try
$SIG{INT} = \&catch_int;
sub catch_int {
exit;
}
...
tie($variable, IPC::Shareable, 'data',
{ 'destroy' => 'Yes!' });
which will at least clean up after your user hits CTRL-C
because IPC::Shareable's DESTROY method will be called. Or,
maybe you'd like to leave the binding in shared memory, so
subsequent process can recover the data...
4 The integer happens to be the shared memory ID of the first
shared memory segment used to store the variable's data.
General Notes
o When using shlock() to lock a variable, be careful to guard
against signals. Under normal circumstances, Shareable's
DESTROY method unlocks any locked variables when the process
exits. However, if an untrapped signal is received while a
process holds an exclusive lock, DESTROY will not be called
and the lock may be maintained even though the process has
exited. If this scares you, you might be better off
implementing your own locking methods.
o The bulk of Shareable's behaviour when dealing with references
relies on undocumented (and possibly unsupported) features
of perl. Changes to perl in the future could break
Shareable.
o As mentioned in the INTERNALS entry elsewhere in this document
shared memory segments are acquired with sizes of
SHM_BUFSIZ. SHM_BUFSIZ's largest possible value is nominally
SHMMAX, which is highly system-dependent. Indeed, for some
systems it may be defined at boot time. If you can't seem to
tie() any variables, it may be that SHM_BUFSIZ is set a
value that exceeds SHMMAX on your system. Try reducing the
size of SHM_BUFSIZ and recompiling the module.
o The class contains a translation of the constants defined in the
<sys/ipc.h>, <sys/shm.h>, and <sys/sem.h> header files.
These constants are used internally by the class and cannot
be imported into a calling environment. To do that, use
IPC::SysV instead. Indeed, I would have used IPC::SysV
myself, but I haven't been able to get it to compile on any
system I have access to :-(.
o Use caution when choosing your values of $glue. If
IPC::Shareable needs to acquire more shared memory segments
(due to a buffer overrun, or implicit referencing), those
shared memory segments will have a different $glue than the
$glue supplied by the application. In general, $glues should
be well separated: aaaa and zzzz are good choices, since
they are unlikely to collide, but aaaa and aaab could easily
collide.
o There is a program called ipcs(1/8) that is available on at
least Solaris and Linux that might be useful for cleaning
moribund shared memory segments or semaphore sets produced
by bugs in either IPC::Shareable or applications using it.
o IPC::Shareable version 0.20 or greater does not understand the
format of shared memory segments created by earlier versions
of IPC::Shareable. If you try to tie to such segments, you
will get an error. The only work around is to clear the
shared memory segments and start with a fresh set.
o Set the variable *$IPC::Shareable::Debug* to a true value to
produce *many* verbose debugging messages on the standard
error (I don't use the Perl debugger as much as I should...
)
CREDITS
Thanks to all those with comments or bug fixes, especially
Stephane Bortzmeyer <bortzmeyer@pasteur.fr>, Michael Stevens
<michael@malkav.imaginet.co.uk>, Richard Neal
<richard@imaginet.co.uk>, Jason Stevens <jstevens@chron.com>,
Maurice Aubrey <maurice@hevanet.com>, and Doug MacEachern
<dougm@telebusiness.co.nz>.
BUGS
Certainly; this is alpha software. When you discover an anomaly,
send me an email at bsugars@canoe.ca.
SEE ALSO
perl(1), perltie(1), Storable(3), shmget(2) and other SysV IPC
man pages.
--
Tom Christiansen tchrist@jhereg.perl.com
We're going to have the best-educated American people in the world.
--Vice President Dan Quayle
------------------------------
Date: 5 Mar 1998 01:22:37 GMT
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: What is PERL? Learn JAVA instead?
Message-Id: <6dkuot$4ni$2@csnews.cs.colorado.edu>
[courtesy cc of this posting sent to cited author via email]
In comp.lang.perl.misc, Evan Kirshenbaum <evan@garrett.hpl.hp.com> writes:
: - Anything involving multiple threads of control.
This is something involving multiple threads of control.
--tom
#!/usr/bin/perl -w
# fwdport -- tchrist@perl.com
# e.g.
# fwdport -s nntp -l localhost -r news.bigorg.com
# fwdport -l myname:9191 -r news.bigorg.com:nntp
use strict;
use Getopt::Long;
use Net::hostent;
use IO::Socket;
use POSIX ":sys_wait_h";
my (
%Children,
$REMOTE,
$LOCAL,
$SERVICE,
$proxy_server,
$ME,
);
($ME = $0) =~ s,.*/,,;
check_args();
start_proxy();
service_clients();
sub service_clients {
my (
$local_client,
$lc_info,
$remote_server,
@rs_config,
$rs_info,
$kidpid,
);
$SIG{CHLD} = \&REAPER;
accepting();
while ($local_client = $proxy_server->accept()) {
$lc_info = peerinfo($local_client);
set_state("servicing local $lc_info");
printf "[Connect from $lc_info]\n";
@rs_config = (
Proto => 'tcp',
PeerAddr => $REMOTE,
);
push(@rs_config, PeerPort => $SERVICE) if $SERVICE;
print "[Connecting to $REMOTE...";
set_state("connecting to $REMOTE");
$remote_server = IO::Socket::INET->new(@rs_config)
|| die "remote server: $@";
print "done]\n";
$rs_info = peerinfo($remote_server);
set_state("connected to $rs_info");
$kidpid = fork();
die "Cannot fork" unless defined $kidpid;
if ($kidpid) {
$Children{$kidpid} = time();
close $remote_server;
close $local_client;
next;
}
close $proxy_server;
$kidpid = fork(); die "Cannot fork" unless defined $kidpid;
if ($kidpid) {
set_state("$rs_info --> $lc_info");
select($local_client); $| = 1;
print while <$remote_server>;
kill('TERM', $kidpid);
} else {
set_state("$rs_info <-- $lc_info");
select($remote_server); $| = 1;
print while <$local_client>;
kill('TERM', getppid());
}
exit;
} continue {
accepting();
}
}
sub accepting {
set_state("accepting proxy for " . ($REMOTE || $SERVICE));
}
sub check_args {
GetOptions(
"remote=s" => \$REMOTE,
"local=s" => \$LOCAL,
"service=s" => \$SERVICE,
) or die <<EOUSAGE;
usage: $0 [ --remote host ] [ --local interface ] [ --service service ]
EOUSAGE
die "Need remote" unless $REMOTE;
die "Need local or service" unless $LOCAL || $SERVICE;
}
sub start_proxy {
my @proxy_server_config = (
Proto => 'tcp',
Reuse => 1,
Listen => SOMAXCONN,
);
push @proxy_server_config, LocalPort => $SERVICE if $SERVICE;
push @proxy_server_config, LocalAddr => $LOCAL if $LOCAL;
$proxy_server = IO::Socket::INET->new(@proxy_server_config)
|| die "can't create proxy server: $@";
print "[Proxy server on ", ($LOCAL || $SERVICE), " initialized.]\n";
}
sub set_state { $0 = "$ME [@_]" }
sub REAPER {
my $child;
my $start;
while (($child = waitpid(-1,WNOHANG)) > 0) {
if ($start = $Children{$child}) {
my $runtime = time() - $start;
printf "Child $child ran %dm%ss\n",
$runtime / 60, $runtime % 60;
delete $Children{$child};
} else {
print "Bizarre kid $child exited $?\n";
}
}
# If I had to choose between System V and 4.2, I'd resign. --Peter Honeyman
$SIG{CHLD} = \&REAPER;
};
sub peerinfo {
my $sock = shift;
my $hostinfo = gethostbyaddr($sock->peeraddr);
return sprintf("%s:%s",
$hostinfo->name || $sock->peerhost,
$sock->peerport);
}
--
Tom Christiansen tchrist@jhereg.perl.com
"Sometimes I wish I could put an expiration date on my quotes." --Larry Wall
------------------------------
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 2027
**************************************
