path: root/solenv/bin/cws.pl

#!/usr/bin/perl -w
#*************************************************************************
#
# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
#
# Copyright 2008 by Sun Microsystems, Inc.
#
# OpenOffice.org - a multi-platform office productivity suite
#
# $RCSfile: cws.pl,v $
#
# $Revision: 1.1.2.14 $
#
# This file is part of OpenOffice.org.
#
# OpenOffice.org is free software: you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License version 3
# only, as published by the Free Software Foundation.
#
# OpenOffice.org is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Lesser General Public License version 3 for more details
# (a copy is included in the LICENSE file that accompanied this code).
#
# You should have received a copy of the GNU Lesser General Public License
# version 3 along with OpenOffice.org.  If not, see
# <http://www.openoffice.org/license.html>
# for a copy of the LGPLv3 License.
#
#*************************************************************************

#*************************************************************************
#
# cws.pl   - wrap common childworkspace operations
#
use strict;
use Getopt::Long;
use File::Basename;
use File::Path;
use Cwd;
use Benchmark;

#### module lookup
my @lib_dirs;
BEGIN {
    if ( !defined($ENV{SOLARENV}) ) {
        die "No environment found (environment variable SOLARENV is undefined)";
    }
    push(@lib_dirs, "$ENV{SOLARENV}/bin/modules");
}
use lib (@lib_dirs);

use Cws;

#### script id #####

( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;

#### globals ####

# TODO: replace dummy vales with actual SVN->hg migration milestones
my $dev300_migration_milestone = 'm64';
my $ooo320_migration_milestone = 'm999';

# valid command with possible abbreviations
my @valid_commands = (
                        'help', 'h', '?',
                        'create',
                        'fetch',  'f',
                        'rebase', 'rb',
                        'analyze', 'an',
                        'query', 'q',
                        'task', 't',
                        'integrate',
                        'cdiff', 'cd',
                        'eisclone',
                        'setcurrent'
                     );

# list the valid options to each command
my %valid_options_hash = (
                            'help'       => ['help'],
                            'create'     => ['help', 'milestone', 'migration', 'hg'],
                            'fetch'      => ['help', 'switch', 'milestone', 'childworkspace','platforms','quiet',
                                            'onlysolver'],
                            'rebase'     => ['help', 'milestone','commit'],
                            'analyze'    => ['help'],
                            'query'      => ['help', 'milestone','masterworkspace','childworkspace'],
                            'task'       => ['help'],
                            'integrate'  => ['help', 'childworkspace'],
                            'cdiff'      => ['help', 'childworkspace', 'masterworkspace', 'files', 'modules'],
                            'setcurrent' => ['help', 'milestone'],
                            'eisclone'   => ['help']
                         );

my %valid_commands_hash;
for (@valid_commands) {
    $valid_commands_hash{$_}++;
}

#  set by --debug switch
my $debug = 0;

#### main ####

my ($command, $args_ref, $options_ref) = parse_command_line();
dispatch_command($command, $args_ref, $options_ref);
exit(0);

#### subroutines ####

# Parses the command line. does prelimiary argument and option verification
sub parse_command_line
{
    if (@ARGV == 0) {
        usage();
        exit(1);
    }

    my %options_hash;
    Getopt::Long::Configure ("no_auto_abbrev", "no_ignorecase");
    my $success = GetOptions(\%options_hash, 'milestone|m=s',
                                             'masterworkspace|master|M=s',
                                             'hg',
                                             'migration',
                                             'childworkspace|child|c=s',
                                             'debug',
                                             'commit|C',
                                             'switch|s',
                                             'platforms|p=s',
                                             'onlysolver|o',
                                             'quiet|q',
                                             'files',
                                             'modules',
                                             'help|h'
                            );

    my $command = shift @ARGV;

    if (!exists $valid_commands_hash{$command}) {
        print_error("Unkown command: '$command'\n");
        usage();
        exit(1);
    }

    if ($command eq 'h' || $command eq '?') {
        $command = 'help';
    }
    elsif ($command eq 'f') {
        $command = 'fetch';
    }
    elsif ($command eq 'rb') {
        $command = 'rebase';
    }
    elsif ($command eq 'an') {
        $command = 'analyze';
    }
    elsif ($command eq 'q') {
        $command = 'query';
    }
    elsif ($command eq 't') {
        $command = 'task';
    }
    elsif ($command eq 'cd') {
        $command = 'cdiff';
    }

    # An unkown option might be accompanied with a valid command.
    # Show the command specific help
    if ( !$success ) {
        do_help([$command])
    }

    verify_options($command, \%options_hash);
    return ($command, \@ARGV, \%options_hash);
}

# Verify options against the valid options list.
sub verify_options
{
    my $command     = shift;
    my $options_ref = shift;

    my $valid_command_options_ref = $valid_options_hash{$command};

    my %valid_command_options_hash;
    foreach (@{$valid_command_options_ref}) {
        $valid_command_options_hash{$_}++;
    }

    # check all specified options against the valid options for the sub command
    foreach (keys %{$options_ref}) {
        if ( /debug/ ) {
            $debug = 1;
            next;
        }
        if (!exists $valid_command_options_hash{$_}) {
            print_error("can't use option '--$_' with subcommand '$command'.", 1);
        }
    }

    # TODO here should be specific checks for the arguments
    # if the check is globally valid
}

# Dispatches to the do_xxx() routines depending on command.
sub dispatch_command
{
    my $command     = shift;
    my $args_ref    = shift;
    my $options_ref = shift;

    no strict 'refs';
    &{"do_".$command}($args_ref, $options_ref);
}

# Returns the global cws object.
BEGIN {
my $the_cws;

    sub get_this_cws {
        if (!defined($the_cws)) {
            $the_cws = Cws->new();
            return $the_cws;
        }
        else {
            return $the_cws;
        }
    }
}

# Returns a list of the master workspaces.
sub get_master_workspaces
{
    my $cws = get_this_cws();
    my @masters = $cws->get_masters();

    return wantarray ? @masters : \@masters;
}

# Checks if master argument is a valid MWS name.
BEGIN {
    my %master_hash;

    sub is_master
    {
        my $master_name = shift;

        if (!%master_hash) {
            my @masters = get_master_workspaces();
            foreach (@masters) {
                $master_hash{$_}++;
            }
        }
        return exists $master_hash{$master_name} ? 1 : 0;
    }
}

# Fetches milestone URL for given server and milestone.
sub get_milestone_url
{
    my $server    = shift;
    my $master    = shift;
    my $milestone = shift;

    my $milestone_url = "$server/tags/${master}_${milestone}";
    return $milestone_url;
}

# Fetches CWS URL for given server and CWSname.
sub get_cws_url
{
    my $server = shift;
    my $cws    = shift;

    my $cws_url = "$server/cws/$cws";
    return $cws_url;
}

sub get_master_url
{
    my $server   = shift;
    my $master   = shift;
    my $revision = shift;

    my $url = "${server}/";

    # TODO: update EIS function for subversion
    my $cws = get_this_cws();
    my $trunk = $cws->get_cvs_head();
    if ( $master eq $trunk ) {
        $url .= 'trunk';
    }
    else {
        my $master_label = uc($master);
        $url .= "branches/$master_label";
    }

    # attach revision if needed
    if ( $revision != 0 ) {
        $url .= "\@$revision";
    }
    return $url;
}

# Returns the URL shortened by the server part
sub get_short_url
{
    my $server = shift;
    my $url    = shift;

    my $offset = length("$server/");
    $url = substr($url, $offset);

    return $url;
}


# Fetches the current CWS from environment, returns a Cws object
sub get_cws_from_environment
{
    my $child  = $ENV{CWS_WORK_STAMP};
    my $master = $ENV{WORK_STAMP};

    if ( !$child ) {
        print_error("Environment variable CWS_WORK_STAMP is not set. Please set it to your CWS name.", 2);
    }

    if ( !$master ) {
        print_error("Environment variable WORK_STAMP is not set. Please set it to the MWS name.", 2);
    }

    my $cws = get_this_cws();
    $cws->child($child);
    $cws->master($master);

    # Check if we got a valid child workspace.
    my $id = $cws->eis_id();
    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... master: $master, child: $child, $id\n";
    }
    if ( !$id ) {
        print_error("Child workspace $child for master workspace $master not found in EIS database.", 2);
    }
    return ($cws);
}

# Fetches the CWS by name, returns a Cws object
sub get_cws_by_name
{
    my $child  = shift;

    my $cws = get_this_cws();
    $cws->child($child);

    # Check if we got a valid child workspace.
    my $id = $cws->eis_id();
    if ( $debug ) {
        print STDERR "CWS-DEBUG: child: $child, $id\n";
    }
    if ( !$id ) {
        print_error("Child workspace $child not found in EIS database.", 2);
    }

    # Update masterws part of Cws object.
    my $masterws = $cws->get_mws();
    if ( $cws->master() ne $masterws ) {
        # can this still happen?
        if ( $debug ) {
            print STDERR "CWS-DEBUG: get_cws_by_name(): fixup of masterws in cws object detected\n";
        }
        $cws->master($masterws);
    }
    return ($cws);
}

# Register child workspace with eis.
sub register_child_workspace
{
    my $cws          = shift;
    my $scm          = shift;
    my $is_promotion = shift;

    my $milestone = $cws->milestone();
    my $child     = $cws->child();
    my $master    = $cws->master();

    # TODO: introduce a EIS_USER in the configuration, which should be used here
    my $config = CwsConfig->new();
    my $vcsid  = $config->vcsid();
    # TODO: there is no real need for socustom anymore, should go ASAP
    my $socustom = $config->sointernal();

    if ( !$vcsid ) {
        if ( $socustom ) {
            print_error("Can't determine owner for CWS '$child'. Please set VCSID environment variable.", 11);
        }
        else {
            print_error("Can't determine owner for CWS '$child'. Please set CVS_ID entry in \$HOME/.cwsrc.", 11);
        }
    }

    if ( $is_promotion ) {
        my $rc = $cws->set_scm($scm);
        if ( !$rc ) {
            print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12);
        }

        $rc = $cws->promote($vcsid, "");

        if ( !$rc ) {
            print_error("Failed to promote child workspace '$child' to status 'new'.\n", 12);
        }
        else {
            print "\n***** Successfully ***** promoted child workspace '$child' to status 'new'.\n";
            print "Milestone: '$milestone'.\n";
        }
    }
    else {

        my $eis_id = $cws->register($vcsid, "");

        if ( !defined($eis_id) ) {
            print_error("Failed to register child workspace '$child' for master '$master'.", 12);
        }
        else {
            my $rc = $cws->set_scm($scm);
            if ( !$rc ) {
                print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12);
            }
            print "\n***** Successfully ***** registered child workspace '$child'\n";
            print "for master workspace '$master' (milestone '$milestone').\n";
            print "Child workspace Id: $eis_id.\n";
        }
    }
    return 0;
}

sub print_time_elapsed
{
    my $t_start = shift;
    my $t_stop  = shift;

    my $time_diff = timediff($t_stop, $t_start);
    print_message("... finished in " . timestr($time_diff));
}

