solenv/bin/cws.pl

   1 #!/usr/bin/perl -w
   2 #*************************************************************************
   3 #
   4 # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   5 #
   6 # Copyright 2008 by Sun Microsystems, Inc.
   7 #
   8 # OpenOffice.org - a multi-platform office productivity suite
   9 #
  10 # $RCSfile: cws.pl,v $
  11 #
  12 # $Revision: 1.1.2.14 $
  13 #
  14 # This file is part of OpenOffice.org.
  15 #
  16 # OpenOffice.org is free software: you can redistribute it and/or modify
  17 # it under the terms of the GNU Lesser General Public License version 3
  18 # only, as published by the Free Software Foundation.
  19 #
  20 # OpenOffice.org is distributed in the hope that it will be useful,
  21 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 # GNU Lesser General Public License version 3 for more details
  24 # (a copy is included in the LICENSE file that accompanied this code).
  25 #
  26 # You should have received a copy of the GNU Lesser General Public License
  27 # version 3 along with OpenOffice.org.  If not, see
  28 # <http://www.openoffice.org/license.html>
  29 # for a copy of the LGPLv3 License.
  30 #
  31 #*************************************************************************
  32
  33 #*************************************************************************
  34 #
  35 # cws.pl   - wrap common childworkspace operations
  36 #
  37 use strict;
  38 use Getopt::Long;
  39 use File::Basename;
  40 use File::Path;
  41 use Cwd;
  42
  43 #### module lookup
  44 my @lib_dirs;
  45 BEGIN {
  46     if ( !defined($ENV{SOLARENV}) ) {
  47         die "No environment found (environment variable SOLARENV is undefined)";
  48     }
  49     push(@lib_dirs, "$ENV{SOLARENV}/bin/modules");
  50 }
  51 use lib (@lib_dirs);
  52
  53 use Cws;
  54
  55 #### script id #####
  56
  57 ( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;
  58
  59 #### globals ####
  60
  61 # valid command with possible abbreviations
  62 my @valid_commands = (
  63                         'help', 'h', '?',
  64                         'create',
  65                         'fetch',  'f',
  66                         'rebase', 'rb',
  67                         'analyze', 'an',
  68                         'query', 'q',
  69                         'task', 't',
  70                         'integrate',
  71                         'cdiff', 'cd',
  72                         'eisclone',
  73                         'setcurrent'
  74                      );
  75
  76 # list the valid options to each command
  77 my %valid_options_hash = (
  78                             'help'       => ['help'],
  79                             'create'     => ['help', 'milestone', 'migration', 'hg'],
  80                             'fetch'      => ['help', 'switch', 'milestone', 'childworkspace','platforms','quiet',
  81                                             'onlysolver'],
  82                             'rebase'     => ['help', 'milestone','commit'],
  83                             'analyze'    => ['help'],
  84                             'query'      => ['help', 'milestone','masterworkspace','childworkspace'],
  85                             'task'       => ['help'],
  86                             'integrate'  => ['help', 'childworkspace'],
  87                             'cdiff'      => ['help', 'childworkspace', 'masterworkspace', 'files', 'modules'],
  88                             'setcurrent' => ['help', 'milestone'],
  89                             'eisclone'   => ['help']
  90                          );
  91
  92 my %valid_commands_hash;
  93 for (@valid_commands) {
  94     $valid_commands_hash{$_}++;
  95 }
  96
  97 #  set by --debug switch
  98 my $debug = 0;
  99
 100 #### main ####
 101
 102 my ($command, $args_ref, $options_ref) = parse_command_line();
 103 dispatch_command($command, $args_ref, $options_ref);
 104 exit(0);
 105
 106 #### subroutines ####
 107
 108 # Parses the command line. does prelimiary argument and option verification
 109 sub parse_command_line
 110 {
 111     if (@ARGV == 0) {
 112         usage();
 113         exit(1);
 114     }
 115
 116     my %options_hash;
 117     Getopt::Long::Configure ("no_auto_abbrev", "no_ignorecase");
 118     my $success = GetOptions(\%options_hash, 'milestone|m=s',
 119                                              'masterworkspace|master|M=s',
 120                                              'hg',
 121                                              'migration',
 122                                              'childworkspace|child|c=s',
 123                                              'debug',
 124                                              'commit|C',
 125                                              'switch|s',
 126                                              'platforms|p=s',
 127                                              'onlysolver|o',
 128                                              'quiet|q',
 129                                              'files',
 130                                              'modules',
 131                                              'help|h'
 132                             );
 133
 134     my $command = shift @ARGV;
 135
 136     if (!exists $valid_commands_hash{$command}) {
 137         print_error("Unkown command: '$command'\n");
 138         usage();
 139         exit(1);
 140     }
 141
 142     if ($command eq 'h' || $command eq '?') {
 143         $command = 'help';
 144     }
 145     elsif ($command eq 'f') {
 146         $command = 'fetch';
 147     }
 148     elsif ($command eq 'rb') {
 149         $command = 'rebase';
 150     }
 151     elsif ($command eq 'an') {
 152         $command = 'analyze';
 153     }
 154     elsif ($command eq 'q') {
 155         $command = 'query';
 156     }
 157     elsif ($command eq 't') {
 158         $command = 'task';
 159     }
 160     elsif ($command eq 'cd') {
 161         $command = 'cdiff';
 162     }
 163
 164     # An unkown option might be accompanied with a valid command.
 165     # Show the command specific help
 166     if ( !$success ) {
 167         do_help([$command])
 168     }
 169
 170     verify_options($command, \%options_hash);
 171     return ($command, \@ARGV, \%options_hash);
 172 }
 173
 174 # Verify options against the valid options list.
 175 sub verify_options
 176 {
 177     my $command     = shift;
 178     my $options_ref = shift;
 179
 180     my $valid_command_options_ref = $valid_options_hash{$command};
 181
 182     my %valid_command_options_hash;
 183     foreach (@{$valid_command_options_ref}) {
 184         $valid_command_options_hash{$_}++;
 185     }
 186
 187     # check all specified options against the valid options for the sub command
 188     foreach (keys %{$options_ref}) {
 189         if ( /debug/ ) {
 190             $debug = 1;
 191             next;
 192         }
 193         if (!exists $valid_command_options_hash{$_}) {
 194             print_error("can't use option '--$_' with subcommand '$command'.", 1);
 195         }
 196     }
 197
 198     # TODO here should be specific checks for the arguments
 199     # if the check is globally valid
 200 }
 201
 202 # Dispatches to the do_xxx() routines depending on command.
 203 sub dispatch_command
 204 {
 205     my $command     = shift;
 206     my $args_ref    = shift;
 207     my $options_ref = shift;
 208
 209     no strict 'refs';
 210     &{"do_".$command}($args_ref, $options_ref);
 211 }
 212
 213 # Returns the global cws object.
 214 BEGIN {
 215 my $the_cws;
 216
 217     sub get_this_cws {
 218         if (!defined($the_cws)) {
 219             $the_cws = Cws->new();
 220             return $the_cws;
 221         }
 222         else {
 223             return $the_cws;
 224         }
 225     }
 226 }
 227
 228 # Returns a list of the master workspaces.
 229 sub get_master_workspaces
 230 {
 231     my $cws = get_this_cws();
 232     my @masters = $cws->get_masters();
 233
 234     return wantarray ? @masters : \@masters;
 235 }
 236
 237 # Checks if master argument is a valid MWS name.
 238 BEGIN {
 239     my %master_hash;
 240
 241     sub is_master
 242     {
 243         my $master_name = shift;
 244
 245         if (!%master_hash) {
 246             my @masters = get_master_workspaces();
 247             foreach (@masters) {
 248                 $master_hash{$_}++;
 249             }
 250         }
 251         return exists $master_hash{$master_name} ? 1 : 0;
 252     }
 253 }
 254
 255 # Fetches milestone URL for given server and milestone.
 256 sub get_milestone_url
 257 {
 258     my $server    = shift;
 259     my $master    = shift;
 260     my $milestone = shift;
 261
 262     my $milestone_url = "$server/tags/${master}_${milestone}";
 263     return $milestone_url;
 264 }
 265
 266 # Fetches CWS URL for given server and CWSname.
 267 sub get_cws_url
 268 {
 269     my $server = shift;
 270     my $cws    = shift;
 271
 272     my $cws_url = "$server/cws/$cws";
 273     return $cws_url;
 274 }
 275
 276 sub get_master_url
 277 {
 278     my $server   = shift;
 279     my $master   = shift;
 280     my $revision = shift;
 281
 282     my $url = "${server}/";
 283
 284     # TODO: update EIS function for subversion
 285     my $cws = get_this_cws();
 286     my $trunk = $cws->get_cvs_head();
 287     if ( $master eq $trunk ) {
 288         $url .= 'trunk';
 289     }
 290     else {
 291         my $master_label = uc($master);
 292         $url .= "branches/$master_label";
 293     }
 294
 295     # attach revision if needed
 296     if ( $revision != 0 ) {
 297         $url .= "\@$revision";
 298     }
 299     return $url;
 300 }
 301
 302 # Returns the URL shortened by the server part
 303 sub get_short_url
 304 {
 305     my $server = shift;
 306     my $url    = shift;
 307
 308     my $offset = length("$server/");
 309     $url = substr($url, $offset);
 310
 311     return $url;
 312 }
 313
 314
 315 # Fetches the current CWS from environment, returns a Cws object
 316 sub get_cws_from_environment
 317 {
 318     my $child  = $ENV{CWS_WORK_STAMP};
 319     my $master = $ENV{WORK_STAMP};
 320
 321     if ( !$child ) {
 322         print_error("Environment variable CWS_WORK_STAMP is not set. Please set it to your CWS name.", 2);
 323     }
 324
 325     if ( !$master ) {
 326         print_error("Environment variable WORK_STAMP is not set. Please set it to the MWS name.", 2);
 327     }
 328
 329     my $cws = get_this_cws();
 330     $cws->child($child);
 331     $cws->master($master);
 332
 333     # Check if we got a valid child workspace.
 334     my $id = $cws->eis_id();
 335     if ( $debug ) {
 336         print STDERR "CWS-DEBUG: ... master: $master, child: $child, $id\n";
 337     }
 338     if ( !$id ) {
 339         print_error("Child workspace $child for master workspace $master not found in EIS database.", 2);
 340     }
 341     return ($cws);
 342 }
 343
 344 # Fetches the CWS by name, returns a Cws object
 345 sub get_cws_by_name
 346 {
 347     my $child  = shift;
 348
 349     my $cws = get_this_cws();
 350     $cws->child($child);
 351
 352     # Check if we got a valid child workspace.
 353     my $id = $cws->eis_id();
 354     if ( $debug ) {
 355         print STDERR "CWS-DEBUG: child: $child, $id\n";
 356     }
 357     if ( !$id ) {
 358         print_error("Child workspace $child not found in EIS database.", 2);
 359     }
 360
 361     # Update masterws part of Cws object.
 362     my $masterws = $cws->get_mws();
 363     $cws->master($masterws);
 364     return ($cws);
 365 }
 366
 367 # Register child workspace with eis.
 368 sub register_child_workspace
 369 {
 370     my $cws          = shift;
 371     my $scm          = shift;
 372     my $is_promotion = shift;
 373
 374     my $milestone = $cws->milestone();
 375     my $child     = $cws->child();
 376     my $master    = $cws->master();
 377
 378     # TODO: introduce a EIS_USER in the configuration, which should be used here
 379     my $config = CwsConfig->new();
 380     my $vcsid  = $config->vcsid();
 381     # TODO: there is no real need for socustom anymore, should go ASAP
 382     my $socustom = $config->sointernal();
 383
 384     if ( !$vcsid ) {
 385         if ( $socustom ) {
 386             print_error("Can't determine owner for CWS '$child'. Please set VCSID environment variable.", 11);
 387         }
 388         else {
 389             print_error("Can't determine owner for CWS '$child'. Please set CVS_ID entry in \$HOME/.cwsrc.", 11);
 390         }
 391     }
 392
 393     if ( $is_promotion ) {
 394         my $rc = $cws->set_scm($scm);
 395         if ( !$rc ) {
 396             print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12);
 397         }
 398
 399         $rc = $cws->promote($vcsid, "");
 400
 401         if ( !$rc ) {
 402             print_error("Failed to promote child workspace '$child' to status 'new'.\n", 12);
 403         }
 404         else {
 405             print "\n***** Successfully ***** promoted child workspace '$child' to status 'new'.\n";
 406             print "Milestone: '$milestone'.\n";
 407         }
 408     }
 409     else {
 410
 411         my $eis_id = $cws->register($vcsid, "");
 412
 413         if ( !defined($eis_id) ) {
 414             print_error("Failed to register child workspace '$child' for master '$master'.", 12);
 415         }
 416         else {
 417             my $rc = $cws->set_scm($scm);
 418             if ( !$rc ) {
 419                 print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12);
 420             }
 421             print "\n***** Successfully ***** registered child workspace '$child'\n";
 422             print "for master workspace '$master' (milestone '$milestone').\n";
 423             print "Child workspace Id: $eis_id.\n";
 424         }
 425     }
 426     return 0;
 427 }
 428
 429 sub query_cws
 430 {
 431     my $query_mode = shift;
 432     my $options_ref = shift;
 433     # get master and child workspace
 434     my $masterws  = exists $options_ref->{'masterworkspace'} ? uc($options_ref->{'masterworkspace'}) : $ENV{WORK_STAMP};
 435     my $childws   = exists $options_ref->{'childworkspace'} ? $options_ref->{'childworkspace'} : $ENV{CWS_WORK_STAMP};
 436     my $milestone = exists $options_ref->{'milestone'} ? $options_ref->{'milestone'} : 'latest';
 437
 438     if ( !defined($masterws) && $query_mode ne 'masters') {
 439         print_error("Can't determine master workspace environment.\n", 30);
 440     }
 441
 442     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) ) {
 443         print_error("Can't determine child workspace environment.\n", 30);
 444     }
 445
 446     my $cws = Cws->new();
 447     if ( defined($childws) ) {
 448         $cws->child($childws);
 449     }
 450     if ( defined($masterws) ) {
 451         $cws->master($masterws);
 452     }
 453
 454     no strict;
 455     &{"query_".$query_mode}($cws, $milestone);
 456     return;
 457 }
 458
 459 sub query_integratedinto
 460 {
 461     my $cws = shift;
 462
 463     if ( is_valid_cws($cws) ) {
 464         my $milestone = $cws->get_milestone_integrated();
 465         print_message("Integrated into:");
 466         print defined($milestone) ? "$milestone\n" : "unkown\n";
 467     }
 468     return;
 469 }
 470
 471 sub query_incompatible
 472 {
 473     my $cws = shift;
 474
 475     if ( is_valid_cws($cws) ) {
 476         my @modules = $cws->incompatible_modules();
 477         print_message("Incompatible Modules:");
 478         foreach (@modules) {
 479             if ( defined($_) ) {
 480                 print "$_\n";
 481             }
 482         }
 483     }
 484     return;
 485 }
 486
 487 sub query_taskids
 488 {
 489     my $cws = shift;
 490
 491     if ( is_valid_cws($cws) ) {
 492         my @taskids = $cws->taskids();
 493         print_message("Task ID(s):");
 494         foreach (@taskids) {
 495             if ( defined($_) ) {
 496                 print "$_\n";
 497             }
 498         }
 499     }
 500     return;
 501 }
 502
 503 sub query_status
 504 {
 505     my $cws = shift;
 506
 507     if ( is_valid_cws($cws) ) {
 508         my $status = $cws->get_approval();
 509         if ( !$status ) {
 510             print_error("Internal error: can't get approval status.", 3);
 511         } else {
 512             print_message("Approval status:");
 513             print "$status\n";
 514         }
 515     }
 516     return;
 517 }
 518
 519 sub query_scm
 520 {
 521     my $cws = shift;
 522     my $masterws = $cws->master();
 523     my $childws  = $cws->child();
 524
 525     if ( is_valid_cws($cws) ) {
 526         my $scm = $cws->get_scm();
 527         if ( !defined($scm) ) {
 528             print_error("Internal error: can't retrieve scm info.", 3);
 529         } else {
 530                 print_message("Child workspace uses '$scm'.");
 531         }
 532     }
 533
 534     return;
 535 }
 536
 537 sub query_ispublic
 538 {
 539     my $cws = shift;
 540     my $masterws = $cws->master();
 541     my $childws  = $cws->child();
 542
 543     if ( is_valid_cws($cws) ) {
 544         my $ispublic = $cws->get_public_flag();
 545         if ( !defined($ispublic) ) {
 546             print_error("Internal error: can't get isPublic flag.", 3);
 547         } else {
 548             if ( $ispublic==1 ) {
 549                 print_message("Child workspace is public");
 550             } else {
 551                 print_message("Child workspace is internal");
 552             }
 553         }
 554     }
 555
 556     return;
 557 }
 558
 559 sub query_current
 560 {
 561     my $cws = shift;
 562
 563     if ( is_valid_cws($cws) ) {
 564         my $milestone = $cws->milestone();
 565         if ( !$milestone ) {
 566             print_error("Internal error: can't get current milestone.", 3);
 567         } else {
 568             print_message("Current milestone:");
 569             print "$milestone\n";
 570         }
 571     }
 572     return;
 573 }
 574
 575 sub query_owner
 576 {
 577     my $cws = shift;
 578
 579     if ( is_valid_cws($cws) ) {
 580         my $owner = $cws->get_owner();
 581         print_message("Owner:");
 582         if ( !$owner ) {
 583             print "not set\n" ;
 584         } else {
 585             print "$owner\n";
 586         }
 587     }
 588     return;
 589 }
 590
 591 sub query_qarep
 592 {
 593     my $cws = shift;
 594
 595     if ( is_valid_cws($cws) ) {
 596         my $qarep = $cws->get_qarep();
 597         print_message("QA Representative:");
 598         if ( !$qarep ) {
 599             print "not set\n" ;
 600         } else {
 601             print "$qarep\n";
 602         }
 603     }
 604     return;
 605 }
 606
 607
 608 sub query_build
 609 {
 610     my $cws = shift;
 611
 612     if ( is_valid_cws($cws) ) {
 613         my $build = $cws->get_build();
 614         print_message("Build:");
 615         if ( $build ) {
 616             print "$build\n";
 617         }
 618     }
 619     return;
 620 }
 621
 622 sub query_latest
 623 {
 624     my $cws = shift;
 625
 626     my $masterws = $cws->master();
 627     my $latest = $cws->get_current_milestone($masterws);
 628
 629
 630     if ( $latest ) {
 631         print_message("Master workspace '$masterws':");
 632         print_message("Latest milestone available for rebase:");
 633         print "$masterws $latest\n";
 634     }
 635     else {
 636         print_error("Can't determine latest milestone of '$masterws' available for rebase.", 3);
 637     }
 638
 639     return;
 640 }
 641
 642 sub query_masters
 643 {
 644     my $cws = shift;
 645
 646     my @mws = $cws->get_masters();
 647     my $list="";
 648
 649     if ( @mws ) {
 650         foreach (@mws) {
 651             if ( $list ne "" ) {
 652                 $list .= ", ";
 653             }
 654             $list .= $_;
 655         }
 656         print_message("Master workspaces available: $list");
 657     }
 658     else {
 659         print_error("Can't determine masterworkspaces.", 3);
 660     }
 661
 662     return;
 663 }
 664
 665 sub query_milestones
 666 {
 667     my $cws = shift;
 668     my $masterws = $cws->master();
 669
 670     my @milestones = $cws->get_milestones($masterws);
 671     my $list="";
 672
 673     if ( @milestones ) {
 674         foreach (@milestones) {
 675             if ( $list ne "" ) {
 676                 $list .= ", ";
 677             }
 678             $list .= $_;
 679         }
 680         print_message("Master workspace '$masterws':");
 681         print_message("Milestones known on Master: $list");
 682     }
 683     else {
 684         print_error("Can't determine milestones of '$masterws'.", 3);
 685     }
 686
 687     return;
 688 }
 689
 690 sub query_ispublicmaster
 691 {
 692     my $cws = shift;
 693     my $masterws = $cws->master();
 694
 695     my $ispublic = $cws->get_publicmaster_flag();
 696     my $list="";
 697
 698     if ( defined($ispublic) ) {
 699         print_message("Master workspace '$masterws':");
 700         if ( !defined($ispublic) ) {
 701             print_error("Internal error: can't get isPublicMaster flag.", 3);
 702         } else {
 703             if ( $ispublic==1 ) {
 704                 print_message("Master workspace is public");
 705             } else {
 706                 print_message("Master workspace is internal");
 707             }
 708         }
 709     }
 710     else {
 711         print_error("Can't determine isPublicMaster flag of '$masterws'.", 3);
 712     }
 713
 714     return;
 715 }
 716
 717 sub query_buildid
 718 {
 719     my $cws       = shift;
 720     my $milestone = shift;
 721
 722     my $masterws = $cws->master();
 723     if ( $milestone eq 'latest' ) {
 724         $milestone = $cws->get_current_milestone($masterws);
 725     }
 726
 727     if ( !$milestone ) {
 728         print_error("Can't determine latest milestone of '$masterws'.", 3);
 729     }
 730
 731     if ( !$cws->is_milestone($masterws, $milestone) ) {
 732         print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3);
 733     }
 734
 735     my $buildid = $cws->get_buildid($masterws, $milestone);
 736
 737
 738     if ( $buildid ) {
 739         print_message("Master workspace '$masterws':");
 740         print_message("BuildId for milestone '$milestone':");
 741         print("$buildid\n");
 742     }
 743
 744     return;
 745 }
 746
 747 sub query_integrated
 748 {
 749     my $cws       = shift;
 750     my $milestone = shift;
 751
 752     my $masterws = $cws->master();
 753     if ( $milestone eq 'latest' ) {
 754         $milestone = $cws->get_current_milestone($masterws);
 755     }
 756
 757     if ( !$milestone ) {
 758         print_error("Can't determine latest milestone of '$masterws'.", 3);
 759     }
 760
 761     if ( !$cws->is_milestone($masterws, $milestone) ) {
 762         print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3);
 763     }
 764
 765     my @integrated_cws = $cws->get_integrated_cws($masterws, $milestone);
 766
 767
 768     if ( @integrated_cws ) {
 769         print_message("Master workspace '$masterws':");
 770         print_message("Integrated CWSs for milestone '$milestone':");
 771         foreach (@integrated_cws) {
 772             print "$_\n";
 773         }
 774     }
 775
 776     return;
 777 }
 778
 779 sub query_approved
 780 {
 781     my $cws       = shift;
 782
 783     my $masterws = $cws->master();
 784
 785     my @approved_cws = $cws->get_cws_with_state($masterws, 'approved by QA');
 786
 787     if ( @approved_cws ) {
 788         print_message("Master workspace '$masterws':");
 789         print_message("CWSs approved by QA:");
 790         foreach (@approved_cws) {
 791             print "$_\n";
 792         }
 793     }
 794
 795     return;
 796 }
 797
 798 sub query_nominated
 799 {
 800     my $cws       = shift;
 801
 802     my $masterws = $cws->master();
 803
 804     my @nominated_cws = $cws->get_cws_with_state($masterws, 'nominated');
 805
 806     if ( @nominated_cws ) {
 807         print_message("Master workspace '$masterws':");
 808         print_message("Nominated CWSs:");
 809         foreach (@nominated_cws) {
 810             print "$_\n";
 811         }
 812     }
 813
 814     return;
 815 }
 816
 817 sub query_ready
 818 {
 819     my $cws       = shift;
 820
 821     my $masterws = $cws->master();
 822
 823     my @ready_cws = $cws->get_cws_with_state($masterws, 'ready for QA');
 824
 825     if ( @ready_cws ) {
 826         print_message("Master workspace '$masterws':");
 827         print_message("CWSs ready for QA:");
 828         foreach (@ready_cws) {
 829             print "$_\n";
 830         }
 831     }
 832
 833     return;
 834 }
 835
 836 sub query_new
 837 {
 838     my $cws       = shift;
 839
 840     my $masterws = $cws->master();
 841
 842     my @ready_cws = $cws->get_cws_with_state($masterws, 'new');
 843
 844     if ( @ready_cws ) {
 845         print_message("Master workspace '$masterws':");
 846         print_message("CWSs with state 'new':");
 847         foreach (@ready_cws) {
 848             print "$_\n";
 849         }
 850     }
 851
 852     return;
 853 }
 854
 855 sub query_planned
 856 {
 857     my $cws       = shift;
 858
 859     my $masterws = $cws->master();
 860
 861     my @ready_cws = $cws->get_cws_with_state($masterws, 'planned');
 862
 863     if ( @ready_cws ) {
 864         print_message("Master workspace '$masterws':");
 865         print_message("CWSs with state 'planned':");
 866         foreach (@ready_cws) {
 867             print "$_\n";
 868         }
 869     }
 870
 871     return;
 872 }
 873
 874 sub is_valid_cws
 875 {
 876     my $cws = shift;
 877
 878     my $masterws = $cws->master();
 879     my $childws  = $cws->child();
 880     # check if we got a valid child workspace
 881     my $id = $cws->eis_id();
 882     if ( !$id ) {
 883         print_error("Child workspace '$childws' for master workspace '$masterws' not found in EIS database.", 2);
 884     }
 885     print STDERR "Master workspace '$masterws', child workspace '$childws'\n";
 886     return 1;
 887 }
 888
 889 sub query_release
 890 {
 891     my $cws = shift;
 892
 893     if ( is_valid_cws($cws) ) {
 894         my $release = $cws->get_release();
 895             print_message("Release target:");
 896         if ( !$release ) {
 897             print "not set\n";
 898         } else {
 899             print "$release\n";
 900         }
 901     }
 902     return;
 903 }
 904
 905 sub query_due
 906 {
 907     my $cws = shift;
 908
 909     if ( is_valid_cws($cws) ) {
 910         my $due = $cws->get_due_date();
 911             print_message("Due date:");
 912         if ( !$due ) {
 913             print "not set\n";
 914         } else {
 915             print "$due\n";
 916         }
 917     }
 918     return;
 919 }
 920
 921 sub query_due_qa
 922 {
 923     my $cws = shift;
 924
 925     if ( is_valid_cws($cws) ) {
 926         my $due_qa = $cws->get_due_date_qa();
 927             print_message("Due date (QA):");
 928         if ( !$due_qa ) {
 929             print "not set\n";
 930         } else {
 931             print "$due_qa\n";
 932         }
 933     }
 934     return;
 935 }
 936
 937 sub query_help
 938 {
 939     my $cws = shift;
 940
 941     if ( is_valid_cws($cws) ) {
 942         my $help = $cws->is_helprelevant();
 943             print_message("Help relevant:");
 944         if ( !$help ) {
 945             print "false\n";
 946         } else {
 947             print "true\n";
 948         }
 949     }
 950     return;
 951 }
 952
 953 sub query_ui
 954 {
 955     my $cws = shift;
 956
 957     if ( is_valid_cws($cws) ) {
 958         my $help = $cws->is_uirelevant();
 959             print_message("UI relevant:");
 960         if ( !$help ) {
 961             print "false\n";
 962         } else {
 963             print "true\n";
 964         }
 965     }
 966     return;
 967 }
 968
 969 sub verify_milestone
 970 {
 971     my $cws = shift;
 972     my $qualified_milestone = shift;
 973
 974     my $invalid = 0;
 975     my ($master, $milestone);
 976     $invalid++ if $qualified_milestone =~ /-/;
 977
 978     if ( $qualified_milestone =~ /:/ ) {
 979         ($master, $milestone) = split(/:/, $qualified_milestone);
 980         $invalid++ unless ( $master && $milestone );
 981     }
 982     else {
 983         $milestone = $qualified_milestone;
 984     }
 985
 986     if ( $invalid ) {
 987         print_error("Invalid milestone", 0);
 988         usage();
 989         exit(1);
 990     }
 991
 992     $master = $cws->master() if !$master;
 993     if ( !$cws->is_milestone($master, $milestone) ) {
 994         print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 21);
 995     }
 996     return ($master, $milestone);
 997 }
 998
 999 sub relink_workspace {
1000     my $linkdir = shift;
1001     my $restore = shift;
1002
1003     # The list of obligatorily added modules, build will not work
1004     # if these are not present.
1005     my %added_modules_hash;
1006     if (defined $ENV{ADDED_MODULES}) {
1007         for ( split(/\s/, $ENV{ADDED_MODULES}) ) {
1008             $added_modules_hash{$_}++;
1009         }
1010     }
1011
1012     # clean out pre-existing linkdir
1013     my $bd = dirname($linkdir);
1014     if ( !opendir(DIR, $bd) ) {
1015         print_error("Can't open directory '$bd': $!.", 44);
1016     }
1017     my @old_link_dirs = grep { /^src.m\d+/ } readdir(DIR);
1018     close(DIR);
1019
1020     if ( @old_link_dirs > 1 ) {
1021         print_error("Found more than one old link directories:", 0);
1022         foreach (@old_link_dirs) {
1023             print STDERR "@old_link_dirs\n";
1024         }
1025         if ( $restore ) {
1026             print_error("Please remove all old link directories but the last one", 67);
1027         }
1028     }
1029
1030     # Originally the extension .lnk indicated a linked module. This turned out to be
1031     # not an overly smart choice. Cygwin has some heuristics which regards .lnk
1032     # files as Windows shortcuts, breaking the build. Use .link instead.
1033     # When in restoring mode still consider .lnk as link to modules (for old CWSs)
1034     my $old_link_dir = "$bd/" . $old_link_dirs[0];
1035     if ( $restore ) {
1036         if ( !opendir(DIR, $old_link_dir) ) {
1037             print_error("Can't open directory '$old_link_dir': $!.", 44);
1038         }
1039         my @links = grep { !(/\.lnk/ || /\.link/)   } readdir(DIR);
1040         close(DIR);
1041         # everything which is not a link to a directory can't be an "added" module
1042         foreach (@links) {
1043             next if /^\./;
1044             my $link = "$old_link_dir/$_";
1045             if ( -s $link && -d $link ) {
1046                 $added_modules_hash{$_} = 1;
1047             }
1048         }
1049     }
1050     print_message("... removing '$old_link_dir'");
1051     rmtree([$old_link_dir], 0);
1052
1053     print_message("... (re)create '$linkdir'");
1054     if ( !mkdir("$linkdir") ) {
1055         print_error("Can't create directory '$linkdir': $!.", 44);
1056     }
1057     if ( !opendir(DIR, "$bd/ooo") ) {
1058         print_error("Can't open directory '$bd/sun': $!.", 44);
1059     }
1060     my @ooo_top_level_dirs = grep { !/^\./ } readdir(DIR);
1061     close(DIR);
1062     if ( !opendir(DIR, "$bd/sun") ) {
1063         print_error("Can't open directory '$bd/sun': $!.", 44);
1064     }
1065     my @so_top_level_dirs = grep { !/^\./ } readdir(DIR);
1066     close(DIR);
1067     my $savedir = getcwd();
1068     if ( !chdir($linkdir) ) {
1069         print_error("Can't chdir() to directory '$linkdir': $!.", 44);
1070     }
1071     my $suffix = '.link';
1072     foreach(@ooo_top_level_dirs) {
1073         if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE'  ) {
1074             next;
1075         }
1076         my $target = $_;
1077         if ( -d "../ooo/$_" && !exists $added_modules_hash{$_} ) {
1078             $target .= $suffix;
1079         }
1080         if ( !symlink("../ooo/$_", $target) ) {
1081             print_error("Can't symlink directory '../ooo/$_ -> $target': $!.", 44);
1082         }
1083     }
1084     foreach(@so_top_level_dirs) {
1085         if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE'  ) {
1086             next;
1087         }
1088         my $target = $_;
1089         if ( -d "../sun/$_" && !exists $added_modules_hash{$_} ) {
1090             $target .= $suffix;
1091         }
1092         if ( !symlink("../sun/$_", $target) ) {
1093             print_error("Can't symlink directory '../sun/$_ -> $target': $!.", 44);
1094         }
1095     }
1096     if ( !chdir($savedir) ) {
1097         print_error("Can't chdir() to directory '$linkdir': $!.", 44);
1098     }
1099 }
1100
1101 sub update_solver
1102 {
1103     my $platform   = shift;
1104     my $source     = shift;
1105     my $solver     = shift;
1106     my $milestone  = shift;
1107
1108     my @zip_sub_dirs = ('bin', 'doc', 'idl', 'inc', 'lib', 'par', 'pck', 'pdb', 'pus', 'rdb', 'res', 'xml', 'sdf');
1109
1110     use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
1111
1112     my $platform_solver = "$solver/$platform";
1113
1114     if ( -d $platform_solver ) {
1115         print_message("... removing old solver for platform '$platform'");
1116         if ( !rmtree([$platform_solver]) ) {
1117             print_error("Can't remove directory '$platform_solver': $!.", 44);
1118         }
1119     }
1120
1121     if ( !mkdir("$platform_solver") ) {
1122         print_error("Can't create directory '$platform_solver': $!.", 44);
1123     }
1124
1125     my $platform_source = "$source/$platform/zip.$milestone";
1126     if ( !opendir(DIR, "$platform_source") ) {
1127         print_error("Can't open directory '$platform_source': $!.", 44);
1128     }
1129     my @zips = grep { /\.zip$/ } readdir(DIR);
1130     close(DIR);
1131
1132     my $nzips = @zips;
1133     print_message("... unzipping $nzips zip archives for platform '$platform'");
1134
1135     foreach(@zips) {
1136         my $zip = Archive::Zip->new();
1137         unless ( $zip->read( "$platform_source/$_" ) == AZ_OK ) {
1138             print_error("Can't read zip file '$platform_source/$_': $!.", 44);
1139         }
1140         # TODO: check for erorrs
1141         foreach (@zip_sub_dirs) {
1142             unless ( $zip->extractTree($_, "$platform_solver/$_.$milestone") == AZ_OK ) {
1143                 print_error("Can't extract stream from zip file '$platform_source/$_': $!.", 44);
1144             }
1145         }
1146      }
1147 }
1148
1149 sub write_rebase_configuration
1150 {
1151     my $workspace = shift;
1152     my $cwsname   = shift;
1153     my $master    = shift;
1154     my $milestone = shift;
1155
1156     my $rebase_config = "$workspace/REBASE.CONFIG_DONT_DELETE";
1157
1158     open(REBASE, ">$rebase_config") or print_error("Can't open file '$rebase_config' for writing: $!", 98);
1159     print REBASE "CWS-TOOLING: do not delete this file, it's needed for 'cws rebase -C'\n";
1160     print REBASE "CWS: $cwsname\n";
1161     print REBASE "New MWS: $master\n";
1162     print REBASE "New milestone: $milestone\n";
1163     close(REBASE);
1164 }
1165
1166 sub read_rebase_configuration
1167 {
1168     my $workspace = shift;
1169
1170     my $rebase_config = "$workspace/REBASE.CONFIG_DONT_DELETE";
1171
1172     my $master;
1173     my $milestone;
1174
1175     open(REBASE, "<$rebase_config") or print_error("Can't open file '$rebase_config' for reading: $!", 98);
1176     while(<REBASE>) {
1177         if ( /New MWS: (\w+)/ ) {
1178             $master = $1;
1179         }
1180         if ( /New milestone: (\w+)/ ) {
1181             $milestone = $1;
1182         }
1183     }
1184     close(REBASE);
1185
1186     if ( !defined($master) || !defined($milestone) ) {
1187         print_error("File '$rebase_config' seems to be garbled. Can't continue.", 98)
1188     }
1189
1190     return ($master, $milestone);
1191 }
1192
1193 sub diff_print_files
1194 {
1195     my $files_ref = shift;
1196     my $diff_options = shift;
1197
1198     my @files = sort(@{$files_ref});
1199
1200     if ( $diff_options eq 'files') {
1201         foreach(@files) {
1202             print "$_\n";
1203         }
1204     }
1205     else {
1206         my @modules;
1207         foreach(@files) {
1208             my ($module) = split(/\//, $_);
1209             push(@modules, $module);
1210         }
1211         # remove adjacent uniques
1212         my $prev = 'nosuchmodule';
1213         my @unique_modules = grep($_ ne $prev && (($prev) = $_), @modules);
1214         foreach(@unique_modules) {
1215             print "$_\n";
1216         }
1217     }
1218 }
1219
1220 # Executes the help command.
1221 sub do_help
1222 {
1223     my $args_ref    = shift;
1224     my $options_ref = shift;
1225
1226     if (@{$args_ref} == 0) {
1227         print STDERR "usage: cws <subcommand> [options] [args]\n";
1228         print STDERR "Type 'cws help <subcommand>' for help on a specific subcommand.\n";
1229         print STDERR "\n";
1230         print STDERR "Available subcommands:\n";
1231         print STDERR "\thelp (h,?)\n";
1232         print STDERR "\tcreate\n";
1233         print STDERR "\tfetch (f)\n";
1234         print STDERR "\trebase (rb)\n";
1235         print STDERR "\tanalyze (an)\n";
1236         print STDERR "\tquery (q)\n";
1237         print STDERR "\ttask (t)\n";
1238         print STDERR "\tcdiff (cd)\n";
1239         print STDERR "\tsetcurrent\n";
1240         print STDERR "\tintegrate *** release engineers only ***\n";
1241         print STDERR "\teisclone *** release engineers only ***\n";
1242     }
1243
1244     my $arg = $args_ref->[0];
1245
1246     if (!defined($arg) || $arg eq 'help') {
1247         print STDERR "help (h, ?): Describe the usage of this script or its subcommands\n";
1248         print STDERR "usage: help [subcommand]\n";
1249     }
1250     elsif ($arg eq 'create') {
1251         print STDERR "create: Create a new child workspace\n";
1252         print STDERR "usage: create [--hg] [-m milestone] <master workspace> <child workspace>\n";
1253         print STDERR "\t-m milestone:          Milestone to base the child workspace on. If ommitted the\n";
1254         print STDERR "\t                       last published milestone will be used.\n";
1255         print STDERR "\t--milestone milestone: Same as -m milestone.\n";
1256         print STDERR "\t--hg:                  Create Mercurial (hg) based CWS.\n";
1257         print STDERR "\t--migration:           Used only for the migration of an exitisting CWS from CVS to SVN.\n";
1258         print STDERR "\t                       Disables existence check in EIS, creates CWS branch in SVN, sets SVN flag.\n";
1259     }
1260     elsif ($arg eq 'task') {
1261         print STDERR "task: Add a task to a child workspace\n";
1262         print STDERR "usage: task <task id> [task id ...]\n";
1263     }
1264     elsif ($arg eq 'query') {
1265         print STDERR "query: Query child workspace for miscellaneous information\n";
1266         print STDERR "usage: query [-M master] [-c child] <current|integratedinto|incompatible|owner|qarep|status|taskids>\n";
1267         print STDERR "       query [-M master] [-c child] <release|due|due_qa|help|ui|ispublic|scm|build>\n";
1268         print STDERR "       query [-M master] <latest|milestones|ispublicmaster>\n";
1269         print STDERR "       query  <masters>\n";
1270         print STDERR "       query [-M master] [-m milestone] <integrated|buildid>\n";
1271         print STDERR "       query [-M master] <planned|new|approved|nominated|ready>\n";
1272         print STDERR "\t-M master:\t\toverride MWS specified in environment\n";
1273         print STDERR "\t-c child:\t\toverride CWS specified in environment\n";
1274         print STDERR "\t-m milestone:\t\toverride latest milestone with specified one\n";
1275         print STDERR "\t--master master:\tSame as -M master\t\n";
1276         print STDERR "\t--child child:\t\tSame -c child\n";
1277         print STDERR "\t--milestone milestone:\tSame as -m milestone\n";
1278         print STDERR "Modes:\n";
1279         print STDERR "\tcurrent\t\tquery current milestone of CWS\n";
1280         print STDERR "\tincompatible\tquery modules which should be build incompatible\n";
1281         print STDERR "\towner\t\tquery CWS owner\n";
1282         print STDERR "\tqarep\t\tquery CWS QA Representative\n";
1283         print STDERR "\tstatus\t\tquery approval status of CWS\n";
1284         print STDERR "\ttaskids\t\tquery taskids to be handled on the CWS\n";
1285         print STDERR "\trelease\t\tquery for target release of CWS\n";
1286         print STDERR "\tdue\t\tquery for due date of CWS\n";
1287         print STDERR "\tdue_qa\t\tquery for due date (QA) of CWS\n";
1288         print STDERR "\thelp\t\tquery if the CWS is help relevant\n";
1289         print STDERR "\tui\t\tquery if the CWS is UI relevant\n";
1290         print STDERR "\tbuild\t\tquery build String for CWS\n";
1291         print STDERR "\tlatest\t\tquery the latest milestone available for resync\n";
1292         print STDERR "\tbuildid\t\tquery build ID for milestone\n";
1293         print STDERR "\tintegrated\tquery integrated CWSs for milestone\n";
1294         print STDERR "\tintegratedinto\tquery milestone which CWS was integrated into\n";
1295         print STDERR "\tplanned\t\tquery for planned CWSs\n";
1296         print STDERR "\tnew\t\tquery for new CWSs\n";
1297         print STDERR "\tapproved\tquery CWSs approved by QA\n";
1298         print STDERR "\tnominated\tquery nominated CWSs\n";
1299         print STDERR "\tready\t\tquery CWSs ready for QA\n";
1300         print STDERR "\tispublic\tquery public flag of CWS\n";
1301         print STDERR "\tscm\t\tquery Source Control Management (SCM) system used for CWS\n";
1302         print STDERR "\tmasters\t\tquery available MWS\n";
1303         print STDERR "\tmilestones\tquery which milestones are know on the given MWS\n";
1304         print STDERR "\tispublicmaster\tquery public flag of MWS\n";
1305
1306      }
1307     elsif ($arg eq 'fetch') {
1308         print STDERR "THE USER-INTERFACE TO THIS SUBCOMMAND IS LIKELY TO CHANGE IN FUTURE\n";
1309         print STDERR "fetch: fetch a milestone or CWS\n";
1310         print STDERR "usage: fetch [-q] [-s] [-p platforms] [-o] <-m milestone> <workspace>\n";
1311         print STDERR "usage: fetch [-q] [-s] [-p platforms] [-o] <-c cws> <workspace>\n";
1312         print STDERR "usage: fetch [-q] [-s] <-m milestone> <workspace>\n";
1313         print STDERR "usage: fetch [-q] [-s] <-c cws> <workspace>\n";
1314         print STDERR "\t-m milestone:           Checkout milestone <milestone> to workspace <workspace>\n";
1315         print STDERR "\t                        Use 'latest' for the for lastest published milestone on the current master\n";
1316         print STDERR "\t                        For cross master checkouts use the form <MWS>:<milestone>\n";
1317         print STDERR "\t--milestone milestone:  Same as -m milestone\n";
1318         print STDERR "\t-c childworkspace:      Checkout CWS <childworkspace> to workspace <workspace>\n";
1319         print STDERR "\t--child childworkspace: Same as -c childworkspace\n";
1320         print STDERR "\t-s:                     Try to switch an existing workspace <workspace> to milestone or CWS\n";
1321         print STDERR "\t--switch:               Same as -s\n";
1322         print STDERR "\t-p platform:            Copy one or more prebuilt platforms 'platform'. \n";
1323         print STDERR "\t                        Separate multiple platforms with commas.\n";
1324         print STDERR "\t--platforms platform:   Same as -p\n";
1325         print STDERR "\t-o                      Omit checkout of sources, copy only solver. \n";
1326         print STDERR "\t--onlysolver:           Same as -o\n";
1327         print STDERR "\t-q                      Silence some of the output of the command.\n";
1328         print STDERR "\t--quiet:                Same as -q\n";
1329     }
1330     elsif ($arg eq 'rebase') {
1331         print STDERR "rebase: Rebase a child workspace to a new milestone\n";
1332         print STDERR "usage: rebase <-m milestone> <workspace>\n";
1333         print STDERR "usage: rebase <-C> <workspace>\n";
1334         print STDERR "\t-m milestone:          Merge changes on MWS into CWS up to and including milestone <milestone>\n";
1335         print STDERR "\t                       Use 'latest' for the for lastest published milestone on the current master\n";
1336         print STDERR "\t                       For cross master rebases use the form <MWS>:<milestone>\n";
1337         print STDERR "\t--milestone milestone: Same as -m milestone\n";
1338         print STDERR "\t-C:                    Commit changes made by merge step and update current milestone in database\n";
1339         print STDERR "\t--commit:              Same as -C\n"
1340     }
1341     elsif ($arg eq 'integrate') {
1342         print STDERR "integrate: Integrate a child workspace into a master workspace\n";
1343         print STDERR "usage: integrate <-c childworkspace>\n";
1344         print STDERR "usage: integrate <-C>\n";
1345         print STDERR "\t-c childworkspace:      Merge changes on CWS <childworkspace> into MWS\n";
1346         print STDERR "\t--child childworkspace: Same as -c childworkspace\n";
1347         print STDERR "\t-C:                     Commit changes made by merge step and update CWS status in database\n";
1348         print STDERR "\t--commit:               Same as -C\n"
1349     }
1350     elsif ($arg eq 'cdiff') {
1351         print STDERR "cdiff: Show changes on CWS relative to current milestone\n";
1352         print STDERR "usage: cdiff [-M master] [-c child] [--files] [--modules]\n";
1353         print STDERR "\t-M master:\t\toverride MWS specified in environment\n";
1354         print STDERR "\t-c child:\t\toverride CWS specified in environment\n";
1355         print STDERR "\t--master master:\tSame as -M master\t\n";
1356         print STDERR "\t--child child:\t\tSame -c child\n";
1357         print STDERR "\t--files:                Print only file names\n";
1358         print STDERR "\t--modules:              Print only top level directories aka modules\n"
1359     }
1360     elsif ($arg eq 'setcurrent') {
1361         print STDERR "setcurrent: Set the current milestone for the CWS (only hg based CWSs)\n";
1362         print STDERR "usage: setcurrent [-m milestone]\n";
1363         print STDERR "\t-m milestone:           Set milestone to <milestone> to workspace <workspace>\n";
1364         print STDERR "\t                        Use 'latest' for the for lastest published milestone on the current master\n";
1365         print STDERR "\t                        For cross master change use the form <MWS>:<milestone>\n";
1366         print STDERR "\t--milestone milestone:  Same as -m milestone\n";
1367     }
1368     else {
1369         print STDERR "'$arg': unknown subcommand\n";
1370         exit(1);
1371     }
1372     exit(0);
1373 }
1374
1375 # Executes the create command.
1376 sub do_create
1377 {
1378     my $args_ref    = shift;
1379     my $options_ref = shift;
1380
1381     if ( exists $options_ref->{'help'} || @{$args_ref} != 2) {
1382         do_help(['create']);
1383     }
1384
1385     my $is_migration = 0;
1386     if ( exists $options_ref->{'migration'} ) {
1387         $is_migration = 1;
1388     }
1389
1390     my $is_hg = 0;
1391     if ( exists $options_ref->{'hg'} ) {
1392         $is_hg = 1;
1393     }
1394
1395     my $master   = uc $args_ref->[0];
1396     my $cws_name = $args_ref->[1];
1397
1398     if (!is_master($master)) {
1399         print_error("'$master' is not a valid master workspace.", 7);
1400     }
1401
1402     # check if cws name fits the convention
1403     if ( $cws_name !~ /^\w[\w\.\#]*$/ ) {
1404         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);
1405     }
1406
1407     my $cws = get_this_cws();
1408     $cws->master($master);
1409     $cws->child($cws_name);
1410
1411     # check if child workspace already exists
1412     my $eis_id = $cws->eis_id();
1413     if ( !defined($eis_id) ) {
1414         print_error("Connection with EIS database failed.", 8);
1415     }
1416
1417     my $is_promotion = 0;
1418     if ( $eis_id > 0 ) {
1419         if ( $cws->get_approval() eq 'planned' ) {
1420             print "Promote child workspace '$cws_name' from 'planned' to 'new'.\n";
1421             $is_promotion++;
1422         }
1423         else {
1424             if ( $is_migration ) {
1425                 print_message("Create CWS branch in Subversion for migrating CWS '$cws_name' from CVS.");
1426             }
1427             else {
1428                 print_error("Child workspace '$cws_name' already exists.", 7);
1429             }
1430         }
1431     }
1432     else {
1433         # check if child workspace name is still available
1434         if ( !$cws->is_cws_name_available()) {
1435             print_error("Child workspace name '$cws_name' is already in use.", 7);
1436         }
1437     }
1438
1439     my $milestone;
1440     # verify milestone or query latest milestone
1441     if ( exists $options_ref->{'milestone'} ) {
1442         $milestone=$options_ref->{'milestone'};
1443         # check if milestone exists
1444         if ( !$cws->is_milestone($master, $milestone) ) {
1445             print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 8);
1446         }
1447     }
1448     else {
1449         $milestone=$cws->get_current_milestone($cws->master());
1450     }
1451
1452     # set milestone
1453     $cws->milestone($milestone);
1454
1455     # handle mercurial(hg) based CWSs
1456     if ( $is_hg ) {
1457         register_child_workspace($cws, 'hg', $is_promotion);
1458         return;
1459     }
1460
1461     my $config = CwsConfig->new();
1462     my $ooo_svn_server = $config->get_ooo_svn_server();
1463     my $so_svn_server = $config->get_so_svn_server();
1464
1465     if (!defined($ooo_svn_server)) {
1466         print_error("No OpenOffice.org SVN server defined, please check your configuration file.", 8);
1467     }
1468
1469     my $ooo_milestone_url = get_milestone_url($ooo_svn_server, $cws->master(), $milestone);
1470     my $ooo_cws_url = get_cws_url($ooo_svn_server, $cws_name);
1471
1472     my $so_milestone_url;
1473     my $so_cws_url;
1474     if ( defined($so_svn_server) ) {
1475         $so_milestone_url = get_milestone_url($so_svn_server, $cws->master(), $milestone);
1476         $so_cws_url = get_cws_url($so_svn_server, $cws_name);
1477     }
1478
1479     # There is a slight chance that the cws creation was interrupted before registration before.
1480     # Check for potential remains in the repository
1481     my $ooo_path_exists = 0;
1482     my $so_path_exists = 0;
1483
1484     print STDERR "... check cws path:\t'$ooo_cws_url'";
1485     if ( svn_path_exists($ooo_cws_url) ) {
1486         $ooo_path_exists=1;
1487         print STDERR "\n";
1488     }
1489     else {
1490         print STDERR ", OK\n";
1491     }
1492
1493     if ( defined($so_svn_server) ) {
1494         print STDERR "... check cws path:\t'$so_cws_url'";
1495         if  ( svn_path_exists($so_cws_url) ) {
1496             print STDERR "\n";
1497             $so_path_exists = 1;
1498         }
1499         else {
1500             print STDERR ", OK\n";
1501         }
1502     }
1503
1504     if ( $ooo_path_exists ) {
1505         print_error("SVN path '$ooo_cws_url' already exists.\nThis can happen if a previous CWS creation attempt failed before registering the CWS with EIS.\nIf this is the case, please delete the path with:\n\t svn delete -m'CWS-TOOLING: undo broken CWS creation' $ooo_cws_url\n", 0);
1506     }
1507
1508     if ( $so_path_exists ) {
1509         print_error("SVN path '$so_cws_url' already exists.\nThis can happen if a previous CWS creation attempt failed before registering the CWS with EIS.\nIf this is the case, please delete the path with:\n\t svn delete -m'CWS-TOOLING: undo broken CWS creation' $so_cws_url\n", 0);
1510     }
1511
1512     if ( $ooo_path_exists || $so_path_exists ) {
1513         exit(15);
1514     }
1515
1516     # determine the revision from which the milestone was copied
1517     my $ooo_milestone_revision;
1518     my $so_milestone_revision;
1519
1520     $ooo_milestone_revision = svn_milestone_revision($ooo_milestone_url);
1521     if ( !$ooo_milestone_revision ) {
1522         print_error("Can't retrieve revision for milestone '$milestone', url '$ooo_milestone_url.", 17 );
1523     }
1524     if ( defined($so_svn_server) ) {
1525         $so_milestone_revision = svn_milestone_revision($so_milestone_url);
1526         if ( !$so_milestone_revision ) {
1527             print_error("Can't retrieve revision for milestone '$milestone', url '$so_milestone_url.", 17 );
1528         }
1529     }
1530
1531     my $ooo_master_url;
1532     my $so_master_url;
1533
1534     $ooo_master_url = get_master_url($ooo_svn_server, $cws->master(), $ooo_milestone_revision);
1535     if ( defined($so_svn_server) ) {
1536         $so_master_url = get_master_url($so_svn_server, $cws->master(), $so_milestone_revision);
1537     }
1538
1539     my $ooo_short_url = get_short_url($ooo_svn_server, $ooo_master_url);
1540     my $ooo_creation_comment = "CWS-TOOLING: create CWS " . $cws->child() . " from $ooo_short_url (milestone: " . $cws->master() . ":$milestone)";
1541     # create branches an ooo server and an optional so server
1542     print STDERR "... create branch:\t'$ooo_cws_url'";
1543     svn_copy($ooo_creation_comment, $ooo_master_url, $ooo_cws_url);
1544     if ( defined($so_svn_server) ) {
1545         my $so_short_url = get_short_url($so_svn_server, $so_master_url);
1546         my $so_creation_comment = "CWS-TOOLING: create CWS " . $cws->child() . " from $so_short_url (milestone: " . $cws->master() . ":$milestone)";
1547         print STDERR "... create branch:\t'$so_cws_url'";
1548         svn_copy($so_creation_comment, $so_master_url, $so_cws_url);
1549     }
1550
1551     if ( $is_migration ) {
1552         # Set master and milestone
1553         $cws->master($master);
1554         $cws->milestone($milestone);
1555         my $rc = $cws->set_subversion_flag(1);
1556         if ( !$rc ) {
1557             print_error("Failed to set subversion flag on child workspace '$cws_name'.\nContact EIS administrator!\n", 12);
1558         }
1559     }
1560     else {
1561         register_child_workspace($cws, 'svn', $is_promotion);
1562     }
1563     return;
1564 }
1565
1566 sub do_rebase
1567 {
1568     my $args_ref    = shift;
1569     my $options_ref = shift;
1570
1571     my $commit_phase = 0;
1572     my $milestone;
1573
1574     # TODO: Switching to a new master dooes work not correctly yet
1575
1576     if (exists $options_ref->{'help'} || @{$args_ref} != 1) {
1577         do_help(['rebase']);
1578     }
1579     if ( exists($options_ref->{'commit'}) && exists($options_ref->{'milestone'}) ) {
1580         print_error("Option -m (--milestone) and -C (--commit) are mutually exclusive.", 0 );
1581         do_help(['rebase']);
1582     }
1583     if ( !exists($options_ref->{'commit'}) && !exists($options_ref->{'milestone'}) ) {
1584         print_error("At least one of the options -m (--milestone) or -C (--commit) are required.", 0 );
1585         do_help(['rebase']);
1586     }
1587
1588     if ( !svn_version_check() ) {
1589         print_error("cws rebase requires svn-1.5.4 or later (merge tracking and bug fixes). Please upgrade your svn client.", 1);
1590     }
1591
1592     my $cws = get_cws_from_environment();
1593     my $old_masterws = $cws->master();
1594     my $new_masterws;
1595     my $new_milestone;
1596
1597     my $workspace = $args_ref->[0];
1598
1599     if ( ! -d $workspace ) {
1600         print_error("Can't find workspace '$workspace': $!", 99);
1601     }
1602
1603     if ( exists($options_ref->{'commit'}) ) {
1604         $commit_phase=1;
1605         ($new_masterws, $new_milestone) = read_rebase_configuration($workspace);
1606     }
1607     elsif( exists($options_ref->{'milestone'}) ) {
1608         $milestone = $options_ref->{'milestone'};
1609         if ( $milestone eq 'latest' ) {
1610             my $latest = $cws->get_current_milestone($old_masterws);
1611
1612             if ( !$latest ) {
1613                 print_error("Can't determine latest milestone of '$old_masterws' available for rebase.", 22);
1614             }
1615             $new_masterws  = $old_masterws;
1616             $new_milestone = $latest;
1617         }
1618         else {
1619             ($new_masterws, $new_milestone) =  verify_milestone($cws, $milestone);
1620         }
1621     }
1622     else {
1623         do_help(['rebase']);
1624     }
1625
1626     my $so_setup = 0;
1627     my $ooo_path;
1628     my $so_path;
1629     # Determine if we got a three directory (so) setup or a plain (ooo) setup.
1630     # This is only needed as long the build system still relies
1631     # on having "modules" from different repositories in the same
1632     # directory besides each other.
1633     if ( -d "$workspace/$old_masterws/sun" ) {
1634         $so_setup = 1;
1635         $ooo_path = "$workspace/$old_masterws/ooo";
1636         $so_path = "$workspace/$old_masterws/sun";
1637     }
1638     else {
1639         $ooo_path = "$workspace";
1640     }
1641
1642     my $config = CwsConfig->new();
1643     my $ooo_svn_server = $config->get_ooo_svn_server();
1644     my $so_svn_server = $config->get_so_svn_server();
1645
1646     if (!defined($ooo_svn_server)) {
1647         print_error("No OpenOffice.org SVN server defined, please check your configuration file.", 8);
1648     }
1649
1650     my $ooo_milestone_url = get_milestone_url($ooo_svn_server, $new_masterws, $new_milestone);
1651     my $ooo_cws_url = get_cws_url($ooo_svn_server, $cws->child());
1652
1653     my $so_milestone_url;
1654     my $so_cws_url;
1655     if ( $so_setup ) {
1656         $so_milestone_url = get_milestone_url($so_svn_server, $new_masterws, $new_milestone);
1657         $so_cws_url = get_cws_url($so_svn_server, $cws->child());
1658     }
1659
1660     my $ooo_milestone_revision;
1661     my $so_milestone_revision;
1662
1663     $ooo_milestone_revision = svn_milestone_revision($ooo_milestone_url);
1664     if ( !$ooo_milestone_revision ) {
1665         print_error("Can't retrieve revision for milestone '$new_milestone', url '$ooo_milestone_url.", 17 );
1666     }
1667     if ( defined($so_svn_server) ) {
1668         $so_milestone_revision = svn_milestone_revision($so_milestone_url);
1669         if ( !$so_milestone_revision ) {
1670             print_error("Can't retrieve revision for milestone '$new_milestone', url '$so_milestone_url.", 17 );
1671         }
1672     }
1673
1674     my $ooo_master_url;
1675     my $so_master_url;
1676
1677     $ooo_master_url = get_master_url($ooo_svn_server, $new_masterws, $ooo_milestone_revision);
1678     if ( defined($so_svn_server) ) {
1679         $so_master_url = get_master_url($so_svn_server, $new_masterws, $so_milestone_revision);
1680     }
1681
1682     if ( $commit_phase ) {
1683         # commit
1684         print_message("... committing merged changes to workspace '$workspace'.");
1685         my $ooo_short_url = get_short_url($ooo_svn_server, $ooo_master_url);
1686         my $commit_message = "CWS-TOOLING: rebase CWS " . $cws->child() . " to $ooo_short_url (milestone: " . $new_masterws . ":$new_milestone)";
1687         svn_commit($ooo_path, $commit_message);
1688         if ( $so_setup ) {
1689             my $so_short_url = get_short_url($so_svn_server, $so_master_url);
1690             $commit_message = "CWS-TOOLING: rebase CWS " . $cws->child() . " to $so_short_url (milestone: " . $new_masterws . ":$new_milestone)";
1691             svn_commit($so_path, $commit_message);
1692         }
1693         if ( $so_setup) {
1694             print_message("... rename '$workspace/$old_masterws' -> '$workspace/$new_masterws'\n");
1695             if ( !rename("$workspace/$old_masterws", "$workspace/$new_masterws") ) {
1696                 print_error("Can't rename '$workspace/$old_masterws' -> '$workspace/$new_masterws': $!", 98);
1697             }
1698             print_message("... relinking workspace\n");
1699             relink_workspace("$workspace/$new_masterws/src.$new_milestone", 1);
1700             if ( !unlink("$workspace/REBASE.CONFIG_DONT_DELETE") ) {
1701                 print_error("Can't unlink '$workspace/REBASE.CONFIG_DONT_DELETE': $!", 0);
1702             }
1703
1704         }
1705
1706         print_message("... updating EIS database");
1707         my $push_return = $cws->set_master_and_milestone($new_masterws, $new_milestone);
1708         # sanity check
1709         if ( $$push_return[1] ne $new_milestone) {
1710             print_error("Couldn't push new milestone '$new_milestone' to database", 0);
1711         }
1712     }
1713     else {
1714         # merge phase
1715
1716         # check if working directory is switched to the right cws branch
1717         my $ooo_wc_url;
1718         my $so_wc_url;
1719         my $cwsname = $cws->child();
1720         print_message("... verifying if  workspace '$workspace' is switched to CWS '$cwsname'.");
1721         $ooo_wc_url = svn_wc_url($ooo_path);
1722         if ( $ooo_wc_url !~ /\/$cwsname$/ ) {
1723             print_error("Your working copy '$ooo_path' is not switched to the cws branch.\nPlease fix and restart rebasing.", 24);
1724         }
1725         if ( $so_setup ) {
1726             $so_wc_url = svn_wc_url($so_path);
1727
1728             if ( $so_wc_url !~ /\/$cwsname$/ ) {
1729                 print_error("Your working copy '$so_path' is not switched to the cws branch.\nPlease fix and restart rebasing.", 24);
1730             }
1731         }
1732         # check for mixed revisions, locally modified files etc
1733         if ( !svn_wc_is_clean($ooo_path) || ($so_setup && !svn_wc_is_clean($so_path)) ) {
1734             print_error("Please fix and restart rebasing.", 25);
1735         }
1736
1737         print_message("... merging changes up to '$new_masterws:$new_milestone' to workspace '$workspace'.");
1738         svn_merge($ooo_milestone_url, $ooo_path);
1739         if ( $so_setup ) {
1740             svn_merge($so_milestone_url, $so_path);
1741         }
1742         # write out the rebase configuration to store new milestone and master information
1743         write_rebase_configuration($workspace, $cwsname, $new_masterws, $new_milestone);
1744     }
1745 }
1746
1747 sub do_analyze
1748 {
1749     my $args_ref    = shift;
1750     my $options_ref = shift;
1751
1752     print_error("not yet implemented.", 2);
1753 }
1754
1755 sub do_integrate
1756 {
1757     my $args_ref    = shift;
1758     my $options_ref = shift;
1759
1760     if (exists $options_ref->{'help'} || @{$args_ref} > 0) {
1761         do_help(['integrate']);
1762     }
1763     if ( exists($options_ref->{'commit'}) && exists($options_ref->{'childworkspace'}) ) {
1764         print_error("Option -c (--child) and -C (--commit) are mutually exclusive.", 0 );
1765         do_help(['integrate']);
1766     }
1767 }
1768
1769 # Executes the fetch command.
1770 sub do_fetch
1771 {
1772     my $args_ref    = shift;
1773     my $options_ref = shift;
1774
1775     if ( exists $options_ref->{'help'} || @{$args_ref} != 1) {
1776         do_help(['fetch']);
1777     }
1778
1779     my $milestone_opt = $options_ref->{'milestone'};
1780     my $child = $options_ref->{'childworkspace'};
1781     my $platforms = $options_ref->{'platforms'};
1782     my $quiet  = $options_ref->{'quiet'}  ? 1 : 0 ;
1783     my $switch = $options_ref->{'switch'} ? 1 : 0 ;
1784     my $onlysolver = $options_ref->{'onlysolver'} ? 1 : 0 ;
1785
1786     if ( !defined($milestone_opt) && !defined($child) ) {
1787         print_error("Specify one of these options: -m or -c", 0);
1788         do_help(['fetch']);
1789     }
1790
1791     if ( defined($milestone_opt) && defined($child) ) {
1792         print_error("Options -m and -c are mutally exclusive", 0);
1793         do_help(['fetch']);
1794     }
1795
1796     if ( defined($platforms) && $switch ) {
1797         print_error("Option '-p' is not yet usuable with Option '-s'. Will be fixed RSN.", 0);
1798         do_help(['fetch']);
1799     }
1800
1801     if ( $onlysolver && !defined($platforms) ) {
1802         print_error("Option '-o' is Only usuable combination with option '-p'.", 0);
1803         do_help(['fetch']);
1804     }
1805
1806     my $cws = get_this_cws();
1807     my $masterws = $ENV{WORK_STAMP};
1808     if ( !defined($masterws) ) {
1809         print_error("Can't determine current master workspace: check environment variable WORK_STAMP", 21);
1810     }
1811     $cws->master($masterws);
1812     my $milestone;
1813     if( defined($milestone_opt) ) {
1814         if ( $milestone_opt eq 'latest' ) {
1815             $cws->master($masterws);
1816             my $latest = $cws->get_current_milestone($masterws);
1817
1818             if ( !$latest ) {
1819                 print_error("Can't determine latest milestone of master workspace '$masterws'.", 22);
1820             }
1821             $milestone = $cws->get_current_milestone($masterws);
1822         }
1823         else {
1824             ($masterws, $milestone) =  verify_milestone($cws, $milestone_opt);
1825         }
1826     }
1827     elsif ( defined($child) ) {
1828         $cws = get_cws_by_name($child);
1829         $masterws = $cws->master(); # CWS can have another master than specified in ENV
1830         $milestone = $cws->milestone();
1831     }
1832     else {
1833         do_help(['fetch']);
1834     }
1835
1836     my $config = CwsConfig->new();
1837     my $ooo_svn_server = $config->get_ooo_svn_server();
1838     my $so_svn_server = $config->get_so_svn_server();
1839     # Check early for platforms so we can bail out before anything time consuming is done
1840     # in case of a missing platform
1841     my @platforms;
1842     my $prebuild_dir;
1843     if ( defined($platforms) ) {
1844         use Archive::Zip; # warn early if module is missing
1845         $prebuild_dir = $config->get_prebuild_binaries_location();
1846         $masterws = $cws->master();
1847         $prebuild_dir = "$prebuild_dir/$masterws";
1848
1849         @platforms = split(/,/, $platforms);
1850
1851         my $added_product = 0;
1852         my $added_nonproduct = 0;
1853         foreach(@platforms) {
1854             if ( $_ eq 'common.pro' ) {
1855                 $added_product = 1;
1856                 print_warning("'$_' is added automatically to the platform list, don't specify it explicit");
1857             }
1858             if ( $_ eq 'common' ) {
1859                 $added_nonproduct = 1;
1860                 print_warning("'$_' is added automatically to the platform list, don't specify it explicit");
1861             }
1862         }
1863
1864         # add common.pro/common to platform list
1865         if ( $so_svn_server ) {
1866             my $product = 0;
1867             my $nonproduct = 0;
1868             foreach(@platforms) {
1869                 if ( /\.pro$/ ) {
1870                     $product = 1;
1871                 }
1872                 else {
1873                     $nonproduct = 1;
1874                 }
1875             }
1876             push(@platforms, 'common.pro') if ($product && !$added_product);
1877             push(@platforms, 'common') if ($nonproduct && !$added_nonproduct);
1878         }
1879
1880         foreach(@platforms) {
1881             if ( ! -d "$prebuild_dir/$_") {
1882                 print_error("Can't find prebuild binaries for platform '$_'.", 22);
1883             }
1884         }
1885
1886     }
1887
1888     my $cwsname = $cws->child();
1889     my $url_suffix = $milestone_opt ? ("/tags/$masterws" . "_$milestone") : ('/cws/' . $cwsname);
1890     my $linkdir = $milestone_opt ? "src.$milestone" : "src." . $cws->milestone;
1891
1892     my $workspace = $args_ref->[0];
1893     if ( !$onlysolver ) {
1894         if ( $switch ) {
1895             # check if to be switched working copy exist or bail out
1896             if ( ! -d $workspace ) {
1897                 print_error("Can't open workspace '$workspace': $!", 21);
1898             }
1899
1900             my $so_setup = 0;
1901             my $ooo_path;
1902             my $so_path;
1903             # Determine if we got a three directory (so) setup or a plain (ooo) setup.
1904             # This is only needed as long the build system still relies
1905             # on having "modules" from different repositories in the same
1906             # directory besides each other.
1907             if ( -d "$workspace/$masterws/sun" ) {
1908                 $so_setup = 1;
1909                 $ooo_path = "$workspace/$masterws/ooo";
1910                 $so_path = "$workspace/$masterws/sun";
1911             }
1912             else {
1913                 $ooo_path = "$workspace";
1914             }
1915
1916             # get the working copy URLs
1917             my $ooo_new_url = svn_wc_root($ooo_path) . $url_suffix;
1918             my $so_new_url;
1919             if ( $so_setup ) {
1920                 $so_new_url = svn_wc_root($so_path) . $url_suffix;
1921             }
1922
1923             print_message("... switching '$ooo_path' to URL '$ooo_new_url'");
1924             svn_switch($ooo_path, $ooo_new_url, $quiet);
1925             # switch working copies
1926             if ( $so_setup ) {
1927                 print_message("... switching '$so_path' to URL '$so_new_url'");
1928                 svn_switch($so_path, $so_new_url, $quiet);
1929             }
1930
1931             if ( $so_setup ) {
1932                 relink_workspace("$workspace/$masterws/$linkdir", 0);
1933             }
1934         }
1935         else {
1936             if (!defined($ooo_svn_server)) {
1937                 print_error("No OpenOffice.org SVN server defined, please check your configuration file.", 8);
1938             }
1939
1940             my $ooo_url = $ooo_svn_server . $url_suffix;
1941             if ( -e $workspace ) {
1942                 print_error("File or directory '$workspace' already exists.", 8);
1943             }
1944
1945             # Check if working directory already exists
1946
1947             if ( defined($so_svn_server) ) {
1948                 if ( !mkdir($workspace) ) {
1949                     print_error("Can't create directory '$workspace': $!.", 8);
1950                 }
1951                 my $work_master = "$workspace/$masterws";
1952                 if ( !mkdir($work_master) ) {
1953                     print_error("Can't create directory '$work_master': $!.", 8);
1954                 }
1955                 print_message("... checkout '$ooo_url' to '$work_master/ooo'");
1956                 svn_checkout($ooo_url, "$work_master/ooo", $quiet);
1957                 my $so_url = $so_svn_server . $url_suffix;
1958                 print_message("... checkout '$so_url' to '$work_master/sun'");
1959                 svn_checkout($so_url, "$work_master/sun", $quiet);
1960                 my $linkdir = "$work_master/src.$milestone";
1961                 if ( !mkdir($linkdir) ) {
1962                     print_error("Can't create directory '$linkdir': $!.", 8);
1963                 }
1964                 relink_workspace($linkdir);
1965             }
1966             else {
1967                 print_message("... checkout '$ooo_url' to '$workspace'");
1968                 svn_checkout($ooo_url, $workspace, $quiet);
1969             }
1970         }
1971     }
1972
1973     if ( defined($platforms) ) {
1974         if ( !-d $workspace ) {
1975             if ( !mkdir($workspace) ) {
1976                 print_error("Can't create directory '$workspace': $!.", 8);
1977             }
1978         }
1979         my $solver = defined($so_svn_server) ? "$workspace/$masterws" : "$workspace/solver";
1980         if ( !-d $solver ) {
1981             if ( !mkdir($solver) ) {
1982                 print_error("Can't create directory '$solver': $!.", 8);
1983             }
1984         }
1985         foreach(@platforms) {
1986             print_message("... copying platform solver '$_'.");
1987             update_solver($_, $prebuild_dir, $solver, $milestone);
1988         }
1989     }
1990 }
1991
1992 sub do_query
1993 {
1994     my $args_ref    = shift;
1995     my $options_ref = shift;
1996
1997     # list of available query modes
1998     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);
1999     my %query_modes_hash = ();
2000     foreach (@query_modes) {
2001         $query_modes_hash{$_}++;
2002     }
2003
2004     if ( exists $options_ref->{'help'} || @{$args_ref} != 1) {
2005         do_help(['query']);
2006     }
2007     my $mode = lc($args_ref->[0]);
2008
2009     # cwquery mode 'state' has been renamed to 'status' to be more consistent
2010     # with CVS etc. 'state' is still an alias for 'status'
2011     $mode = 'status' if $mode eq 'state';
2012
2013     # cwquery mode 'vcs' has been renamed to 'scm' to be more consistent
2014     # with general use etc. 'vcs' is still an alias for 'scm'
2015     $mode = 'scm' if $mode eq 'vcs';
2016
2017     # there will be more query modes over time
2018     if ( !exists $query_modes_hash{$mode} ) {
2019         do_help(['query']);
2020     }
2021     query_cws($mode, $options_ref);
2022 }
2023
2024 sub do_task
2025 {
2026     my $args_ref    = shift;
2027     my $options_ref = shift;
2028
2029     if ( exists $options_ref->{'help'} ) {
2030         do_help(['task']);
2031     }
2032
2033     # CWS states for which adding tasks are blocked.
2034     my @states_blocked_for_adding = (
2035                                         "integrated",
2036                                         "nominated",
2037                                         "approved by QA",
2038                                         "cancelled",
2039                                         "finished"
2040                                     );
2041     my $cws = get_cws_from_environment();
2042
2043     # register taskids with EIS database;
2044     # checks taksids for sanity, will notify user
2045     # if taskid is already registered.
2046     my $status = $cws->get_approval();
2047
2048     my $child = $cws->child();
2049     my $master = $cws->master();
2050
2051     my @registered_taskids = $cws->taskids();
2052
2053     # if called without ids to register just query for tasks
2054     if ( @{$args_ref} == 0 ) {
2055         print_message("Task ID(s):");
2056         foreach (@registered_taskids) {
2057             if ( defined($_) ) {
2058                 print "$_\n";
2059             }
2060         }
2061     }
2062
2063     if ( !defined($status) ) {
2064         print_error("Can't determine status of child workspace `$child`.", 20);
2065     }
2066
2067     if ( grep($status eq $_, @states_blocked_for_adding) ) {
2068         print_error("Can't add tasks to child workspace '$child' with state '$status'.", 21);
2069     }
2070
2071     # Create hash for easier searching.
2072     my %registered_taskids_hash = ();
2073     for (@registered_taskids) {
2074         $registered_taskids_hash{$_}++;
2075     }
2076
2077     my @new_taskids = ();
2078     foreach (@{$args_ref}) {
2079         if ( $_ !~ /^([ib]?\d+)$/ ) {
2080             print_error("'$_' is an invalid task ID.", 22);
2081         }
2082         if ( exists $registered_taskids_hash{$1} ) {
2083             print_warning("Task ID '$_' already registered, skipping.");
2084             next;
2085         }
2086         push(@new_taskids, $_);
2087     }
2088
2089     # TODO: introduce a EIS_USER in the configuration, which should be used here
2090     my $config = CwsConfig->new();
2091     my $vcsid  = $config->vcsid();
2092     my $added_taskids_ref = $cws->add_taskids($vcsid, @new_taskids);
2093     if ( !$added_taskids_ref )  {
2094         my $taskids_str = join(" ", @new_taskids);
2095         print_error("Couldn't register taskID(s) '$taskids_str' with child workspace '$child'.", 23);
2096     }
2097     my @added_taskids = @{$added_taskids_ref};
2098     if ( @added_taskids ) {
2099         my $taskids_str = join(" ", @added_taskids);
2100         print_message("Registered taskID(s) '$taskids_str' with child workspace '$child'.");
2101     }
2102     return;
2103 }
2104
2105 sub do_cdiff
2106 {
2107     my $args_ref    = shift;
2108     my $options_ref = shift;
2109
2110     if ( exists $options_ref->{'help'} || @{$args_ref} != 0) {
2111         do_help(['cdiff']);
2112     }
2113
2114     my $files   = exists $options_ref->{'files'}   ? 1 : 0;
2115     my $modules = exists $options_ref->{'modules'} ? 1 : 0;
2116
2117     if ( $files && $modules ) {
2118         print_error("Options --files and --modules are mutally exclusive", 0);
2119         do_help(['cdiff']);
2120     }
2121
2122     my $diff_option;
2123     if ( $files ) {
2124         $diff_option = 'files';
2125     }
2126     elsif ( $modules ) {
2127         $diff_option = 'modules';
2128     }
2129     else {
2130         $diff_option = 0;
2131     }
2132
2133
2134     my $masterws  = exists $options_ref->{'masterworkspace'} ? uc($options_ref->{'masterworkspace'}) : $ENV{WORK_STAMP};
2135     my $childws   = exists $options_ref->{'childworkspace'} ? $options_ref->{'childworkspace'} : $ENV{CWS_WORK_STAMP};
2136
2137     if ( !defined($masterws) ) {
2138         print_error("Can't determine master workspace environment.\n", 30);
2139     }
2140
2141     if ( !defined($childws) ) {
2142         print_error("Can't determine child workspace environment.\n", 30);
2143     }
2144
2145     my $cws = Cws->new();
2146     $cws->child($childws);
2147     $cws->master($masterws);
2148
2149     if ( !is_valid_cws($cws) ) {
2150         print_error("'$childws' is not a valid CWS name.\n", 30);
2151     }
2152
2153     my $milestone = $cws->milestone();
2154
2155     my $config = CwsConfig->new();
2156     my $ooo_svn_server = $config->get_ooo_svn_server();
2157     my $so_svn_server = $config->get_so_svn_server();
2158
2159     my $ooo_milestone_url = get_milestone_url($ooo_svn_server, $masterws, $milestone);
2160     my $ooo_cws_url = get_cws_url($ooo_svn_server, $childws);
2161     my $ooo_files;
2162     if ( $diff_option  ) {
2163         $ooo_files = svn_diff($ooo_milestone_url, $ooo_cws_url, $diff_option);
2164         diff_print_files($ooo_files, $diff_option);
2165     }
2166     else {
2167         svn_diff($ooo_milestone_url, $ooo_cws_url, 0);
2168     }
2169
2170     my $so_files;
2171     if ( $so_svn_server ) {
2172         my $so_milestone_url = get_milestone_url($so_svn_server, $masterws, $milestone);
2173         my $so_cws_url = get_cws_url($so_svn_server, $childws);
2174         if  ( svn_path_exists($so_cws_url) ) {
2175             if ( $diff_option ) {
2176                 $so_files = svn_diff($so_milestone_url, $so_cws_url, $diff_option);
2177                 diff_print_files($so_files, $diff_option);
2178             }
2179             else {
2180                 svn_diff($so_milestone_url, $so_cws_url, 0);
2181             }
2182         }
2183     }
2184
2185 }
2186
2187 sub do_setcurrent
2188 {
2189     my $args_ref    = shift;
2190     my $options_ref = shift;
2191
2192     if ( exists $options_ref->{'help'} || @{$args_ref} != 0) {
2193         do_help(['setcurrent']);
2194     }
2195
2196     if ( !exists $options_ref->{'milestone'} ) {
2197         do_help(['setcurrent']);
2198     }
2199
2200     my $cws = get_cws_from_environment();
2201     my $old_masterws = $cws->master();
2202     my $new_masterws;
2203     my $new_milestone;
2204
2205     my $milestone = $options_ref->{'milestone'};
2206     if ( $milestone eq 'latest' ) {
2207         my $latest = $cws->get_current_milestone($old_masterws);
2208
2209         if ( !$latest ) {
2210             print_error("Can't determine latest milestone of '$old_masterws'.", 22);
2211         }
2212         $new_masterws  = $old_masterws;
2213         $new_milestone = $latest;
2214     }
2215     else {
2216         ($new_masterws, $new_milestone) =  verify_milestone($cws, $milestone);
2217     }
2218
2219     print_message("... updating EIS database");
2220     my $push_return = $cws->set_master_and_milestone($new_masterws, $new_milestone);
2221     # sanity check
2222     if ( $$push_return[1] ne $new_milestone) {
2223         print_error("Couldn't push new milestone '$new_milestone' to database", 0);
2224     }
2225 }
2226
2227 sub do_eisclone
2228 {
2229     my $args_ref    = shift;
2230     my $options_ref = shift;
2231
2232     print_error("not yet implemented.", 2);
2233 }
2234
2235 sub print_message
2236 {
2237     my $message     = shift;
2238
2239     print "$message\n";
2240     return;
2241 }
2242
2243 sub print_warning
2244 {
2245     my $message     = shift;
2246     print STDERR "$script_name: ";
2247     print STDERR "WARNING: $message\n";
2248     return;
2249 }
2250
2251 sub print_error
2252 {
2253     my $message     = shift;
2254     my $error_code  = shift;
2255
2256     print STDERR "$script_name: ";
2257     print STDERR "ERROR: $message\n";
2258
2259     if ( $error_code ) {
2260         print STDERR "\nFAILURE: $script_name aborted.\n";
2261         exit($error_code);
2262     }
2263     return;
2264 }
2265
2266 sub usage
2267 {
2268         print STDERR "Type 'cws help' for usage.\n";
2269 }
2270
2271 ### SVN glue ###
2272
2273 # TODO: is it a better idea to use the SVN bindings?
2274 # pro:
2275 #       - SVN make guarantees about API stability but no about the command line
2276 #       - finer access to the SVN functionality, better error reporting
2277 #       - prevents parsing errors due to localized SVN messages
2278 # con:
2279 #       - the bindings are difficult to install, mostly due to subtle install bugs
2280 #       - we do not really use much of the SVN functionality here
2281
2282 sub svn_wc_is_clean
2283 {
2284     my $wc_path = shift;
2285
2286     my $result = execute_svnversion_command($wc_path);
2287
2288     my $error = 0;
2289
2290     if ( $result =~ /:/ ) {
2291         print_error("Working copy '$wc_path' contains mixed revisions. Please run 'svn update'!", 0);
2292         $error++;
2293     }
2294     if ( $result =~ /M/ ) {
2295         print_error("Working copy '$wc_path' contains locally modified files. Please commit or revert all modified files.", 0);
2296         $error++;
2297     }
2298     if ( $result =~ /S/ ) {
2299         print_error("Working copy '$wc_path' is partially switched. The whole working copy needs to be switched to the CWS branch.", 0);
2300         $error++;
2301     }
2302     if ( $result =~ /P/ ) {
2303         print_error("Working copy '$wc_path' is only partially checked out. CWS tools can't work on partially checked out working copies.", 0);
2304         $error++;
2305     }
2306
2307     return !$error;
2308 }
2309
2310 sub svn_version_check
2311 {
2312     my $major_required = 1;
2313     my $minor_required = 5;
2314     my $patchlevel_required = 4;
2315
2316     my $version_required = $major_required*1000000 + $minor_required*1000 + $patchlevel_required;
2317
2318     if ( $debug ) {
2319         print STDERR "\nCWS-DEBUG: ... svn version\n";
2320     }
2321
2322     my @result = execute_svn_command(0, '--version --quiet', " ");
2323     # svn --version --quiet returns the version in major.minor.patchlevel scheme
2324     # for example: 1.5.4 or 1.6.0-dev (for developer codelines)
2325     # hopefully they don't change the versioning scheme
2326     my ($major, $minor, $patchlevel);
2327     if ( $result[0] =~ /^(\d+)\.(\d+)\.(\d+)/ ) {
2328         $major       = $1;
2329         $minor       = $2;
2330         $patchlevel  = $3;
2331     }
2332     else {
2333         print_error("Can't determine svn version. Please file an issue with the output of 'svn --version --quiet'. CWS tooling requires svn-1.5.4 or later\n", 1)
2334     }
2335
2336     my $version =  $major*1000000 + $minor*1000 + $patchlevel;
2337
2338     if ( $version < $version_required ) {
2339         return 0;
2340     }
2341     return 1;
2342 }
2343
2344 sub svn_copy
2345 {
2346     my $comment = shift;
2347     my $source = shift;
2348     my $dest = shift;
2349
2350     if ( $debug ) {
2351         print STDERR "\nCWS-DEBUG: ... preparing branch: '$source' -> '$dest'\n";
2352     }
2353
2354     my @result = execute_svn_command(0, 'copy', "-m '$comment'", $source, $dest);
2355     if ( $result[1] =~ /Committed revision (\d+)\./ ) {
2356         print STDERR ", committed revision $1\n";
2357     } else {
2358         print STDERR "failed!\n";
2359         print STDERR @result;
2360     }
2361 }
2362
2363 sub svn_milestone_revision
2364 {
2365     my $milestone_url = shift;
2366
2367     if ( $debug ) {
2368         print STDERR "\nCWS-DEBUG: ... preparing log --stop-on-copy: '$milestone_url'\n";
2369     }
2370
2371     my @result = execute_svn_command(0, 'log', '--stop-on-copy', $milestone_url);
2372
2373     # There might be revisions committed to a tag (allowed in subversion).
2374     # The lowestmost revision listed in a 'log --stop-on-copy' is the one which
2375     # was current when the tag was created
2376     my $revision = 0;
2377     foreach ( @result ) {
2378         if ( /^r(\d+)\s+\|\s+/ ) {
2379             $revision = $1;
2380         }
2381     }
2382
2383     return $revision;
2384 }
2385
2386 sub svn_path_exists
2387 {
2388     my $url = shift;
2389
2390     my @result = svn_info($url);
2391
2392     foreach ( @result ) {
2393         if ( /^Path: / ) {
2394             return 1;
2395         }
2396     }
2397     return 0;
2398 }
2399
2400 sub svn_wc_url
2401 {
2402     my $wc_path = shift;
2403
2404     my @result = svn_info($wc_path);
2405
2406     foreach ( @result ) {
2407         if ( /^URL: (.+)$/ ) {
2408             return $1;
2409         }
2410     }
2411
2412     print_error("Can't retrieve svn info from working copy '$wc_path'\n", 23);
2413 }
2414
2415 sub svn_wc_root
2416 {
2417     my $wc_path = shift;
2418
2419     my @result = svn_info($wc_path);
2420
2421     foreach ( @result ) {
2422         if ( /^Repository Root: (.+)$/ ) {
2423             return $1;
2424         }
2425     }
2426
2427     print_error("Can't retrieve svn info from working copy '$wc_path'\n", 23);
2428 }
2429
2430 sub svn_info
2431 {
2432     my $url = shift;
2433
2434     if ( $debug ) {
2435         print STDERR "\nCWS-DEBUG: ... preparing info: '$url'\n";
2436     }
2437
2438     my @result = execute_svn_command(0, 'info', '--depth empty', $url);
2439     return @result;
2440 }
2441
2442 sub svn_merge
2443 {
2444     my $url = shift;
2445     my $wc  = shift;
2446
2447     if ( $debug ) {
2448         print STDERR "\nCWS-DEBUG: ... preparing merge: '$url -> $wc'\n";
2449     }
2450
2451     my $log_file = "$wc/REBASE.LOG";
2452     my @result = execute_svn_command($log_file, 'merge', '--accept postpone', $url, $wc);
2453     return @result;
2454 }
2455
2456 sub svn_switch
2457 {
2458     my $wc  = shift;
2459     my $url = shift;
2460     my $quiet = shift;
2461
2462     if ( $debug ) {
2463         print STDERR "\nCWS-DEBUG: ... preparing switch: '$url -> $wc'\n";
2464     }
2465
2466     my $switch = $quiet ? 'switch --quiet' : 'switch';
2467
2468     my @result = execute_svn_command('print', $switch, $url, $wc);
2469     return @result;
2470 }
2471
2472 sub svn_checkout
2473 {
2474     my $url   = shift;
2475     my $wc    = shift;
2476     my $quiet = shift;
2477
2478     if ( $debug ) {
2479         print STDERR "\nCWS-DEBUG: ... preparing checkout: '$url -> $wc'\n";
2480     }
2481
2482     my $checkout = $quiet ? 'checkout --quiet' : 'checkout';
2483
2484     my @result = execute_svn_command('print', $checkout, $url, $wc);
2485     return @result;
2486 }
2487
2488 sub svn_commit
2489 {
2490     my $wc             = shift;
2491     my $commit_message = shift;
2492
2493     if ( $debug ) {
2494         print STDERR "\nCWS-DEBUG: ... preparing commit: '$wc'\n";
2495     }
2496
2497     my $log_file = "$wc/REBASE.LOG";
2498     my @result = execute_svn_command($log_file, 'commit', "-m '$commit_message'", $wc);
2499     return @result;
2500 }
2501
2502 sub svn_diff
2503 {
2504     my $url1 = shift;
2505     my $url2 = shift;
2506     my $diff_option = shift;
2507
2508     my $summarize = '';
2509     if ( $diff_option ) {
2510         $summarize = '--summarize';
2511     }
2512
2513     if ( $debug ) {
2514         print STDERR "\nCWS-DEBUG: ... preparing diff $summarize: '$url1' vs. '$url2'\n";
2515     }
2516
2517     if ( $summarize ) {
2518         my $result = execute_svn_command(0, 'diff', $summarize, $url1, $url2);
2519         my $nlen = length($url1);
2520         my @files;
2521         foreach( @{$result} ) {
2522             my ($dummy, $url) = split();
2523             next if length($url) <= $nlen;   # skip short URLs (like $url1)
2524             my $file = substr($url, $nlen+1);
2525             next if index($file, '/') == -1; # skip 'modified' top level dirs
2526             push (@files, $file);
2527         }
2528         return \@files;
2529     }
2530     else {
2531         execute_svn_command('print', 'diff', $url1, $url2);
2532     }
2533 }
2534
2535 sub execute_svn_command
2536 {
2537     my $log     = shift;
2538     my $command = shift;
2539     my $options = shift;
2540     my @args    = @_;
2541
2542     my $args_str = join(" ", @args);
2543
2544     # we can only parse english strings, hopefully a C locale is available everywhere
2545     $ENV{LC_ALL}='C';
2546     $command = "svn $command $options $args_str";
2547
2548     if ( $debug ) {
2549         print STDERR "\nCWS-DEBUG: ... execute command line: '$command'\n";
2550     }
2551
2552     my @result;
2553     my $date;
2554     if ( $log && $log ne 'print') {
2555         open(LOG, ">>$log") or print_error("can't open log file '$log'", 30);
2556         $date = localtime();
2557         print LOG "Start $command $args_str at $date\n";
2558     }
2559     open(OUTPUT, "$command 2>&1 |") or print_error("Can't execute svn command line client", 98);
2560     STDOUT->autoflush(1) if $log;
2561     while (<OUTPUT>) {
2562         if ( $log ) {
2563             print STDOUT $_;
2564             print LOG $_ if $log ne 'print';
2565         }
2566         else {
2567             push(@result, $_);
2568         }
2569     }
2570     STDOUT->autoflush(0) if $log;
2571     close(OUTPUT);
2572     if ( $log && $log ne 'print') {
2573         $date = localtime();
2574         print LOG "Stop $command $args_str at $date\n";
2575         close (LOG);
2576     }
2577
2578     my $rc = $? >> 8;
2579
2580     if ( $rc > 0) {
2581         print STDERR "\n";
2582         print STDERR @result if !$log;
2583         print_error("The subversion command line client failed with exit status '$rc'", 99);
2584     }
2585     return wantarray ? @result : \@result;
2586 }
2587
2588 sub execute_svnversion_command
2589 {
2590     my $options = shift;
2591     my @args    = @_;
2592
2593     my $args_str = join(" ", @args);
2594
2595     # we can only parse english strings, hopefully a C locale is available everywhere
2596     $ENV{LC_ALL}='C';
2597     $command = "svnversion $options $args_str";
2598
2599     if ( $debug ) {
2600         print STDERR "\nCWS-DEBUG: ... execute command line: '$command'\n";
2601     }
2602
2603     my $result = `$command`;
2604     my $rc = $? >> 8;
2605     if ($rc > 0) {
2606         print_error("The subversion command line tool 'svnversion' failed with exit status '$rc'", 99);
2607     }
2608
2609     return $result;
2610 }
2611 # vim: set ts=4 shiftwidth=4 expandtab syntax=perl: