[23094] in Perl-Users-Digest
Perl-Users Digest, Issue: 5315 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Tue Aug 5 14:21:24 2003
Date: Tue, 5 Aug 2003 11:20:52 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Tue, 5 Aug 2003 Volume: 10 Number: 5315
Today's topics:
Distinguishing between socket buffer full & socket disc (John Ramsden)
Re: Distinguishing between socket buffer full & socket <nobull@mail.com>
Re: Distinguishing between socket buffer full & socket (Greg Bacon)
Re: FILE SELECTION DIALOG PROBLEM <bwalton@rochester.rr.com>
Final "Flocking" Script <ducott@hotmail.com>
Re: Final "Flocking" Script <matthew.garrish@sympatico.ca>
Re: Final "Flocking" Script <noreply@gunnar.cc>
Re: Final "Flocking" Script (Tad McClellan)
Re: Final "Flocking" Script (Tad McClellan)
Re: Final "Flocking" Script <noreply@gunnar.cc>
Re: Final "Flocking" Script <flavell@mail.cern.ch>
Re: Final "Flocking" Script <noreply@gunnar.cc>
Re: for ($foo) {} vs. $_ = $foo; <nobull@mail.com>
Re: for ($foo) {} vs. $_ = $foo; <jaspax@u.washington.edu>
Re: for ($foo) {} vs. $_ = $foo; <usenet@expires082003.tinita.de>
Getting a keystroke without Term::ReadKey (J. Romano)
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 5 Aug 2003 01:55:15 -0700
From: john_ramsden@sagitta-ps.com (John Ramsden)
Subject: Distinguishing between socket buffer full & socket disconnected
Message-Id: <d27434e.0308050055.689f0da7@posting.google.com>
I am using the IO::Select method can_write() to flow control the writing
of a large amount of data to a socket, where the writer may well run ahead
of the receiver at the other end and thus cause the local buffer to become
full.
I gather the can_write() method takes care of that, by only returning
true when the outgoing buffer is not full. But how does one distinguish
this from the situation where the remote process has closed its end of
the socket connection?
I'm happy to set a large timeout for can_write(), and call it in a loop,
while the connection is open and the receiver will sooner or later get
round to reading its end of the socket and thereby clear the log jam.
But obviously the sender will loop forever if can_write() is returning
false because the receiver process has packed up and gone home!
Cheers
John Ramsden (john_ramsden@sagitta-ps.com)
------------------------------
Date: 05 Aug 2003 12:01:07 +0100
From: Brian McCauley <nobull@mail.com>
Subject: Re: Distinguishing between socket buffer full & socket disconnected
Message-Id: <u94r0wnzbg.fsf@wcl-l.bham.ac.uk>
john_ramsden@sagitta-ps.com (John Ramsden) writes:
> I am using the IO::Select method can_write() to flow control the writing
> of a large amount of data to a socket, where the writer may well run ahead
> of the receiver at the other end and thus cause the local buffer to become
> full.
>
> I gather the can_write() method takes care of that, by only returning
> true when the outgoing buffer is not full. But how does one distinguish
> this from the situation where the remote process has closed its end of
> the socket connection?
I think has_exception() is true for such handles.
--
\\ ( )
. _\\__[oo
.__/ \\ /\@
. l___\\
# ll l\\
###LL LL\\
------------------------------
Date: Tue, 05 Aug 2003 14:25:00 -0000
From: gbacon@hiwaay.net (Greg Bacon)
Subject: Re: Distinguishing between socket buffer full & socket disconnected
Message-Id: <vivfhse11ij441@corp.supernews.com>
In article <d27434e.0308050055.689f0da7@posting.google.com>,
John Ramsden <john_ramsden@sagitta-ps.com> wrote:
: [...]
:
: I gather the can_write() method takes care of that, by only returning
: true when the outgoing buffer is not full. But how does one distinguish
: this from the situation where the remote process has closed its end of
: the socket connection?
Are you checking the return value from the write to the socket? What
does $s->connected return?
To look for a closed peer, check for a can_read handle that produces a
zero-byte read.
: [...]
Hope this helps,
Greg
--
Government's view of the economy could be summed up in a few short
phrases: If it moves, tax it. If it keeps moving, regulate it. And if
it stops moving, subsidize it.
-- Ronald Reagan
------------------------------
Date: Mon, 04 Aug 2003 00:55:23 GMT
From: Bob Walton <bwalton@rochester.rr.com>
Subject: Re: FILE SELECTION DIALOG PROBLEM
Message-Id: <3F2DAEF9.4090101@rochester.rr.com>
Go Perl wrote:
> I am using the following code to create file selection dialogs..But
> apparently the Browse buttons do not seem to work.. i got this from
> examples provided by typing widget. I changed a little to remove the
> radio buttons and stuff, but i am not able to browse and select the
> files. I will be glad if anyone can point the error and throw some
> light on this.
...
>
> use Tk;
> $mw = MainWindow->new();
>
> foreach my $i (qw(one two three four)) {
> my $f = $mw->Frame;
> my $lab = $f->Label(-text => "Select $i file to Open: ",
> -anchor => 'e');
> my $ent = $f->Entry(-width => 20);
> my $but = $f->Button(-text => "Browse ...",
> -command => sub { fileDialog($mw, $ent, $i)});
> $lab->pack(-side => 'left');
> $ent->pack(-side => 'left',-expand => 'yes', -fill => 'x');
> $but->pack(-side => 'left');
> $f->pack(-fill => 'x', -padx => '1c', -pady => 3);
> }
MainLoop; #is needed here
>
>
> sub filebox {
> my $demo = shift;
>
>
> (
> -name => $demo,
> -text => "Enter a file name in the entry box or click on
> the \"Browse\" buttons to select a file name
>
> using the file selection dialog.",
> -iconname => 'filebox',
> );
> }
>
> sub fileDialog {
> my $w = shift;
> my $ent = shift;
> my $operation = shift;
> my $types;
> my $file;
> @types =
> (["Text files", '*.txt'],
> ["All files", '*']
> );
> if ($operation eq 'open') {
> $file = $w->getOpenFile(-filetypes => \@types);
> }
>
> }
>
Your "browse" buttons work fine. The sub you are calling with the
-command of each Button is not given a third argument of 'open',
however, so it appears as if the Button does nothing. If you change it
so the the third argument is 'open' instead of $i, then the file dialog
does appear. But then, you don't do anything with $file once you have
it, so your program needs lots more work.
And BTW, your example is missing a MainLoop; statement in the main program.
--
Bob Walton
------------------------------
Date: Tue, 05 Aug 2003 03:49:42 GMT
From: "\"Dandy\" Randy" <ducott@hotmail.com>
Subject: Final "Flocking" Script
Message-Id: <qPFXa.650827$Vi5.15477178@news1.calgary.shaw.ca>
Thanx you to everyone who has been helping with my flocking issue. After
reading several perdocs from www.perdoc.com I have come up with the
following script. This script simply advances the second value of a text
file number by 1 each time it is run. The only quirk I have found is with
"use strict" and "use warnings" In my script these lines are blocked out ...
it is the only way the sript runs correctly.
#!/usr/bin/perl
#use strict;
#use warnings;
use 5.004;
use Fcntl qw(:DEFAULT :flock);
open (FH, "<data.txt") or die "Can't open file: $!";
flock (FH, LOCK_EX) or die "Can't lock file: $!";
$data=<FH>;
chomp ($data);
($total,$opened,$followed)=split(/\|/,$data);
close(FH);
$opened = $opened + 1;
sysopen(FH, "data.txt", O_WRONLY | O_CREAT) or die "can't open filename:
$!";
flock (FH, LOCK_EX) or die "can't lock filename: $!";
truncate (FH, 0) or die "can't truncate filename: $!";
print FH "$total|$opened|$followed\n";
close FH;
print "Content-type: text/html \n\n";
print "Done\n";
exit;
The end result, the number advances correctly. This script is basically a
counter for email ... one of my other programs sends out several emails, and
in the email code, there are instructions to run this script ... it simply
tells me how many emails were actually opened compared to how many sent. I
am hoping the flocking script i'm using above is the correct one for my
"cause". If it's not, please advise. thanx to everyone for the help;
Randy
P.S.
In case any of you are wondering about the strict or warning issues, when I
unblock these commands, the server returns the following text:
--------------------------------------
Internal Server Error
The server encountered an internal error or misconfiguration and was unable
to complete your request.
Please contact the server administrator and inform them of the time the
error occurred, and anything you might have done that may have caused the
error.
More information about this error may be available in the server error log.
--------------------------------------
Apache/1.3.27 Server at www.awebsite.com Port 80
------------------------------
Date: Tue, 5 Aug 2003 01:03:15 -0400
From: "Matt Garrish" <matthew.garrish@sympatico.ca>
Subject: Re: Final "Flocking" Script
Message-Id: <sUGXa.1648$_a4.352948@news20.bellglobal.com>
""Dandy" Randy" <ducott@hotmail.com> wrote in message
news:qPFXa.650827$Vi5.15477178@news1.calgary.shaw.ca...
>
> In case any of you are wondering about the strict or warning issues, when
I
> unblock these commands, the server returns the following text:
>
That's not surprising since you haven't declared any of the variables in
your script. If you look in the log file you'll see a lot "Global symbol ...
requires explicit package name at ..." messages.
Matt
------------------------------
Date: Tue, 05 Aug 2003 09:23:04 +0200
From: Gunnar Hjalmarsson <noreply@gunnar.cc>
Subject: Re: Final "Flocking" Script
Message-Id: <bgnmia$q6ufb$1@ID-184292.news.uni-berlin.de>
"Dandy" Randy wrote:
> In case any of you are wondering about the strict or warning
> issues, when I unblock these commands, the server returns the
> following text:
>
> --------------------------------------
> Internal Server Error
<snip>
Put the following at the beginning of the script:
use CGI::Carp 'fatalsToBrowser';
It will make more meaningful error messages be shown on the screen.
Very useful, escpecially if you would be running the script on a
shared hosting account without access to the error log.
Have you installed Perl locally on your computer? If not, you should.
If you are using a Windows PC, I recommend you to check out
http://www.indigostar.com/indigoperl.htm
Besides Perl with the docs, it would give you an Apache server (for
testing CGI scripts locally), PHP, etc. And it's *very* easy to install.
--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl
------------------------------
Date: Tue, 5 Aug 2003 08:04:25 -0500
From: tadmc@augustmail.com (Tad McClellan)
Subject: Re: Final "Flocking" Script
Message-Id: <slrnbivaqp.eqf.tadmc@magna.augustmail.com>
\"Dandy\" Randy <ducott@hotmail.com> wrote:
> sysopen(FH, "data.txt", O_WRONLY | O_CREAT) or die "can't open filename:
> $!";
> flock (FH, LOCK_EX) or die "can't lock filename: $!";
> truncate (FH, 0) or die "can't truncate filename: $!";
There should be a seek(FH, 0, 0) here in case some other process
advanced the file pointer between your sysopen() and your flock().
> In case any of you are wondering about the strict or warning issues, when I
> unblock these commands, the server returns the following text:
>
> --------------------------------------
[snip]
> More information about this error may be available in the server error log.
> --------------------------------------
So then, what did it say in the server error log?
--
Tad McClellan SGML consulting
tadmc@augustmail.com Perl programming
Fort Worth, Texas
------------------------------
Date: Tue, 5 Aug 2003 08:04:58 -0500
From: tadmc@augustmail.com (Tad McClellan)
Subject: Re: Final "Flocking" Script
Message-Id: <slrnbivarq.eqf.tadmc@magna.augustmail.com>
Gunnar Hjalmarsson <noreply@gunnar.cc> wrote:
> Put the following at the beginning of the script:
>
> use CGI::Carp 'fatalsToBrowser';
And be sure to *remove it* for production!
--
Tad McClellan SGML consulting
tadmc@augustmail.com Perl programming
Fort Worth, Texas
------------------------------
Date: Tue, 05 Aug 2003 16:20:12 +0200
From: Gunnar Hjalmarsson <noreply@gunnar.cc>
Subject: Re: Final "Flocking" Script
Message-Id: <bgof12$qa2ot$1@ID-184292.news.uni-berlin.de>
Tad McClellan wrote:
> Gunnar Hjalmarsson <noreply@gunnar.cc> wrote:
>>Put the following at the beginning of the script:
>>
>> use CGI::Carp 'fatalsToBrowser';
>
> And be sure to *remove it* for production!
What makes you say that, Tad? The CGI::Carp docs suggests that the
carpout() routine shouldn't be used for production for *performance*
reasons, but I don't think there is such a comment as regards
fatalsToBrowser(). Or is there any other reason for your advise?
--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl
------------------------------
Date: Tue, 5 Aug 2003 16:59:12 +0200
From: "Alan J. Flavell" <flavell@mail.cern.ch>
Subject: Re: Final "Flocking" Script
Message-Id: <Pine.LNX.4.53.0308051654400.14745@lxplus078.cern.ch>
On Tue, Aug 5, Gunnar Hjalmarsson inscribed on the eternal scroll:
> Tad McClellan wrote:
> > And be sure to *remove it* for production!
>
> What makes you say that, Tad? The CGI::Carp docs suggests that the
> carpout() routine shouldn't be used for production for *performance*
> reasons, but I don't think there is such a comment as regards
> fatalsToBrowser(). Or is there any other reason for your advise?
I don't know Tad's motivation, but: it can expose details of the
internals of your scripts to an intruder. The same goes for exposing
warnings within the browser window.
Of course, it also gives an unprofessional impression if it happens to
a bona fide user. Ideally you should cover all known failure modes at
development time, and supply user-friendly responses for them, rather
than exposing the end-users to what are _supposed_ to be your internal
diagnostics.
But indeed, during development these features can be _very_ useful.
--
"In the hardest of cases, I show them the W3C membership list: as
soon as the customer sees that MS is a member, then everything the
W3C says is good, and typically they even demand conformance with
W3C written into the contract" - (Matthias Esken, freely translated)
------------------------------
Date: Tue, 05 Aug 2003 17:35:23 +0200
From: Gunnar Hjalmarsson <noreply@gunnar.cc>
Subject: Re: Final "Flocking" Script
Message-Id: <bgoje5$qq5ib$1@ID-184292.news.uni-berlin.de>
Alan J. Flavell wrote:
> On Tue, Aug 5, Gunnar Hjalmarsson inscribed on the eternal scroll:
>> Tad McClellan wrote:
>>> And be sure to *remove it* for production!
>>
>> What makes you say that, Tad? The CGI::Carp docs suggests that
>> the carpout() routine shouldn't be used for production for
>> *performance* reasons, but I don't think there is such a comment
>> as regards fatalsToBrowser(). Or is there any other reason for
>> your advise?
>
> I don't know Tad's motivation, but: it can expose details of the
> internals of your scripts to an intruder. The same goes for
> exposing warnings within the browser window.
That aspect can I understand.
> Of course, it also gives an unprofessional impression if it happens
> to a bona fide user. Ideally you should cover all known failure
> modes at development time, and supply user-friendly responses for
> them, rather than exposing the end-users to what are _supposed_ to
> be your internal diagnostics.
I'm distributing a CGI script to largely novise users (mostly on
shared hosting accounts without access to the error logs...), and I'm
using the fatalsToBrowser() routine to display "user-friendly"
messages (from 'die' statements), mostly resulting from incorrect
configuration of the program. I have taken pains to prevent it from
revealing internal details that might be useful for intruders, and I
find fatalsToBrowser() more or less indispensable to help the users
install the program. "Internal Server Error" messages give a far less
professional impression IMO.
I'm aware that there are other methods to trap such error messages,
like using eval(), but I've found the fatalsToBrowser() routine to be
a convenient way.
--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl
------------------------------
Date: 04 Aug 2003 17:45:57 +0100
From: Brian McCauley <nobull@mail.com>
Subject: Re: for ($foo) {} vs. $_ = $foo;
Message-Id: <u9oez5nzga.fsf@wcl-l.bham.ac.uk>
JS Bangs <jaspax@u.washington.edu> writes:
> Whenever I need something like this, I'm in the habit of doing an
> explicit assignment to $_
>
> $_ = $foo;
As others have pointed out, that makes a copy of $foo not an alias to
$foo.
> Rather than:
>
> for ($foo) {}
>
> If I'm worried about scope, I'll put the whole thing in a bare block. Is
> there any tremendous reason not to do this?
Yes and no.
Personally I think
{
local *_ = \$foo;
# Do stuff
}
Is more ugly than
for ( $foo ) {
# Do stuff
}
It also has the disadvantage of localising %_ and @_ which you may not
want localised.
Of course, if you don't want aliasing, you might think you could
safely use:
{
local $_ = $foo;
# Do stuff
}
But you can't! There is a bug in Perl's tied variables that will bite
you sooner or later:
use Tie::Array;
tie my @q1, 'Tie::StdArray';
sub foo1 {
local $_ = 'BAZ';
print "@q1 $_\n";
}
@q1 = ('foo','bar');
for ( @q1 ) {
foo1;
}
--
\\ ( )
. _\\__[oo
.__/ \\ /\@
. l___\\
# ll l\\
###LL LL\\
------------------------------
Date: Mon, 4 Aug 2003 12:30:20 -0700
From: JS Bangs <jaspax@u.washington.edu>
Subject: Re: for ($foo) {} vs. $_ = $foo;
Message-Id: <Pine.A41.4.56.0308041228560.109844@dante38.u.washington.edu>
Brian McCauley sikyal:
> JS Bangs <jaspax@u.washington.edu> writes:
>
> > Whenever I need something like this, I'm in the habit of doing an
> > explicit assignment to $_
> >
> > $_ = $foo;
>
> As others have pointed out, that makes a copy of $foo not an alias to
> $foo.
This has never mattered to me in the past, but I can definitely see where
it might. Thanks to all for pointing this out.
> > Rather than:
> >
> > for ($foo) {}
> >
> > If I'm worried about scope, I'll put the whole thing in a bare block. Is
> > there any tremendous reason not to do this?
>
> Yes and no.
>
> Personally I think
>
> {
> local *_ = \$foo;
> # Do stuff
> }
>
> Is more ugly than
>
> for ( $foo ) {
> # Do stuff
> }
I agree. Now that I know this trick, I intend to start using it
immediately :).
--
Jesse S. Bangs jaspax@u.washington.edu
http://students.washington.edu/jaspax/
http://students.washington.edu/jaspax/blog
Jesus asked them, "Who do you say that I am?"
And they answered, "You are the eschatological manifestation of the ground
of our being, the kerygma in which we find the ultimate meaning of our
interpersonal relationship."
And Jesus said, "What?"
------------------------------
Date: 4 Aug 2003 23:39:49 GMT
From: Tina Mueller <usenet@expires082003.tinita.de>
Subject: Re: for ($foo) {} vs. $_ = $foo;
Message-Id: <bgmqs5$q9cuu$1@ID-24002.news.uni-berlin.de>
JS Bangs wrote:
> Whenever I need something like this, I'm in the habit of doing an
> explicit assignment to $_
> $_ = $foo;
> Rather than:
> for ($foo) {}
another point: that would leave $foo unchanged.
you'd have to do:
$foo = $_;
at the end of the block, anyway.
regards, tina
--
http://www.tinita.de/ \ enter__| |__the___ _ _ ___
http://Movies.tinita.de/ \ / _` / _ \/ _ \ '_(_-< of
http://www.perlquotes.de/ \ \ _,_\ __/\ __/_| /__/ perception
- my mail address expires end of august 2003 -
------------------------------
Date: 3 Aug 2003 17:23:35 -0700
From: jl_post@hotmail.com (J. Romano)
Subject: Getting a keystroke without Term::ReadKey
Message-Id: <b893f5d4.0308031623.7ca86c9b@posting.google.com>
Hi,
Many times I have run across posts from Perl programmers that ask
how they can make a Perl script record a single keystroke without
having to press the ENTER key. The simple solution is to use the
Term::ReadKey module. However, this is often not possible for many
Perl scripts because this module is not a standard Perl module.
The problem with non-standard Perl modules is that, in order to use
them, they must first be installed on the system on which the Perl
script that needs it to be run. To do this, the programmer must have
a C compiler (which is not always the case, especially on Win32
systems) or have access to the module's pre-compiled binary form for
that platform. And even once the programmer obtains the binary form
of the module, he or she must have administrator privileges to install
the module, or else modify some of the install files so that the
module can install locally on his or her account (I have done this,
and it isn't easy -- it hasn't always worked, either).
Not only that, but some Linux distributions are run directly off of
CDs (which are generally read-only filesystems) so they don't support
changes to the /usr directories (one such example is Knoppix, a
version of Linux that boots up straight from CD -- no installation
required. Because it runs from the CD, the user is pretty much
limited to the programs that are already found on the CD, which
includes Perl, but not the Term::ReadKey module). Since not every
Perl programmer is the administrator on the computer they use most,
simply installing Term::ReadKey is not always a realistic option (nor
as simple as many people would like it to be).
Aside from using the Term::ReadKey module, the programmer can read
a key by using some method in an OS-dependent fashion, like one
mentioned in the Perl cookbook. But then the program isn't very
portable at all.
So if Term::ReadKey is used, the script is not portable to systems
that don't have Term::ReadKey, and if some OS-dependent method is
used, the script is definitely not portable. Personally, I think this
is the reason why there are so many posts asking how to read a
keystroke in Perl. One of Perl's mottos is "Making easy things easy
and hard things possible" so naturally, many users think that Perl
should have a simple way of reading one keystroke without resorting to
installing a module from CPAN. (Incidentally, this is why I really
hope that Perl 6 has a standard way of reading single keystrokes
without having to get a module from CPAN.)
Not all CPAN modules suffer from the installation restrictions,
however. The Roman module (used to convert decimal numbers to and
from Roman numerals) does not require compilation. All that's needed
is to copy the Roman.pm file to the PERL5 include directory, and the
module should be in working order, with or without a C compiler or
root privileges. If more modules were constructed this way, there
would be less problems with using modules from CPAN (unfortunately,
this is just not possible for all modules). Simply stated, some
people CANNOT use a CPAN module unless it is written like the Roman.pm
module. (If anybody in this situation wants to be able to download
web pages without the LWP module, I recommend reading the "perldoc
perlipc" documentation in the section titled "A Webget Client.")
Therefore, I decided to write a little program uses several
OS-dependent tricks to be able to detect one keystroke in the hopes
that the programmer either uses an OS that is supported or can make a
small modification. This program uses the Term::ReadKey module only
if it is available (unless the program is running in a Win32
platform), otherwise it uses an OS-dependent method.
I tested this program on four different platforms (Win32 (using
ActiveState's ActivePerl), linux, sunos, and aix) and the program
behaves exactly the same on all of them. If you like this program's
functionality, feel free to use it yourself (in other words, this
program is public domain).
Since I don't have access to any BSD systems, I can't be sure it
works on BSD systems. Nevertheless, I put code in that I think works
on BSD systems, so if anybody would like to test it for me, that would
be appreciated. Likewise, if someone wants to add the functionality
for additional operating systems, that also would be appreciated.
Note that this script knows what system is used by comparing the
$^O variable to the @bsd and @non_bsd lists. I know that there is the
"-e /vmunix" trick, but I found an aix system that has a /vmunix file
(like BSD systems?) but does not like the BSD system command.
A quick thing to point out: Unix often allows users to hit CTRL-Z
to suspend the program. If this is done while the script is waiting
for a keystroke, and then the script is resumed, the script may have
lost its ability to detect a single keystroke (at least until the next
time the turnOffEcho() function is called).
Using this script, in order to detect a single keystroke, the
turnOffEcho() function must be called before the getKeyBlocking() and
getKeyNonBlocking() functions (or else they may not work correctly).
This means that when a key is detected, it will NOT be echoed back to
the user. To get around this, simply use a print statement to print
the key that was detected. Also, the getKeyInit() function must be
the first one called for any of the other functions to work correctly.
Please keep in mind that this script does not record arrow-key
presses correctly. Different platforms handle them differently, so it
would require extra coding to be able to extract them.
I decided to also include some cursor positioning functions that
should be portable on Win32 and Unix platforms. By no means are they
as complete as the Curses library, so if you want to add more
functions, feel free to.
Feel free to use my script, modify it, etc. as long as I not held
liable for anything bad that it might cause. It should be easy enough
to figure out how to use it by examining the code in the main package.
So, here it is:
#!/usr/bin/perl -w
use strict;
package PortableReadKey;
my $type;
my @bsd = qw();
my @non_bsd = qw(aix linux sunos);
use IO::Select;
my $s = IO::Select->new();
$s->add(\*STDIN);
my ($old_mode, $input_con, $output_con); # for win32
my ($saved_x, $saved_y) = (0,0); # for win32
sub getKeyInit {
if ($^O eq "MSWin32") {
unless (eval "require Win32::Console") {
die "Cannot find module Win32::Console";
}
$type = "win32";
$input_con = new Win32::Console(
Win32::Console::STD_INPUT_HANDLE() );
$old_mode = $input_con->Mode();
$output_con = new Win32::Console(
Win32::Console::STD_OUTPUT_HANDLE() );
} elsif (eval "require Term::ReadKey") {
# print "\nUsing Term::ReadKey...\n";
$type = "ReadKey";
} elsif (grep {$^O eq $_} @bsd) {
$type = "bsd";
} elsif (grep {$^O eq $_} @non_bsd) {
$type = "non_bsd";
} else {
print "Could not determinte type for \"$^O\".\nExiting...\n";
exit(1);
}
}
sub turnOffEcho {
my $break_out = 0;
if ($type eq "ReadKey") {
Term::ReadKey::ReadMode('cbreak');
} elsif ($type eq "bsd") {
# No idea if this works:
system "stty cbreak -echo </dev/tty >/dev/tty 2>&1";
$break_out = 1 if $?; # if true, user most likely hit CTRL-C
} elsif ($type eq "non_bsd") {
system("stty", '-echo', '-icanon', 'eol', "\001");
$break_out = 1 if $?; # if true, user most likely hit CTRL-C
} elsif ($type eq "win32") {
$input_con->Mode(
~(Win32::Console::ENABLE_LINE_INPUT()
| Win32::Console::ENABLE_ECHO_INPUT())
& $old_mode );
} else {
die "\nsub getKeyInit() was never called";
}
if ($break_out) {
PortableReadKey::turnOnEcho();
print "\n";
if (exists $SIG{INT} && $SIG{INT}) {
&{$SIG{INT}};
} else {
exit(1);
}
}
}
sub turnOnEcho {
my $break_out = 0;
if ($type eq "ReadKey") {
Term::ReadKey::ReadMode('normal');
} elsif ($type eq "bsd") {
# No idea if this works:
system "stty -cbreak echo </dev/tty >/dev/tty 2>&1";
$break_out = 1 if $?; # if true, user most likely hit CTRL-C
} elsif ($type eq "non_bsd") {
system("stty", 'echo', 'icanon', 'eol', '^@'); # ASCII null
$break_out = 1 if $?; # if true, user most likely hit CTRL-C
} elsif ($type eq "win32") {
$input_con->Mode( $old_mode);
} else {
die "\nsub getKeyInit() was never called";
}
if ($break_out) {
print "\n";
if (exists $SIG{INT} && $SIG{INT}) {
&{$SIG{INT}};
} else {
exit(1);
}
}
}
# The subroutine PortableReadKey::turnOffEcho() MUST
# be called before getKeyBlocking() for it to function
# correctly.
sub getKeyBlocking {
my $key;
if ($type eq "ReadKey") {
# For some reason this messes up when ENTER
# is pressed under MSWin32:
$key = Term::ReadKey::ReadKey(0);
} elsif ($type eq "bsd" or $type eq "non_bsd") {
$key = getc(STDIN);
} elsif ($type eq "win32") {
$key = $input_con->InputChar(1);
$key = "\n" if defined $key and ord($key) == 13;
} else {
die "\nsub getKeyInit() was never called";
}
return $key;
}
# The subroutine PortableReadKey::turnOffEcho() MUST
# be called before getKeyNonBlocking() for it to function
# correctly.
sub getKeyNonBlocking {
my $key;
if ($type eq "ReadKey") {
$key = Term::ReadKey::ReadKey(-1);
} elsif ($type eq "bsd" or $type eq "non_bsd") {
sysread(STDIN,$key,1) if $s->can_read(0);
} elsif ($type eq "win32") {
if ($input_con->PeekInput()) {
my @event = $input_con->Input();
# print " \@event = (@event)\n";
$key = chr($event[5])
if ($event[0] == 1 and $event[1] and $event[5]);
$key = "\n" if defined $key and ord($key) == 13;
}
} else {
die "\nsub getKeyInit() was never called";
}
return $key;
}
sub clearScreen {
if ($type eq "win32") {
$output_con->Cls();
} elsif ($type eq "bsd" or $type eq "non_bsd"
or $type eq "ReadKey") {
print "\e[2J"; # clear screen and move cursor
# to home position
print "\e[H"; # move cursor to home position
# (necessary for some systems)
} else {
die "\nsub getKeyInit() was never called";
}
}
sub moveCursorAbsolute {
my ($x, $y) = @_;
# Note that negative values may not give
# the desired results.
if ($type eq "win32") {
$output_con->Cursor($x, $y);
} elsif ($type eq "bsd" or $type eq "non_bsd"
or $type eq "ReadKey") {
printf("\e[%d;%dH", $y, $x);
} else {
die "\nsub getKeyInit() was never called";
}
}
sub moveCursorRelative {
my ($x, $y) = @_;
if ($type eq "win32") {
my ($current_x, $current_y) = $output_con->Cursor();
# Note that negative values may not give
# the desired results.
$x += $current_x;
$y += $current_y;
$x = 0 if $x < 0;
$y = 0 if $y < 0;
$output_con->Cursor($x, $y);
} elsif ($type eq "bsd" or $type eq "non_bsd"
or $type eq "ReadKey") {
if ($x > 0) { # Go right:
printf("\e[%dC", $x);
} elsif ($x < 0) { # Go left:
printf("\e[%dD", -$x);
}
if ($y > 0) { # Go down:
printf("\e[%dB", $y);
} elsif ($y < 0) { # Go up:
printf("\e[%dA", -$y);
}
} else {
die "\nsub getKeyInit() was never called";
}
}
sub saveCursorPosition {
if ($type eq "win32") {
($saved_x, $saved_y) = $output_con->Cursor();
} elsif ($type eq "bsd" or $type eq "non_bsd"
or $type eq "ReadKey") {
print "\e[s";
} else {
die "\nsub getKeyInit() was never called";
}
}
sub restoreCursorPosition {
if ($type eq "win32") {
$output_con->Cursor($saved_x, $saved_y);
} elsif ($type eq "bsd" or $type eq "non_bsd"
or $type eq "ReadKey") {
print "\e[u";
} else {
die "\nsub getKeyInit() was never called";
}
}
package main;
$| = 1; # autoflush
PortableReadKey::getKeyInit();
PortableReadKey::clearScreen();
my $key;
PortableReadKey::turnOffEcho();
print "Press a key for an example of a blocking read...\n";
$key = PortableReadKey::getKeyBlocking();
# print "ASCII = ", ord($key), "\n";
$key = "[ENTER]" if $key eq "\n";
$key = "[ESCAPE]" if $key eq "\e";
$key = "[BACKSPACE]"
if $key eq "\b" or $key eq "\cH" or $key eq "\c?";
# Now check for CTRL combinations:
eval qq/\$key = "[CTRL-$_]"
if \$key eq "\\c$_"/ for ('A' .. 'Z');
print "\n";
print "Good! You pressed \"$key\"!\n\n";
my $num_secs = 30;
print <<"END_INSTRUCTIONS";
Now, after you press ENTER, you can type for the next
$num_secs seconds. A '.' will be printed every second.
Any key you type will show up as the '*' symbol.
This is an example of a non-blocking read.
END_INSTRUCTIONS
PortableReadKey::moveCursorAbsolute(3,10);
print "Press ENTER when ready.";
# Warning on win32 systems: when the echo is turned off,
# reading from <STDIN> won't work, even to read
# an ENTER keypress.
PortableReadKey::turnOnEcho();
<STDIN>;
print "\n";
print "Now, type!";
PortableReadKey::moveCursorRelative(-4,1);
PortableReadKey::turnOffEcho();
my $input = "";
my ($start_time, $current_time);
$start_time = $current_time = time;
print ".";
while (time - $start_time < $num_secs) {
PortableReadKey::turnOffEcho();
$current_time != time and ($current_time = time and print ".");
my $key = PortableReadKey::getKeyNonBlocking();
$input .= $key, print "*" if defined $key;
}
PortableReadKey::turnOnEcho();
print qq(\n\nYou typed "$input".\n);
print "Now for examples of cursor positioning.\n";
print "Hit ENTER to continue."; <STDIN>;
PortableReadKey::clearScreen();
PortableReadKey::moveCursorAbsolute(10,10);
print "Now at (10,10). (Press ENTER)";
PortableReadKey::saveCursorPosition();
<STDIN>;
PortableReadKey::moveCursorAbsolute(5,5);
print "Now at (5,5). (Press ENTER)";
<STDIN>;
PortableReadKey::restoreCursorPosition();
print "Back to previous position!\n\n";
__END__
Well, that's it! Have fun with it!
-- Jean-Luc Romano
------------------------------
Date: 6 Apr 2001 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 6 Apr 01)
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.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 V10 Issue 5315
***************************************
