diff options
Diffstat (limited to 'solenv/bin/cws.pl')
| -rw-r--r-- | solenv/bin/cws.pl | 2068 |
1 files changed, 2068 insertions, 0 deletions
diff --git a/solenv/bin/cws.pl b/solenv/bin/cws.pl new file mode 100644 index 000000000000..439ce02e2742 --- /dev/null +++ b/solenv/bin/cws.pl @@ -0,0 +1,2068 @@ +#!/usr/bin/perl -w +#************************************************************************* +# +# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. +# +# Copyright 2000, 2010 Oracle and/or its affiliates. +# +# OpenOffice.org - a multi-platform office productivity suite +# +# 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 File::Copy; +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 source_config migration milestone +my $ooo320_source_config_milestone = 'm999'; + +# valid command with possible abbreviations +my @valid_commands = ( + 'help', 'h', '?', + 'create', + 'fetch', 'f', + 'query', 'q', + 'task', 't', + 'eisclone', + 'setcurrent' + ); + +# list the valid options to each command +my %valid_options_hash = ( + 'help' => ['help'], + 'create' => ['help', 'milestone', 'migration', 'hg'], + 'fetch' => ['help', 'milestone', 'childworkspace','platforms','quiet', + 'onlysolver'], + 'query' => ['help', 'milestone','masterworkspace','childworkspace'], + 'task' => ['help'], + 'setcurrent' => ['help', 'milestone'], + 'eisclone' => ['help'] + ); + +my %valid_commands_hash; +for (@valid_commands) { + $valid_commands_hash{$_}++; +} + +# set by --debug switch +my $debug = 0; +# set by --profile switch +my $profile = 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', + 'profile', + 'commit|C', + 'platforms|p=s', + 'onlysolver|o', + 'quiet|q', + '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 'q') { + $command = 'query'; + } + elsif ($command eq 't') { + $command = 'task'; + } + + # 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 ( /profile/ ) { + $profile = 1; + next; + } + if (!exists $valid_command_options_hash{$_}) { + print_error("can't use option '--$_' with subcommand '$command'.", 1); + } + } + +} + +# 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 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 hg_clone_cws_or_milestone +{ + 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"; + } + } + + my $pull_from_remote = 0; + my $cws_remote_source; + if ( !$clone_milestone_only ) { + $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 availibility + # 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 + print_message("... check availibility of 'outgoing' repository '$cws_remote_source'."); + require LWP::Simple; + my $content = LWP::Simple::get($cws_remote_source); + my $pattern = "<title>cws/". $cws->child(); + if ( $content =~ /$pattern/ ) { + $pull_from_remote = 1; + } + else { + print_message("... 'outgoing' repository '$cws_remote_source' is not accessible/available yet."); + } + } + + # clone repository (without working tree if we still need to pull from remote) + my $clone_with_update = !$pull_from_remote; + hg_clone_repository($master_local_source, $master_lan_source, $target, $milestone_tag, $clone_with_update); + + # now pull from the remote cws outgoing repository if its already available + if ( $pull_from_remote ) { + hg_remote_pull_repository($cws_remote_source, $target); + } + + # if we fetched a CWS adorn the result with push-path and hooks + if ( $cws_remote_source ) { + hgrc_append_push_path_and_hooks($target, $cws_remote_source); + } + + # update the result if necessary + if ( !$clone_with_update ) { + hg_update_repository($target); + } + +} + +sub hg_clone_repository +{ + my $local_source = shift; + my $lan_source = shift; + my $dest = shift; + my $milestone_tag = shift; + my $update = shift; + + my $t1 = Benchmark->new(); + my $source; + my $clone_option = $update ? '' : '-U '; + if ( -d $local_source && can_use_hardlinks($local_source, $dest) ) { + $source = $local_source; + if ( !hg_milestone_is_latest_in_repository($local_source, $milestone_tag) ) { + $clone_option .= "-r $milestone_tag"; + } + print_message("... clone LOCAL repository '$local_source' to '$dest'"); + } + else { + $source = $lan_source; + $clone_option .= "-r $milestone_tag"; + print_message("... clone LAN repository '$lan_source' to '$dest'"); + } + hg_clone($source, $dest, $clone_option); + + my $t2 = Benchmark->new(); + print_time_elapsed($t1, $t2) if $profile; +} + +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) if $profile; +} + +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) if $profile; +} + +sub hg_milestone_is_latest_in_repository +{ + my $repository = shift; + my $milestone_tag = shift; + + # Our milestone is the lastest thing in the repository + # if the parent of the repository tip is adorned + # with the milestone tag. + my $tags_of_parent_of_tip = hg_parent($repository, 'tip', "--template='{tags}\\n'"); + if ( $tags_of_parent_of_tip =~ /\b$milestone_tag\b/ ) { + return 1; + } + return 0; +} + +# 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(dirname($dest)); + + if ( $debug ) { + my $source_result = defined($stat_source[0]) ? $stat_source[0] : 'stat failed'; + my $dest_result = defined($stat_dest[0]) ? $stat_dest[0] : 'stat failed'; + print STDERR "CWS-DEBUG: can_use_hardlinks(): source device: '$stat_source[0]', destination device: '$stat_dest[0]'\n"; + } + if ( defined($stat_source[0]) && defined($stat_dest[0]) && $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 update:"); + print "$masterws $latest\n"; + } + else { + print_error("Can't determine latest milestone of '$masterws' available for update.", 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 fetch_external_tarballs +{ + my $source_root_dir = shift; + my $external_tarballs_source = shift; + + my $ooo_external_file = "$source_root_dir/ooo/ooo.lst"; + my $sun_external_file = "$source_root_dir/sun/sun.lst"; + my $sun_path = "$source_root_dir/sun"; + + my @external_sources_list; + push(@external_sources_list, read_external_file($ooo_external_file)); + if ( -d $sun_path ) { + if ( -e $sun_external_file ) { + push(@external_sources_list, read_external_file($sun_external_file)); + } + else { + print_error("Can't find external file list '$sun_external_file'.", 8); + } + } + + my $ext_sources_dir = "$source_root_dir/ext_sources"; + print_message("Copy external tarballs to '$ext_sources_dir'"); + if ( ! -d $ext_sources_dir) { + if ( !mkdir($ext_sources_dir) ) { + print_error("Can't create directory '$ext_sources_dir': $!.", 44); + } + } + foreach (@external_sources_list) { + if ( ! copy("$external_tarballs_source/$_", $ext_sources_dir) ) { + print_error("Can't copy file '$external_tarballs_source' -> '$ext_sources_dir': $!", 0); + } + } + return; +} + +sub read_external_file +{ + my $external_file = shift; + + my @external_sources; + open(EXT, "<$external_file") or print_error("Can't open file '$external_file' for reading: $!", 98); + while(<EXT>) { + if ( !/^http:/ ) { + chomp; + push(@external_sources, $_); + } + } + close(EXT); + return @external_sources; +} + +sub update_solver +{ + my $platform = shift; + my $source = shift; + my $solver = shift; + my $milestone = shift; + my $source_config = 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) { + my $extract_destination = $source_config ? "$platform_solver/$_" : "$platform_solver/$_.$milestone"; + unless ( $zip->extractTree($_, $extract_destination) == AZ_OK ) { + print_error("Can't extract stream from zip file '$platform_source/$_': $!.", 44); + } + } + } +} + +# TODO: special provisions for "source_config" migration, remove this +# some time after migration +sub get_source_config_for_milestone +{ + my $masterws = shift; + my $milestone = shift; + + my $milestone_sequence_number = extract_milestone_sequence_number($milestone); + my $ooo320_migration_sequence_number = extract_milestone_sequence_number($ooo320_source_config_milestone); + + my $source_config = 1; + if ( $masterws eq 'OOO320' ) { + if ( $milestone_sequence_number < $ooo320_migration_sequence_number ) { + $source_config = 0; + } + } + return $source_config; +} + +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 "\tquery (q)\n"; + print STDERR "\ttask (t)\n"; + print STDERR "\tsetcurrent\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 [-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"; + } + 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 "fetch: fetch a milestone or CWS\n"; + print STDERR "usage: fetch [-q] [-p platforms] [-o] <-m milestone> <workspace>\n"; + print STDERR "usage: fetch [-q] [-p platforms] [-o] <-c cws> <workspace>\n"; + print STDERR "usage: fetch [-q] <-m milestone> <workspace>\n"; + print STDERR "usage: fetch [-q] <-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-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 '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']); + } + + if ( exists $options_ref->{'hg'} ) { + print_warning("All childworkspaces are now hosted on Mercurial. The switch --hg is obsolete."); + } + + 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 { + 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); + + register_child_workspace($cws, 'hg', $is_promotion); + + return; +} + +# 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 ( $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; + 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); + } + } + elsif ( defined($child) ) { + $cws = get_cws_by_name($child); + $masterws = $cws->master(); # CWS can have another master than specified in ENV + $milestone = $cws->milestone(); + } + else { + do_help(['fetch']); + } + + my $config = CwsConfig->new(); + # $so_svn_server is still required to determine if we are in SO environment + # TODO: change this configuration setting to something more meaningful + my $so_svn_server = $config->get_so_svn_server(); + my $prebuild_dir = $config->get_prebuild_binaries_location(); + my $external_tarball_source = $prebuild_dir; + # Check early for platforms so we can bail out before anything time consuming is done + # in case of a missing platform + my @platforms; + if ( defined($platforms) ) { + use Archive::Zip; # warn early if module is missing + if ( !defined($prebuild_dir ) ) { + print_error("PREBUILD_BINARIES not configured, can't find platform solvers", 99); + } + $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; + } + } + unshift(@platforms, 'common.pro') if ($product && !$added_product); + unshift(@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 ) { + if ( -e $workspace ) { + print_error("File or directory '$workspace' already exists.", 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); + } + hg_clone_cws_or_milestone('ooo', $cws, "$work_master/ooo", $clone_milestone_only); + hg_clone_cws_or_milestone('so', $cws, "$work_master/sun", $clone_milestone_only); + if ( get_source_config_for_milestone($masterws, $milestone) ) { + # write source_config file + my $source_config_file = "$work_master/source_config"; + if ( !open(SOURCE_CONFIG, ">$source_config_file") ) { + print_error("Can't create source_config file '$source_config_file': $!.", 8); + } + print SOURCE_CONFIG "[repositories]\n"; + print SOURCE_CONFIG "ooo=active\n"; + print SOURCE_CONFIG "sun=active\n"; + close(SOURCE_CONFIG); + } + else { + my $linkdir = "$work_master/src.$milestone"; + if ( !mkdir($linkdir) ) { + print_error("Can't create directory '$linkdir': $!.", 8); + } + relink_workspace($linkdir); + } + } + else { + hg_clone_cws_or_milestone('ooo', $cws, $workspace, $clone_milestone_only); + } + } + + if ( !$onlysolver && defined($external_tarball_source) ) { + my $source_root_dir = "$workspace/$masterws"; + $external_tarball_source .= "/$masterws/ext_sources"; + if ( -e "$source_root_dir/ooo/ooo.lst" && -d $external_tarball_source ) { + fetch_external_tarballs($source_root_dir, $external_tarball_source); + } + } + + 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); + } + } + my $source_config = get_source_config_for_milestone($masterws, $milestone); + foreach(@platforms) { + my $time_solver_start = Benchmark->new(); + print_message("... copying platform solver '$_'."); + update_solver($_, $prebuild_dir, $solver, $milestone, $source_config); + my $time_solver_stop = Benchmark->new(); + print_time_elapsed($time_solver_start, $time_solver_stop) if $profile; + } + } + 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_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"; +} + +### 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_parent +{ + my $repository = shift; + my $rev_id = shift; + my $options = shift; + + if ( $debug ) { + print STDERR "CWS-DEBUG: ... hg parent: 'repository', revision: '$rev_id', options: $options\n"; + } + + my @result = execute_hg_command(0, 'parent', "--cwd $repository", "-r $rev_id", $options); + my $line = $result[0]; + 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: |