sub hgrc_append_push_path_and_hooks
{
    my $target     = shift;
    my $cws_source = shift;

    $cws_source =~ s/http:\/\//ssh:\/\/hg@/;
    if ( $debug ) {
        print STDERR "CWS-DEBUG: hgrc_append_push_path_and_hooks(): default-push path: '$cws_source'\n";
    }
    if ( !open(HGRC, ">>$target/.hg/hgrc") ) {
        print_error("Can't append to hgrc file of repository '$target'.\n", 88);
    }
    print HGRC "default-push = " . "$cws_source\n";
    print HGRC "[extensions]\n";
    print HGRC "hgext.win32text=\n";
    print HGRC "[hooks]\n";
    print HGRC "# Reject commits which would introduce windows-style CR/LF files\n";
    print HGRC "pretxncommit.crlf = python:hgext.win32text.forbidcrlf\n";
    close(HGRC);
}

sub is_hg_strip_available
{
    my $profile = hg_show();

    foreach (@{$profile}) {
        if ( $_ =~ /hgext.mq=/ ) {
            return 1;
        }
    }
    return 0;
}

sub hg_clone_repository
{
    my $rep_type             = shift;
    my $cws                  = shift;
    my $target               = shift;
    my $clone_milestone_only = shift;

    my ($hg_local_source, $hg_lan_source, $hg_remote_source);
    my $config = CwsConfig->new();
    if ( $rep_type eq 'ooo') {
        $hg_local_source = $config->get_ooo_hg_local_source();
        $hg_lan_source = $config->get_ooo_hg_lan_source();
        $hg_remote_source = $config->get_ooo_hg_remote_source();
    }
    else {
        $hg_local_source = $config->get_so_hg_local_source();
        $hg_lan_source = $config->get_so_hg_lan_source();
        $hg_remote_source = $config->get_so_hg_remote_source();
    }

    my $masterws = $cws->master();
    my $master_local_source = "$hg_local_source/" . $masterws;
    my $master_lan_source = "$hg_lan_source/" . $masterws;

    my $milestone_tag;
    if ( $clone_milestone_only ) {
        $milestone_tag = uc($masterws) . '_' . $clone_milestone_only;
    }
    else {
        my @tags = $cws->get_tags();
        $milestone_tag = $tags[3];
    }

    if ( $debug ) {
        print STDERR "CWS-DEBUG: master_local_source: '$master_local_source'\n";
        print STDERR "CWS-DEBUG: master_lan_source: '$master_lan_source'\n";
        if ( !-d $master_local_source ) {
            print STDERR "CWS-DEBUG: not a directory '$master_local_source'\n";
        }
    }

    # clone from local source if possible, otherwise from LAN source
    if ( -d $master_local_source && can_use_hardlinks($master_local_source, dirname($target)) ) {
        hg_local_clone_repository($master_local_source, $target, $milestone_tag);
    }
    else {
        hg_lan_clone_repository($master_lan_source, $target, $milestone_tag);
    }

    # now pull from the remote cws outgoing repository if it already contains something
    if ( !$clone_milestone_only ) {
        my $cws_remote_source = "$hg_remote_source/cws/" . $cws->child();

        # The outgoing repository might not yet be available. Which is not
        # an error. Since pulling from the cws outgoing URL results in an ugly
        # and hardly understandable error message, we check for the availaility
        # first. TODO: incorporate configured proxy instead of env_proxy. Use
        # a dedicated request and content-type to find out if the repo is there
        # instead of parsing the content of the page
        require LWP::Simple;
        my $content = LWP::Simple::get($cws_remote_source);
        my $pattern = "<title>cws/". $cws->child();
        if ( $content =~ /$pattern/ ) {
            hg_remote_pull_repository($cws_remote_source, $target);
        }
        else {
            print_message("The 'outgoing' repository '$cws_remote_source' is not accessible/available");
        }
        hgrc_append_push_path_and_hooks($target, $cws_remote_source);
    }

    # update the result
    hg_update_repository($target);

}

sub hg_local_clone_repository
{
    my $local_source  = shift;
    my $dest          = shift;
    my $milestone_tag = shift;

    # fastest way to clone a repository up to a certain milestone
    # 1) clone w/o -r options (hard links!)
    # 2) find (local) revision which corresponds to milestone
    # 3) strip revision+1

    my $t1 = Benchmark->new();
    print_message("... clone LOCAL repository '$local_source' to '$dest'");
    hg_clone($local_source, $dest, '-U');
    my $id_option = "-n -r $milestone_tag";
    my $revision = hg_ident($dest, $milestone_tag);
    if ( defined($revision) ) {
        my $strip_revision = $revision+1;
        hg_strip($dest, $revision);
    }
    my $t2 = Benchmark->new();
    print_time_elapsed($t1, $t2);
}

sub hg_lan_clone_repository
{
    my $lan_source    = shift;
    my $dest          = shift;
    my $milestone_tag = shift;

    my $t1 = Benchmark->new();
    print_message("... clone LAN repository '$lan_source' to '$dest'");
    hg_clone($lan_source, $dest, "-U -r $milestone_tag");
    my $t2 = Benchmark->new();
    print_time_elapsed($t1, $t2);
}

sub hg_remote_pull_repository
{
    my $remote_source = shift;
    my $dest          = shift;

    my $t1 = Benchmark->new();
    print_message("... pull from REMOTE repository '$remote_source' to '$dest'");
    hg_pull($dest, $remote_source);
    my $t2 = Benchmark->new();
    print_time_elapsed($t1, $t2);
}

sub hg_update_repository
{
    my $dest          = shift;

    my $t1 = Benchmark->new();
    print_message("... update repository '$dest'");
    hg_update($dest);
    my $t2 = Benchmark->new();
    print_time_elapsed($t1, $t2);
}

# Check if clone source and destination are on the same filesystem,
# in that case hg clone can employ hard links.
sub can_use_hardlinks
{
    my $source = shift;
    my $dest = shift;

    if ( $^O eq 'cygwin' ) {
        # no hard links on windows
        return 0;
    }
    # st_dev is the first field return by stat()
    my @stat_source = stat($source);
    my @stat_dest = stat($dest);

    if ( $debug ) {
        print STDERR "can_use_hardlinks(): source device: '$stat_source[0]', destination device: '$stat_dest[0]'\n";
    }
    if ( $stat_source[0] == $stat_dest[0] ) {
        return 1;
    }
    return 0;
}

sub query_cws
{
    my $query_mode = shift;
    my $options_ref = shift;
    # get master and child workspace
    my $masterws  = exists $options_ref->{'masterworkspace'} ? uc($options_ref->{'masterworkspace'}) : $ENV{WORK_STAMP};
    my $childws   = exists $options_ref->{'childworkspace'} ? $options_ref->{'childworkspace'} : $ENV{CWS_WORK_STAMP};
    my $milestone = exists $options_ref->{'milestone'} ? $options_ref->{'milestone'} : 'latest';

    if ( !defined($masterws) && $query_mode ne 'masters') {
        print_error("Can't determine master workspace environment.\n", 30);
    }

    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) ) {
        print_error("Can't determine child workspace environment.\n", 30);
    }

    my $cws = Cws->new();
    if ( defined($childws) ) {
        $cws->child($childws);
    }
    if ( defined($masterws) ) {
        $cws->master($masterws);
    }

    no strict;
    &{"query_".$query_mode}($cws, $milestone);
    return;
}

sub query_integratedinto
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $milestone = $cws->get_milestone_integrated();
        print_message("Integrated into:");
        print defined($milestone) ? "$milestone\n" : "unkown\n";
    }
    return;
}

sub query_incompatible
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my @modules = $cws->incompatible_modules();
        print_message("Incompatible Modules:");
        foreach (@modules) {
            if ( defined($_) ) {
                print "$_\n";
            }
        }
    }
    return;
}

sub query_taskids
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my @taskids = $cws->taskids();
        print_message("Task ID(s):");
        foreach (@taskids) {
            if ( defined($_) ) {
                print "$_\n";
            }
        }
    }
    return;
}

sub query_status
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $status = $cws->get_approval();
        if ( !$status ) {
            print_error("Internal error: can't get approval status.", 3);
        } else {
            print_message("Approval status:");
            print "$status\n";
        }
    }
    return;
}

sub query_scm
{
    my $cws = shift;
    my $masterws = $cws->master();
    my $childws  = $cws->child();

    if ( is_valid_cws($cws) ) {
        my $scm = $cws->get_scm();
        if ( !defined($scm) ) {
            print_error("Internal error: can't retrieve scm info.", 3);
        } else {
                print_message("Child workspace uses '$scm'.");
        }
    }
    return;
}

sub query_ispublic
{
    my $cws = shift;
    my $masterws = $cws->master();
    my $childws  = $cws->child();

    if ( is_valid_cws($cws) ) {
        my $ispublic = $cws->get_public_flag();
        if ( !defined($ispublic) ) {
            print_error("Internal error: can't get isPublic flag.", 3);
        } else {
            if ( $ispublic==1 ) {
                print_message("Child workspace is public");
            } else {
                print_message("Child workspace is internal");
            }
        }
    }

    return;
}

sub query_current
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $milestone = $cws->milestone();
        if ( !$milestone ) {
            print_error("Internal error: can't get current milestone.", 3);
        } else {
            print_message("Current milestone:");
            print "$milestone\n";
        }
    }
    return;
}

sub query_owner
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $owner = $cws->get_owner();
        print_message("Owner:");
        if ( !$owner ) {
            print "not set\n" ;
        } else {
            print "$owner\n";
        }
    }
    return;
}

sub query_qarep
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $qarep = $cws->get_qarep();
        print_message("QA Representative:");
        if ( !$qarep ) {
            print "not set\n" ;
        } else {
            print "$qarep\n";
        }
    }
    return;
}


sub query_build
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $build = $cws->get_build();
        print_message("Build:");
        if ( $build ) {
            print "$build\n";
        }
    }
    return;
}

sub query_latest
{
    my $cws = shift;

    my $masterws = $cws->master();
    my $latest = $cws->get_current_milestone($masterws);


    if ( $latest ) {
        print_message("Master workspace '$masterws':");
        print_message("Latest milestone available for rebase:");
        print "$masterws $latest\n";
    }
    else {
        print_error("Can't determine latest milestone of '$masterws' available for rebase.", 3);
    }

    return;
}

sub query_masters
{
    my $cws = shift;

    my @mws = $cws->get_masters();
    my $list="";

    if ( @mws ) {
        foreach (@mws) {
            if ( $list ne "" ) {
                $list .= ", ";
            }
            $list .= $_;
        }
        print_message("Master workspaces available: $list");
    }
    else {
        print_error("Can't determine masterworkspaces.", 3);
    }

    return;
}

sub query_milestones
{
    my $cws = shift;
    my $masterws = $cws->master();

    my @milestones = $cws->get_milestones($masterws);
    my $list="";

    if ( @milestones ) {
        foreach (@milestones) {
            if ( $list ne "" ) {
                $list .= ", ";
            }
            $list .= $_;
        }
        print_message("Master workspace '$masterws':");
        print_message("Milestones known on Master: $list");
    }
    else {
        print_error("Can't determine milestones of '$masterws'.", 3);
    }

    return;
}

