Changeset 17537 for gsdl/trunk/perllib/downloaders/WgetDownload.pm

Timestamp:

2008-10-15T12:41:28+13:00 (16 years ago)

Author:

ak19

Message:

Subroutine useWgetMonitored updated to include the modifications made recently to subroutine useWget: uses a serverSocket to monitor any signals from GLI indicating that wget should be prematurely terminated.

File:

• gsdl/trunk/perllib/downloaders/WgetDownload.pm (modified) (3 diffs)

gsdl/trunk/perllib/downloaders/WgetDownload.pm

@@ -304 +304 @@
 sub useWgetMonitored
 {
+    #local $| = 1; # autoflush stdout buffer
+    #print STDOUT "*** Start of subroutine useWgetMonitored in $0\n";
+
     my ($self, $cmdWget,$blnShow, $working_dir) = @_;
 
@@ -313 +316 @@
     $changed_dir = 1;
     }
+
+    # When we are running this script through GLI, the SIGTERM signal handler 
+    # won't get called on Windows when wget is to be prematurely terminated. 
+    # Instead, when wget has to be terminated in the middle of execution, GLI will
+    # connect to a serverSocket here to communicate when it's time to stop wget.
+    if(defined $self->{'gli'} && $self->{'gli'} && !defined $port) {
+
+    $port = <STDIN>; # gets a port on localhost that's not yet in use
+    chomp($port);
+    
+    $serverSocket = IO::Socket::INET->new( Proto     => 'tcp',
+                           LocalPort => $port,
+                           Listen    => 1,
+                           Reuse     => 1);
+    
+    die "can't setup server" unless $serverSocket;
+    #print STDOUT "[Serversocket $0 accepting clients at port $port]\n";
+
+    $read_set = new IO::Select();         # create handle set for reading
+    $read_set->add($serverSocket);        # add the main socket to the set
+    }
+
     my $wget_file_path = &util::filename_cat($ENV{'GSDLHOME'}, "bin", $ENV{'GSDLOS'}, "wget");
     #my $command = "\"$wget_file_path\" $cmdWget 2>&1 |"; #open(*WIN,$command) || die "wget request failed: $!\n";
-###    print STDERR "**** wget cmd = $command\n";
-    #open(*WIN,$command) || die "wget request failed: $!\n";
-
-    my $command = "\"$wget_file_path\" $cmdWget";
+    my $command = "\"$wget_file_path\" $cmdWget 2>&1";
+    # print STDERR "Command is: $command\n";
     $childpid = open2($chld_out, $chld_in, $command) || die "wget request failed: $!\n";
 
@@ -326 +349 @@
     my $line;
 
-    while (defined($line=<$chld_out>)) # we're reading in from child process' stdout
-    {
-    if((defined $blnShow) && $blnShow)
-    {
-        print STDERR "$line";
-    }
-
-    if ($line =~ m/^Location:\s*(.*?)\s*\[following\]\s*$/i) {
-        my $follow_url = $1;
-        push(@follow_list,$follow_url);
-    }
-
-    if ($line =~ m/ERROR\s+\d+/) {
-        $error_text .= $line;
-    }
-
-    $full_text .= $line;
-    }
-
-    close($chld_in);
-    close($chld_out);
-
-    # Program terminates only when the following line is included 
-    # http://perldoc.perl.org/IPC/Open2.html explains why this is necessary
-    # it prevents the child from turning into a "zombie process".
-    # While the wget process terminates without it, this perl script does not: 
-    # the DOS prompt is not returned without it.
-    waitpid $childpid, 0;
+    my $loop = 1;
+    while($loop)
+    {
+    if (defined($line=<$chld_out>)) { # we're reading in from child process' stdout
+        if((defined $blnShow) && $blnShow)
+        {
+        print STDERR "$line";
+        }
+        
+        if ($line =~ m/^Location:\s*(.*?)\s*\[following\]\s*$/i) {
+        my $follow_url = $1;
+        push(@follow_list,$follow_url);
+        }
+        
+        if ($line =~ m/ERROR\s+\d+/) {
+        $error_text .= $line;
+        }
+        
+        $full_text .= $line;
+    } 
+    else { # wget finished, terminate naturally
+        #print STDERR "\nPerl: open2 command, input stream closed. Wget terminated naturally.\n";
+        close($chld_in);
+        close($chld_out);
+        # Program terminates only when the following line is included 
+        # http://perldoc.perl.org/IPC/Open2.html explains why this is necessary
+        # it prevents the child from turning into a "zombie process".
+        # While the wget process terminates without it, this perl script does not: 
+        # the DOS prompt is not returned without it.
+        waitpid $childpid, 0;
+        $loop = 0;
+        
+        $childpid = undef;
+        if(defined $port) {
+        $read_set->remove($serverSocket);
+        close($serverSocket);
+        }
+    }
+
+    # if we run this script from the command-line (as opposed to from GLI), 
+    # then we're not working with sockets and can therefore can skip the next bits
+    next unless(defined $port);
+
+    # http://www.perlfect.com/articles/select.shtml
+    # "multiplex between several filehandles within a single thread of control, 
+    # thus creating the effect of parallelism in the handling of I/O."
+    my @rh_set = $read_set->can_read(0.002); # every 2 ms check if there's a client socket connecting
+
+    # take all readable handles in turn
+    foreach my $rh (@rh_set) {
+        if($rh == $serverSocket) {
+        my $client = $rh->accept();
+        #$client->autoflush(1); # autoflush output buffer - don't put this back in: splits output irregularly over multilines
+        print $client "Talked to ServerSocket (port $port). Connection accepted\n";
+        
+        # Read from the client (getting rid of trailing newline)
+        # Has the client sent the <<STOP>> signal?
+        my $signal = <$client>;
+        chomp($signal); 
+        if($signal eq "<<STOP>>") {
+            print $client "Perl received STOP signal (on port $port): stopping wget\n";
+            
+            $loop = 0;
+            close($chld_in);
+            close($chld_out);
+            kill("TERM", $childpid);
+            
+            $childpid = undef;
+
+            # Stop monitoring the read_handle
+            # close the serverSocket (the Java end will close the client socket that Java opened)
+            $read_set->remove($rh); #$read_set->remove($serverSocket);
+            close($rh);         #close($serverSocket);
+            #print $client "Perl is about to exit\n";
+            last;
+        }
+        }
+    }
+    }
 
     my $command_status = $?;