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 browsing the Monastery: (13)
As of 2014-07-29 19:03 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (226 votes), past polls