use IO::Handle; use IO::Select; use Tk; use Tk::Button; use Storable; use DBI; # Author: James Moosmann , 2004 # Info: Non-block Tk Child #Set up 2 way communication with child pipe PREAD, CWRITE; pipe CREAD, PWRITE; my %hash; my $href =\ %hash; my $sql_statement = "SELECT * FROM Customers"; $|=1; my $ID; my $tmpdir = $ENV{TEMP}; $tmpdir =~s/\\/\//ig; my $tempfile = $tmpdir."/hash.dat"; my $mw = tkinit; my $var = "Status: "; my $l = $mw->Label(-text, "Message: ", -textvariable, \$var)->pack(-side, 'top'); my $txt = $mw->Text(-height, 2, -width, 40)->pack(-expand, 1, -fill, 'both', -pady, 4, -padx, 4); $txt->insert('end', $sql_statement); my $b = $mw->Button(-text, "Run", -width, 10, -command, sub { &send_msg($txt->get('0.1','end')); })->pack(); #$mask = 0; #vec($mask, fileno(STDIN), 1); #vec($mask, fileno(PREAD), 1); #my ($read, $write) = ($mask, $mask); my $pid = fork(); if($pid==0){ # $pid == 0 for the child... this will act as our AGENT for processing long running DBI calls # We have to create the child before we enter the MainLoop in Tk or Tk goes bonkers... # DO NOT attempt to create any widgets from here... and do not attempt to land on Europa # Perhaps we could eval an output of the child to create widgets ? close CWRITE; close CREAD; #my $dbh = DBI->connect('dbi:ODBC:data'); while(1){ #select(undef,undef,undef, 0.05); #dead end # This seems to work fine... it doesn't block and tells me if data is there # when $r == NO Bytes to read # when $r > 0 we have a sql statment to read and process my ($r) =(stat(PREAD))[7]; #<<<--- No Block :0) tells me if I have data... I just poll for it if($r > 0){ while(){ my $t = time; my $msg = $_; my $sth; # $sth = $dbh->prepare($_); # my $err = $dbh->errstr; #unless( $err){ #$sth->execute(); #while(my $hr = $sth->fetchrow_hashref){ # foreach(keys %$hr){ # $hash{$_} = $$hr{$_}; # } #} #} for(1..10){ sleep 1; $hash{$_} = $msg. ": ".$_; } print "Finished in ", (time-$t), "secs \n"; #Data is not shared between parent and child #so we will use storable module to do this for use :) #maybe slow, but at least we can use complex structures store \%hash, $tempfile; if($err=~/\w/){ $msg = "Error:".$err; }else{ $msg = "OK"; } syswrite PWRITE, "$msg\n"; last; } } } # This will likely become a zombie... # bind to a destroy to reap this puppy } close PREAD; close PWRITE; $mw->bind('', sub{ &_cleanup;}); MainLoop; sub send_msg { my $sql = $_[0]; $sql =~s/\n/\r/g; syswrite CWRITE, $sql."\n"; $ID = $mw->repeat(100, \&datacheck); } sub datacheck{ #Do we have anything to get? my ($r) =( stat(CREAD))[7]; # <<<---- Doesn't block :o) $var = "Status: "; my $var1; if ($r > 0){ $ID->cancel; while(){ chomp; $var1 .= $_; %hash = %{retrieve($tempfile)}; $var1 =~s/Error:.*]\s+The/The/ig; $var1 =~s/\(.*\)//ig; if($r>0){ my (@list) = split /\./, $var1; $var .= "$_.\n" foreach @list; $var=~s/\n\.\n+$//g;} print "$_ => $hash{$_}\n" for keys %hash; last; } } } sub _cleanup { kill 9, $pid; unlink $tempfile; } __END__