sub query_ispublicmaster
{
    my $cws = shift;
    my $masterws = $cws->master();

    my $ispublic = $cws->get_publicmaster_flag();
    my $list="";

    if ( defined($ispublic) ) {
        print_message("Master workspace '$masterws':");
        if ( !defined($ispublic) ) {
            print_error("Internal error: can't get isPublicMaster flag.", 3);
        } else {
            if ( $ispublic==1 ) {
                print_message("Master workspace is public");
            } else {
                print_message("Master workspace is internal");
            }
        }
    }
    else {
        print_error("Can't determine isPublicMaster flag of '$masterws'.", 3);
    }

    return;
}

sub query_buildid
{
    my $cws       = shift;
    my $milestone = shift;

    my $masterws = $cws->master();
    if ( $milestone eq 'latest' ) {
        $milestone = $cws->get_current_milestone($masterws);
    }

    if ( !$milestone ) {
        print_error("Can't determine latest milestone of '$masterws'.", 3);
    }

    if ( !$cws->is_milestone($masterws, $milestone) ) {
        print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3);
    }

    my $buildid = $cws->get_buildid($masterws, $milestone);


    if ( $buildid ) {
        print_message("Master workspace '$masterws':");
        print_message("BuildId for milestone '$milestone':");
        print("$buildid\n");
    }

    return;
}

sub query_integrated
{
    my $cws       = shift;
    my $milestone = shift;

    my $masterws = $cws->master();
    if ( $milestone eq 'latest' ) {
        $milestone = $cws->get_current_milestone($masterws);
    }

    if ( !$milestone ) {
        print_error("Can't determine latest milestone of '$masterws'.", 3);
    }

    if ( !$cws->is_milestone($masterws, $milestone) ) {
        print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3);
    }

    my @integrated_cws = $cws->get_integrated_cws($masterws, $milestone);


    if ( @integrated_cws ) {
        print_message("Master workspace '$masterws':");
        print_message("Integrated CWSs for milestone '$milestone':");
        foreach (@integrated_cws) {
            print "$_\n";
        }
    }

    return;
}

sub query_approved
{
    my $cws       = shift;

    my $masterws = $cws->master();

    my @approved_cws = $cws->get_cws_with_state($masterws, 'approved by QA');

    if ( @approved_cws ) {
        print_message("Master workspace '$masterws':");
        print_message("CWSs approved by QA:");
        foreach (@approved_cws) {
            print "$_\n";
        }
    }

    return;
}

sub query_nominated
{
    my $cws       = shift;

    my $masterws = $cws->master();

    my @nominated_cws = $cws->get_cws_with_state($masterws, 'nominated');

    if ( @nominated_cws ) {
        print_message("Master workspace '$masterws':");
        print_message("Nominated CWSs:");
        foreach (@nominated_cws) {
            print "$_\n";
        }
    }

    return;
}

sub query_ready
{
    my $cws       = shift;

    my $masterws = $cws->master();

    my @ready_cws = $cws->get_cws_with_state($masterws, 'ready for QA');

    if ( @ready_cws ) {
        print_message("Master workspace '$masterws':");
        print_message("CWSs ready for QA:");
        foreach (@ready_cws) {
            print "$_\n";
        }
    }

    return;
}

sub query_new
{
    my $cws       = shift;

    my $masterws = $cws->master();

    my @ready_cws = $cws->get_cws_with_state($masterws, 'new');

    if ( @ready_cws ) {
        print_message("Master workspace '$masterws':");
        print_message("CWSs with state 'new':");
        foreach (@ready_cws) {
            print "$_\n";
        }
    }

    return;
}

sub query_planned
{
    my $cws       = shift;

    my $masterws = $cws->master();

    my @ready_cws = $cws->get_cws_with_state($masterws, 'planned');

    if ( @ready_cws ) {
        print_message("Master workspace '$masterws':");
        print_message("CWSs with state 'planned':");
        foreach (@ready_cws) {
            print "$_\n";
        }
    }

    return;
}

sub is_valid_cws
{
    my $cws = shift;

    my $masterws = $cws->master();
    my $childws  = $cws->child();
    # check if we got a valid child workspace
    my $id = $cws->eis_id();
    if ( !$id ) {
        print_error("Child workspace '$childws' for master workspace '$masterws' not found in EIS database.", 2);
    }
    print STDERR "Master workspace '$masterws', child workspace '$childws'\n";
    return 1;
}

sub query_release
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $release = $cws->get_release();
            print_message("Release target:");
        if ( !$release ) {
            print "not set\n";
        } else {
            print "$release\n";
        }
    }
    return;
}

sub query_due
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $due = $cws->get_due_date();
            print_message("Due date:");
        if ( !$due ) {
            print "not set\n";
        } else {
            print "$due\n";
        }
    }
    return;
}

sub query_due_qa
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $due_qa = $cws->get_due_date_qa();
            print_message("Due date (QA):");
        if ( !$due_qa ) {
            print "not set\n";
        } else {
            print "$due_qa\n";
        }
    }
    return;
}

sub query_help
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $help = $cws->is_helprelevant();
            print_message("Help relevant:");
        if ( !$help ) {
            print "false\n";
        } else {
            print "true\n";
        }
    }
    return;
}

sub query_ui
{
    my $cws = shift;

    if ( is_valid_cws($cws) ) {
        my $help = $cws->is_uirelevant();
            print_message("UI relevant:");
        if ( !$help ) {
            print "false\n";
        } else {
            print "true\n";
        }
    }
    return;
}

sub verify_milestone
{
    my $cws = shift;
    my $qualified_milestone = shift;

    my $invalid = 0;
    my ($master, $milestone);
    $invalid++ if $qualified_milestone =~ /-/;

    if ( $qualified_milestone =~ /:/ ) {
        ($master, $milestone) = split(/:/, $qualified_milestone);
        $invalid++ unless ( $master && $milestone );
    }
    else {
        $milestone = $qualified_milestone;
    }

    if ( $invalid ) {
        print_error("Invalid milestone", 0);
        usage();
        exit(1);
    }

    $master = $cws->master() if !$master;
    if ( !$cws->is_milestone($master, $milestone) ) {
        print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 21);
    }
    return ($master, $milestone);
}

sub relink_workspace {
    my $linkdir = shift;
    my $restore = shift;

    # The list of obligatorily added modules, build will not work
    # if these are not present.
    my %added_modules_hash;
    if (defined $ENV{ADDED_MODULES}) {
        for ( split(/\s/, $ENV{ADDED_MODULES}) ) {
            $added_modules_hash{$_}++;
        }
    }

    # clean out pre-existing linkdir
    my $bd = dirname($linkdir);
    if ( !opendir(DIR, $bd) ) {
        print_error("Can't open directory '$bd': $!.", 44);
    }
    my @old_link_dirs = grep { /^src.m\d+/ } readdir(DIR);
    close(DIR);

    if ( @old_link_dirs > 1 ) {
        print_error("Found more than one old link directories:", 0);
        foreach (@old_link_dirs) {
            print STDERR "@old_link_dirs\n";
        }
        if ( $restore ) {
            print_error("Please remove all old link directories but the last one", 67);
        }
    }

    # Originally the extension .lnk indicated a linked module. This turned out to be
    # not an overly smart choice. Cygwin has some heuristics which regards .lnk
    # files as Windows shortcuts, breaking the build. Use .link instead.
    # When in restoring mode still consider .lnk as link to modules (for old CWSs)
    my $old_link_dir = "$bd/" . $old_link_dirs[0];
    if ( $restore ) {
        if ( !opendir(DIR, $old_link_dir) ) {
            print_error("Can't open directory '$old_link_dir': $!.", 44);
        }
        my @links = grep { !(/\.lnk/ || /\.link/)   } readdir(DIR);
        close(DIR);
        # everything which is not a link to a directory can't be an "added" module
        foreach (@links) {
            next if /^\./;
            my $link = "$old_link_dir/$_";
            if ( -s $link && -d $link ) {
                $added_modules_hash{$_} = 1;
            }
        }
    }
    print_message("... removing '$old_link_dir'");
    rmtree([$old_link_dir], 0);

    print_message("... (re)create '$linkdir'");
    if ( !mkdir("$linkdir") ) {
        print_error("Can't create directory '$linkdir': $!.", 44);
    }
    if ( !opendir(DIR, "$bd/ooo") ) {
        print_error("Can't open directory '$bd/sun': $!.", 44);
    }
    my @ooo_top_level_dirs = grep { !/^\./ } readdir(DIR);
    close(DIR);
    if ( !opendir(DIR, "$bd/sun") ) {
        print_error("Can't open directory '$bd/sun': $!.", 44);
    }
    my @so_top_level_dirs = grep { !/^\./ } readdir(DIR);
    close(DIR);
    my $savedir = getcwd();
    if ( !chdir($linkdir) ) {
        print_error("Can't chdir() to directory '$linkdir': $!.", 44);
    }
    my $suffix = '.link';
    foreach(@ooo_top_level_dirs) {
        if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE'  ) {
            next;
        }
        my $target = $_;
        if ( -d "../ooo/$_" && !exists $added_modules_hash{$_} ) {
            $target .= $suffix;
        }
        if ( !symlink("../ooo/$_", $target) ) {
            print_error("Can't symlink directory '../ooo/$_ -> $target': $!.", 44);
        }
    }
    foreach(@so_top_level_dirs) {
        if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE'  ) {
            next;
        }
        my $target = $_;
        if ( -d "../sun/$_" && !exists $added_modules_hash{$_} ) {
            $target .= $suffix;
        }
        if ( !symlink("../sun/$_", $target) ) {
            print_error("Can't symlink directory '../sun/$_ -> $target': $!.", 44);
        }
    }
    if ( !chdir($savedir) ) {
        print_error("Can't chdir() to directory '$linkdir': $!.", 44);
    }
}

sub update_solver
{
    my $platform   = shift;
    my $source     = shift;
    my $solver     = shift;
    my $milestone  = shift;

    my @zip_sub_dirs = ('bin', 'doc', 'idl', 'inc', 'lib', 'par', 'pck', 'pdb', 'pus', 'rdb', 'res', 'xml', 'sdf');

    use Archive::Zip qw( :ERROR_CODES :CONSTANTS );

    my $platform_solver = "$solver/$platform";

    if ( -d $platform_solver ) {
        print_message("... removing old solver for platform '$platform'");
        if ( !rmtree([$platform_solver]) ) {
            print_error("Can't remove directory '$platform_solver': $!.", 44);
        }
    }

    if ( !mkdir("$platform_solver") ) {
        print_error("Can't create directory '$platform_solver': $!.", 44);
    }

    my $platform_source = "$source/$platform/zip.$milestone";
    if ( !opendir(DIR, "$platform_source") ) {
        print_error("Can't open directory '$platform_source': $!.", 44);
    }
    my @zips = grep { /\.zip$/ } readdir(DIR);
    close(DIR);

    my $nzips = @zips;
    print_message("... unzipping $nzips zip archives for platform '$platform'");

    foreach(@zips) {
        my $zip = Archive::Zip->new();
        unless ( $zip->read( "$platform_source/$_" ) == AZ_OK ) {
            print_error("Can't read zip file '$platform_source/$_': $!.", 44);
        }
        # TODO: check for erorrs
        foreach (@zip_sub_dirs) {
            unless ( $zip->extractTree($_, "$platform_solver/$_.$milestone") == AZ_OK ) {
                print_error("Can't extract stream from zip file '$platform_source/$_': $!.", 44);
            }
        }
     }
}

