|
1 # Copyright (c) 2003-2009 Nokia Corporation and/or its subsidiary(-ies). |
|
2 # All rights reserved. |
|
3 # This component and the accompanying materials are made available |
|
4 # under the terms of "Eclipse Public License v1.0" |
|
5 # which accompanies this distribution, and is available |
|
6 # at the URL "http://www.eclipse.org/legal/epl-v10.html". |
|
7 # |
|
8 # Initial Contributors: |
|
9 # Nokia Corporation - initial contribution. |
|
10 # |
|
11 # Contributors: |
|
12 # |
|
13 # Description: |
|
14 # |
|
15 |
|
16 package BuildServer; |
|
17 |
|
18 use strict; |
|
19 |
|
20 use FindBin; # for FindBin::Bin |
|
21 use lib "$FindBin::Bin/lib/freezethaw"; # For FreezeThaw |
|
22 |
|
23 # Other necessary modules. For "use Scanlog;" see dynamic code below. |
|
24 use Carp; |
|
25 use Msg; |
|
26 use ParseXML; |
|
27 use FreezeThaw qw(freeze thaw); |
|
28 use IO::File; |
|
29 use File::Basename; |
|
30 use File::Copy; |
|
31 use Compress::Zlib; # For decompression library routines |
|
32 |
|
33 |
|
34 # Globals |
|
35 my @gCommands; # Holds the parsed "Execute" data from the XML file. |
|
36 my @gSetEnv; # Holds the parsed "SetEnv" data from the XML file. |
|
37 my $gIDCount = 0; # The current Execute ID we're processing. |
|
38 my $gStage; # The current Stage we're in. |
|
39 my %gClientEnvNum; # Holds the current index into @gSetEnv for each client. Indexed by client name. |
|
40 my %gClientStatus; # Holds the status of each client. Indexed by client name. |
|
41 my %gClientHandles; # Holds the socket of each client. Indexed by client name |
|
42 my $gLogFileH; # The logfile. |
|
43 my $gLogStarted = 0; # Boolean to say if the logfile has been started. |
|
44 my $gRealTimeError = ""; # "" = No error, otherwise a string significant to AutoBuild's log parsing |
|
45 my $gScanlogAvailable = 0; # Boolean to say if scanlog is available. |
|
46 my $gExit = 0; # 0 = FALSE (Do not exit) # 1 = TRUE (Send Exit to all clients for next command) |
|
47 |
|
48 |
|
49 |
|
50 # Check if HiRes Timer is available |
|
51 my ($gHiResTimer) = 0; #Flag - true (1) if HiRes Timer module available |
|
52 if (eval "require Time::HiRes;") { |
|
53 $gHiResTimer = 1; |
|
54 } else { |
|
55 print "Cannot load HiResTimer Module\n"; |
|
56 } |
|
57 |
|
58 |
|
59 # Check if Scanlog.pm is available. |
|
60 # In the Perforce order of things, scanlog.pm is in directory ".\scanlog" relative to BuildServer.pl |
|
61 # However, at build time, BuildServer.pl is in "\EPOC32\Tools\Build" while scanlog.pm is in "\EPOC32\Tools" |
|
62 # i.e. in the parent directory relative to BuildServer.pl |
|
63 # If Scanlog cannot be found in either place, we continue, but the Scanlog functionality will be skipped. |
|
64 if (eval {require scanlog::Scanlog;}) |
|
65 { |
|
66 $gScanlogAvailable = 1; |
|
67 } |
|
68 elsif (eval {use lib $FindBin::Bin.'/..'; require Scanlog;}) |
|
69 { |
|
70 $gScanlogAvailable = 1; |
|
71 } |
|
72 else |
|
73 { |
|
74 print "Cannot load Scanlog Module\n"; |
|
75 } |
|
76 |
|
77 # GetServerVersion |
|
78 # |
|
79 # Inputs |
|
80 # |
|
81 # Outputs |
|
82 # Server Version Number |
|
83 # |
|
84 # Description |
|
85 # This function returns the server version number |
|
86 sub GetServerVersion |
|
87 { |
|
88 return "1.3"; |
|
89 } |
|
90 |
|
91 # rcvd_msg_from_client |
|
92 # |
|
93 # Inputs |
|
94 # $iConn (Instance of the Msg Module) |
|
95 # $msg (the recieved message from the client) |
|
96 # $err (any error message from the Msg Module) |
|
97 # |
|
98 # Outputs |
|
99 # |
|
100 # Description |
|
101 # This function processes the incoming message from the BuildClient and acts upon them |
|
102 sub rcvd_msg_from_client { |
|
103 my ($iConn, $msg, $err) = @_; |
|
104 |
|
105 # If the message is empty or a "Bad file descriptor" error happens then it |
|
106 # usually means the the BuildServer has closed the socket connection. |
|
107 # The BuildClient will keep trying to connect to a BuildServer |
|
108 if (($msg eq "") || ($err eq "Bad file descriptor")) |
|
109 { |
|
110 print "A client has probably Disconnected\n"; |
|
111 croak "ERROR: Cannot recover from Error: $err\n"; |
|
112 } |
|
113 |
|
114 # Thaw the message, this decodes the text string sent from the client back into perl variables |
|
115 my ($iCommand, $iClientName, $iID, $iStage, $iComp, $iCwd, $iCommandline, $args) = thaw ($msg); |
|
116 |
|
117 # Handle a "Ready" command. A client wishes to connect. |
|
118 if ( $iCommand eq "Ready") |
|
119 { |
|
120 # Check the Client Version. $iID holds the client version in the "Ready" message. |
|
121 if ($iID ne &GetServerVersion) |
|
122 { |
|
123 die "ERROR: Client version \"$iID\" does not match Server version \"".&GetServerVersion."\", cannot continue\n"; |
|
124 } |
|
125 # Handle the initial "Ready" Command from the client |
|
126 # Check that the Client name is unique |
|
127 if (defined $gClientHandles{$iClientName}) |
|
128 { |
|
129 # The Client name is not unique, a client by this name has already connected |
|
130 warn "WARNING: Multiple Clients using the same name\n"; |
|
131 warn "Adding random number to client name to try and make it unique\n"; |
|
132 warn "This will affect the preference order of the Clients\n"; |
|
133 # Generate a ramdom number to add to the client name. |
|
134 my ($iRNum) = int(rand 10000000); |
|
135 $iClientName .= $iRNum; |
|
136 print "Changing ClientName to \"$iClientName\"\n"; |
|
137 # Send the new Client name to the client |
|
138 my $iMsg = freeze("ChangeClientName", $iClientName); |
|
139 $iConn->transmit_immediately($iMsg); |
|
140 } |
|
141 |
|
142 # Add the connection object to the store of connections |
|
143 $gClientHandles{$iClientName} = $iConn; |
|
144 |
|
145 # Write the header to the logfile on first connection only |
|
146 if ( $gLogStarted == 0) |
|
147 { |
|
148 # The start of the log file only needs to be printed once |
|
149 $gLogStarted = 1; |
|
150 &PrintStageStart; |
|
151 } |
|
152 |
|
153 # Set Environment Variable counter to zero |
|
154 # This client has not been sent any environment variables yet |
|
155 $gClientEnvNum{$iClientName} = 0; |
|
156 # Set the $iCommand variable so that we begin sending Environment Variables |
|
157 $iCommand = "SetEnv Ready"; |
|
158 } |
|
159 |
|
160 # Handle the "SetEnv Ready" command. The client is ready for a command or env var. |
|
161 if ( $iCommand eq "SetEnv Ready") |
|
162 { |
|
163 # If there are any environment variables to be set, send the next one to the client to set it |
|
164 if (defined $gSetEnv[$gClientEnvNum{$iClientName}]) |
|
165 { |
|
166 &Send_SetEnv($iConn, $gClientEnvNum{$iClientName}); |
|
167 $gClientEnvNum{$iClientName}++; |
|
168 } else { |
|
169 # The client has gone through the connect process and has been sent all its environment variables |
|
170 # Add this client to the list of client ready to process commands |
|
171 AddReady($iClientName, $iConn); |
|
172 } |
|
173 } |
|
174 |
|
175 # Handle the "Results" command. The client has finished a step and given us the results. |
|
176 if ( $iCommand eq "Results") |
|
177 { |
|
178 $args = Decompress($args); # Decompress the results. |
|
179 |
|
180 # If Scanlog has been found, check returned text for real time error string. |
|
181 # If a client reports a real time error, set global flag. We can't just die here and |
|
182 # now; instead we must wait for other "busy" clients to finish their current tasks. |
|
183 if ($gScanlogAvailable) |
|
184 { |
|
185 if (Scanlog::CheckForRealTimeErrors($args)) |
|
186 { |
|
187 # Command returned a RealTimeBuild error - abort this script, |
|
188 # and propagate it up to our parent process |
|
189 $gRealTimeError = "RealTimeBuild:"; |
|
190 } |
|
191 elsif ($gCommands[$iID]{'ExitOnScanlogError'} =~ /y/i && Scanlog::CheckForErrors($args) ) |
|
192 { |
|
193 # This is a critical step - flag a real time error, |
|
194 # and don't process anything else in this script |
|
195 $gRealTimeError = "Realtime error (ExitOnScanlogError)"; |
|
196 } |
|
197 } |
|
198 |
|
199 # Print the correct headers for an individual command to the log |
|
200 print $gLogFileH "=== Stage=$gStage == $iComp\n"; |
|
201 print $gLogFileH "-- $iCommandline\n"; |
|
202 print $gLogFileH "--- $iClientName Executed ID ".($iID+1)."\n"; |
|
203 # Print the output of the command into the log |
|
204 print $gLogFileH "$args"; |
|
205 # Flush the handle to try and make sure the logfile is up to date |
|
206 $gLogFileH->flush; |
|
207 # Add this client to the list of client ready to process commands |
|
208 AddReady($iClientName, $iConn); |
|
209 } |
|
210 } |
|
211 |
|
212 # Send_SetEnv |
|
213 # |
|
214 # Inputs |
|
215 # $iOrder - index into @gSetEnv |
|
216 # |
|
217 # Outputs |
|
218 # Sends frozen SetEnv message |
|
219 # |
|
220 # Description |
|
221 # This function is used to produce frozen SetEnv messages from the hash and then sends its |
|
222 sub Send_SetEnv |
|
223 { |
|
224 my ($iConn, $iOrder) = @_; |
|
225 |
|
226 my $iName = $gSetEnv[$iOrder]{'Name'}; |
|
227 my $iValue = $gSetEnv[$iOrder]{'Value'}; |
|
228 |
|
229 my $iMsg = freeze ('SetEnv', $iName, $iValue); |
|
230 |
|
231 $iConn->transmit_immediately($iMsg); |
|
232 } |
|
233 |
|
234 |
|
235 # login_proc |
|
236 # |
|
237 # Inputs |
|
238 # |
|
239 # Outputs |
|
240 # |
|
241 # Description |
|
242 # This function can be used to process a login procedure |
|
243 # No login procedure is implemented |
|
244 sub login_proc { |
|
245 # Unconditionally accept |
|
246 \&rcvd_msg_from_client; |
|
247 } |
|
248 |
|
249 # Start |
|
250 # |
|
251 # Inputs |
|
252 # $iDataSource (XML Command file) |
|
253 # $iPort (Port number to listen on for Build Clients) |
|
254 # $iLogFile (Logfile to write output from Build Clients to) |
|
255 # |
|
256 # Outputs |
|
257 # |
|
258 # Description |
|
259 # This function starts the server |
|
260 |
|
261 sub Start |
|
262 { |
|
263 my ($iDataSource, $iPort, $iLogFile, $iEnvSource, $iConnectionTimeout, $iSocketConnections) = @_; |
|
264 |
|
265 my ($iHost) = ''; |
|
266 |
|
267 # Open the log file for writing, it will not overwrite logs |
|
268 $gLogFileH = IO::File->new("> $iLogFile") |
|
269 or croak "ERROR: Couldn't open \"$iLogFile\" for writing: $!\n"; |
|
270 |
|
271 # If $iEnvSource is defined the Environment needs to be processed from this file |
|
272 if (defined $iEnvSource) |
|
273 { |
|
274 # Parse the XML data |
|
275 my ($iCommands, $iSetEnv) = &ParseXML::ParseXMLData($iEnvSource); |
|
276 push @gSetEnv, @$iSetEnv; |
|
277 } |
|
278 |
|
279 # Parse the XML data |
|
280 my ($iCommands, $iSetEnv) = &ParseXML::ParseXMLData($iDataSource); |
|
281 push @gCommands, @$iCommands; |
|
282 push @gSetEnv, @$iSetEnv; |
|
283 |
|
284 # Assuming there are commands to be executed, initialise the "current stage" |
|
285 # variable with the stage of the first command |
|
286 $gStage = $gCommands[$gIDCount]{'Stage'} if (scalar @gCommands); |
|
287 |
|
288 # Create the TCP/IP listen socket |
|
289 Msg->recent_agent($iPort, $iHost, \&login_proc, $iConnectionTimeout, $iSocketConnections); |
|
290 print "BuildServer created. Waiting for BuildClients\n"; |
|
291 # Enter event loop to process incoming connections and messages |
|
292 Msg->result_iteration(); |
|
293 } |
|
294 |
|
295 |
|
296 # SendCommand |
|
297 # |
|
298 # Inputs |
|
299 # $iConn - the socket to use |
|
300 # $iID - the ID of the command |
|
301 # |
|
302 # Outputs |
|
303 # Command or file or file request sent via TCP connection |
|
304 # |
|
305 # Description |
|
306 # Sends the command or file or file request indexed by $iID to the client |
|
307 sub SendCommand |
|
308 { |
|
309 my ($iConn, $iID) = @_; |
|
310 |
|
311 my $msg; |
|
312 my $iData; |
|
313 |
|
314 $msg = freeze ($gCommands[$iID]{'Type'}, $iID, $gCommands[$iID]{'Stage'}, $gCommands[$iID]{'Component'}, $gCommands[$iID]{'Cwd'}, $gCommands[$iID]{'CommandLine'}); |
|
315 |
|
316 |
|
317 $iConn->transmit_immediately($msg); |
|
318 } |
|
319 |
|
320 |
|
321 # AddReady |
|
322 # |
|
323 # Inputs |
|
324 # $iClientName (Client name) |
|
325 # $iConn (Connection Object) |
|
326 # |
|
327 # Outputs |
|
328 # |
|
329 # Description |
|
330 # This function adds the client defined by the connection ($iConn) to the list of ready clients |
|
331 # It also sends new commands to clients if apropriate |
|
332 sub AddReady |
|
333 { |
|
334 my ($iClientName, $iConn) = @_; |
|
335 |
|
336 my @iClientsWaiting; |
|
337 |
|
338 # Set the client status to the "Waiting" State |
|
339 $gClientStatus{$iClientName} = "Waiting"; |
|
340 |
|
341 # If the next command is Exit set global Exit flag |
|
342 if (defined $gCommands[$gIDCount]) |
|
343 { |
|
344 $gExit = 1 if ($gCommands[$gIDCount]{'Type'} eq "Exit"); |
|
345 } |
|
346 |
|
347 # Add the all "Waiting" clients to a list of waiting Clients |
|
348 foreach my $iClient (keys %gClientStatus) |
|
349 { |
|
350 push @iClientsWaiting, $iClient if ($gClientStatus{$iClient} eq "Waiting"); |
|
351 } |
|
352 |
|
353 # Are all the clients waiting? |
|
354 if (scalar @iClientsWaiting == $iConn->AllAssociations) |
|
355 { |
|
356 # Everyone has finished. Everyone is waiting. One of 3 things has happened: |
|
357 # - There has been a realtime error. |
|
358 # - All commands have been run. |
|
359 # - We have come to the end of the current stage. |
|
360 # - There is only one client, and it has further commands in the current stage. |
|
361 |
|
362 if ($gRealTimeError) |
|
363 { |
|
364 &PrintStageEnd; |
|
365 |
|
366 print $gLogFileH "ERROR: $gRealTimeError BuildServer terminating\n"; |
|
367 close ($gLogFileH); |
|
368 die "ERROR: $gRealTimeError BuildServer terminating\n"; |
|
369 } |
|
370 |
|
371 # If all other clients waiting for a command and an exit pending |
|
372 # Send Messages to all clients (not just current) to exit their procees |
|
373 # No return is expected so exit the buildserver process |
|
374 if ($gExit) |
|
375 { |
|
376 # Close up log nicely |
|
377 &PrintStageEnd; |
|
378 foreach my $key (keys %gClientHandles) |
|
379 { |
|
380 my $msg = freeze ("Exit"); |
|
381 $gClientHandles{$key}->transmit_immediately($msg); |
|
382 } |
|
383 exit 0; |
|
384 } |
|
385 |
|
386 if (!defined $gCommands[$gIDCount]) |
|
387 { |
|
388 # All commands have been run. There are no more commands. |
|
389 &PrintStageEnd; |
|
390 |
|
391 print "No more stages\n"; |
|
392 close ($gLogFileH); |
|
393 # Exit successfully |
|
394 exit 0; |
|
395 } |
|
396 |
|
397 if ( !defined $gStage || # the last command had no stage set |
|
398 $gStage eq '' || # the last command had no stage set |
|
399 $gStage != $gCommands[$gIDCount]{'Stage'} # the last command's stage is different to the next command's stage |
|
400 ) |
|
401 { |
|
402 # We've successfully reached the end of a stage |
|
403 &PrintStageEnd; |
|
404 |
|
405 # Update the current stage variable to be the stage of the next command |
|
406 $gStage = $gCommands[$gIDCount]{'Stage'}; |
|
407 |
|
408 &PrintStageStart; |
|
409 } |
|
410 } |
|
411 |
|
412 # If the next command is the first in a stage then all clients are waiting. |
|
413 |
|
414 # Below this point we are approaching the command sending section. |
|
415 # Other clients could be working on previous commands at this point. |
|
416 |
|
417 # If the next command can not be run in parallel with the previous command |
|
418 # and another client is executing the previous command, then we should |
|
419 # return and simply wait for the other client to finish. |
|
420 |
|
421 # Don't issue anymore commands if there is an exit pending |
|
422 return if ($gExit); |
|
423 |
|
424 # Don't issue anymore commands if there has been a realtime error. |
|
425 return if ($gRealTimeError); |
|
426 |
|
427 # Sort the waiting clients alphabetically |
|
428 @iClientsWaiting = sort(@iClientsWaiting); |
|
429 # Extract the first client name |
|
430 my $iClient = shift @iClientsWaiting; |
|
431 |
|
432 # Check if there are commands and clients available |
|
433 while (defined $gCommands[$gIDCount] and defined $iClient) |
|
434 { |
|
435 # Check if the next command's stage is different to the current stage. |
|
436 # They will be identical if we are running the first command in a stage. |
|
437 # They will also be identical if we are running a subsequent command in the same stage. |
|
438 # So if they are different it means the next command is in a different stage. |
|
439 # Therefore we want to return and wait until all other clients have finished before |
|
440 # sending this command. |
|
441 return if ($gStage ne $gCommands[$gIDCount]{'Stage'}); |
|
442 |
|
443 # Check to make sure a Exit command is not sent to 1 of multiple clients if Exit was not in it's own stage |
|
444 return if ($gCommands[$gIDCount]{'Type'} eq "Exit"); |
|
445 |
|
446 # If at least one client is doing some work, and both the previous and next |
|
447 # commands' stages are not set, just wait until the working client finishes. |
|
448 # So we treat two steps with no stage name as though a stage change has occurred between them. |
|
449 if ((!defined $gCommands[$gIDCount-1]{'Stage'} or '' eq $gCommands[$gIDCount-1]{'Stage'}) and |
|
450 (!defined $gCommands[$gIDCount]{'Stage'} or '' eq $gCommands[$gIDCount]{'Stage'}) ) |
|
451 { |
|
452 foreach my $status (values %gClientStatus) |
|
453 { |
|
454 return if ($status ne 'Waiting'); |
|
455 } |
|
456 } |
|
457 |
|
458 print "Sending Step ". ($gIDCount+1) ." to $iClient\n"; |
|
459 |
|
460 # Set client as "Busy" and then send the command |
|
461 $gClientStatus{$iClient} = "Busy"; |
|
462 &SendCommand($gClientHandles{$iClient}, $gIDCount); |
|
463 $gIDCount++; |
|
464 |
|
465 # Extract the next client name |
|
466 $iClient = shift @iClientsWaiting; |
|
467 } |
|
468 } |
|
469 |
|
470 sub PrintStageStart |
|
471 { |
|
472 # Output to log that the Stage has started |
|
473 print $gLogFileH "===-------------------------------------------------\n"; |
|
474 print $gLogFileH "=== Stage=$gStage\n"; |
|
475 print $gLogFileH "===-------------------------------------------------\n"; |
|
476 print $gLogFileH "=== Stage=$gStage started ".localtime()."\n"; |
|
477 |
|
478 # Flush the handle to try and make sure the logfile is up to date |
|
479 $gLogFileH->flush; |
|
480 } |
|
481 |
|
482 sub PrintStageEnd |
|
483 { |
|
484 print "Stage End $gStage\n"; |
|
485 |
|
486 # Output to the log that the Stage has finished |
|
487 print $gLogFileH "=== Stage=$gStage finished ".localtime()."\n"; |
|
488 # Flush the handle to try and make sure the logfile is up to date |
|
489 $gLogFileH->flush; |
|
490 } |
|
491 |
|
492 # TimeStampStart |
|
493 # |
|
494 # Inputs |
|
495 # $iData - Reference to variable to put the start time stamp |
|
496 # |
|
497 # Outputs |
|
498 # |
|
499 # Description |
|
500 # This places a timestamp in the logs |
|
501 sub TimeStampStart |
|
502 { |
|
503 my $ref = shift; |
|
504 |
|
505 # Add the client side per command start timestamp |
|
506 $$ref = "++ Started at ".localtime()."\n"; |
|
507 # Add the client side per command start HiRes timestamp if available |
|
508 if ($gHiResTimer == 1) |
|
509 { |
|
510 $$ref .= "+++ HiRes Start ".Time::HiRes::time()."\n"; |
|
511 } else { |
|
512 # Add the HiRes timer unavailable statement |
|
513 $$ref .= "+++ HiRes Time Unavailable\n"; |
|
514 } |
|
515 } |
|
516 |
|
517 # TimeStampEnd |
|
518 # |
|
519 # Inputs |
|
520 # $iData - Reference to variable to put the end time stamp |
|
521 # |
|
522 # Outputs |
|
523 # |
|
524 # Description |
|
525 # This places a timestamp in the logs |
|
526 sub TimeStampEnd |
|
527 { |
|
528 my $ref = shift; |
|
529 |
|
530 # Add the client side per command end HiRes timestamp if available |
|
531 $$ref .= "+++ HiRes End ".Time::HiRes::time()."\n" if ($gHiResTimer == 1); |
|
532 # Add the client side per command end timestamp |
|
533 $$ref .= "++ Finished at ".localtime()."\n"; |
|
534 } |
|
535 |
|
536 # Subroutine for decompressing data stream. |
|
537 # Input: message to be decompressed. |
|
538 # Output: decompressed message. |
|
539 # Note: here, when decompression is taking place, usually a complete message |
|
540 # is passed as the input parameter; in this case Z_STREAM_END is the |
|
541 # returned status. If an empty message is decompressed (e.g. because "" |
|
542 # was sent) Z_OK is returned. |
|
543 sub Decompress($) |
|
544 { |
|
545 my $msg = shift; # Get the message. |
|
546 |
|
547 # Initialise deflation stream |
|
548 my ($x, $init_status); |
|
549 eval { ($x, $init_status) = inflateInit() or die "Cannot create an inflation stream\n"; }; |
|
550 |
|
551 if($@) # Inflation initialisation has failed. |
|
552 { |
|
553 return "ERROR: Decompression initialisation failed: $@\nERROR: zlib error message: ", $x->msg(), "\n"; |
|
554 } |
|
555 |
|
556 # Some other failure? |
|
557 if($init_status != Z_OK and !defined($x)) |
|
558 { |
|
559 return "ERROR: Decompression initialisation failed: $init_status\n"; |
|
560 } |
|
561 |
|
562 # Decompress the message |
|
563 my ($output, $status); |
|
564 eval { ($output, $status) = $x->inflate(\$msg) or die "ERROR: Unable to decompress message"; }; |
|
565 |
|
566 if($@) # Failure of decompression |
|
567 { |
|
568 return "ERROR: unable to decompress: $@\n"; |
|
569 } |
|
570 |
|
571 # Some other failure? |
|
572 if($status != Z_STREAM_END and $status != Z_OK) |
|
573 { |
|
574 my $error = $x->msg(); |
|
575 return "ERROR: Decompression failed: $error\n"; |
|
576 } |
|
577 |
|
578 # Return the decompressed output. |
|
579 return $output; |
|
580 } |
|
581 |
|
582 1; |