1#!/usr/bin/perl -w 2#************************************************************** 3# 4# Licensed to the Apache Software Foundation (ASF) under one 5# or more contributor license agreements. See the NOTICE file 6# distributed with this work for additional information 7# regarding copyright ownership. The ASF licenses this file 8# to you under the Apache License, Version 2.0 (the 9# "License"); you may not use this file except in compliance 10# with the License. You may obtain a copy of the License at 11# 12# http://www.apache.org/licenses/LICENSE-2.0 13# 14# Unless required by applicable law or agreed to in writing, 15# software distributed under the License is distributed on an 16# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 17# KIND, either express or implied. See the License for the 18# specific language governing permissions and limitations 19# under the License. 20# 21#************************************************************** 22 23 24 25#************************************************************************* 26# 27# cws.pl - wrap common childworkspace operations 28# 29use strict; 30use Getopt::Long; 31use File::Basename; 32use File::Path; 33use File::Copy; 34use Cwd; 35use Benchmark; 36 37#### module lookup 38my @lib_dirs; 39BEGIN { 40 if ( !defined($ENV{SOLARENV}) ) { 41 die "No environment found (environment variable SOLARENV is undefined)"; 42 } 43 push(@lib_dirs, "$ENV{SOLARENV}/bin/modules"); 44} 45use lib (@lib_dirs); 46 47use Cws; 48 49#### script id ##### 50 51( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; 52 53#### globals #### 54 55# TODO: replace dummy vales with actual source_config migration milestone 56my $ooo320_source_config_milestone = 'm999'; 57 58# valid command with possible abbreviations 59my @valid_commands = ( 60 'help', 'h', '?', 61 'create', 62 'fetch', 'f', 63 'query', 'q', 64 'task', 't', 65 'eisclone', 66 'setcurrent' 67 ); 68 69# list the valid options to each command 70my %valid_options_hash = ( 71 'help' => ['help'], 72 'create' => ['help', 'milestone', 'migration', 'hg'], 73 'fetch' => ['help', 'milestone', 'childworkspace','platforms','noautocommon', 74 'quiet', 'onlysolver', 'additionalrepositories'], 75 'query' => ['help', 'milestone','masterworkspace','childworkspace'], 76 'task' => ['help'], 77 'setcurrent' => ['help', 'milestone'], 78 'eisclone' => ['help'] 79 ); 80 81my %valid_commands_hash; 82for (@valid_commands) { 83 $valid_commands_hash{$_}++; 84} 85 86# set by --debug switch 87my $debug = 0; 88# set by --profile switch 89my $profile = 0; 90 91 92#### main #### 93 94my ($command, $args_ref, $options_ref) = parse_command_line(); 95dispatch_command($command, $args_ref, $options_ref); 96exit(0); 97 98#### subroutines #### 99 100# Parses the command line. does prelimiary argument and option verification 101sub parse_command_line 102{ 103 if (@ARGV == 0) { 104 usage(); 105 exit(1); 106 } 107 108 my %options_hash; 109 Getopt::Long::Configure ("no_auto_abbrev", "no_ignorecase"); 110 my $success = GetOptions(\%options_hash, 'milestone|m=s', 111 'masterworkspace|master|M=s', 112 'hg', 113 'migration', 114 'childworkspace|child|c=s', 115 'debug', 116 'profile', 117 'commit|C', 118 'platforms|p=s', 119 'additionalrepositories|r=s', 120 'noautocommon|x=s', 121 'onlysolver|o', 122 'quiet|q', 123 'help|h' 124 ); 125 126 my $command = shift @ARGV; 127 128 if (!exists $valid_commands_hash{$command}) { 129 print_error("Unkown command: '$command'\n"); 130 usage(); 131 exit(1); 132 } 133 134 if ($command eq 'h' || $command eq '?') { 135 $command = 'help'; 136 } 137 elsif ($command eq 'f') { 138 $command = 'fetch'; 139 } 140 elsif ($command eq 'q') { 141 $command = 'query'; 142 } 143 elsif ($command eq 't') { 144 $command = 'task'; 145 } 146 147 # An unkown option might be accompanied with a valid command. 148 # Show the command specific help 149 if ( !$success ) { 150 do_help([$command]) 151 } 152 153 verify_options($command, \%options_hash); 154 return ($command, \@ARGV, \%options_hash); 155} 156 157# Verify options against the valid options list. 158sub verify_options 159{ 160 my $command = shift; 161 my $options_ref = shift; 162 163 my $valid_command_options_ref = $valid_options_hash{$command}; 164 165 my %valid_command_options_hash; 166 foreach (@{$valid_command_options_ref}) { 167 $valid_command_options_hash{$_}++; 168 } 169 170 # check all specified options against the valid options for the sub command 171 foreach (keys %{$options_ref}) { 172 if ( /debug/ ) { 173 $debug = 1; 174 next; 175 } 176 if ( /profile/ ) { 177 $profile = 1; 178 next; 179 } 180 if (!exists $valid_command_options_hash{$_}) { 181 print_error("can't use option '--$_' with subcommand '$command'.", 1); 182 } 183 } 184 185} 186 187# Dispatches to the do_xxx() routines depending on command. 188sub dispatch_command 189{ 190 my $command = shift; 191 my $args_ref = shift; 192 my $options_ref = shift; 193 194 no strict 'refs'; 195 &{"do_".$command}($args_ref, $options_ref); 196} 197 198# Returns the global cws object. 199BEGIN { 200my $the_cws; 201 202 sub get_this_cws { 203 if (!defined($the_cws)) { 204 $the_cws = Cws->new(); 205 return $the_cws; 206 } 207 else { 208 return $the_cws; 209 } 210 } 211} 212 213# Returns a list of the master workspaces. 214sub get_master_workspaces 215{ 216 my $cws = get_this_cws(); 217 my @masters = $cws->get_masters(); 218 219 return wantarray ? @masters : \@masters; 220} 221 222# Checks if master argument is a valid MWS name. 223BEGIN { 224 my %master_hash; 225 226 sub is_master 227 { 228 my $master_name = shift; 229 230 if (!%master_hash) { 231 my @masters = get_master_workspaces(); 232 foreach (@masters) { 233 $master_hash{$_}++; 234 } 235 } 236 return exists $master_hash{$master_name} ? 1 : 0; 237 } 238} 239 240# Fetches the current CWS from environment, returns a Cws object 241sub get_cws_from_environment 242{ 243 my $child = $ENV{CWS_WORK_STAMP}; 244 my $master = $ENV{WORK_STAMP}; 245 246 if ( !$child ) { 247 print_error("Environment variable CWS_WORK_STAMP is not set. Please set it to your CWS name.", 2); 248 } 249 250 if ( !$master ) { 251 print_error("Environment variable WORK_STAMP is not set. Please set it to the MWS name.", 2); 252 } 253 254 my $cws = get_this_cws(); 255 $cws->child($child); 256 $cws->master($master); 257 258 # Check if we got a valid child workspace. 259 my $id = $cws->eis_id(); 260 if ( $debug ) { 261 print STDERR "CWS-DEBUG: ... master: $master, child: $child, $id\n"; 262 } 263 if ( !$id ) { 264 print_error("Child workspace $child for master workspace $master not found in EIS database.", 2); 265 } 266 return ($cws); 267} 268 269# Fetches the CWS by name, returns a Cws object 270sub get_cws_by_name 271{ 272 my $child = shift; 273 274 my $cws = get_this_cws(); 275 $cws->child($child); 276 277 # Check if we got a valid child workspace. 278 my $id = $cws->eis_id(); 279 if ( $debug ) { 280 print STDERR "CWS-DEBUG: child: $child, $id\n"; 281 } 282 if ( !$id ) { 283 print_error("Child workspace $child not found in EIS database.", 2); 284 } 285 286 # Update masterws part of Cws object. 287 my $masterws = $cws->get_mws(); 288 if ( $cws->master() ne $masterws ) { 289 # can this still happen? 290 if ( $debug ) { 291 print STDERR "CWS-DEBUG: get_cws_by_name(): fixup of masterws in cws object detected\n"; 292 } 293 $cws->master($masterws); 294 } 295 return ($cws); 296} 297 298# Register child workspace with eis. 299sub register_child_workspace 300{ 301 my $cws = shift; 302 my $scm = shift; 303 my $is_promotion = shift; 304 305 my $milestone = $cws->milestone(); 306 my $child = $cws->child(); 307 my $master = $cws->master(); 308 309 # TODO: introduce a EIS_USER in the configuration, which should be used here 310 my $config = CwsConfig->new(); 311 my $vcsid = $config->vcsid(); 312 # TODO: there is no real need for socustom anymore, should go ASAP 313 my $socustom = $config->sointernal(); 314 315 if ( !$vcsid ) { 316 if ( $socustom ) { 317 print_error("Can't determine owner for CWS '$child'. Please set VCSID environment variable.", 11); 318 } 319 else { 320 print_error("Can't determine owner for CWS '$child'. Please set CVS_ID entry in \$HOME/.cwsrc.", 11); 321 } 322 } 323 324 if ( $is_promotion ) { 325 my $rc = $cws->set_scm($scm); 326 if ( !$rc ) { 327 print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12); 328 } 329 330 $rc = $cws->promote($vcsid, ""); 331 332 if ( !$rc ) { 333 print_error("Failed to promote child workspace '$child' to status 'new'.\n", 12); 334 } 335 else { 336 print "\n***** Successfully ***** promoted child workspace '$child' to status 'new'.\n"; 337 print "Milestone: '$milestone'.\n"; 338 } 339 } 340 else { 341 342 my $eis_id = $cws->register($vcsid, ""); 343 344 if ( !defined($eis_id) ) { 345 print_error("Failed to register child workspace '$child' for master '$master'.", 12); 346 } 347 else { 348 my $rc = $cws->set_scm($scm); 349 if ( !$rc ) { 350 print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12); 351 } 352 print "\n***** Successfully ***** registered child workspace '$child'\n"; 353 print "for master workspace '$master' (milestone '$milestone').\n"; 354 print "Child workspace Id: $eis_id.\n"; 355 } 356 } 357 return 0; 358} 359 360sub print_time_elapsed 361{ 362 my $t_start = shift; 363 my $t_stop = shift; 364 365 my $time_diff = timediff($t_stop, $t_start); 366 print_message("... finished in " . timestr($time_diff)); 367} 368 369sub hgrc_append_push_path_and_hooks 370{ 371 my $target = shift; 372 my $cws_source = shift; 373 374 $cws_source =~ s/http:\/\//ssh:\/\/hg@/; 375 if ( $debug ) { 376 print STDERR "CWS-DEBUG: hgrc_append_push_path_and_hooks(): default-push path: '$cws_source'\n"; 377 } 378 if ( !open(HGRC, ">>$target/.hg/hgrc") ) { 379 print_error("Can't append to hgrc file of repository '$target'.\n", 88); 380 } 381 print HGRC "default-push = " . "$cws_source\n"; 382 print HGRC "[extensions]\n"; 383 print HGRC "hgext.win32text=\n"; 384 print HGRC "[hooks]\n"; 385 print HGRC "# Reject commits which would introduce windows-style CR/LF files\n"; 386 print HGRC "pretxncommit.crlf = python:hgext.win32text.forbidcrlf\n"; 387 close(HGRC); 388} 389 390sub hg_clone_cws_or_milestone 391{ 392 my $rep_type = shift; 393 my $cws = shift; 394 my $target = shift; 395 my $clone_milestone_only = shift; 396 397 my ($hg_local_source, $hg_lan_source, $hg_remote_source); 398 my $config = CwsConfig->new(); 399 400 $hg_local_source = $config->get_hg_source(uc $rep_type, 'LOCAL'); 401 $hg_lan_source = $config->get_hg_source(uc $rep_type, 'LAN'); 402 $hg_remote_source = $config->get_hg_source(uc $rep_type, 'REMOTE'); 403 404 my $masterws = $cws->master(); 405 my ($master_local_source, $master_lan_source); 406 407 $master_local_source = "$hg_local_source/" . $masterws; 408 $master_lan_source = "$hg_lan_source/" . $masterws; 409 410 my $milestone_tag; 411 if ( $clone_milestone_only ) { 412 $milestone_tag = uc($masterws) . '_' . $clone_milestone_only; 413 } 414 else { 415 my @tags = $cws->get_tags(); 416 $milestone_tag = $tags[3]; 417 } 418 419 if ( $debug ) { 420 print STDERR "CWS-DEBUG: master_local_source: '$master_local_source'\n"; 421 print STDERR "CWS-DEBUG: master_lan_source: '$master_lan_source'\n"; 422 if ( !-d $master_local_source ) { 423 print STDERR "CWS-DEBUG: not a directory '$master_local_source'\n"; 424 } 425 } 426 427 my $pull_from_remote = 0; 428 my $cws_remote_source; 429 if ( !$clone_milestone_only ) { 430 if ($rep_type eq "ooo" || $rep_type eq "so") 431 { 432 $cws_remote_source = "$hg_remote_source/cws/" . $cws->child(); 433 } 434 # e.g. cws_l10n 435 else 436 { 437 $cws_remote_source = "$hg_remote_source/cws_".$rep_type."/" . $cws->child(); 438 } 439 440 # The outgoing repository might not yet be available. Which is not 441 # an error. Since pulling from the cws outgoing URL results in an ugly 442 # and hardly understandable error message, we check for availibility 443 # first. TODO: incorporate configured proxy instead of env_proxy. Use 444 # a dedicated request and content-type to find out if the repo is there 445 # instead of parsing the content of the page 446 print_message("... check availibility of 'outgoing' repository '$cws_remote_source'."); 447 require LWP::Simple; 448 my $content = LWP::Simple::get($cws_remote_source); 449 my $pattern = "<title>cws/". $cws->child(); 450 my $pattern2 = "<title>cws_".$rep_type."/". $cws->child(); 451 if ( $content && ($content =~ /$pattern/ || $content =~ /$pattern2/) ) { 452 $pull_from_remote = 1; 453 } 454 else { 455 print_message("... 'outgoing' repository '$cws_remote_source' is not accessible/available yet."); 456 } 457 } 458 459 # clone repository (without working tree if we still need to pull from remote) 460 my $clone_with_update = !$pull_from_remote; 461 hg_clone_repository($master_local_source, $master_lan_source, $target, $milestone_tag, $clone_with_update); 462 463 # now pull from the remote cws outgoing repository if its already available 464 if ( $pull_from_remote ) { 465 hg_remote_pull_repository($cws_remote_source, $target); 466 } 467 468 # if we fetched a CWS adorn the result with push-path and hooks 469 if ( $cws_remote_source ) { 470 hgrc_append_push_path_and_hooks($target, $cws_remote_source); 471 } 472 473 # update the result if necessary 474 if ( !$clone_with_update ) { 475 hg_update_repository($target); 476 } 477 478} 479 480sub hg_clone_repository 481{ 482 my $local_source = shift; 483 my $lan_source = shift; 484 my $dest = shift; 485 my $milestone_tag = shift; 486 my $update = shift; 487 488 my $t1 = Benchmark->new(); 489 my $source; 490 my $clone_option = $update ? '' : '-U '; 491 if ( -d $local_source && can_use_hardlinks($local_source, $dest) ) { 492 $source = $local_source; 493 if ( !hg_milestone_is_latest_in_repository($local_source, $milestone_tag) ) { 494 $clone_option .= "-r $milestone_tag"; 495 } 496 print_message("... clone LOCAL repository '$local_source' to '$dest'"); 497 } 498 else { 499 $source = $lan_source; 500 $clone_option .= "-r $milestone_tag"; 501 print_message("... clone LAN repository '$lan_source' to '$dest'"); 502 } 503 hg_clone($source, $dest, $clone_option); 504 505 my $t2 = Benchmark->new(); 506 print_time_elapsed($t1, $t2) if $profile; 507} 508 509sub hg_remote_pull_repository 510{ 511 my $remote_source = shift; 512 my $dest = shift; 513 514 my $t1 = Benchmark->new(); 515 print_message("... pull from REMOTE repository '$remote_source' to '$dest'"); 516 hg_pull($dest, $remote_source); 517 my $t2 = Benchmark->new(); 518 print_time_elapsed($t1, $t2) if $profile; 519} 520 521sub hg_update_repository 522{ 523 my $dest = shift; 524 525 my $t1 = Benchmark->new(); 526 print_message("... update repository '$dest'"); 527 hg_update($dest); 528 my $t2 = Benchmark->new(); 529 print_time_elapsed($t1, $t2) if $profile; 530} 531 532sub hg_milestone_is_latest_in_repository 533{ 534 my $repository = shift; 535 my $milestone_tag = shift; 536 537 # Our milestone is the lastest thing in the repository 538 # if the parent of the repository tip is adorned 539 # with the milestone tag. 540 my $tags_of_parent_of_tip = hg_parent($repository, 'tip', "--template='{tags}\\n'"); 541 if ( $tags_of_parent_of_tip =~ /\b$milestone_tag\b/ ) { 542 return 1; 543 } 544 return 0; 545} 546 547# Check if clone source and destination are on the same filesystem, 548# in that case hg clone can employ hard links. 549sub can_use_hardlinks 550{ 551 my $source = shift; 552 my $dest = shift; 553 554 if ( $^O eq 'cygwin' ) { 555 # no hard links on windows 556 return 0; 557 } 558 # st_dev is the first field return by stat() 559 my @stat_source = stat($source); 560 my @stat_dest = stat(dirname($dest)); 561 562 if ( $debug ) { 563 my $source_result = defined($stat_source[0]) ? $stat_source[0] : 'stat failed'; 564 my $dest_result = defined($stat_dest[0]) ? $stat_dest[0] : 'stat failed'; 565 print STDERR "CWS-DEBUG: can_use_hardlinks(): source device: '$stat_source[0]', destination device: '$stat_dest[0]'\n"; 566 } 567 if ( defined($stat_source[0]) && defined($stat_dest[0]) && $stat_source[0] == $stat_dest[0] ) { 568 return 1; 569 } 570 return 0; 571} 572 573sub query_cws 574{ 575 my $query_mode = shift; 576 my $options_ref = shift; 577 # get master and child workspace 578 my $masterws = exists $options_ref->{'masterworkspace'} ? uc($options_ref->{'masterworkspace'}) : $ENV{WORK_STAMP}; 579 my $childws = exists $options_ref->{'childworkspace'} ? $options_ref->{'childworkspace'} : $ENV{CWS_WORK_STAMP}; 580 my $milestone = exists $options_ref->{'milestone'} ? $options_ref->{'milestone'} : 'latest'; 581 582 if ( !defined($masterws) && $query_mode ne 'masters') { 583 print_error("Can't determine master workspace environment.\n", 30); 584 } 585 586 if ( ($query_mode eq 'integratedinto' || $query_mode eq 'incompatible' || $query_mode eq 'taskids' || $query_mode eq 'status' || $query_mode eq 'current' || $query_mode eq 'owner' || $query_mode eq 'qarep' || $query_mode eq 'issubversion' || $query_mode eq 'ispublic' || $query_mode eq 'build') && !defined($childws) ) { 587 print_error("Can't determine child workspace environment.\n", 30); 588 } 589 590 my $cws = Cws->new(); 591 if ( defined($childws) ) { 592 $cws->child($childws); 593 } 594 if ( defined($masterws) ) { 595 $cws->master($masterws); 596 } 597 598 no strict; 599 &{"query_".$query_mode}($cws, $milestone); 600 return; 601} 602 603sub query_integratedinto 604{ 605 my $cws = shift; 606 607 if ( is_valid_cws($cws) ) { 608 my $milestone = $cws->get_milestone_integrated(); 609 print_message("Integrated into:"); 610 print defined($milestone) ? "$milestone\n" : "unkown\n"; 611 } 612 return; 613} 614 615sub query_incompatible 616{ 617 my $cws = shift; 618 619 if ( is_valid_cws($cws) ) { 620 my @modules = $cws->incompatible_modules(); 621 print_message("Incompatible Modules:"); 622 foreach (@modules) { 623 if ( defined($_) ) { 624 print "$_\n"; 625 } 626 } 627 } 628 return; 629} 630 631sub query_taskids 632{ 633 my $cws = shift; 634 635 if ( is_valid_cws($cws) ) { 636 my @taskids = $cws->taskids(); 637 print_message("Task ID(s):"); 638 foreach (@taskids) { 639 if ( defined($_) ) { 640 print "$_\n"; 641 } 642 } 643 } 644 return; 645} 646 647sub query_status 648{ 649 my $cws = shift; 650 651 if ( is_valid_cws($cws) ) { 652 my $status = $cws->get_approval(); 653 if ( !$status ) { 654 print_error("Internal error: can't get approval status.", 3); 655 } else { 656 print_message("Approval status:"); 657 print "$status\n"; 658 } 659 } 660 return; 661} 662 663sub query_scm 664{ 665 my $cws = shift; 666 my $masterws = $cws->master(); 667 my $childws = $cws->child(); 668 669 if ( is_valid_cws($cws) ) { 670 my $scm = $cws->get_scm(); 671 if ( !defined($scm) ) { 672 print_error("Internal error: can't retrieve scm info.", 3); 673 } else { 674 print_message("Child workspace uses '$scm'."); 675 } 676 } 677 return; 678} 679 680sub query_ispublic 681{ 682 my $cws = shift; 683 my $masterws = $cws->master(); 684 my $childws = $cws->child(); 685 686 if ( is_valid_cws($cws) ) { 687 my $ispublic = $cws->get_public_flag(); 688 if ( !defined($ispublic) ) { 689 print_error("Internal error: can't get isPublic flag.", 3); 690 } else { 691 if ( $ispublic==1 ) { 692 print_message("Child workspace is public"); 693 } else { 694 print_message("Child workspace is internal"); 695 } 696 } 697 } 698 699 return; 700} 701 702sub query_current 703{ 704 my $cws = shift; 705 706 if ( is_valid_cws($cws) ) { 707 my $milestone = $cws->milestone(); 708 if ( !$milestone ) { 709 print_error("Internal error: can't get current milestone.", 3); 710 } else { 711 print_message("Current milestone:"); 712 print "$milestone\n"; 713 } 714 } 715 return; 716} 717 718sub query_owner 719{ 720 my $cws = shift; 721 722 if ( is_valid_cws($cws) ) { 723 my $owner = $cws->get_owner(); 724 print_message("Owner:"); 725 if ( !$owner ) { 726 print "not set\n" ; 727 } else { 728 print "$owner\n"; 729 } 730 } 731 return; 732} 733 734sub query_qarep 735{ 736 my $cws = shift; 737 738 if ( is_valid_cws($cws) ) { 739 my $qarep = $cws->get_qarep(); 740 print_message("QA Representative:"); 741 if ( !$qarep ) { 742 print "not set\n" ; 743 } else { 744 print "$qarep\n"; 745 } 746 } 747 return; 748} 749 750 751sub query_build 752{ 753 my $cws = shift; 754 755 if ( is_valid_cws($cws) ) { 756 my $build = $cws->get_build(); 757 print_message("Build:"); 758 if ( $build ) { 759 print "$build\n"; 760 } 761 } 762 return; 763} 764 765sub query_latest 766{ 767 my $cws = shift; 768 769 my $masterws = $cws->master(); 770 my $latest = $cws->get_current_milestone($masterws); 771 772 773 if ( $latest ) { 774 print_message("Master workspace '$masterws':"); 775 print_message("Latest milestone available for update:"); 776 print "$masterws $latest\n"; 777 } 778 else { 779 print_error("Can't determine latest milestone of '$masterws' available for update.", 3); 780 } 781 782 return; 783} 784 785sub query_masters 786{ 787 my $cws = shift; 788 789 my @mws = $cws->get_masters(); 790 my $list=""; 791 792 if ( @mws ) { 793 foreach (@mws) { 794 if ( $list ne "" ) { 795 $list .= ", "; 796 } 797 $list .= $_; 798 } 799 print_message("Master workspaces available: $list"); 800 } 801 else { 802 print_error("Can't determine masterworkspaces.", 3); 803 } 804 805 return; 806} 807 808sub query_milestones 809{ 810 my $cws = shift; 811 my $masterws = $cws->master(); 812 813 my @milestones = $cws->get_milestones($masterws); 814 my $list=""; 815 816 if ( @milestones ) { 817 foreach (@milestones) { 818 if ( $list ne "" ) { 819 $list .= ", "; 820 } 821 $list .= $_; 822 } 823 print_message("Master workspace '$masterws':"); 824 print_message("Milestones known on Master: $list"); 825 } 826 else { 827 print_error("Can't determine milestones of '$masterws'.", 3); 828 } 829 830 return; 831} 832 833sub query_ispublicmaster 834{ 835 my $cws = shift; 836 my $masterws = $cws->master(); 837 838 my $ispublic = $cws->get_publicmaster_flag(); 839 my $list=""; 840 841 if ( defined($ispublic) ) { 842 print_message("Master workspace '$masterws':"); 843 if ( !defined($ispublic) ) { 844 print_error("Internal error: can't get isPublicMaster flag.", 3); 845 } else { 846 if ( $ispublic==1 ) { 847 print_message("Master workspace is public"); 848 } else { 849 print_message("Master workspace is internal"); 850 } 851 } 852 } 853 else { 854 print_error("Can't determine isPublicMaster flag of '$masterws'.", 3); 855 } 856 857 return; 858} 859 860sub query_buildid 861{ 862 my $cws = shift; 863 my $milestone = shift; 864 865 my $masterws = $cws->master(); 866 if ( $milestone eq 'latest' ) { 867 $milestone = $cws->get_current_milestone($masterws); 868 } 869 870 if ( !$milestone ) { 871 print_error("Can't determine latest milestone of '$masterws'.", 3); 872 } 873 874 if ( !$cws->is_milestone($masterws, $milestone) ) { 875 print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3); 876 } 877 878 my $buildid = $cws->get_buildid($masterws, $milestone); 879 880 881 if ( $buildid ) { 882 print_message("Master workspace '$masterws':"); 883 print_message("BuildId for milestone '$milestone':"); 884 print("$buildid\n"); 885 } 886 887 return; 888} 889 890sub query_integrated 891{ 892 my $cws = shift; 893 my $milestone = shift; 894 895 my $masterws = $cws->master(); 896 if ( $milestone eq 'latest' ) { 897 $milestone = $cws->get_current_milestone($masterws); 898 } 899 900 if ( !$milestone ) { 901 print_error("Can't determine latest milestone of '$masterws'.", 3); 902 } 903 904 if ( !$cws->is_milestone($masterws, $milestone) ) { 905 print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3); 906 } 907 908 my @integrated_cws = $cws->get_integrated_cws($masterws, $milestone); 909 910 911 if ( @integrated_cws ) { 912 print_message("Master workspace '$masterws':"); 913 print_message("Integrated CWSs for milestone '$milestone':"); 914 foreach (@integrated_cws) { 915 print "$_\n"; 916 } 917 } 918 919 return; 920} 921 922sub query_approved 923{ 924 my $cws = shift; 925 926 my $masterws = $cws->master(); 927 928 my @approved_cws = $cws->get_cws_with_state($masterws, 'approved by QA'); 929 930 if ( @approved_cws ) { 931 print_message("Master workspace '$masterws':"); 932 print_message("CWSs approved by QA:"); 933 foreach (@approved_cws) { 934 print "$_\n"; 935 } 936 } 937 938 return; 939} 940 941sub query_nominated 942{ 943 my $cws = shift; 944 945 my $masterws = $cws->master(); 946 947 my @nominated_cws = $cws->get_cws_with_state($masterws, 'nominated'); 948 949 if ( @nominated_cws ) { 950 print_message("Master workspace '$masterws':"); 951 print_message("Nominated CWSs:"); 952 foreach (@nominated_cws) { 953 print "$_\n"; 954 } 955 } 956 957 return; 958} 959 960sub query_ready 961{ 962 my $cws = shift; 963 964 my $masterws = $cws->master(); 965 966 my @ready_cws = $cws->get_cws_with_state($masterws, 'ready for QA'); 967 968 if ( @ready_cws ) { 969 print_message("Master workspace '$masterws':"); 970 print_message("CWSs ready for QA:"); 971 foreach (@ready_cws) { 972 print "$_\n"; 973 } 974 } 975 976 return; 977} 978 979sub query_new 980{ 981 my $cws = shift; 982 983 my $masterws = $cws->master(); 984 985 my @ready_cws = $cws->get_cws_with_state($masterws, 'new'); 986 987 if ( @ready_cws ) { 988 print_message("Master workspace '$masterws':"); 989 print_message("CWSs with state 'new':"); 990 foreach (@ready_cws) { 991 print "$_\n"; 992 } 993 } 994 995 return; 996} 997 998sub query_planned 999{ 1000 my $cws = shift; 1001 1002 my $masterws = $cws->master(); 1003 1004 my @ready_cws = $cws->get_cws_with_state($masterws, 'planned'); 1005 1006 if ( @ready_cws ) { 1007 print_message("Master workspace '$masterws':"); 1008 print_message("CWSs with state 'planned':"); 1009 foreach (@ready_cws) { 1010 print "$_\n"; 1011 } 1012 } 1013 1014 return; 1015} 1016 1017sub is_valid_cws 1018{ 1019 my $cws = shift; 1020 1021 my $masterws = $cws->master(); 1022 my $childws = $cws->child(); 1023 # check if we got a valid child workspace 1024 my $id = $cws->eis_id(); 1025 if ( !$id ) { 1026 print_error("Child workspace '$childws' for master workspace '$masterws' not found in EIS database.", 2); 1027 } 1028 print STDERR "Master workspace '$masterws', child workspace '$childws'\n"; 1029 return 1; 1030} 1031 1032sub query_release 1033{ 1034 my $cws = shift; 1035 1036 if ( is_valid_cws($cws) ) { 1037 my $release = $cws->get_release(); 1038 print_message("Release target:"); 1039 if ( !$release ) { 1040 print "not set\n"; 1041 } else { 1042 print "$release\n"; 1043 } 1044 } 1045 return; 1046} 1047 1048sub query_due 1049{ 1050 my $cws = shift; 1051 1052 if ( is_valid_cws($cws) ) { 1053 my $due = $cws->get_due_date(); 1054 print_message("Due date:"); 1055 if ( !$due ) { 1056 print "not set\n"; 1057 } else { 1058 print "$due\n"; 1059 } 1060 } 1061 return; 1062} 1063 1064sub query_due_qa 1065{ 1066 my $cws = shift; 1067 1068 if ( is_valid_cws($cws) ) { 1069 my $due_qa = $cws->get_due_date_qa(); 1070 print_message("Due date (QA):"); 1071 if ( !$due_qa ) { 1072 print "not set\n"; 1073 } else { 1074 print "$due_qa\n"; 1075 } 1076 } 1077 return; 1078} 1079 1080sub query_help 1081{ 1082 my $cws = shift; 1083 1084 if ( is_valid_cws($cws) ) { 1085 my $help = $cws->is_helprelevant(); 1086 print_message("Help relevant:"); 1087 if ( !$help ) { 1088 print "false\n"; 1089 } else { 1090 print "true\n"; 1091 } 1092 } 1093 return; 1094} 1095 1096sub query_ui 1097{ 1098 my $cws = shift; 1099 1100 if ( is_valid_cws($cws) ) { 1101 my $help = $cws->is_uirelevant(); 1102 print_message("UI relevant:"); 1103 if ( !$help ) { 1104 print "false\n"; 1105 } else { 1106 print "true\n"; 1107 } 1108 } 1109 return; 1110} 1111 1112sub verify_milestone 1113{ 1114 my $cws = shift; 1115 my $qualified_milestone = shift; 1116 1117 my $invalid = 0; 1118 my ($master, $milestone); 1119 $invalid++ if $qualified_milestone =~ /-/; 1120 1121 if ( $qualified_milestone =~ /:/ ) { 1122 ($master, $milestone) = split(/:/, $qualified_milestone); 1123 $invalid++ unless ( $master && $milestone ); 1124 } 1125 else { 1126 $milestone = $qualified_milestone; 1127 } 1128 1129 if ( $invalid ) { 1130 print_error("Invalid milestone", 0); 1131 usage(); 1132 exit(1); 1133 } 1134 1135 $master = $cws->master() if !$master; 1136 if ( !$cws->is_milestone($master, $milestone) ) { 1137 print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 21); 1138 } 1139 return ($master, $milestone); 1140} 1141 1142sub relink_workspace { 1143 my $linkdir = shift; 1144 my $restore = shift; 1145 1146 # The list of obligatorily added modules, build will not work 1147 # if these are not present. 1148 my %added_modules_hash; 1149 if (defined $ENV{ADDED_MODULES}) { 1150 for ( split(/\s/, $ENV{ADDED_MODULES}) ) { 1151 $added_modules_hash{$_}++; 1152 } 1153 } 1154 1155 # clean out pre-existing linkdir 1156 my $bd = dirname($linkdir); 1157 if ( !opendir(DIR, $bd) ) { 1158 print_error("Can't open directory '$bd': $!.", 44); 1159 } 1160 my @old_link_dirs = grep { /^src.m\d+/ } readdir(DIR); 1161 close(DIR); 1162 1163 if ( @old_link_dirs > 1 ) { 1164 print_error("Found more than one old link directories:", 0); 1165 foreach (@old_link_dirs) { 1166 print STDERR "@old_link_dirs\n"; 1167 } 1168 if ( $restore ) { 1169 print_error("Please remove all old link directories but the last one", 67); 1170 } 1171 } 1172 1173 # Originally the extension .lnk indicated a linked module. This turned out to be 1174 # not an overly smart choice. Cygwin has some heuristics which regards .lnk 1175 # files as Windows shortcuts, breaking the build. Use .link instead. 1176 # When in restoring mode still consider .lnk as link to modules (for old CWSs) 1177 my $old_link_dir = "$bd/" . $old_link_dirs[0]; 1178 if ( $restore ) { 1179 if ( !opendir(DIR, $old_link_dir) ) { 1180 print_error("Can't open directory '$old_link_dir': $!.", 44); 1181 } 1182 my @links = grep { !(/\.lnk/ || /\.link/) } readdir(DIR); 1183 close(DIR); 1184 # everything which is not a link to a directory can't be an "added" module 1185 foreach (@links) { 1186 next if /^\./; 1187 my $link = "$old_link_dir/$_"; 1188 if ( -s $link && -d $link ) { 1189 $added_modules_hash{$_} = 1; 1190 } 1191 } 1192 } 1193 print_message("... removing '$old_link_dir'"); 1194 rmtree([$old_link_dir], 0); 1195 1196 print_message("... (re)create '$linkdir'"); 1197 if ( !mkdir("$linkdir") ) { 1198 print_error("Can't create directory '$linkdir': $!.", 44); 1199 } 1200 if ( !opendir(DIR, "$bd/ooo") ) { 1201 print_error("Can't open directory '$bd/sun': $!.", 44); 1202 } 1203 my @ooo_top_level_dirs = grep { !/^\./ } readdir(DIR); 1204 close(DIR); 1205 if ( !opendir(DIR, "$bd/sun") ) { 1206 print_error("Can't open directory '$bd/sun': $!.", 44); 1207 } 1208 my @so_top_level_dirs = grep { !/^\./ } readdir(DIR); 1209 close(DIR); 1210 my $savedir = getcwd(); 1211 if ( !chdir($linkdir) ) { 1212 print_error("Can't chdir() to directory '$linkdir': $!.", 44); 1213 } 1214 my $suffix = '.link'; 1215 foreach(@ooo_top_level_dirs) { 1216 if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE' ) { 1217 next; 1218 } 1219 my $target = $_; 1220 if ( -d "../ooo/$_" && !exists $added_modules_hash{$_} ) { 1221 $target .= $suffix; 1222 } 1223 if ( !symlink("../ooo/$_", $target) ) { 1224 print_error("Can't symlink directory '../ooo/$_ -> $target': $!.", 44); 1225 } 1226 } 1227 foreach(@so_top_level_dirs) { 1228 if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE' ) { 1229 next; 1230 } 1231 my $target = $_; 1232 if ( -d "../sun/$_" && !exists $added_modules_hash{$_} ) { 1233 $target .= $suffix; 1234 } 1235 if ( !symlink("../sun/$_", $target) ) { 1236 print_error("Can't symlink directory '../sun/$_ -> $target': $!.", 44); 1237 } 1238 } 1239 if ( !chdir($savedir) ) { 1240 print_error("Can't chdir() to directory '$linkdir': $!.", 44); 1241 } 1242} 1243 1244sub fetch_external_tarballs 1245{ 1246 my $source_root_dir = shift; 1247 my $external_tarballs_source = shift; 1248 1249 my $ooo_external_file = "$source_root_dir/ooo/ooo.lst"; 1250 my $sun_external_file = "$source_root_dir/sun/sun.lst"; 1251 my $sun_path = "$source_root_dir/sun"; 1252 1253 my @external_sources_list; 1254 push(@external_sources_list, read_external_file($ooo_external_file)); 1255 if ( -d $sun_path ) { 1256 if ( -e $sun_external_file ) { 1257 push(@external_sources_list, read_external_file($sun_external_file)); 1258 } 1259 else { 1260 print_error("Can't find external file list '$sun_external_file'.", 8); 1261 } 1262 } 1263 1264 my $ext_sources_dir = "$source_root_dir/ext_sources"; 1265 print_message("Copy external tarballs to '$ext_sources_dir'"); 1266 if ( ! -d $ext_sources_dir) { 1267 if ( !mkdir($ext_sources_dir) ) { 1268 print_error("Can't create directory '$ext_sources_dir': $!.", 44); 1269 } 1270 } 1271 foreach (@external_sources_list) { 1272 if ( ! copy("$external_tarballs_source/$_", $ext_sources_dir) ) { 1273 print_error("Can't copy file '$external_tarballs_source' -> '$ext_sources_dir': $!", 0); 1274 } 1275 } 1276 return; 1277} 1278 1279sub read_external_file 1280{ 1281 my $external_file = shift; 1282 1283 my @external_sources; 1284 open(EXT, "<$external_file") or print_error("Can't open file '$external_file' for reading: $!", 98); 1285 while(<EXT>) { 1286 if ( !/^http:/ ) { 1287 chomp; 1288 push(@external_sources, $_); 1289 } 1290 } 1291 close(EXT); 1292 return @external_sources; 1293} 1294 1295sub update_solver 1296{ 1297 my $platform = shift; 1298 my $source = shift; 1299 my $solver = shift; 1300 my $milestone = shift; 1301 my $source_config = shift; 1302 1303 my @zip_sub_dirs = ('bin', 'doc', 'idl', 'inc', 'lib', 'par', 'pck', 'pdb', 'pus', 'rdb', 'res', 'xml', 'sdf'); 1304 1305 use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); 1306 1307 my $platform_solver = "$solver/$platform"; 1308 1309 if ( -d $platform_solver ) { 1310 print_message("... removing old solver for platform '$platform'"); 1311 if ( !rmtree([$platform_solver]) ) { 1312 print_error("Can't remove directory '$platform_solver': $!.", 44); 1313 } 1314 } 1315 1316 if ( !mkdir("$platform_solver") ) { 1317 print_error("Can't create directory '$platform_solver': $!.", 44); 1318 } 1319 1320 my $platform_source = "$source/$platform/zip.$milestone"; 1321 if ( !opendir(DIR, "$platform_source") ) { 1322 print_error("Can't open directory '$platform_source': $!.", 44); 1323 } 1324 my @zips = grep { /\.zip$/ } readdir(DIR); 1325 close(DIR); 1326 1327 my $nzips = @zips; 1328 print_message("... unzipping $nzips zip archives for platform '$platform'"); 1329 1330 1331 foreach(@zips) { 1332 my $zip = Archive::Zip->new(); 1333 unless ( $zip->read( "$platform_source/$_" ) == AZ_OK ) { 1334 print_error("Can't read zip file '$platform_source/$_': $!.", 44); 1335 } 1336 # TODO: check for erorrs 1337 foreach (@zip_sub_dirs) { 1338 my $extract_destination = $source_config ? "$platform_solver/$_" : "$platform_solver/$_.$milestone"; 1339 unless ( $zip->extractTree($_, $extract_destination) == AZ_OK ) { 1340 print_error("Can't extract stream from zip file '$platform_source/$_': $!.", 44); 1341 } 1342 } 1343 } 1344} 1345 1346# TODO: special provisions for "source_config" migration, remove this 1347# some time after migration 1348sub get_source_config_for_milestone 1349{ 1350 my $masterws = shift; 1351 my $milestone = shift; 1352 1353 my $milestone_sequence_number = extract_milestone_sequence_number($milestone); 1354 my $ooo320_migration_sequence_number = extract_milestone_sequence_number($ooo320_source_config_milestone); 1355 1356 my $source_config = 1; 1357 if ( $masterws eq 'OOO320' ) { 1358 if ( $milestone_sequence_number < $ooo320_migration_sequence_number ) { 1359 $source_config = 0; 1360 } 1361 } 1362 return $source_config; 1363} 1364 1365sub extract_milestone_sequence_number 1366{ 1367 my $milestone = shift; 1368 1369 my $milestone_sequence_number; 1370 if ( $milestone =~ /m(\d+)/ ) { 1371 $milestone_sequence_number = $1; 1372 } 1373 else { 1374 print_error("can't extract milestone sequence number from milestone '$milestone'", 99); 1375 } 1376 return $milestone_sequence_number; 1377} 1378 1379# Executes the help command. 1380sub do_help 1381{ 1382 my $args_ref = shift; 1383 my $options_ref = shift; 1384 1385 if (@{$args_ref} == 0) { 1386 print STDERR "usage: cws <subcommand> [options] [args]\n"; 1387 print STDERR "Type 'cws help <subcommand>' for help on a specific subcommand.\n"; 1388 print STDERR "\n"; 1389 print STDERR "Available subcommands:\n"; 1390 print STDERR "\thelp (h,?)\n"; 1391 print STDERR "\tcreate\n"; 1392 print STDERR "\tfetch (f)\n"; 1393 print STDERR "\tquery (q)\n"; 1394 print STDERR "\ttask (t)\n"; 1395 print STDERR "\tsetcurrent\n"; 1396 print STDERR "\teisclone *** release engineers only ***\n"; 1397 } 1398 1399 my $arg = $args_ref->[0]; 1400 1401 if (!defined($arg) || $arg eq 'help') { 1402 print STDERR "help (h, ?): Describe the usage of this script or its subcommands\n"; 1403 print STDERR "usage: help [subcommand]\n"; 1404 } 1405 elsif ($arg eq 'create') { 1406 print STDERR "create: Create a new child workspace\n"; 1407 print STDERR "usage: create [-m milestone] <master workspace> <child workspace>\n"; 1408 print STDERR "\t-m milestone: Milestone to base the child workspace on. If ommitted the\n"; 1409 print STDERR "\t last published milestone will be used.\n"; 1410 print STDERR "\t--milestone milestone: Same as -m milestone.\n"; 1411 } 1412 elsif ($arg eq 'task') { 1413 print STDERR "task: Add a task to a child workspace\n"; 1414 print STDERR "usage: task <task id> [task id ...]\n"; 1415 } 1416 elsif ($arg eq 'query') { 1417 print STDERR "query: Query child workspace for miscellaneous information\n"; 1418 print STDERR "usage: query [-M master] [-c child] <current|integratedinto|incompatible|owner|qarep|status|taskids>\n"; 1419 print STDERR " query [-M master] [-c child] <release|due|due_qa|help|ui|ispublic|scm|build>\n"; 1420 print STDERR " query [-M master] <latest|milestones|ispublicmaster>\n"; 1421 print STDERR " query <masters>\n"; 1422 print STDERR " query [-M master] [-m milestone] <integrated|buildid>\n"; 1423 print STDERR " query [-M master] <planned|new|approved|nominated|ready>\n"; 1424 print STDERR "\t-M master:\t\toverride MWS specified in environment\n"; 1425 print STDERR "\t-c child:\t\toverride CWS specified in environment\n"; 1426 print STDERR "\t-m milestone:\t\toverride latest milestone with specified one\n"; 1427 print STDERR "\t--master master:\tSame as -M master\t\n"; 1428 print STDERR "\t--child child:\t\tSame -c child\n"; 1429 print STDERR "\t--milestone milestone:\tSame as -m milestone\n"; 1430 print STDERR "Modes:\n"; 1431 print STDERR "\tcurrent\t\tquery current milestone of CWS\n"; 1432 print STDERR "\tincompatible\tquery modules which should be build incompatible\n"; 1433 print STDERR "\towner\t\tquery CWS owner\n"; 1434 print STDERR "\tqarep\t\tquery CWS QA Representative\n"; 1435 print STDERR "\tstatus\t\tquery approval status of CWS\n"; 1436 print STDERR "\ttaskids\t\tquery taskids to be handled on the CWS\n"; 1437 print STDERR "\trelease\t\tquery for target release of CWS\n"; 1438 print STDERR "\tdue\t\tquery for due date of CWS\n"; 1439 print STDERR "\tdue_qa\t\tquery for due date (QA) of CWS\n"; 1440 print STDERR "\thelp\t\tquery if the CWS is help relevant\n"; 1441 print STDERR "\tui\t\tquery if the CWS is UI relevant\n"; 1442 print STDERR "\tbuild\t\tquery build String for CWS\n"; 1443 print STDERR "\tlatest\t\tquery the latest milestone available for resync\n"; 1444 print STDERR "\tbuildid\t\tquery build ID for milestone\n"; 1445 print STDERR "\tintegrated\tquery integrated CWSs for milestone\n"; 1446 print STDERR "\tintegratedinto\tquery milestone which CWS was integrated into\n"; 1447 print STDERR "\tplanned\t\tquery for planned CWSs\n"; 1448 print STDERR "\tnew\t\tquery for new CWSs\n"; 1449 print STDERR "\tapproved\tquery CWSs approved by QA\n"; 1450 print STDERR "\tnominated\tquery nominated CWSs\n"; 1451 print STDERR "\tready\t\tquery CWSs ready for QA\n"; 1452 print STDERR "\tispublic\tquery public flag of CWS\n"; 1453 print STDERR "\tscm\t\tquery Source Control Management (SCM) system used for CWS\n"; 1454 print STDERR "\tmasters\t\tquery available MWS\n"; 1455 print STDERR "\tmilestones\tquery which milestones are know on the given MWS\n"; 1456 print STDERR "\tispublicmaster\tquery public flag of MWS\n"; 1457 1458 } 1459 elsif ($arg eq 'fetch') { 1460 print STDERR "fetch: fetch a milestone or CWS\n"; 1461 print STDERR "usage: fetch [-q] [-p platforms] [-r additionalrepositories] [-o] <-m milestone> <workspace>\n"; 1462 print STDERR "usage: fetch [-q] [-p platforms] [-r additionalrepositories] [-o] <-c cws> <workspace>\n"; 1463 print STDERR "usage: fetch [-q] [-x platforms] [-r additionalrepositories] [-o] <-m milestone> <workspace>\n"; 1464 print STDERR "usage: fetch [-q] [-x platforms] [-r additionalrepositories] [-o] <-c cws> <workspace>\n"; 1465 print STDERR "usage: fetch [-q] <-m milestone> <workspace>\n"; 1466 print STDERR "usage: fetch [-q] <-c cws> <workspace>\n"; 1467 print STDERR "\t-m milestone: Checkout milestone <milestone> to workspace <workspace>\n"; 1468 print STDERR "\t Use 'latest' for the for lastest published milestone on the current master\n"; 1469 print STDERR "\t For cross master checkouts use the form <MWS>:<milestone>\n"; 1470 print STDERR "\t--milestone milestone: Same as -m milestone\n"; 1471 print STDERR "\t-c childworkspace: Checkout CWS <childworkspace> to workspace <workspace>\n"; 1472 print STDERR "\t--child childworkspace: Same as -c childworkspace\n"; 1473 print STDERR "\t-p platform: Copy one or more prebuilt platforms 'platform'. \n"; 1474 print STDERR "\t Separate multiple platforms with commas.\n"; 1475 print STDERR "\t Automatically adds 'common[.pro]' as required.\n"; 1476 print STDERR "\t--platforms platform: Same as -p\n"; 1477 print STDERR "\t-x platform: Copy one or more prebuilt platforms 'platform'. \n"; 1478 print STDERR "\t Separate multiple platforms with commas.\n"; 1479 print STDERR "\t Does not automatically adds 'common[.pro]'.\n"; 1480 print STDERR "\t-r additionalrepositories Checkout additional repositories. \n"; 1481 print STDERR "\t Separate multiple repositories with commas.\n"; 1482 print STDERR "\t--noautocommon platform: Same as -x\n"; 1483 print STDERR "\t-o: Omit checkout of sources, copy only solver. \n"; 1484 print STDERR "\t--onlysolver: Same as -o\n"; 1485 print STDERR "\t-q: Silence some of the output of the command.\n"; 1486 print STDERR "\t--quiet: Same as -q\n"; 1487 } 1488 elsif ($arg eq 'setcurrent') { 1489 print STDERR "setcurrent: Set the current milestone for the CWS (only hg based CWSs)\n"; 1490 print STDERR "usage: setcurrent [-m milestone]\n"; 1491 print STDERR "\t-m milestone: Set milestone to <milestone> to workspace <workspace>\n"; 1492 print STDERR "\t Use 'latest' for the for lastest published milestone on the current master\n"; 1493 print STDERR "\t For cross master change use the form <MWS>:<milestone>\n"; 1494 print STDERR "\t--milestone milestone: Same as -m milestone\n"; 1495 } 1496 else { 1497 print STDERR "'$arg': unknown subcommand\n"; 1498 exit(1); 1499 } 1500 exit(0); 1501} 1502 1503# Executes the create command. 1504sub do_create 1505{ 1506 my $args_ref = shift; 1507 my $options_ref = shift; 1508 1509 if ( exists $options_ref->{'help'} || @{$args_ref} != 2) { 1510 do_help(['create']); 1511 } 1512 1513 if ( exists $options_ref->{'hg'} ) { 1514 print_warning("All childworkspaces are now hosted on Mercurial. The switch --hg is obsolete."); 1515 } 1516 1517 my $master = uc $args_ref->[0]; 1518 my $cws_name = $args_ref->[1]; 1519 1520 if (!is_master($master)) { 1521 print_error("'$master' is not a valid master workspace.", 7); 1522 } 1523 1524 # check if cws name fits the convention 1525 if ( $cws_name !~ /^\w[\w\.\#]*$/ ) { 1526 print_error("Invalid child workspace name '$cws_name'.\nCws names should consist of alphanumeric characters, preferable all lowercase and starting with a letter.\nThe characters . and # are allowed if they are not the first character.", 7); 1527 } 1528 1529 my $cws = get_this_cws(); 1530 $cws->master($master); 1531 $cws->child($cws_name); 1532 1533 # check if child workspace already exists 1534 my $eis_id = $cws->eis_id(); 1535 if ( !defined($eis_id) ) { 1536 print_error("Connection with EIS database failed.", 8); 1537 } 1538 1539 my $is_promotion = 0; 1540 if ( $eis_id > 0 ) { 1541 if ( $cws->get_approval() eq 'planned' ) { 1542 print "Promote child workspace '$cws_name' from 'planned' to 'new'.\n"; 1543 $is_promotion++; 1544 } 1545 else { 1546 print_error("Child workspace '$cws_name' already exists.", 7); 1547 } 1548 } 1549 else { 1550 # check if child workspace name is still available 1551 if ( !$cws->is_cws_name_available()) { 1552 print_error("Child workspace name '$cws_name' is already in use.", 7); 1553 } 1554 } 1555 1556 my $milestone; 1557 # verify milestone or query latest milestone 1558 if ( exists $options_ref->{'milestone'} ) { 1559 $milestone=$options_ref->{'milestone'}; 1560 # check if milestone exists 1561 if ( !$cws->is_milestone($master, $milestone) ) { 1562 print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 8); 1563 } 1564 } 1565 else { 1566 $milestone=$cws->get_current_milestone($cws->master()); 1567 } 1568 1569 # set milestone 1570 $cws->milestone($milestone); 1571 1572 register_child_workspace($cws, 'hg', $is_promotion); 1573 1574 return; 1575} 1576 1577# Executes the fetch command. 1578sub do_fetch 1579{ 1580 my $args_ref = shift; 1581 my $options_ref = shift; 1582 1583 my $time_fetch_start = Benchmark->new(); 1584 if ( exists $options_ref->{'help'} || @{$args_ref} != 1) { 1585 do_help(['fetch']); 1586 } 1587 1588 my $milestone_opt = $options_ref->{'milestone'}; 1589 my $additional_repositories_opt = $options_ref->{'additionalrepositories'}; 1590 $additional_repositories_opt = "", if ( !defined $additional_repositories_opt ); 1591 my $child = $options_ref->{'childworkspace'}; 1592 my $platforms = $options_ref->{'platforms'}; 1593 my $noautocommon = $options_ref->{'noautocommon'}; 1594 my $quiet = $options_ref->{'quiet'} ? 1 : 0 ; 1595 my $switch = $options_ref->{'switch'} ? 1 : 0 ; 1596 my $onlysolver = $options_ref->{'onlysolver'} ? 1 : 0 ; 1597 1598 if ( !defined($milestone_opt) && !defined($child) ) { 1599 print_error("Specify one of these options: -m or -c", 0); 1600 do_help(['fetch']); 1601 } 1602 1603 if ( defined($milestone_opt) && defined($child) ) { 1604 print_error("Options -m and -c are mutally exclusive", 0); 1605 do_help(['fetch']); 1606 } 1607 1608 if ( defined($platforms) && defined($noautocommon) ) { 1609 print_error("Options -p and -x are mutally exclusive", 0); 1610 do_help(['fetch']); 1611 } 1612 1613 if ( $onlysolver && !(defined($platforms) || defined($noautocommon)) ) { 1614 print_error("Option '-o' is Only usuable combination with option '-p' or '-x'.", 0); 1615 do_help(['fetch']); 1616 } 1617 1618 my $cws = get_this_cws(); 1619 my $masterws = $ENV{WORK_STAMP}; 1620 if ( !defined($masterws) ) { 1621 print_error("Can't determine current master workspace: check environment variable WORK_STAMP", 21); 1622 } 1623 $cws->master($masterws); 1624 my $milestone; 1625 if( defined($milestone_opt) ) { 1626 if ( $milestone_opt eq 'latest' ) { 1627 $cws->master($masterws); 1628 my $latest = $cws->get_current_milestone($masterws); 1629 1630 if ( !$latest ) { 1631 print_error("Can't determine latest milestone of master workspace '$masterws'.", 22); 1632 } 1633 $milestone = $cws->get_current_milestone($masterws); 1634 } 1635 else { 1636 ($masterws, $milestone) = verify_milestone($cws, $milestone_opt); 1637 } 1638 } 1639 elsif ( defined($child) ) { 1640 $cws = get_cws_by_name($child); 1641 $masterws = $cws->master(); # CWS can have another master than specified in ENV 1642 $milestone = $cws->milestone(); 1643 } 1644 else { 1645 do_help(['fetch']); 1646 } 1647 1648 my $config = CwsConfig->new(); 1649 # $so_svn_server is still required to determine if we are in SO environment 1650 # TODO: change this configuration setting to something more meaningful 1651 my $so_svn_server = $config->get_so_svn_server(); 1652 my $prebuild_dir = $config->get_prebuild_binaries_location(); 1653 my $external_tarball_source = $prebuild_dir; 1654 # Check early for platforms so we can bail out before anything time consuming is done 1655 # in case of a missing platform 1656 my @platforms; 1657 if ( defined($platforms) || defined($noautocommon) ) { 1658 use Archive::Zip; # warn early if module is missing 1659 if ( !defined($prebuild_dir ) ) { 1660 print_error("PREBUILD_BINARIES not configured, can't find platform solvers", 99); 1661 } 1662 $prebuild_dir = "$prebuild_dir/$masterws"; 1663 1664 if ( defined($platforms) ) { 1665 @platforms = split(/,/, $platforms); 1666 1667 my $added_product = 0; 1668 my $added_nonproduct = 0; 1669 foreach(@platforms) { 1670 if ( $_ eq 'common.pro' ) { 1671 $added_product = 1; 1672 print_warning("'$_' is added automatically to the platform list, don't specify it explicit"); 1673 } 1674 if ( $_ eq 'common' ) { 1675 $added_nonproduct = 1; 1676 print_warning("'$_' is added automatically to the platform list, don't specify it explicit"); 1677 } 1678 } 1679 1680 # add common.pro/common to platform list 1681 if ( $so_svn_server ) { 1682 my $product = 0; 1683 my $nonproduct = 0; 1684 foreach(@platforms) { 1685 if ( /\.pro$/ ) { 1686 $product = 1; 1687 } 1688 else { 1689 $nonproduct = 1; 1690 } 1691 } 1692 unshift(@platforms, 'common.pro') if ($product && !$added_product); 1693 unshift(@platforms, 'common') if ($nonproduct && !$added_nonproduct); 1694 } 1695 } 1696 else { 1697 @platforms = split(/,/, $noautocommon); 1698 } 1699 1700 foreach(@platforms) { 1701 if ( ! -d "$prebuild_dir/$_") { 1702 print_error("Can't find prebuild binaries for platform '$_'.", 22); 1703 } 1704 } 1705 1706 } 1707 1708 my $cwsname = $cws->child(); 1709 my $linkdir = $milestone_opt ? "src.$milestone" : "src." . $cws->milestone; 1710 1711 my $workspace = $args_ref->[0]; 1712 1713 if ( !$onlysolver ) { 1714 if ( -e $workspace ) { 1715 print_error("File or directory '$workspace' already exists.", 8); 1716 } 1717 1718 my $clone_milestone_only = $milestone_opt ? $milestone : 0; 1719 if ( defined($so_svn_server) ) { 1720 if ( !mkdir($workspace) ) { 1721 print_error("Can't create directory '$workspace': $!.", 8); 1722 } 1723 my $work_master = "$workspace/$masterws"; 1724 if ( !mkdir($work_master) ) { 1725 print_error("Can't create directory '$work_master': $!.", 8); 1726 } 1727 1728 my %unique = map { $_ => 1 } split( /,/ , $additional_repositories_opt); 1729 my @unique_repo_list = keys %unique; 1730 1731 if (defined($additional_repositories_opt)) 1732 { 1733 foreach my $repo(@unique_repo_list) 1734 { 1735 # do not double clone ooo and sun 1736 hg_clone_cws_or_milestone($repo, $cws, "$work_master/".$repo, $clone_milestone_only), if $repo ne "ooo" && $repo ne "sun"; 1737 } 1738 1739 } 1740 1741 hg_clone_cws_or_milestone('ooo', $cws, "$work_master/ooo", $clone_milestone_only); 1742 hg_clone_cws_or_milestone('so', $cws, "$work_master/sun", $clone_milestone_only); 1743 1744 if ( get_source_config_for_milestone($masterws, $milestone) ) { 1745 # write source_config file 1746 my $source_config_file = "$work_master/source_config"; 1747 if ( !open(SOURCE_CONFIG, ">$source_config_file") ) { 1748 print_error("Can't create source_config file '$source_config_file': $!.", 8); 1749 } 1750 print SOURCE_CONFIG "[repositories]\n"; 1751 print SOURCE_CONFIG "ooo=active\n"; 1752 print SOURCE_CONFIG "sun=active\n"; 1753 foreach my $repo(@unique_repo_list) 1754 { 1755 print SOURCE_CONFIG $repo."=active\n", if $repo ne "ooo" || $repo ne "sun"; 1756 } 1757 close(SOURCE_CONFIG); 1758 } 1759 else { 1760 my $linkdir = "$work_master/src.$milestone"; 1761 if ( !mkdir($linkdir) ) { 1762 print_error("Can't create directory '$linkdir': $!.", 8); 1763 } 1764 relink_workspace($linkdir); 1765 } 1766 } 1767 else { 1768 hg_clone_cws_or_milestone('ooo', $cws, $workspace, $clone_milestone_only); 1769 } 1770 } 1771 1772 if ( !$onlysolver && defined($external_tarball_source) ) { 1773 my $source_root_dir = "$workspace/$masterws"; 1774 $external_tarball_source .= "/$masterws/ext_sources"; 1775 if ( -e "$source_root_dir/ooo/ooo.lst" && -d $external_tarball_source ) { 1776 fetch_external_tarballs($source_root_dir, $external_tarball_source); 1777 } 1778 } 1779 1780 if ( defined($platforms) || defined($noautocommon) ) { 1781 if ( !-d $workspace ) { 1782 if ( !mkdir($workspace) ) { 1783 print_error("Can't create directory '$workspace': $!.", 8); 1784 } 1785 } 1786 my $solver = defined($so_svn_server) ? "$workspace/$masterws" : "$workspace/solver"; 1787 if ( !-d $solver ) { 1788 if ( !mkdir($solver) ) { 1789 print_error("Can't create directory '$solver': $!.", 8); 1790 } 1791 } 1792 my $source_config = get_source_config_for_milestone($masterws, $milestone); 1793 foreach(@platforms) { 1794 my $time_solver_start = Benchmark->new(); 1795 print_message("... copying platform solver '$_'."); 1796 update_solver($_, $prebuild_dir, $solver, $milestone, $source_config); 1797 my $time_solver_stop = Benchmark->new(); 1798 print_time_elapsed($time_solver_start, $time_solver_stop) if $profile; 1799 } 1800 } 1801 my $time_fetch_stop = Benchmark->new(); 1802 my $time_fetch = timediff($time_fetch_stop, $time_fetch_start); 1803 print_message("cws fetch: total time required " . timestr($time_fetch)); 1804} 1805 1806sub do_query 1807{ 1808 my $args_ref = shift; 1809 my $options_ref = shift; 1810 1811 # list of available query modes 1812 my @query_modes = qw(integratedinto incompatible taskids status latest current owner qarep build buildid integrated approved nominated ready new planned release due due_qa help ui milestones masters scm ispublic ispublicmaster); 1813 my %query_modes_hash = (); 1814 foreach (@query_modes) { 1815 $query_modes_hash{$_}++; 1816 } 1817 1818 if ( exists $options_ref->{'help'} || @{$args_ref} != 1) { 1819 do_help(['query']); 1820 } 1821 my $mode = lc($args_ref->[0]); 1822 1823 # cwquery mode 'state' has been renamed to 'status' to be more consistent 1824 # with CVS etc. 'state' is still an alias for 'status' 1825 $mode = 'status' if $mode eq 'state'; 1826 1827 # cwquery mode 'vcs' has been renamed to 'scm' to be more consistent 1828 # with general use etc. 'vcs' is still an alias for 'scm' 1829 $mode = 'scm' if $mode eq 'vcs'; 1830 1831 # there will be more query modes over time 1832 if ( !exists $query_modes_hash{$mode} ) { 1833 do_help(['query']); 1834 } 1835 query_cws($mode, $options_ref); 1836} 1837 1838sub do_task 1839{ 1840 my $args_ref = shift; 1841 my $options_ref = shift; 1842 1843 if ( exists $options_ref->{'help'} ) { 1844 do_help(['task']); 1845 } 1846 1847 # CWS states for which adding tasks are blocked. 1848 my @states_blocked_for_adding = ( 1849 "integrated", 1850 "nominated", 1851 "approved by QA", 1852 "cancelled", 1853 "finished" 1854 ); 1855 my $cws = get_cws_from_environment(); 1856 1857 # register taskids with EIS database; 1858 # checks taksids for sanity, will notify user 1859 # if taskid is already registered. 1860 my $status = $cws->get_approval(); 1861 1862 my $child = $cws->child(); 1863 my $master = $cws->master(); 1864 1865 my @registered_taskids = $cws->taskids(); 1866 1867 # if called without ids to register just query for tasks 1868 if ( @{$args_ref} == 0 ) { 1869 print_message("Task ID(s):"); 1870 foreach (@registered_taskids) { 1871 if ( defined($_) ) { 1872 print "$_\n"; 1873 } 1874 } 1875 } 1876 1877 if ( !defined($status) ) { 1878 print_error("Can't determine status of child workspace `$child`.", 20); 1879 } 1880 1881 if ( grep($status eq $_, @states_blocked_for_adding) ) { 1882 print_error("Can't add tasks to child workspace '$child' with state '$status'.", 21); 1883 } 1884 1885 # Create hash for easier searching. 1886 my %registered_taskids_hash = (); 1887 for (@registered_taskids) { 1888 $registered_taskids_hash{$_}++; 1889 } 1890 1891 my @new_taskids = (); 1892 foreach (@{$args_ref}) { 1893 if ( $_ !~ /^([ib]?\d+)$/ ) { 1894 print_error("'$_' is an invalid task ID.", 22); 1895 } 1896 if ( exists $registered_taskids_hash{$1} ) { 1897 print_warning("Task ID '$_' already registered, skipping."); 1898 next; 1899 } 1900 push(@new_taskids, $_); 1901 } 1902 1903 # TODO: introduce a EIS_USER in the configuration, which should be used here 1904 my $config = CwsConfig->new(); 1905 my $vcsid = $config->vcsid(); 1906 my $added_taskids_ref = $cws->add_taskids($vcsid, @new_taskids); 1907 if ( !$added_taskids_ref ) { 1908 my $taskids_str = join(" ", @new_taskids); 1909 print_error("Couldn't register taskID(s) '$taskids_str' with child workspace '$child'.", 23); 1910 } 1911 my @added_taskids = @{$added_taskids_ref}; 1912 if ( @added_taskids ) { 1913 my $taskids_str = join(" ", @added_taskids); 1914 print_message("Registered taskID(s) '$taskids_str' with child workspace '$child'."); 1915 } 1916 return; 1917} 1918 1919sub do_setcurrent 1920{ 1921 my $args_ref = shift; 1922 my $options_ref = shift; 1923 1924 if ( exists $options_ref->{'help'} || @{$args_ref} != 0) { 1925 do_help(['setcurrent']); 1926 } 1927 1928 if ( !exists $options_ref->{'milestone'} ) { 1929 do_help(['setcurrent']); 1930 } 1931 1932 my $cws = get_cws_from_environment(); 1933 my $old_masterws = $cws->master(); 1934 my $new_masterws; 1935 my $new_milestone; 1936 1937 my $milestone = $options_ref->{'milestone'}; 1938 if ( $milestone eq 'latest' ) { 1939 my $latest = $cws->get_current_milestone($old_masterws); 1940 1941 if ( !$latest ) { 1942 print_error("Can't determine latest milestone of '$old_masterws'.", 22); 1943 } 1944 $new_masterws = $old_masterws; 1945 $new_milestone = $latest; 1946 } 1947 else { 1948 ($new_masterws, $new_milestone) = verify_milestone($cws, $milestone); 1949 } 1950 1951 print_message("... updating EIS database"); 1952 my $push_return = $cws->set_master_and_milestone($new_masterws, $new_milestone); 1953 # sanity check 1954 if ( $$push_return[1] ne $new_milestone) { 1955 print_error("Couldn't push new milestone '$new_milestone' to database", 0); 1956 } 1957} 1958 1959sub do_eisclone 1960{ 1961 my $args_ref = shift; 1962 my $options_ref = shift; 1963 1964 print_error("not yet implemented.", 2); 1965} 1966 1967sub print_message 1968{ 1969 my $message = shift; 1970 1971 print "$message\n"; 1972 return; 1973} 1974 1975sub print_warning 1976{ 1977 my $message = shift; 1978 print STDERR "$script_name: "; 1979 print STDERR "WARNING: $message\n"; 1980 return; 1981} 1982 1983sub print_error 1984{ 1985 my $message = shift; 1986 my $error_code = shift; 1987 1988 print STDERR "$script_name: "; 1989 print STDERR "ERROR: $message\n"; 1990 1991 if ( $error_code ) { 1992 print STDERR "\nFAILURE: $script_name aborted.\n"; 1993 exit($error_code); 1994 } 1995 return; 1996} 1997 1998sub usage 1999{ 2000 print STDERR "Type 'cws help' for usage.\n"; 2001} 2002 2003### HG glue ### 2004 2005sub hg_clone 2006{ 2007 my $source = shift; 2008 my $dest = shift; 2009 my $options = shift; 2010 2011 if ( $debug ) { 2012 print STDERR "CWS-DEBUG: ... hg clone: '$source -> $dest', options: '$options'\n"; 2013 } 2014 2015 # The to be cloned revision might not yet be avaliable. In this case clone 2016 # the available tip. 2017 my @result = execute_hg_command(0, 'clone', $options, $source, $dest); 2018 if ( defined($result[0]) && $result[0] =~ /abort: unknown revision/ ) { 2019 $options =~ s/-r \w+//; 2020 @result = execute_hg_command(1, 'clone', $options, $source, $dest); 2021 } 2022 return @result; 2023} 2024 2025sub hg_parent 2026{ 2027 my $repository = shift; 2028 my $rev_id = shift; 2029 my $options = shift; 2030 2031 if ( $debug ) { 2032 print STDERR "CWS-DEBUG: ... hg parent: 'repository', revision: '$rev_id', options: $options\n"; 2033 } 2034 2035 my @result = execute_hg_command(0, 'parent', "--cwd $repository", "-r $rev_id", $options); 2036 my $line = $result[0]; 2037 chomp($line); 2038 return $line; 2039} 2040 2041sub hg_pull 2042{ 2043 my $repository = shift; 2044 my $remote = shift; 2045 2046 if ( $debug ) { 2047 print STDERR "CWS-DEBUG: ... hg pull: 'repository', remote: '$remote'\n"; 2048 } 2049 2050 my @result = execute_hg_command(0, 'pull', "--cwd $repository", $remote); 2051 my $line = $result[0]; 2052 if ($line =~ /abort: /) { 2053 return undef; 2054 } 2055} 2056 2057sub hg_update 2058{ 2059 my $repository = shift; 2060 2061 if ( $debug ) { 2062 print STDERR "CWS-DEBUG: ... hg update: 'repository'\n"; 2063 } 2064 2065 my @result = execute_hg_command(1, 'update', "--cwd $repository"); 2066 return @result; 2067} 2068 2069sub hg_show 2070{ 2071 if ( $debug ) { 2072 print STDERR "CWS-DEBUG: ... hg show\n"; 2073 } 2074 my $result = execute_hg_command(0, 'show', ''); 2075 return $result; 2076} 2077 2078sub execute_hg_command 2079{ 2080 my $terminate_on_rc = shift; 2081 my $command = shift; 2082 my $options = shift; 2083 my @args = @_; 2084 2085 my $args_str = join(" ", @args); 2086 2087 # we can only parse english strings, hopefully a C locale is available everywhere 2088 $ENV{LC_ALL}='C'; 2089 $command = "hg $command $options $args_str"; 2090 2091 if ( $debug ) { 2092 print STDERR "CWS-DEBUG: ... execute command line: '$command'\n"; 2093 } 2094 2095 my @result; 2096 open(OUTPUT, "$command 2>&1 |") or print_error("Can't execute mercurial command line client", 98); 2097 while (<OUTPUT>) { 2098 push(@result, $_); 2099 } 2100 close(OUTPUT); 2101 2102 my $rc = $? >> 8; 2103 2104 if ( $rc > 0 && $terminate_on_rc) { 2105 print STDERR @result; 2106 print_error("The mercurial command line client failed with exit status '$rc'", 99); 2107 } 2108 return wantarray ? @result : \@result; 2109} 2110 2111 2112# vim: set ts=4 shiftwidth=4 expandtab syntax=perl: 2113