sub write_rebase_configuration
{
    my $workspace = shift;
    my $cwsname   = shift;
    my $master    = shift;
    my $milestone = shift;

    my $rebase_config = "$workspace/REBASE.CONFIG_DONT_DELETE";

    open(REBASE, ">$rebase_config") or print_error("Can't open file '$rebase_config' for writing: $!", 98);
    print REBASE "CWS-TOOLING: do not delete this file, it's needed for 'cws rebase -C'\n";
    print REBASE "CWS: $cwsname\n";
    print REBASE "New MWS: $master\n";
    print REBASE "New milestone: $milestone\n";
    close(REBASE);
}

sub read_rebase_configuration
{
    my $workspace = shift;

    my $rebase_config = "$workspace/REBASE.CONFIG_DONT_DELETE";

    my $master;
    my $milestone;

    open(REBASE, "<$rebase_config") or print_error("Can't open file '$rebase_config' for reading: $!", 98);
    while(<REBASE>) {
        if ( /New MWS: (\w+)/ ) {
            $master = $1;
        }
        if ( /New milestone: (\w+)/ ) {
            $milestone = $1;
        }
    }
    close(REBASE);

    if ( !defined($master) || !defined($milestone) ) {
        print_error("File '$rebase_config' seems to be garbled. Can't continue.", 98)
    }

    return ($master, $milestone);
}

sub diff_print_files
{
    my $files_ref = shift;
    my $diff_options = shift;

    my @files = sort(@{$files_ref});

    if ( $diff_options eq 'files') {
        foreach(@files) {
            print "$_\n";
        }
    }
    else {
        my @modules;
        foreach(@files) {
            my ($module) = split(/\//, $_);
            push(@modules, $module);
        }
        # remove adjacent uniques
        my $prev = 'nosuchmodule';
        my @unique_modules = grep($_ ne $prev && (($prev) = $_), @modules);
        foreach(@unique_modules) {
            print "$_\n";
        }
    }
}

# TODO: special provisions for SVN->HG migrations, remove this
# some time after migration
sub get_scm_for_milestone
{
    my $masterws = shift;
    my $milestone = shift;

    my $milestone_sequence_number = extract_milestone_sequence_number($milestone);
    my $dev300_migration_sequence_number = extract_milestone_sequence_number($dev300_migration_milestone);
    my $ooo320_migration_sequence_number = extract_milestone_sequence_number($ooo320_migration_milestone);

    my $scm = 'SVN';

    if ( $masterws eq 'DEV300' ) {
        if ( $milestone_sequence_number >= $dev300_migration_sequence_number ) {
            $scm = 'HG';
        }
    }
    elsif ( $masterws eq 'OOO320' ) {
        if ( $milestone_sequence_number >= $ooo320_migration_sequence_number ) {
            $scm = 'HG';
        }
    }
    else {
        $scm = 'SVN'
    }
    return $scm;
}

sub extract_milestone_sequence_number
{
    my $milestone = shift;

    my $milestone_sequence_number;
    if ( $milestone =~ /m(\d+)/ ) {
        $milestone_sequence_number = $1;
    }
    else {
        print_error("can't extract milestone sequence number from milestone '$milestone'", 99);
    }
    return $milestone_sequence_number;
}

# Executes the help command.
sub do_help
{
    my $args_ref    = shift;
    my $options_ref = shift;

    if (@{$args_ref} == 0) {
        print STDERR "usage: cws <subcommand> [options] [args]\n";
        print STDERR "Type 'cws help <subcommand>' for help on a specific subcommand.\n";
        print STDERR "\n";
        print STDERR "Available subcommands:\n";
        print STDERR "\thelp (h,?)\n";
        print STDERR "\tcreate\n";
        print STDERR "\tfetch (f)\n";
        print STDERR "\trebase (rb)\n";
        print STDERR "\tanalyze (an)\n";
        print STDERR "\tquery (q)\n";
        print STDERR "\ttask (t)\n";
        print STDERR "\tcdiff (cd)\n";
        print STDERR "\tsetcurrent\n";
        print STDERR "\tintegrate *** release engineers only ***\n";
        print STDERR "\teisclone *** release engineers only ***\n";
    }

    my $arg = $args_ref->[0];

    if (!defined($arg) || $arg eq 'help') {
        print STDERR "help (h, ?): Describe the usage of this script or its subcommands\n";
        print STDERR "usage: help [subcommand]\n";
    }
    elsif ($arg eq 'create') {
        print STDERR "create: Create a new child workspace\n";
        print STDERR "usage: create [--hg] [-m milestone] <master workspace> <child workspace>\n";
        print STDERR "\t-m milestone:          Milestone to base the child workspace on. If ommitted the\n";
        print STDERR "\t                       last published milestone will be used.\n";
        print STDERR "\t--milestone milestone: Same as -m milestone.\n";
        print STDERR "\t--hg:                  Create Mercurial (hg) based CWS.\n";
        print STDERR "\t--migration:           Used only for the migration of an exitisting CWS from CVS to SVN.\n";
        print STDERR "\t                       Disables existence check in EIS, creates CWS branch in SVN, sets SVN flag.\n";
    }
    elsif ($arg eq 'task') {
        print STDERR "task: Add a task to a child workspace\n";
        print STDERR "usage: task <task id> [task id ...]\n";
    }
    elsif ($arg eq 'query') {
        print STDERR "query: Query child workspace for miscellaneous information\n";
        print STDERR "usage: query [-M master] [-c child] <current|integratedinto|incompatible|owner|qarep|status|taskids>\n";
        print STDERR "       query [-M master] [-c child] <release|due|due_qa|help|ui|ispublic|scm|build>\n";
        print STDERR "       query [-M master] <latest|milestones|ispublicmaster>\n";
        print STDERR "       query  <masters>\n";
        print STDERR "       query [-M master] [-m milestone] <integrated|buildid>\n";
        print STDERR "       query [-M master] <planned|new|approved|nominated|ready>\n";
        print STDERR "\t-M master:\t\toverride MWS specified in environment\n";
        print STDERR "\t-c child:\t\toverride CWS specified in environment\n";
        print STDERR "\t-m milestone:\t\toverride latest milestone with specified one\n";
        print STDERR "\t--master master:\tSame as -M master\t\n";
        print STDERR "\t--child child:\t\tSame -c child\n";
        print STDERR "\t--milestone milestone:\tSame as -m milestone\n";
        print STDERR "Modes:\n";
        print STDERR "\tcurrent\t\tquery current milestone of CWS\n";
        print STDERR "\tincompatible\tquery modules which should be build incompatible\n";
        print STDERR "\towner\t\tquery CWS owner\n";
        print STDERR "\tqarep\t\tquery CWS QA Representative\n";
        print STDERR "\tstatus\t\tquery approval status of CWS\n";
        print STDERR "\ttaskids\t\tquery taskids to be handled on the CWS\n";
        print STDERR "\trelease\t\tquery for target release of CWS\n";
        print STDERR "\tdue\t\tquery for due date of CWS\n";
        print STDERR "\tdue_qa\t\tquery for due date (QA) of CWS\n";
        print STDERR "\thelp\t\tquery if the CWS is help relevant\n";
        print STDERR "\tui\t\tquery if the CWS is UI relevant\n";
        print STDERR "\tbuild\t\tquery build String for CWS\n";
        print STDERR "\tlatest\t\tquery the latest milestone available for resync\n";
        print STDERR "\tbuildid\t\tquery build ID for milestone\n";
        print STDERR "\tintegrated\tquery integrated CWSs for milestone\n";
        print STDERR "\tintegratedinto\tquery milestone which CWS was integrated into\n";
        print STDERR "\tplanned\t\tquery for planned CWSs\n";
        print STDERR "\tnew\t\tquery for new CWSs\n";
        print STDERR "\tapproved\tquery CWSs approved by QA\n";
        print STDERR "\tnominated\tquery nominated CWSs\n";
        print STDERR "\tready\t\tquery CWSs ready for QA\n";
        print STDERR "\tispublic\tquery public flag of CWS\n";
        print STDERR "\tscm\t\tquery Source Control Management (SCM) system used for CWS\n";
        print STDERR "\tmasters\t\tquery available MWS\n";
        print STDERR "\tmilestones\tquery which milestones are know on the given MWS\n";
        print STDERR "\tispublicmaster\tquery public flag of MWS\n";

     }
    elsif ($arg eq 'fetch') {
        print STDERR "THE USER-INTERFACE TO THIS SUBCOMMAND IS LIKELY TO CHANGE IN FUTURE\n";
        print STDERR "fetch: fetch a milestone or CWS\n";
        print STDERR "usage: fetch [-q] [-s] [-p platforms] [-o] <-m milestone> <workspace>\n";
        print STDERR "usage: fetch [-q] [-s] [-p platforms] [-o] <-c cws> <workspace>\n";
        print STDERR "usage: fetch [-q] [-s] <-m milestone> <workspace>\n";
        print STDERR "usage: fetch [-q] [-s] <-c cws> <workspace>\n";
        print STDERR "\t-m milestone:           Checkout milestone <milestone> to workspace <workspace>\n";
        print STDERR "\t                        Use 'latest' for the for lastest published milestone on the current master\n";
        print STDERR "\t                        For cross master checkouts use the form <MWS>:<milestone>\n";
        print STDERR "\t--milestone milestone:  Same as -m milestone\n";
        print STDERR "\t-c childworkspace:      Checkout CWS <childworkspace> to workspace <workspace>\n";
        print STDERR "\t--child childworkspace: Same as -c childworkspace\n";
        print STDERR "\t-s:                     Try to switch an existing workspace <workspace> to milestone or CWS\n";
        print STDERR "\t--switch:               Same as -s\n";
        print STDERR "\t-p platform:            Copy one or more prebuilt platforms 'platform'. \n";
        print STDERR "\t                        Separate multiple platforms with commas.\n";
        print STDERR "\t--platforms platform:   Same as -p\n";
        print STDERR "\t-o                      Omit checkout of sources, copy only solver. \n";
        print STDERR "\t--onlysolver:           Same as -o\n";
        print STDERR "\t-q                      Silence some of the output of the command.\n";
        print STDERR "\t--quiet:                Same as -q\n";
    }
    elsif ($arg eq 'rebase') {
        print STDERR "rebase: Rebase a child workspace to a new milestone\n";
        print STDERR "usage: rebase <-m milestone> <workspace>\n";
        print STDERR "usage: rebase <-C> <workspace>\n";
        print STDERR "\t-m milestone:          Merge changes on MWS into CWS up to and including milestone <milestone>\n";
        print STDERR "\t                       Use 'latest' for the for lastest published milestone on the current master\n";
        print STDERR "\t                       For cross master rebases use the form <MWS>:<milestone>\n";
        print STDERR "\t--milestone milestone: Same as -m milestone\n";
        print STDERR "\t-C:                    Commit changes made by merge step and update current milestone in database\n";
        print STDERR "\t--commit:              Same as -C\n"
    }
    elsif ($arg eq 'integrate') {
        print STDERR "integrate: Integrate a child workspace into a master workspace\n";
        print STDERR "usage: integrate <-c childworkspace>\n";
        print STDERR "usage: integrate <-C>\n";
        print STDERR "\t-c childworkspace:      Merge changes on CWS <childworkspace> into MWS\n";
        print STDERR "\t--child childworkspace: Same as -c childworkspace\n";
        print STDERR "\t-C:                     Commit changes made by merge step and update CWS status in database\n";
        print STDERR "\t--commit:               Same as -C\n"
    }
    elsif ($arg eq 'cdiff') {
        print STDERR "cdiff: Show changes on CWS relative to current milestone\n";
        print STDERR "usage: cdiff [-M master] [-c child] [--files] [--modules]\n";
        print STDERR "\t-M master:\t\toverride MWS specified in environment\n";
        print STDERR "\t-c child:\t\toverride CWS specified in environment\n";
        print STDERR "\t--master master:\tSame as -M master\t\n";
        print STDERR "\t--child child:\t\tSame -c child\n";
        print STDERR "\t--files:                Print only file names\n";
        print STDERR "\t--modules:              Print only top level directories aka modules\n"
    }
    elsif ($arg eq 'setcurrent') {
        print STDERR "setcurrent: Set the current milestone for the CWS (only hg based CWSs)\n";
        print STDERR "usage: setcurrent [-m milestone]\n";
        print STDERR "\t-m milestone:           Set milestone to <milestone> to workspace <workspace>\n";
        print STDERR "\t                        Use 'latest' for the for lastest published milestone on the current master\n";
        print STDERR "\t                        For cross master change use the form <MWS>:<milestone>\n";
        print STDERR "\t--milestone milestone:  Same as -m milestone\n";
    }
    else {
        print STDERR "'$arg': unknown subcommand\n";
        exit(1);
    }
    exit(0);
}

# Executes the create command.
sub do_create
{
    my $args_ref    = shift;
    my $options_ref = shift;

    if ( exists $options_ref->{'help'} || @{$args_ref} != 2) {
        do_help(['create']);
    }

    my $is_migration = 0;
    if ( exists $options_ref->{'migration'} ) {
        $is_migration = 1;
    }

    my $is_hg = 0;
    if ( exists $options_ref->{'hg'} ) {
        $is_hg = 1;
    }

    my $master   = uc $args_ref->[0];
    my $cws_name = $args_ref->[1];

    if (!is_master($master)) {
        print_error("'$master' is not a valid master workspace.", 7);
    }

    # check if cws name fits the convention
    if ( $cws_name !~ /^\w[\w\.\#]*$/ ) {
        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);
    }

    my $cws = get_this_cws();
    $cws->master($master);
    $cws->child($cws_name);

    # check if child workspace already exists
    my $eis_id = $cws->eis_id();
    if ( !defined($eis_id) ) {
        print_error("Connection with EIS database failed.", 8);
    }

    my $is_promotion = 0;
    if ( $eis_id > 0 ) {
        if ( $cws->get_approval() eq 'planned' ) {
            print "Promote child workspace '$cws_name' from 'planned' to 'new'.\n";
            $is_promotion++;
        }
        else {
            if ( $is_migration ) {
                print_message("Create CWS branch in Subversion for migrating CWS '$cws_name' from CVS.");
            }
            else {
                print_error("Child workspace '$cws_name' already exists.", 7);
            }
        }
    }
    else {
        # check if child workspace name is still available
        if ( !$cws->is_cws_name_available()) {
            print_error("Child workspace name '$cws_name' is already in use.", 7);
        }
    }

    my $milestone;
    # verify milestone or query latest milestone
    if ( exists $options_ref->{'milestone'} ) {
        $milestone=$options_ref->{'milestone'};
        # check if milestone exists
        if ( !$cws->is_milestone($master, $milestone) ) {
            print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 8);
        }
    }
    else {
        $milestone=$cws->get_current_milestone($cws->master());
    }

    # set milestone
    $cws->milestone($milestone);

    # handle mercurial(hg) based CWSs
    if ( $is_hg ) {
        register_child_workspace($cws, 'hg', $is_promotion);
        return;
    }

    # Refuse to create Subversion hosted cildworkspaces after
    # migration milestone
    my $milestone_scm = get_scm_for_milestone($cws->master(), $cws->milestone());
    if ( $milestone_scm eq 'HG' ) {
        print_error("This code line has been migrated to Mercurial.", 0);
        print_error("Please use the '--hg' option to create a Mercurial hosted CWS.", 8);
    }

    my $config = CwsConfig->new();
    my $ooo_svn_server = $config->get_ooo_svn_server();
    my $so_svn_server = $config->get_so_svn_server();

    if (!defined($ooo_svn_server)) {
        print_error("No OpenOffice.org SVN server defined, please check your configuration file.", 8);
    }

    my $ooo_milestone_url = get_milestone_url($ooo_svn_server, $cws->master(), $milestone);
    my $ooo_cws_url = get_cws_url($ooo_svn_server, $cws_name);

    my $so_milestone_url;
    my $so_cws_url;
    if ( defined($so_svn_server) ) {
        $so_milestone_url = get_milestone_url($so_svn_server, $cws->master(), $milestone);
        $so_cws_url = get_cws_url($so_svn_server, $cws_name);
    }

    # There is a slight chance that the cws creation was interrupted before registration before.
    # Check for potential remains in the repository
    my $ooo_path_exists = 0;
    my $so_path_exists = 0;

    print STDERR "... check cws path:\t'$ooo_cws_url'";
    if ( svn_path_exists($ooo_cws_url) ) {
        $ooo_path_exists=1;
        print STDERR "\n";
    }
    else {
        print STDERR ", OK\n";
    }

    if ( defined($so_svn_server) ) {
        print STDERR "... check cws path:\t'$so_cws_url'";
        if  ( svn_path_exists($so_cws_url) ) {
            print STDERR "\n";
            $so_path_exists = 1;
        }
        else {
            print STDERR ", OK\n";
        }
    }

    if ( $ooo_path_exists ) {
        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);
    }

    if ( $so_path_exists ) {
        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);
    }

    if ( $ooo_path_exists || $so_path_exists ) {
        exit(15);
    }

    # determine the revision from which the milestone was copied
    my $ooo_milestone_revision;
    my $so_milestone_revision;

    $ooo_milestone_revision = svn_milestone_revision($ooo_milestone_url);
    if ( !$ooo_milestone_revision ) {
        print_error("Can't retrieve revision for milestone '$milestone', url '$ooo_milestone_url.", 17 );
    }
    if ( defined($so_svn_server) ) {
        $so_milestone_revision = svn_milestone_revision($so_milestone_url);
        if ( !$so_milestone_revision ) {
            print_error("Can't retrieve revision for milestone '$milestone', url '$so_milestone_url.", 17 );
        }
    }

    my $ooo_master_url;
    my $so_master_url;

    $ooo_master_url = get_master_url($ooo_svn_server, $cws->master(), $ooo_milestone_revision);
    if ( defined($so_svn_server) ) {
        $so_master_url = get_master_url($so_svn_server, $cws->master(), $so_milestone_revision);
    }

    my $ooo_short_url = get_short_url($ooo_svn_server, $ooo_master_url);
    my $ooo_creation_comment = "CWS-TOOLING: create CWS " . $cws->child() . " from $ooo_short_url (milestone: " . $cws->master() . ":$milestone)";
    # create branches an ooo server and an optional so server
    print STDERR "... create branch:\t'$ooo_cws_url'";
    svn_copy($ooo_creation_comment, $ooo_master_url, $ooo_cws_url);
    if ( defined($so_svn_server) ) {
        my $so_short_url = get_short_url($so_svn_server, $so_master_url);
        my $so_creation_comment = "CWS-TOOLING: create CWS " . $cws->child() . " from $so_short_url (milestone: " . $cws->master() . ":$milestone)";
        print STDERR "... create branch:\t'$so_cws_url'";
        svn_copy($so_creation_comment, $so_master_url, $so_cws_url);
    }

    if ( $is_migration ) {
        # Set master and milestone
        $cws->master($master);
        $cws->milestone($milestone);
        my $rc = $cws->set_subversion_flag(1);
        if ( !$rc ) {
            print_error("Failed to set subversion flag on child workspace '$cws_name'.\nContact EIS administrator!\n", 12);
        }
    }
    else {
        register_child_workspace($cws, 'svn', $is_promotion);
    }
    return;
}

