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