Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Another Win32 Tk fileevent work around : using ioctl() properly

by bitshiftleft (Sexton)
on Jul 14, 2009 at 21:42 UTC ( #780083=CUFP: print w/ replies, xml ) Need Help??

The Win32 version to the unix ioctl() is DeviceIoControl.
To communicate with device drivers you can use the standard module:

use Win32API::File qw( :ALL );
... the rest of your perl code ...
$result = DeviceIoControl( $handle,....)

which gives you far more capabilities if your Administrator.
The ioctl() under Win32 actually maps to ioctlsocket() by the ActiveState docs.

Many earlier postings used:

$nonblocking = 1;
ioctl($socket,0x8004667e,\$nonblocking);

This will unblock the socket , but for the wrong reason .

\$nonblocking returns an address to a small memory structure that perl maintains
the variable with. That address is readable and will never have the value of zero.
As a result you get a nonblocking socket.
You will NOT get a BLOCKING socket if you use:
$nonblocking = 0; # remains non blocking !!!!

The third argument in ioctl() expects a pointer to a long.
Apparently, this is not the case for perls under UNIX, - I haven't tried that.

The correct way to use ioctl() is:

$nonblocking = "\x00\x00\x00\x01"; # pack("L",1) works too
use constant FIONBIO => 0x8004667e;
$PtrToLong = unpack("I",pack('P',$nonblocking)); # get address to the variable contents, not it's reference structure
ioctl($socket, FIONBIO,$PtrToLong );

Now that you are the wiser , you breath easy and say "GREAT" I don't have to fix any code.
Ignorance is not always bliss.
Consider what more you can do with this.

I took Steve Lidie's Mastering Perl/Tk fileevent sockets work around for Win32.
I removed the very important polling line: my(@ready) = $sel->can_read(0);
and used:

use constant FIONREAD => 0x4004667f;
our $numbytes = "\x00" x 4; # pack('L',0) works too
ioctl($socket, FIONREAD, unpack('I',pack('P',$numbytes)));
$nbytes = unpack('I',$numbytes);
return if $nbytes == 0;

This returns how many bytes on the socket to be read, blocking or not !!!!.
If its zero bytes the Tk repeat event continues as before.

I left out the UNIX part of this code during changing it ,
but I will leave it for you to put it in(easy).

Here is a small CONSOLE Capture Tk application.
Execute as:
c:\> perl.exe TkClient.pl 2>&1 | perl.exe IO_server.pl
# TkClient.pl # A modification of the fileevent work around on Win32, from the book +: "Mastering Perl/Tk", # by Steve Lidie and Nancy Walsh pp 492-493 # USAGE: open a DOS32 CONSOLE (Yes!!! CMD.EXE is 32 bit, COMMAND.COM 1 +6 bit) and type: # c:\> perl.exe TkClient.pl 2>&1 | perl.exe IO_server.pl # Don't forget to leave in "perl.exe" for this to work properly use Tk ; use Tk ':variables'; use Tk::Event; use POSIX ":sys_wait_h"; use strict; our $mw = MainWindow->new( -title => "Tk client"); $mw->geometry('325x250'); our $programs = $mw->Button(-text => 'EXEC CODE ', -width => 35, -acti +vebackground => 'steelblue', -command => \&myprograms) ->place(-anchor => 'nw', -relx => 0.10, -rely => 0.60, -relwidth = +> .28); our $quitbttn = $mw->Button(-text => 'QUIT ', -width => 35, -activebac +kground => 'steelblue', -command => \&exit) ->place(-anchor => 'nw', -relx => 0.10, -rely => 0.80, -relwidth = +> .28); ################# output text box toplevel ########### our $polling; our $sock; our $sel; our $numbytes = "\x00" x 4; # pack('L' works too my $dbgout = $mw->Toplevel; $dbgout->title('CAPTURED FILTERED OUTPUT'); my $textdbg = $dbgout->Scrolled('Text', -scrollbars => 'osoe')->pa +ck; $textdbg->Subwidget("text")->configure(-width => 80, -height => 25 + ,-wrap => 'none'); if ($^O eq 'MSWin32') { use IO::Socket; use constant FIONBIO => 0x8004667e; # winsock2.h macro use constant FIONREAD => 0x4004667f; # winsock2.h macro my $nonblocking = "\x00\x00\x00\x01"; # long nonblocking != 0; $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '10254', Proto => 'tcp', ) or die "IO::Socket::INET: $!"; ioctl($sock, FIONBIO, unpack("I",pack('P',$nonblocking))) == 0 or +die "ioctlsocket(\$sock, FIONBIO,...):$!" ; $polling = $mw->repeat(50 => \&read_sock); } #################### EVENTLOOP ############################### MainLoop; exit; #################### SUBROUTINES ############################# sub read_sock { my $hand = $sock; my ($stat,$buf,$content,$line,$nbytes); if ($^O eq 'MSWin32') { ioctl($hand, FIONREAD, unpack('I',pack('P',$numbytes))) == 0 o +r die "ioctlsocket(\$hand, FIONREAD,...):$!" ; $nbytes = unpack('I',$numbytes); $nbytes == 0 ? return : $polling->cancel; # not re-entrant } $stat = sysread $hand, $buf, $nbytes; $line .= $buf if $stat > 0; $line = "sysread error: $!\n" unless defined $stat; # filter the text using regular expressions here, then: $textdbg->insert('end',"$line"); $textdbg->yviewMoveto(1.0); $polling = $mw->repeat(50 => \&read_sock) if ($^O eq 'MSWin32'); # + restart repeat } sub myprograms{ # put your external calls here # system(1, ...) returns immediately - great with Tk event loop my $cpid; $cpid = system(1,"echo --- Start of test ---"); TkUpdates(); $cpid = system(1,"ipconfig"); TkUpdates(); $cpid = system(1,"ping -n 3 localhost"); TkUpdates(); $cpid = system(1,"dir"); TkUpdates(); $cpid = system(1,"echo --- End of test ---"); TkUpdates(); } sub TkUpdates{ my ($kid,$status); do { $kid = waitpid(-1,&WNOHANG); # wait for all child processes to f +inish $status = $?; $mw->update; # LET Tk DO UPDATES } until $kid == -1; }
# IO_server.pl # see also: # http://aspn.activestate.com/ASPN/Mail/Message/perl-tk/1857686 use IO::Socket; use File::Basename; use strict; our $data; my $socket = IO::Socket::INET-> new( Listen => 5, Reuse => 1, LocalPort => 10254, Proto => 'tcp', ) or die "Couldn't open socket: $!"; print basename($0)," started\n"; my $new_sock = $socket->accept(); while ($data = <STDIN>) { print $data; # tee syswrite $new_sock, $data; }

Comment on Another Win32 Tk fileevent work around : using ioctl() properly
Select or Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://780083]
Approved by jdrago_999
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (6)
As of 2015-07-05 21:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (68 votes), past polls