sub do_rebase
{
    my $args_ref    = shift;
    my $options_ref = shift;

    my $commit_phase = 0;
    my $milestone;

    # TODO: Switching to a new master dooes work not correctly yet

    if (exists $options_ref->{'help'} || @{$args_ref} != 1) {
        do_help(['rebase']);
    }
    if ( exists($options_ref->{'commit'}) && exists($options_ref->{'milestone'}) ) {
        print_error("Option -m (--milestone) and -C (--commit) are mutually exclusive.", 0 );
        do_help(['rebase']);
    }
    if ( !exists($options_ref->{'commit'}) && !exists($options_ref->{'milestone'}) ) {
        print_error("At least one of the options -m (--milestone) or -C (--commit) are required.", 0 );
        do_help(['rebase']);
    }

    if ( !svn_version_check() ) {
        print_error("cws rebase requires svn-1.5.4 or later (merge tracking and bug fixes). Please upgrade your svn client.", 1);
    }

    my $cws = get_cws_from_environment();

    my $old_masterws = $cws->master();
    my $new_masterws;
    my $new_milestone;

    my $workspace = $args_ref->[0];

    if ( ! -d $workspace ) {
        print_error("Can't find workspace '$workspace': $!", 99);
    }

    if ( exists($options_ref->{'commit'}) ) {
        $commit_phase=1;
        ($new_masterws, $new_milestone) = read_rebase_configuration($workspace);
    }
    elsif( exists($options_ref->{'milestone'}) ) {
        $milestone = $options_ref->{'milestone'};
        if ( $milestone eq 'latest' ) {
            my $latest = $cws->get_current_milestone($old_masterws);

            if ( !$latest ) {
                print_error("Can't determine latest milestone of '$old_masterws' available for rebase.", 22);
            }
            $new_masterws  = $old_masterws;
            $new_milestone = $latest;
        }
        else {
            ($new_masterws, $new_milestone) =  verify_milestone($cws, $milestone);
        }
    }
    else {
        do_help(['rebase']);
    }

    if ( $cws->get_scm() eq 'HG' ) {
        my $child = $cws->child();
        print_error("cws rebase is not supported for mercurial based childworkspaces", 0);
        print_error("re-synchronize your CWS with:", 0);
        print_error("hg pull <master>", 0);
        print_error("hg merge", 0);
        print_error("hg commit -m\"$child: merge with $new_masterws $new_milestone\"", 0);
        print_error("and update EIS with:", 0);
        print_error("cws setcurrent -m $new_milestone", 99);
    }

    my $so_setup = 0;
    my $ooo_path;
    my $so_path;
    # Determine if we got a three directory (so) setup or a plain (ooo) setup.
    # This is only needed as long the build system still relies
    # on having "modules" from different repositories in the same
    # directory besides each other.
    if ( -d "$workspace/$old_masterws/sun" ) {
        $so_setup = 1;
        $ooo_path = "$workspace/$old_masterws/ooo";
        $so_path = "$workspace/$old_masterws/sun";
    }
    else {
        $ooo_path = "$workspace";
    }

    my $config = CwsConfig->new();
    my $ooo_svn_server = $config->get_ooo_svn_server();
    my $so_svn_server = $config->get_so_svn_server();

    if (!defined($ooo_svn_server)) {
        print_error("No OpenOffice.org SVN server defined, please check your configuration file.", 8);
    }

    my $ooo_milestone_url = get_milestone_url($ooo_svn_server, $new_masterws, $new_milestone);
    my $ooo_cws_url = get_cws_url($ooo_svn_server, $cws->child());

    my $so_milestone_url;
    my $so_cws_url;
    if ( $so_setup ) {
        $so_milestone_url = get_milestone_url($so_svn_server, $new_masterws, $new_milestone);
        $so_cws_url = get_cws_url($so_svn_server, $cws->child());
    }

    my $ooo_milestone_revision;
    my $so_milestone_revision;

    $ooo_milestone_revision = svn_milestone_revision($ooo_milestone_url);
    if ( !$ooo_milestone_revision ) {
        print_error("Can't retrieve revision for milestone '$new_milestone', url '$ooo_milestone_url.", 17 );
    }
    if ( defined($so_svn_server) ) {
        $so_milestone_revision = svn_milestone_revision($so_milestone_url);
        if ( !$so_milestone_revision ) {
            print_error("Can't retrieve revision for milestone '$new_milestone', url '$so_milestone_url.", 17 );
        }
    }

    my $ooo_master_url;
    my $so_master_url;

    $ooo_master_url = get_master_url($ooo_svn_server, $new_masterws, $ooo_milestone_revision);
    if ( defined($so_svn_server) ) {
        $so_master_url = get_master_url($so_svn_server, $new_masterws, $so_milestone_revision);
    }

    if ( $commit_phase ) {
        # commit
        print_message("... committing merged changes to workspace '$workspace'.");
        my $ooo_short_url = get_short_url($ooo_svn_server, $ooo_master_url);
        my $commit_message = "CWS-TOOLING: rebase CWS " . $cws->child() . " to $ooo_short_url (milestone: " . $new_masterws . ":$new_milestone)";
        svn_commit($ooo_path, $commit_message);
        if ( $so_setup ) {
            my $so_short_url = get_short_url($so_svn_server, $so_master_url);
            $commit_message = "CWS-TOOLING: rebase CWS " . $cws->child() . " to $so_short_url (milestone: " . $new_masterws . ":$new_milestone)";
            svn_commit($so_path, $commit_message);
        }
        if ( $so_setup) {
            print_message("... rename '$workspace/$old_masterws' -> '$workspace/$new_masterws'\n");
            if ( !rename("$workspace/$old_masterws", "$workspace/$new_masterws") ) {
                print_error("Can't rename '$workspace/$old_masterws' -> '$workspace/$new_masterws': $!", 98);
            }
            print_message("... relinking workspace\n");
            relink_workspace("$workspace/$new_masterws/src.$new_milestone", 1);
            if ( !unlink("$workspace/REBASE.CONFIG_DONT_DELETE") ) {
                print_error("Can't unlink '$workspace/REBASE.CONFIG_DONT_DELETE': $!", 0);
            }

        }

        print_message("... updating EIS database");
        my $push_return = $cws->set_master_and_milestone($new_masterws, $new_milestone);
        # sanity check
        if ( $$push_return[1] ne $new_milestone) {
            print_error("Couldn't push new milestone '$new_milestone' to database", 0);
        }
    }
    else {
        # merge phase

        # check if working directory is switched to the right cws branch
        my $ooo_wc_url;
        my $so_wc_url;
        my $cwsname = $cws->child();
        print_message("... verifying if  workspace '$workspace' is switched to CWS '$cwsname'.");
        $ooo_wc_url = svn_wc_url($ooo_path);
        if ( $ooo_wc_url !~ /\/$cwsname$/ ) {
            print_error("Your working copy '$ooo_path' is not switched to the cws branch.\nPlease fix and restart rebasing.", 24);
        }
        if ( $so_setup ) {
            $so_wc_url = svn_wc_url($so_path);

            if ( $so_wc_url !~ /\/$cwsname$/ ) {
                print_error("Your working copy '$so_path' is not switched to the cws branch.\nPlease fix and restart rebasing.", 24);
            }
        }
        # check for mixed revisions, locally modified files etc
        if ( !svn_wc_is_clean($ooo_path) || ($so_setup && !svn_wc_is_clean($so_path)) ) {
            print_error("Please fix and restart rebasing.", 25);
        }

        print_message("... merging changes up to '$new_masterws:$new_milestone' to workspace '$workspace'.");
        svn_merge($ooo_milestone_url, $ooo_path);
        if ( $so_setup ) {
            svn_merge($so_milestone_url, $so_path);
        }
        # write out the rebase configuration to store new milestone and master information
        write_rebase_configuration($workspace, $cwsname, $new_masterws, $new_milestone);
    }
}

sub do_analyze
{
    my $args_ref    = shift;
    my $options_ref = shift;

    print_error("not yet implemented.", 2);
}

sub do_integrate
{
    my $args_ref    = shift;
    my $options_ref = shift;

    if (exists $options_ref->{'help'} || @{$args_ref} > 0) {
        do_help(['integrate']);
    }
    if ( exists($options_ref->{'commit'}) && exists($options_ref->{'childworkspace'}) ) {
        print_error("Option -c (--child) and -C (--commit) are mutually exclusive.", 0 );
        do_help(['integrate']);
    }
}

# Executes the fetch command.
sub do_fetch
{
    my $args_ref    = shift;
    my $options_ref = shift;

    my $time_fetch_start = Benchmark->new();
    if ( exists $options_ref->{'help'} || @{$args_ref} != 1) {
        do_help(['fetch']);
    }

    my $milestone_opt = $options_ref->{'milestone'};
    my $child = $options_ref->{'childworkspace'};
    my $platforms = $options_ref->{'platforms'};
    my $quiet  = $options_ref->{'quiet'}  ? 1 : 0 ;
    my $switch = $options_ref->{'switch'} ? 1 : 0 ;
    my $onlysolver = $options_ref->{'onlysolver'} ? 1 : 0 ;

    if ( !defined($milestone_opt) && !defined($child) ) {
        print_error("Specify one of these options: -m or -c", 0);
        do_help(['fetch']);
    }

    if ( defined($milestone_opt) && defined($child) ) {
        print_error("Options -m and -c are mutally exclusive", 0);
        do_help(['fetch']);
    }

    if ( defined($platforms) && $switch ) {
        print_error("Option '-p' is not usuable with Option '-s'.", 0);
        do_help(['fetch']);
    }

    if ( $onlysolver && !defined($platforms) ) {
        print_error("Option '-o' is Only usuable combination with option '-p'.", 0);
        do_help(['fetch']);
    }

    my $cws = get_this_cws();
    my $masterws = $ENV{WORK_STAMP};
    if ( !defined($masterws) ) {
        print_error("Can't determine current master workspace: check environment variable WORK_STAMP", 21);
    }
    $cws->master($masterws);
    my $milestone;
    my $scm;
    if( defined($milestone_opt) ) {
        if ( $milestone_opt eq 'latest' ) {
            $cws->master($masterws);
            my $latest = $cws->get_current_milestone($masterws);

            if ( !$latest ) {
                print_error("Can't determine latest milestone of master workspace '$masterws'.", 22);
            }
            $milestone = $cws->get_current_milestone($masterws);
        }
        else {
            ($masterws, $milestone) =  verify_milestone($cws, $milestone_opt);
        }
        $scm = get_scm_for_milestone($masterws, $milestone);
    }
    elsif ( defined($child) ) {
        $cws = get_cws_by_name($child);
        $masterws = $cws->master(); # CWS can have another master than specified in ENV
        $milestone = $cws->milestone();
        $scm = $cws->get_scm();
    }
    else {
        do_help(['fetch']);
    }

    if ( $switch && $scm eq 'HG' ) {
        print_error("Option '-s' is not supported with a hg based CWS.", 0);
        do_help(['fetch']);
    }

    if ( $debug ) {
        print STDERR "CWS-DEBUG: SCM: $scm\n";
    }

    if ( $scm eq 'HG' ) {
        if ( !is_hg_strip_available() ) {
            print_error("The 'cws fetch' command requires that 'hg strip' is enabled", 0);
            print_error("Please add the following lines to your hg profile (\$HOME/.hgrc)", 0);
            print_error("[extensions]", 0);
            print_error("hgext.mq=", 33);
        }
    }

    my $config = CwsConfig->new();
    my $ooo_svn_server = $config->get_ooo_svn_server();
    my $so_svn_server = $config->get_so_svn_server();
    # Check early for platforms so we can bail out before anything time consuming is done
    # in case of a missing platform
    my @platforms;
    my $prebuild_dir;
    if ( defined($platforms) ) {
        use Archive::Zip; # warn early if module is missing
        $prebuild_dir = $config->get_prebuild_binaries_location();
        $masterws = $cws->master();
        $prebuild_dir = "$prebuild_dir/$masterws";

        @platforms = split(/,/, $platforms);

        my $added_product = 0;
        my $added_nonproduct = 0;
        foreach(@platforms) {
            if ( $_ eq 'common.pro' ) {
                $added_product = 1;
                print_warning("'$_' is added automatically to the platform list, don't specify it explicit");
            }
            if ( $_ eq 'common' ) {
                $added_nonproduct = 1;
                print_warning("'$_' is added automatically to the platform list, don't specify it explicit");
            }
        }

        # add common.pro/common to platform list
        if ( $so_svn_server ) {
            my $product = 0;
            my $nonproduct = 0;
            foreach(@platforms) {
                if ( /\.pro$/ ) {
                    $product = 1;
                }
                else {
                    $nonproduct = 1;
                }
            }
            push(@platforms, 'common.pro') if ($product && !$added_product);
            push(@platforms, 'common') if ($nonproduct && !$added_nonproduct);
        }

        foreach(@platforms) {
            if ( ! -d "$prebuild_dir/$_") {
                print_error("Can't find prebuild binaries for platform '$_'.", 22);
            }
        }

    }

    my $cwsname = $cws->child();
    my $linkdir = $milestone_opt ? "src.$milestone" : "src." . $cws->milestone;

    my $workspace = $args_ref->[0];

    if ( !$onlysolver ) {
        my $url_suffix = $milestone_opt ? ("/tags/$masterws" . "_$milestone") : ('/cws/' . $cwsname);
        if ( $switch ) {
            # check if to be switched working copy exist or bail out
            if ( ! -d $workspace ) {
                print_error("Can't open workspace '$workspace': $!", 21);
            }

            my $so_setup = 0;
            my $ooo_path;
            my $so_path;
            # Determine if we got a three directory (so) setup or a plain (ooo) setup.
            # This is only needed as long the build system still relies
            # on having "modules" from different repositories in the same
            # directory besides each other.
            if ( -d "$workspace/$masterws/sun" ) {
                $so_setup = 1;
                $ooo_path = "$workspace/$masterws/ooo";
                $so_path = "$workspace/$masterws/sun";
            }
            else {
                $ooo_path = "$workspace";
            }

            # get the working copy URLs
            my $ooo_new_url = svn_wc_root($ooo_path) . $url_suffix;
            my $so_new_url;
            if ( $so_setup ) {
                $so_new_url = svn_wc_root($so_path) . $url_suffix;
            }

            print_message("... switching '$ooo_path' to URL '$ooo_new_url'");
            svn_switch($ooo_path, $ooo_new_url, $quiet);
            # switch working copies
            if ( $so_setup ) {
                print_message("... switching '$so_path' to URL '$so_new_url'");
                svn_switch($so_path, $so_new_url, $quiet);
            }

            if ( $so_setup ) {
                relink_workspace("$workspace/$masterws/$linkdir", 0);
            }
        }
        else {
            if (!defined($ooo_svn_server)) {
                print_error("No OpenOffice.org SVN server defined, please check your configuration file.", 8);
            }

            my $ooo_url = $ooo_svn_server . $url_suffix;
            if ( -e $workspace ) {
                print_error("File or directory '$workspace' already exists.", 8);
            }

            if ( !(($scm eq 'SVN') || ($scm eq 'HG')) ) {
                print_error("Unsupported SCM '$scm'.", 8);
            }

            my $clone_milestone_only = $milestone_opt ? $milestone : 0;
            if ( defined($so_svn_server) ) {
                if ( !mkdir($workspace) ) {
                    print_error("Can't create directory '$workspace': $!.", 8);
                }
                my $work_master = "$workspace/$masterws";
                if ( !mkdir($work_master) ) {
                    print_error("Can't create directory '$work_master': $!.", 8);
                }
                if ( $scm eq 'SVN' ) {
                    print_message("... checkout '$ooo_url' to '$work_master/ooo'");
                    svn_checkout($ooo_url, "$work_master/ooo", $quiet);
                    my $so_url = $so_svn_server . $url_suffix;
                    print_message("... checkout '$so_url' to '$work_master/sun'");
                    svn_checkout($so_url, "$work_master/sun", $quiet);
                }
                else{
                    hg_clone_repository('ooo', $cws, "$work_master/ooo", $clone_milestone_only);
                    hg_clone_repository('so', $cws, "$work_master/sun", $clone_milestone_only);
                }
                my $linkdir = "$work_master/src.$milestone";
                if ( !mkdir($linkdir) ) {
                    print_error("Can't create directory '$linkdir': $!.", 8);
                }
                relink_workspace($linkdir);
            }
            else {
                if ( $scm eq 'SVN' ) {
                    print_message("... checkout '$ooo_url' to '$workspace'");
                    svn_checkout($ooo_url, $workspace, $quiet);
                }
                else {
                    hg_clone_repository('ooo', $cws, $workspace, $clone_milestone_only);
                }
            }
        }
    }

    if ( defined($platforms) ) {
        if ( !-d $workspace ) {
            if ( !mkdir($workspace) ) {
                print_error("Can't create directory '$workspace': $!.", 8);
            }
        }
        my $solver = defined($so_svn_server) ? "$workspace/$masterws" : "$workspace/solver";
        if ( !-d $solver ) {
            if ( !mkdir($solver) ) {
                print_error("Can't create directory '$solver': $!.", 8);
            }
        }
        foreach(@platforms) {
            my $time_solver_start = Benchmark->new();
            print_message("... copying platform solver '$_'.");
            update_solver($_, $prebuild_dir, $solver, $milestone);
            my $time_solver_stop = Benchmark->new();
            print_time_elapsed($time_solver_start, $time_solver_stop);
        }
    }
    my $time_fetch_stop = Benchmark->new();
    my $time_fetch = timediff($time_fetch_stop, $time_fetch_start);
    print_message("cws fetch: total time required " . timestr($time_fetch));
}

sub do_query
{
    my $args_ref    = shift;
    my $options_ref = shift;

    # list of available query modes
    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);
    my %query_modes_hash = ();
    foreach (@query_modes) {
        $query_modes_hash{$_}++;
    }

    if ( exists $options_ref->{'help'} || @{$args_ref} != 1) {
        do_help(['query']);
    }
    my $mode = lc($args_ref->[0]);

    # cwquery mode 'state' has been renamed to 'status' to be more consistent
    # with CVS etc. 'state' is still an alias for 'status'
    $mode = 'status' if $mode eq 'state';

    # cwquery mode 'vcs' has been renamed to 'scm' to be more consistent
    # with general use etc. 'vcs' is still an alias for 'scm'
    $mode = 'scm' if $mode eq 'vcs';

    # there will be more query modes over time
    if ( !exists $query_modes_hash{$mode} ) {
        do_help(['query']);
    }
    query_cws($mode, $options_ref);
}

sub do_task
{
    my $args_ref    = shift;
    my $options_ref = shift;

    if ( exists $options_ref->{'help'} ) {
        do_help(['task']);
    }

    # CWS states for which adding tasks are blocked.
    my @states_blocked_for_adding = (
                                        "integrated",
                                        "nominated",
                                        "approved by QA",
                                        "cancelled",
                                        "finished"
                                    );
    my $cws = get_cws_from_environment();

    # register taskids with EIS database;
    # checks taksids for sanity, will notify user
    # if taskid is already registered.
    my $status = $cws->get_approval();

    my $child = $cws->child();
    my $master = $cws->master();

    my @registered_taskids = $cws->taskids();

    # if called without ids to register just query for tasks
    if ( @{$args_ref} == 0 ) {
        print_message("Task ID(s):");
        foreach (@registered_taskids) {
            if ( defined($_) ) {
                print "$_\n";
            }
        }
    }

    if ( !defined($status) ) {
        print_error("Can't determine status of child workspace `$child`.", 20);
    }

    if ( grep($status eq $_, @states_blocked_for_adding) ) {
        print_error("Can't add tasks to child workspace '$child' with state '$status'.", 21);
    }

    # Create hash for easier searching.
    my %registered_taskids_hash = ();
    for (@registered_taskids) {
        $registered_taskids_hash{$_}++;
    }

    my @new_taskids = ();
    foreach (@{$args_ref}) {
        if ( $_ !~ /^([ib]?\d+)$/ ) {
            print_error("'$_' is an invalid task ID.", 22);
        }
        if ( exists $registered_taskids_hash{$1} ) {
            print_warning("Task ID '$_' already registered, skipping.");
            next;
        }
        push(@new_taskids, $_);
    }

    # TODO: introduce a EIS_USER in the configuration, which should be used here
    my $config = CwsConfig->new();
    my $vcsid  = $config->vcsid();
    my $added_taskids_ref = $cws->add_taskids($vcsid, @new_taskids);
    if ( !$added_taskids_ref )  {
        my $taskids_str = join(" ", @new_taskids);
        print_error("Couldn't register taskID(s) '$taskids_str' with child workspace '$child'.", 23);
    }
    my @added_taskids = @{$added_taskids_ref};
    if ( @added_taskids ) {
        my $taskids_str = join(" ", @added_taskids);
        print_message("Registered taskID(s) '$taskids_str' with child workspace '$child'.");
    }
    return;
}

sub do_cdiff
{
    my $args_ref    = shift;
    my $options_ref = shift;

    if ( exists $options_ref->{'help'} || @{$args_ref} != 0) {
        do_help(['cdiff']);
    }

    my $files   = exists $options_ref->{'files'}   ? 1 : 0;
    my $modules = exists $options_ref->{'modules'} ? 1 : 0;

    if ( $files && $modules ) {
        print_error("Options --files and --modules are mutally exclusive", 0);
        do_help(['cdiff']);
    }

    my $diff_option;
    if ( $files ) {
        $diff_option = 'files';
    }
    elsif ( $modules ) {
        $diff_option = 'modules';
    }
    else {
        $diff_option = 0;
    }


    my $masterws  = exists $options_ref->{'masterworkspace'} ? uc($options_ref->{'masterworkspace'}) : $ENV{WORK_STAMP};
    my $childws   = exists $options_ref->{'childworkspace'} ? $options_ref->{'childworkspace'} : $ENV{CWS_WORK_STAMP};

    if ( !defined($masterws) ) {
        print_error("Can't determine master workspace environment.\n", 30);
    }

    if ( !defined($childws) ) {
        print_error("Can't determine child workspace environment.\n", 30);
    }

    my $cws = Cws->new();
    $cws->child($childws);
    $cws->master($masterws);

    if ( !is_valid_cws($cws) ) {
        print_error("'$childws' is not a valid CWS name.\n", 30);
    }

    my $milestone = $cws->milestone();

    my $config = CwsConfig->new();
    my $ooo_svn_server = $config->get_ooo_svn_server();
    my $so_svn_server = $config->get_so_svn_server();

    my $ooo_milestone_url = get_milestone_url($ooo_svn_server, $masterws, $milestone);
    my $ooo_cws_url = get_cws_url($ooo_svn_server, $childws);
    my $ooo_files;
    if ( $diff_option  ) {
        $ooo_files = svn_diff($ooo_milestone_url, $ooo_cws_url, $diff_option);
        diff_print_files($ooo_files, $diff_option);
    }
    else {
        svn_diff($ooo_milestone_url, $ooo_cws_url, 0);
    }

    my $so_files;
    if ( $so_svn_server ) {
        my $so_milestone_url = get_milestone_url($so_svn_server, $masterws, $milestone);
        my $so_cws_url = get_cws_url($so_svn_server, $childws);
        if  ( svn_path_exists($so_cws_url) ) {
            if ( $diff_option ) {
                $so_files = svn_diff($so_milestone_url, $so_cws_url, $diff_option);
                diff_print_files($so_files, $diff_option);
            }
            else {
                svn_diff($so_milestone_url, $so_cws_url, 0);
            }
        }
    }

}

sub do_setcurrent
{
    my $args_ref    = shift;
    my $options_ref = shift;

    if ( exists $options_ref->{'help'} || @{$args_ref} != 0) {
        do_help(['setcurrent']);
    }

    if ( !exists $options_ref->{'milestone'} ) {
        do_help(['setcurrent']);
    }

    my $cws = get_cws_from_environment();
    my $old_masterws = $cws->master();
    my $new_masterws;
    my $new_milestone;

    my $milestone = $options_ref->{'milestone'};
    if ( $milestone eq 'latest' ) {
        my $latest = $cws->get_current_milestone($old_masterws);

        if ( !$latest ) {
            print_error("Can't determine latest milestone of '$old_masterws'.", 22);
        }
        $new_masterws  = $old_masterws;
        $new_milestone = $latest;
    }
    else {
        ($new_masterws, $new_milestone) =  verify_milestone($cws, $milestone);
    }

    print_message("... updating EIS database");
    my $push_return = $cws->set_master_and_milestone($new_masterws, $new_milestone);
    # sanity check
    if ( $$push_return[1] ne $new_milestone) {
        print_error("Couldn't push new milestone '$new_milestone' to database", 0);
    }
}

sub do_eisclone
{
    my $args_ref    = shift;
    my $options_ref = shift;

    print_error("not yet implemented.", 2);
}

sub print_message
{
    my $message     = shift;

    print "$message\n";
    return;
}

sub print_warning
{
    my $message     = shift;
    print STDERR "$script_name: ";
    print STDERR "WARNING: $message\n";
    return;
}

sub print_error
{
    my $message     = shift;
    my $error_code  = shift;

    print STDERR "$script_name: ";
    print STDERR "ERROR: $message\n";

    if ( $error_code ) {
        print STDERR "\nFAILURE: $script_name aborted.\n";
        exit($error_code);
    }
    return;
}

sub usage
{
        print STDERR "Type 'cws help' for usage.\n";
}

### SVN glue ###

# TODO: is it a better idea to use the SVN bindings?
# pro:
#       - SVN make guarantees about API stability but no about the command line
#       - finer access to the SVN functionality, better error reporting
#       - prevents parsing errors due to localized SVN messages
# con:
#       - the bindings are difficult to install, mostly due to subtle install bugs
#       - we do not really use much of the SVN functionality here

sub svn_wc_is_clean
{
    my $wc_path = shift;

    my $result = execute_svnversion_command($wc_path);

    my $error = 0;

    if ( $result =~ /:/ ) {
        print_error("Working copy '$wc_path' contains mixed revisions. Please run 'svn update'!", 0);
        $error++;
    }
    if ( $result =~ /M/ ) {
        print_error("Working copy '$wc_path' contains locally modified files. Please commit or revert all modified files.", 0);
        $error++;
    }
    if ( $result =~ /S/ ) {
        print_error("Working copy '$wc_path' is partially switched. The whole working copy needs to be switched to the CWS branch.", 0);
        $error++;
    }
    if ( $result =~ /P/ ) {
        print_error("Working copy '$wc_path' is only partially checked out. CWS tools can't work on partially checked out working copies.", 0);
        $error++;
    }

    return !$error;
}

sub svn_version_check
{
    my $major_required = 1;
    my $minor_required = 5;
    my $patchlevel_required = 4;

    my $version_required = $major_required*1000000 + $minor_required*1000 + $patchlevel_required;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... svn version\n";
    }

    my @result = execute_svn_command(0, '--version --quiet', " ");
    # svn --version --quiet returns the version in major.minor.patchlevel scheme
    # for example: 1.5.4 or 1.6.0-dev (for developer codelines)
    # hopefully they don't change the versioning scheme
    my ($major, $minor, $patchlevel);
    if ( $result[0] =~ /^(\d+)\.(\d+)\.(\d+)/ ) {
        $major       = $1;
        $minor       = $2;
        $patchlevel  = $3;
    }
    else {
        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)
    }

    my $version =  $major*1000000 + $minor*1000 + $patchlevel;

    if ( $version < $version_required ) {
        return 0;
    }
    return 1;
}

sub svn_copy
{
    my $comment = shift;
    my $source = shift;
    my $dest = shift;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing branch: '$source' -> '$dest'\n";
    }

    my @result = execute_svn_command(0, 'copy', "-m '$comment'", $source, $dest);
    if ( $result[1] =~ /Committed revision (\d+)\./ ) {
        print STDERR ", committed revision $1\n";
    } else {
        print STDERR "failed!\n";
        print STDERR @result;
    }
}

sub svn_milestone_revision
{
    my $milestone_url = shift;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing log --stop-on-copy: '$milestone_url'\n";
    }

    my @result = execute_svn_command(0, 'log', '--stop-on-copy', $milestone_url);

    # There might be revisions committed to a tag (allowed in subversion).
    # The lowestmost revision listed in a 'log --stop-on-copy' is the one which
    # was current when the tag was created
    my $revision = 0;
    foreach ( @result ) {
        if ( /^r(\d+)\s+\|\s+/ ) {
            $revision = $1;
        }
    }

    return $revision;
}

sub svn_path_exists
{
    my $url = shift;

    my @result = svn_info($url);

    foreach ( @result ) {
        if ( /^Path: / ) {
            return 1;
        }
    }
    return 0;
}

sub svn_wc_url
{
    my $wc_path = shift;

    my @result = svn_info($wc_path);

    foreach ( @result ) {
        if ( /^URL: (.+)$/ ) {
            return $1;
        }
    }

    print_error("Can't retrieve svn info from working copy '$wc_path'\n", 23);
}

sub svn_wc_root
{
    my $wc_path = shift;

    my @result = svn_info($wc_path);

    foreach ( @result ) {
        if ( /^Repository Root: (.+)$/ ) {
            return $1;
        }
    }

    print_error("Can't retrieve svn info from working copy '$wc_path'\n", 23);
}

sub svn_info
{
    my $url = shift;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing info: '$url'\n";
    }

    my @result = execute_svn_command(0, 'info', '--depth empty', $url);
    return @result;
}

sub svn_merge
{
    my $url = shift;
    my $wc  = shift;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing merge: '$url -> $wc'\n";
    }

    my $log_file = "$wc/REBASE.LOG";
    my @result = execute_svn_command($log_file, 'merge', '--accept postpone', $url, $wc);
    return @result;
}

sub svn_switch
{
    my $wc  = shift;
    my $url = shift;
    my $quiet = shift;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing switch: '$url -> $wc'\n";
    }

    my $switch = $quiet ? 'switch --quiet' : 'switch';

    my @result = execute_svn_command('print', $switch, $url, $wc);
    return @result;
}

sub svn_checkout
{
    my $url   = shift;
    my $wc    = shift;
    my $quiet = shift;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing checkout: '$url -> $wc'\n";
    }

    my $checkout = $quiet ? 'checkout --quiet' : 'checkout';

    my @result = execute_svn_command('print', $checkout, $url, $wc);
    return @result;
}

sub svn_commit
{
    my $wc             = shift;
    my $commit_message = shift;

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing commit: '$wc'\n";
    }

    my $log_file = "$wc/REBASE.LOG";
    my @result = execute_svn_command($log_file, 'commit', "-m '$commit_message'", $wc);
    return @result;
}

sub svn_diff
{
    my $url1 = shift;
    my $url2 = shift;
    my $diff_option = shift;

    my $summarize = '';
    if ( $diff_option ) {
        $summarize = '--summarize';
    }

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... preparing diff $summarize: '$url1' vs. '$url2'\n";
    }

    if ( $summarize ) {
        my $result = execute_svn_command(0, 'diff', $summarize, $url1, $url2);
        my $nlen = length($url1);
        my @files;
        foreach( @{$result} ) {
            my ($dummy, $url) = split();
            next if length($url) <= $nlen;   # skip short URLs (like $url1)
            my $file = substr($url, $nlen+1);
            next if index($file, '/') == -1; # skip 'modified' top level dirs
            push (@files, $file);
        }
        return \@files;
    }
    else {
        execute_svn_command('print', 'diff', $url1, $url2);
    }
}

sub execute_svn_command
{
    my $log     = shift;
    my $command = shift;
    my $options = shift;
    my @args    = @_;

    my $args_str = join(" ", @args);

    # we can only parse english strings, hopefully a C locale is available everywhere
    $ENV{LC_ALL}='C';
    $command = "svn $command $options $args_str";

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... execute command line: '$command'\n";
    }

    my @result;
    my $date;
    if ( $log && $log ne 'print') {
        open(LOG, ">>$log") or print_error("can't open log file '$log'", 30);
        $date = localtime();
        print LOG "Start $command $args_str at $date\n";
    }
    open(OUTPUT, "$command 2>&1 |") or print_error("Can't execute svn command line client", 98);
    STDOUT->autoflush(1) if $log;
    while (<OUTPUT>) {
        if ( $log ) {
            print STDOUT $_;
            print LOG $_ if $log ne 'print';
        }
        else {
            push(@result, $_);
        }
    }
    STDOUT->autoflush(0) if $log;
    close(OUTPUT);
    if ( $log && $log ne 'print') {
        $date = localtime();
        print LOG "Stop $command $args_str at $date\n";
        close (LOG);
    }

    my $rc = $? >> 8;

    if ( $rc > 0) {
        print STDERR "\n";
        print STDERR @result if !$log;
        print_error("The subversion command line client failed with exit status '$rc'", 99);
    }
    return wantarray ? @result : \@result;
}

sub execute_svnversion_command
{
    my $options = shift;
    my @args    = @_;

    my $args_str = join(" ", @args);

    # we can only parse english strings, hopefully a C locale is available everywhere
    $ENV{LC_ALL}='C';
    $command = "svnversion $options $args_str";

    if ( $debug ) {
        print STDERR "\nCWS-DEBUG: ... execute command line: '$command'\n";
    }

    my $result = `$command`;
    my $rc = $? >> 8;
    if ($rc > 0) {
        print_error("The subversion command line tool 'svnversion' failed with exit status '$rc'", 99);
    }

    return $result;
}

### HG glue ###

sub hg_clone
{
    my $source  = shift;
    my $dest    = shift;
    my $options = shift;

    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... hg clone: '$source -> $dest', options: '$options'\n";
    }

    # The to be cloned revision might not yet be avaliable. In this case clone
    # the available tip.
    my @result = execute_hg_command(0, 'clone', $options, $source, $dest);
    if ( defined($result[0]) && $result[0] =~ /abort: unknown revision/ ) {
        $options =~ s/-r \w+//;
        @result = execute_hg_command(1, 'clone', $options, $source, $dest);
    }
    return @result;
}

sub hg_ident
{
    my $repository  = shift;
    my $rev_id = shift;

    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... hg ident: 'repository', revision: '$rev_id'\n";
    }

    my @result = execute_hg_command(0, 'ident', "--cwd $repository", "-n -r $rev_id");
    my $line = $result[0];
    if ($line =~ /abort: unknown revision/) {
        return undef;
    }
    else {
        chomp($line);
        return $line;
    }
}

sub hg_strip
{
    my $repository  = shift;
    my $rev_id = shift;

    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... hg strip: 'repository', revision: '$rev_id'\n";
    }

    my @result = execute_hg_command(1, 'strip', "--cwd $repository", '-n', $rev_id);
    my $line = $result[0];
    if ($line =~ /abort: unknown revision/) {
        return undef;
    }
    else {
        chomp($line);
        return $line;
    }
}

sub hg_pull
{
    my $repository  = shift;
    my $remote = shift;

    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... hg pull: 'repository', remote: '$remote'\n";
    }

    my @result = execute_hg_command(0, 'pull', "--cwd $repository", $remote);
    my $line = $result[0];
    if ($line =~ /abort: /) {
        return undef;
    }
}

sub hg_update
{
    my $repository  = shift;

    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... hg update: 'repository'\n";
    }

    my @result = execute_hg_command(1, 'update', "--cwd $repository");
    return @result;
}

sub hg_show
{
    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... hg show\n";
    }
    my $result = execute_hg_command(0, 'show', '');
    return $result;
}

sub execute_hg_command
{
    my $terminate_on_rc = shift;
    my $command = shift;
    my $options = shift;
    my @args = @_;

    my $args_str = join(" ", @args);

    # we can only parse english strings, hopefully a C locale is available everywhere
    $ENV{LC_ALL}='C';
    $command = "hg $command $options $args_str";

    if ( $debug ) {
        print STDERR "CWS-DEBUG: ... execute command line: '$command'\n";
    }

    my @result;
    open(OUTPUT, "$command 2>&1 |") or print_error("Can't execute mercurial command line client", 98);
    while (<OUTPUT>) {
        push(@result, $_);
    }
    close(OUTPUT);

    my $rc = $? >> 8;

    if ( $rc > 0 && $terminate_on_rc) {
        print STDERR @result;
        print_error("The mercurial command line client failed with exit status '$rc'", 99);
    }
    return wantarray ? @result : \@result;
}


# vim: set ts=4 shiftwidth=4 expandtab syntax=perl: