diff options
author | Jens-Heiner Rechtien <hr@openoffice.org> | 2004-06-25 23:23:20 +0000 |
---|---|---|
committer | Jens-Heiner Rechtien <hr@openoffice.org> | 2004-06-25 23:23:20 +0000 |
commit | 543c4ee80452861860f878c879f323625f619c4b (patch) | |
tree | 559803f90c0e8e137c7a9a7f48adc3ebec3b6154 /solenv | |
parent | 7e986df33236da2db7df78a9f4766aa265b67fa5 (diff) |
#i30244#: adaption to OOo environment
Diffstat (limited to 'solenv')
-rwxr-xr-x | solenv/bin/cwsadd | 6 | ||||
-rwxr-xr-x | solenv/bin/cwsadd.pl | 653 | ||||
-rwxr-xr-x | solenv/bin/cwsaddtask | 6 | ||||
-rwxr-xr-x | solenv/bin/cwsaddtask.pl | 254 | ||||
-rwxr-xr-x | solenv/bin/cwsanalyze | 6 | ||||
-rwxr-xr-x | solenv/bin/cwsanalyze.pl | 965 | ||||
-rwxr-xr-x | solenv/bin/cwscreate | 6 | ||||
-rwxr-xr-x | solenv/bin/cwscreate.pl | 659 | ||||
-rwxr-xr-x | solenv/bin/cwsquery | 6 | ||||
-rw-r--r-- | solenv/bin/cwsquery.pl | 281 | ||||
-rwxr-xr-x | solenv/bin/cwsresync | 6 | ||||
-rwxr-xr-x | solenv/bin/cwsresync.pl | 1754 | ||||
-rw-r--r-- | solenv/bin/modules/Cvs.pm | 13 | ||||
-rwxr-xr-x | solenv/bin/modules/CvsModule.pm | 857 | ||||
-rwxr-xr-x | solenv/bin/modules/Cws.pm | 1170 | ||||
-rw-r--r-- | solenv/bin/modules/CwsConfig.pm | 396 | ||||
-rwxr-xr-x | solenv/bin/modules/Eis.pm | 224 |
17 files changed, 7257 insertions, 5 deletions
diff --git a/solenv/bin/cwsadd b/solenv/bin/cwsadd new file mode 100755 index 000000000000..b08d224b5e70 --- /dev/null +++ b/solenv/bin/cwsadd @@ -0,0 +1,6 @@ +#!/bin/sh +if [ x${SOLARENV}x = xx ]; then + echo No environment found, please use 'configure' or 'setsolar' + exit 1 +fi +exec perl -w $SOLARENV/cwsadd.pl "$@" diff --git a/solenv/bin/cwsadd.pl b/solenv/bin/cwsadd.pl new file mode 100755 index 000000000000..cac727432d1f --- /dev/null +++ b/solenv/bin/cwsadd.pl @@ -0,0 +1,653 @@ +: +eval 'exec perl -wS $0 ${1+"$@"}' + if 0; +#************************************************************************* +# +# $RCSfile: cwsadd.pl,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:23:18 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + +# +# cwsadd.pl - add modules to child workspaces +# + +use strict; +use Getopt::Long; +use Cwd; +use IO::Handle; + +#### module lookup + +use lib ("$ENV{SOLARENV}/bin/modules"); +if (defined $ENV{COMMON_ENV_TOOLS}) { + unshift(@INC, "$ENV{COMMON_ENV_TOOLS}/modules"); +}; + +use Cws; +use CwsConfig; + +eval { require Logging; import Logging; }; +# $log variable is only defined in SO environment... +my $log = undef; +$log = Logging->new() if (!$@); +eval { require CopyPrj; import CopyPrj; }; +use CvsModule; +use Config::Tiny; + +######### Interrupt handler ######### + $SIG{'INT'} = 'INT_handler' if defined($log); + +#### script id ##### + +( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; + +my $script_rev; +my $id_str = ' $Revision: 1.2 $ '; +$id_str =~ /Revision:\s+(\S+)\s+\$/ + ? ($script_rev = $1) : ($script_rev = "-"); + +print "$script_name -- version: $script_rev\n"; + +#### global ##### + +my $force_checkout = ''; +my $is_debug = 0; +my $opt_dir = ''; # dir option +my $vcsid = "unkown"; +my $add_output_tree = 1; +my @found_platforms = (); + +my @args_bak = @ARGV; + # store the @ARGS here for logging + +# module names to be rejected +my @invalid_names = +qw(common common.pro cvs cws wntmsci unxsols unxsoli unxlngi unxlngp macosxp); + + +#### main ##### +my $parameter_list = $log->array2string(";",@args_bak) if (defined $log); + +my @modules = parse_options(); +my ($dir, $cws) = get_and_verify_cws(); +my @modules_to_add = check_modules($cws, @modules); +my $workspace_db; +if ( @modules_to_add ) { + if (defined $log) { + require EnvHelper; import EnvHelper; + $workspace_db = EnvHelper::get_workspace_db(); + @modules_to_add = copy_modules($cws, $dir, $workspace_db, @modules_to_add); + } else { + @modules_to_add = update_modules($cws, $dir, @modules_to_add); + }; + if ( @modules_to_add ) { + my @registered_modules = (); + my $success = 0; + my $module; + foreach (@modules_to_add) { + $module = $_; + $success = branch_module($cws, $dir, $module); + last unless $success; + $success = register_module($cws, $workspace_db, $module); + last unless $success; + push(@registered_modules, $module); + } + if ( @registered_modules ) { + my $modules_str = join(", ", @registered_modules); + my $child = $cws->child(); + print "\n"; + print_message("Summary:"); + print_message("Sucessfully added and registered module(s) '$modules_str'."); + } + if ( !$success ) { + print_error("Adding and/or registering module '$module' failed!", 5); + } + } +} + +$log->end_log_extended($script_name,$vcsid,"success") if (defined $log); +exit(0); + +#### subroutines #### + +# +# Subroutine updates module +# +sub update_modules { + my ($cws, $stand_dir, @modules_to_update) = @_; + my (@updated_modules, @rejected_modules); + my $master_tag = $cws->get_master_tag(); + foreach my $module (@modules_to_add) { + my $cvs_module = CvsModule->new(); + $cvs_module->module($module); + print "\tUpdating '$module' ...\n"; + my $result = $cvs_module->update($stand_dir, $master_tag); + my ($updated, $merged, $conflicts) = + $cvs_module->handle_update_infomation($result); + if ($merged || $conflicts) { + push(@rejected_modules, $module); + next; + }; + push(@updated_modules, $module); + }; + if (@rejected_modules) { + print_warning("Found conflicts and/or locallily files in the following modules:"); + print STDERR "$_\n" foreach (@rejected_modules); + print_warning("These modules will not be added to CWS. Clean up and try adding them again."); + }; + return @updated_modules; +}; + +sub get_and_verify_cws +{ + # get current child workspace from environment + my $childws = $ENV{CWS_WORK_STAMP}; + my $masterws = $ENV{WORK_STAMP}; + + if ( !defined($childws) || !defined($masterws) ) { + print_error("Can't determine child workspace environment.\n" + . "Please initialize environment with setsolar ...", 1); + } + + # get destination directory for modules to add + my $dir = $ENV{SRC_ROOT}; + + if ( !defined($dir) ) + { + print_error("Need to get destination from SOURCE_ROOT - but it's not defined!",1); + } + + my $cws = Cws->new(); + $cws->child($childws); + $cws->master($masterws); + $log->start_log_extended($script_name,$parameter_list,$masterws,$childws) if (defined $log); + + # check if we got a valid child workspace + my $id = $cws->eis_id(); + print "Master: $masterws, Child: $childws, $id\n" if $is_debug; + if ( !$id ) { + print_error("Child workspace $childws for master workspace $masterws not found in EIS database.", 2); + } + return ($dir, $cws); +} + +sub parse_options +{ + # parse options and do some sanity checks + # returns freshly allocated Cws reference + + # linking and unlinking requires UNIX + if ( $^O =~ "MSWin32" ) + { + print_error("Sorry! not for windows",2); + } + my $help; + my $success = GetOptions('-h' => \$help, '-a' => \$force_checkout); + if ( $help || !$success || $#ARGV < 0 ) { + usage(); + exit(1); + } + + return @ARGV; +} + +sub check_modules +{ + # check if modules are registered with child workspace + # returns list of modules which can be added + + my $cws = shift; + my @modules = @_; + + my @registered_modules = $cws->modules(); + + # create hash for easier searching + my %registered_modules_hash = (); + for (@registered_modules) { + $registered_modules_hash{$_}++; + } + my %invalid_names_hash = (); + for (@invalid_names) { + $invalid_names_hash{$_}++; + } + + my $config = CwsConfig->get_config(); + my $cvs_module = CvsModule->new(); + $cvs_module->cvs_method($config->get_cvs_server_method()); + $cvs_module->vcsid($config->get_cvs_server_id()); + $cvs_module->cvs_server($config->get_cvs_server()); + $cvs_module->cvs_repository($config->get_cvs_server_repository()); + my @new_modules = (); + my %cvs_aliases = $cvs_module->get_aliases_hash(); + foreach (@modules) { + if ( $_ =~ /[\s\t\|\$\(\)\[\]\{\\}]/ || exists $invalid_names_hash{lc($_)} ) { + print_error("'$_' is an invalid module name.", 3); + } + if ( exists $registered_modules_hash{$_} ) { + print_warning("Module '$_' already registered, skipping."); + next; + }; + if (!defined($log) && !defined $cvs_aliases{$_}) { + print_error("There is no such module alias '$_'.", 3); + }; + push(@new_modules, $_); + } + + return @new_modules; +} + +sub copyprj_module_output +{ + return if ($force_checkout); + + my $module_name = shift; + my $src_dest = shift; + print "copyprj $module_name\n"; + + # hash, that should contain all the + # data needed by CopyPrj module + my %ENVHASH = (); + my %projects_to_copy = (); + $ENVHASH{'projects_hash'} = \%projects_to_copy; + $ENVHASH{'no_otree'} = 0; + $ENVHASH{'no_path'} = 1; + $ENVHASH{'only_otree'} = 1; + $ENVHASH{'only_update'} = 1; + $ENVHASH{'last_minor'} = 0; + $ENVHASH{'spec_src'} = 0; + $ENVHASH{'dest'} = "$src_dest"; + $ENVHASH{'prj_to_copy'} = ''; + $ENVHASH{'i_server'} = ''; + $ENVHASH{'current_dir'} = cwd(); + $ENVHASH{'remote'} = ''; + + $projects_to_copy{$module_name}++; + + CopyPrj::copy_projects(\%ENVHASH); + +}; + +sub copyprj_module_sourcetree +{ + my $module_name = shift; + my $src_dest = shift; + print "copyprj $module_name\n"; + + # hash, that should contain all the + # data needed by CopyPrj module + my %ENVHASH = (); + my %platforms_to_copy = (); + $ENVHASH{'platforms_hash'} = \%platforms_to_copy; + if ( $add_output_tree && !$force_checkout ) { + $platforms_to_copy{$_}++ foreach (@found_platforms); + }; + my %projects_to_copy = (); + $ENVHASH{'projects_hash'} = \%projects_to_copy; + $ENVHASH{'no_otree'} = 1; + $ENVHASH{'no_path'} = 1; + $ENVHASH{'only_otree'} = 0; + $ENVHASH{'only_update'} = 1; + $ENVHASH{'last_minor'} = 0; + $ENVHASH{'spec_src'} = 0; + $ENVHASH{'dest'} = "$src_dest"; + $ENVHASH{'prj_to_copy'} = ''; + $ENVHASH{'i_server'} = ''; + $ENVHASH{'current_dir'} = cwd(); + $ENVHASH{'remote'} = ''; + $ENVHASH{'force_checkout'} = 1 if ($force_checkout); + + $projects_to_copy{$module_name}++; + + CopyPrj::copy_projects(\%ENVHASH); + +}; + +sub copy_modules +{ + # copy modules from master workspace into child workspace + my $cws = shift; + my $dir = shift; + my $workspace_db = shift; + my @modules = @_; + + my $masterws = $cws->master(); + my $childws = $cws->child(); + my $milestone = $cws->milestone(); + + # ause: Deine Spielwiese + my $result; + my @success_modules = (); + + my $workspace = $workspace_db->get_key($masterws); + if ( !$workspace ) { + print_error("Master workspace '$masterws' not found in workspace database.", 3); + } + + my $wslocation = $workspace_db->get_value($masterws."/Drives/o:/UnixVolume"); + if ( !defined($wslocation) ) { + print_error("Location of master workspace '$masterws' not found in workspace database.", 3); + } + + print "$wslocation\n" if $is_debug; + + my $source_root = $ENV{SOURCE_ROOT}; + if ( !defined( $source_root )) { + print_error("SOURCE_ROOT not defined! Please setup a valid environment for CWS \"$childws\"", 1); + } + my $cws_solver = "$source_root/$masterws"; + + my $start_dir = getcwd(); + $result = chdir($dir); + if ( !$result ) { + print_error("Cannot change to $dir!", 1); + } + + # assume that every valid platform on child "solver" has to be coppied + $result = opendir( SOLVER, "$cws_solver"); + if ( !$result ){ print_error ("Root dir of child workspace not accessible: $!", 1) }; + my @found_dirs = readdir( SOLVER ); + closedir( SOLVER ); + + # hack to get the milestone :-((((( + if ( ! defined($milestone)) + { + $milestone = $ENV{UPDMINOR}; + } + if ( $#found_dirs ) + { + foreach my $dir_candidate ( @found_dirs ) + { + if ( -d "$cws_solver/$dir_candidate/inc.".$milestone ) + { + push @found_platforms, $dir_candidate; + } + } + } + # preparing pseudo environment for copyprj + $ENV{SRC_ROOT}="$wslocation/$masterws/src.$ENV{UPDMINOR}"; + + print "$ENV{SRC_ROOT}\n" if ( $is_debug ); + print "working dir: ".getcwd()."\n" if ( $is_debug ); + foreach my $one_module (@modules) { + # do some snity checks for this module + if ( -e "$one_module.lnk" && -e "$one_module" ) + { + print_error("Duplicate representation of module $one_module ($one_module.lnk $one_module)", 0); + print_error("Please clean up!", 0); + print_error("Will NOT add module $one_module to child workspace!", 0); + # fail for this module + next; + } + if ( -e "$one_module.backup.lnk" || -e "$one_module.backup" ) + { + print_error("Backup of module $one_module already exists.", 0); + print_error("Please clean up!", 0); + print_error("Will NOT add module $one_module to child workspace!", 0); + # fail for this module + next; + + } + + $result = 0; + $result = rename($one_module, "$one_module.backup.lnk") if ( -l $one_module ); + if ( ! -l $one_module && -e $one_module ) { + $result ||= rename($one_module, "$one_module.backup"); + # if it is no link, assume incompatible build + # -> don't copy output tree + $add_output_tree = 0; + } + $result ||= rename("$one_module.lnk", "$one_module.backup.lnk") if ( -e "$one_module.lnk" ); + $result = 0 if ( -e $one_module || -e "$one_module.lnk" ); + if ( ! $result ) + { + print_error("Couldn't backup existing module $one_module before copying", 0); + print_error("Will NOT add module $one_module to child workspace!", 0); + # fail for this module + next; + } + + # now copy sources + $result = copyprj_module_sourcetree( $one_module, "." ); + if ( $result ) + { + if ( -d $one_module ) + { + $result = rename("$one_module", "$one_module.failed"); + $result = system("rm -rf $one_module.failed"); + } + print_error("Couldn't copy module $one_module, restoring previous.", 0); + if ( -e "$one_module.backup" ) + { + $result = rename("$one_module.backup", $one_module); + } + else + { + $result = rename("$one_module.backup.lnk", "$one_module.lnk"); + } + print_error("Restoring link for $one_module failed! Cleanup is in your hand now", 1) if ( ! $result ); + # fail for this module + next; + } + + # remove backuped link + unlink("$one_module.backup.lnk") if -l "$one_module.backup.lnk"; + + # or backuped directory... + if ( -d "$one_module.backup" ) + { + if ( $^O =~ "MSWin32" ) + { + print_error("Sorry! not for windows, nobody should ever get here!",2); + } + $result = system("rm -rf $one_module.backup"); + } + + # insert module in list of successfull copied modules + push(@success_modules, $one_module); + } + + chdir($start_dir); + +# return my @empty = (); # ause - disable all further steps + return @success_modules; +} + +sub branch_module +{ + # tag modules with cws branch cws root tag + my $cws = shift; + my $dir = shift; + my $module = shift; + + my ($cws_master_tag, $cws_branch_tag, $cws_root_tag) = $cws->get_tags(); + + # Sanity check + print "operating on $dir/$_\n" if $is_debug; + if ( -S "$dir/$module" || ! -d "$dir/$module" ) { + print_error("Can't find physical copy of module '$module'", 4); + } + + STDOUT->autoflush(1); + print_message("Tagging module '$module'."); + my $cvs_module = CvsModule->new(); + $cvs_module->module($module); + $cvs_module->verbose(1); + + print_message("Tag with branch tag '$cws_branch_tag'."); + my ($branched_files, $branch_errors) = $cvs_module->tag($dir, $cws_branch_tag, '-b'); + if ( $branched_files < 1 ) { + print_error("Tagging module '$module' failed.", 0); + return 0; + } + if ( $branch_errors > 0 ) { + print_error(cleanup_tags_msg($module), 0); + return 0; + } + print_message("Tagged $branched_files files in module '$module' with branch tag."); + + print_message("Tag with tag '$cws_root_tag'."); + my ($tagged_files, $anchor_errors) = $cvs_module->tag($dir, $cws_root_tag); + if ( $tagged_files < 1 || $anchor_errors > 0 + || $branched_files != $tagged_files ) + { + print_error(cleanup_tags_msg($module), 0); + return 0; + } + print_message("Tagged $tagged_files files in module '$module'."); + + print_message("Updating module '$module' to branch '$cws_branch_tag'."); + my @dirs = $cvs_module->update($dir, $cws_branch_tag); + if ( $#dirs < 0 ) { + print_error("Updating module '$module' to branch '$cws_branch_tag' failed.\n", 0); + return 0; + } + STDOUT->autoflush(0); + return 1; +} + +sub cleanup_tags_msg +{ + my $module = shift; + my ($cws_master_tag, $cws_branch_tag, $cws_root_tag) = $cws->get_tags(); + + my $msg = "Tagging module '$module' failed partly. Can't continue.\n"; + $msg .= "Please remember to manually remove the tags '$cws_branch_tag' and '$cws_root_tag'\n"; + $msg .= "from module '$module' before retrying the operation!"; + + return $msg; +} + +# Register module with EIS. +sub register_module +{ + my $cws = shift; + my $workspace_db = shift; + my $module = shift; + + my $public = 1; + + # find out if module has public flag + my $master = $cws->master(); + if (defined $log) { + my $key = "$master/Drives/o:/Projects/$module/SCS"; + my $scs = $workspace_db->get_value($key); + + if ( !defined($scs) ) { + print_error("Can't find module '$module' in workspace db", 0); + return 0; + } + + # FIXME - this really shouldn't be hard coded + if ( $scs !~ /tunnel/ ) { + $public = 0; + } + } + + my $success = $cws->add_module($module, $public); + if ( !$success ) { + print_error("Can't register module '$module' with EIS!", 0); + return 0; + } + print_message("Succesfully registered module '$module'."); + return 1; +} + +sub print_message +{ + my $message = shift; + + print "$script_name: "; + 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"; + $log->end_log_extended($script_name,$vcsid,$message) if (defined $log); + exit($error_code); + } + return; +} + +sub usage +{ + print STDERR "Usage: cwsadd [-h] [-a] <module> ... \n"; + print STDERR "Add one or more modules to child workspace.\n"; + print STDERR "Options:\n"; + print STDERR " -a use cvs checkout instead of copying\n"; + print STDERR " -h print this help\n"; + +} diff --git a/solenv/bin/cwsaddtask b/solenv/bin/cwsaddtask new file mode 100755 index 000000000000..063551059d27 --- /dev/null +++ b/solenv/bin/cwsaddtask @@ -0,0 +1,6 @@ +#!/bin/sh +if [ x${SOLARENV}x = xx ]; then + echo No environment found, please use 'configure' or 'setsolar' + exit 1 +fi +exec perl -w $SOLARENV/cwsaddtask.pl "$@" diff --git a/solenv/bin/cwsaddtask.pl b/solenv/bin/cwsaddtask.pl new file mode 100755 index 000000000000..f361d36e11fc --- /dev/null +++ b/solenv/bin/cwsaddtask.pl @@ -0,0 +1,254 @@ +: +eval 'exec perl -wS $0 ${1+"$@"}' + if 0; +#************************************************************************* +# +# $RCSfile: cwsaddtask.pl,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:23:19 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + +# +# cwsaddtask.pl - add taskids to child workspaces +# + +use strict; +use Getopt::Long; + +#### module lookup + +use lib ("$ENV{SOLARENV}/bin/modules"); +if (defined $ENV{COMMON_ENV_TOOLS}) { + unshift(@INC, "$ENV{COMMON_ENV_TOOLS}/modules"); +}; +use Cws; +use CvsModule; +use CwsConfig; + +#### script id ##### + +( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; + +my $script_rev; +my $id_str = ' $Revision: 1.2 $ '; +$id_str =~ /Revision:\s+(\S+)\s+\$/ + ? ($script_rev = $1) : ($script_rev = "-"); + +print "$script_name -- version: $script_rev\n"; + +#### global ##### + +my $is_debug = 0; + +# CWS states for which adding tasks are blocked. +my @states_blocked_for_adding = ( + "integrated", + "nominated", + "approved by QA" + ); + +#### main ##### + +my ($cws, $vcsid) = get_and_verify_cws(); +my @taskids = parse_options(); +register_taskids($cws, $vcsid, @taskids); + +exit(0); + +#### subroutines #### + +# Get current child workspace from environment. +sub get_and_verify_cws +{ + my $childws = $ENV{CWS_WORK_STAMP}; + my $masterws = $ENV{WORK_STAMP}; + + my $config = CwsConfig->get_config(); + my $vcsid = $config->vcsid(); + if ( !defined($vcsid) ) { + print_error("VCSID environment variable not set", 1); + } + + if ( !defined($childws) || !defined($masterws) ) { + print_error("Can't determine child workspace environment.\n" + . "Please initialize environment with setsolar ...", 1); + } + + my $cws = Cws->new(); + $cws->child($childws); + $cws->master($masterws); + + # Check if we got a valid child workspace. + my $id = $cws->eis_id(); + print "Master: $masterws, Child: $childws, $id\n" if $is_debug; + if ( !$id ) { + print_error("Child workspace $childws for master workspace $masterws not found in EIS database.", 2); + } + + return ($cws, $vcsid); +} + +# Parse options and do some sanity checks; +sub parse_options +{ + my $help; + my $success = GetOptions('h' => \$help); + if ( !$success || $help || $#ARGV < 0 ) { + usage(); + exit(1); + } + + return @ARGV; +} + +# Register taskids with EIS database; +# checks taksids for sanity, will notify user +# if taskid is already registered. +sub register_taskids +{ + + my $cws = shift; + my $vcsid = shift; + my @taskids = @_; + + my $child = $cws->child(); + + my $status = $cws->get_approval(); + + if ( !defined($status) ) { + print_error("Can't determine status of child workspace `$child`.", 4); + } + + if ( grep($status eq $_, @states_blocked_for_adding) ) { + print_error("Can't add tasks to child workspace '$child' with state '$status'.", 5); + } + + my @registered_taskids = $cws->taskids(); + + # Create hash for easier searching. + my %registered_taskids_hash = (); + for (@registered_taskids) { + $registered_taskids_hash{$_}++; + } + + my @new_taskids = (); + foreach (@taskids) { + if ( $_ !~ /^([ib]?\d+)$/ ) { + print_error("'$_' is an invalid task ID.", 3); + } + if ( exists $registered_taskids_hash{$1} ) { + print_warning("Task ID '$_' already registered, skipping."); + next; + } + push(@new_taskids, $_); + } + + 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'.", 4); + } + 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 print_message +{ + my $message = shift; + + print "$script_name: "; + 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 "Usage: cwsaddtask [-h] <taskID> ... \n"; + print STDERR "Add one or more taskIDs to child workspace.\n"; + print STDERR "Options:\n"; + print STDERR " -h print this help\n"; +} diff --git a/solenv/bin/cwsanalyze b/solenv/bin/cwsanalyze new file mode 100755 index 000000000000..40cc3582db25 --- /dev/null +++ b/solenv/bin/cwsanalyze @@ -0,0 +1,6 @@ +#!/bin/sh +if [ x${SOLARENV}x = xx ]; then + echo No environment found, please use 'configure' or 'setsolar' + exit 1 +fi +exec perl -w $SOLARENV/cwsanalyze.pl "$@" diff --git a/solenv/bin/cwsanalyze.pl b/solenv/bin/cwsanalyze.pl new file mode 100755 index 000000000000..34364f432007 --- /dev/null +++ b/solenv/bin/cwsanalyze.pl @@ -0,0 +1,965 @@ +: +eval 'exec perl -wS $0 ${1+"$@"}' + if 0; +#************************************************************************* +# +# $RCSfile: cwsanalyze.pl,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:23:19 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + +# +# cwsanalyze.pl - analyze child workspace, report findings +# cwsintegrate.pl - integrate child workspace into master workspace +# +# TODO implements 'alerts' for integrate mode + +use strict; +use File::Basename; +use Getopt::Long; +use Cwd; +use IO::Handle; + +#### module lookup + +use lib ("$ENV{SOLARENV}/bin/modules", "$ENV{COMMON_ENV_TOOLS}/modules"); +use Cws; +use CvsModule; +use Cvs; +eval { require Logging; import Logging; }; +# $log variable is only defined in SO environment... +my $log = undef; +$log = Logging->new() if (!$@); + +######### Interrupt handler ######### + $SIG{'INT'} = 'INT_handler'; + +#### script id ##### + +( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; + +my $script_rev; +my $id_str = ' $Revision: 1.2 $ '; +$id_str =~ /Revision:\s+(\S+)\s+\$/ + ? ($script_rev = $1) : ($script_rev = "-"); + +print "$script_name -- version: $script_rev\n"; + +#### hardcoded globals ##### + +# Don't use this tool on a MWS workspaces in the veto +# list, because the behavior my not be clearly defined +# examples: +# no MWS branch exists +# MWS branch is obsolete +my @veto_list = ( + 'SRX644', + 'FIX645' + ); + +my %veto_hash; +foreach (@veto_list) { + $veto_hash{$_}++; +} + +# Commit veto pattern. Never integrate files matching this pattern +my %commit_veto_hash; +my @commit_veto_list = ( + # The defs file mechanism is not compatible with CWS. + # It really needs to be changed. + 'defs\/wntmsci\d+$' + ); +foreach (@commit_veto_list) { + $commit_veto_hash{$_}++; +} + + +#### global ##### + +my $is_debug = 0; # misc traces for debugging purposes +my $mode = $script_name; # operational mode (cwsanalyze|cwsintegrate) +my $opt_fast = 0; # fast mode, disable conflict check +my $opt_force = 0; # force integration +my $opt_no_set_integrated = 0; # don't toggle integration status +my $vcsid = "unkown"; +my @args_bak = @ARGV; + +#### main ##### +my $parameter_list = $log->array2string(";",@args_bak) if defined($log); + +my ($dir, @modules) = parse_options(); +my $cws = get_and_verify_cws(); +@modules = verify_modules($cws, @modules); +if ( $mode eq 'cwsanalyze' ) { + analyze($cws, $dir, @modules); +} +else { + integrate($cws, $dir, @modules); +} +print_plog(); +$log->end_log_extended($script_name,$vcsid,"success") if defined($log); +exit(0); + +#### subroutines #### + +# Get current child workspace from environment. +sub get_and_verify_cws +{ + my $childws = $ENV{CWS_WORK_STAMP}; + my $masterws = $ENV{WORK_STAMP}; + + if ( exists $veto_hash{$masterws} ) { + print_error("Please don't use this tool for a CWS based on MWS '$masterws',", 0); + print_error("before you haven't resynced it to a more recent MWS.", 1); + } + + if ( !defined($childws) || !defined($masterws) ) { + print_error("Can't determine child workspace environment.\n" + . "Please initialize environment with setsolar ...", 1); + } + + my $cws = Cws->new(); + $cws->child($childws); + $cws->master($masterws); + $log->start_log_extended($script_name,$parameter_list,$masterws,$childws) if defined($log); + + # check if we got a valid child workspace + my $id = $cws->eis_id(); + print "Master: $masterws, Child: $childws, $id\n" if $is_debug; + if ( !$id ) { + print_error("Child workspace $childws for master workspace $masterws not found in EIS database.", 2); + } + return $cws; +} + +# Parse options and do some sanity checks; +# returns freshly allocated Cws reference. +sub parse_options +{ my $dir = 0; + my $help = 0; + my $success = GetOptions('d=s' => \$dir, 'n' => \$opt_fast, 'h' => \$help, + 'F' => \$opt_force, 'q' => \$opt_no_set_integrated); + if ( !$success || @ARGV<1 ) { + usage(); + exit(1); + } + + if ( $dir && $opt_fast ) { + usage(); + exit(1); + } + + $dir = $dir ? $dir : cwd(); + + # check directory + if ( ! -d $dir ) { + print_error("'$dir' is not a directory.", 1); + } + if ( ! -w $dir ) { + print_error("Can't write to directory '$dir'.", 1); + } + + unless ( $opt_fast ) { + my @cvsdirs = glob("$dir/*/CVS"); + if ( @cvsdirs ) { + print_error("'$dir' contains CVS modules. Please specify an empty scratch directory.", 1); + } + } + + return ($dir, @ARGV); +} + +# Check if requested modules are registered with child workspace. +sub verify_modules +{ + my $cws = shift; + my @modules = @_; + + my @registered_modules = $cws->modules(); + my $child = $cws->child(); + + # call with empty modules list + return @registered_modules if $modules[0] eq 'all'; + + # create hash for easier searching + my %registered_modules_hash = (); + for (@registered_modules) { + $registered_modules_hash{$_}++; + } + + foreach (@modules) { + if ( !exists $registered_modules_hash{$_} ) { + print_error("Module '$_' is not registered for child '$child'.", 2); + } + } + return @modules; +} + +# Analyze changes in child work space +sub analyze +{ + my $cws = shift; + my $dir = shift; + my @modules = @_; + + my $child = $cws->child(); + my $master = $cws->master(); + + print_message("Analyzing child workspace '$child', master workspace '$master'."); + print_message("*** Conflict check disabled ***") if $opt_fast; + # display child workspace approval status + my $approval = $cws->get_approval(); + if ( !$approval ) { + print_error("Internal error: can't get approval status for '$child'.", 3); + } + print_message("Child workspace approval status: $approval"); + + my ($ntotal_merged, $ntotal_new, $ntotal_removed, $ntotal_conflicts, $ntotal_alerts) + = (0, 0, 0, 0); + foreach (@modules) { + my ($nmerged, $nnew, $nremoved, $nconflicts, $nalerts) = analyze_module($cws, $dir, $_); + $ntotal_merged += $nmerged; + $ntotal_new += $nnew; + $ntotal_removed += $nremoved; + $ntotal_conflicts += $nconflicts; + $ntotal_alerts += $nalerts; + } + my $merge_str = $opt_fast ? 'change(s)' : 'clean merge(s)'; + my $stats = "All Modules: $ntotal_merged $merge_str, $ntotal_new new, "; + $stats .= "$ntotal_removed removed"; + $stats .= $opt_fast ? '' : ", $ntotal_conflicts conflict(s), $ntotal_alerts alert(s)"; + print_message($stats); +} + +# Integrate child workspace into master. +sub integrate +{ + my $cws = shift; + my $dir = shift; + my @modules = @_; + + my $child = $cws->child(); + my $master = $cws->master(); + + print_message("Integrating child workspace '$child' into master workspace '$master'."); + # check if child workspace has been approved for integration + my $approval = $cws->get_approval(); + if ( !$approval ) { + print_error("Internal error: can't get approval status for '$child'.", 3); + } + + if ( $approval eq 'new' ) { + print_error("Child workspace '$child' is not approved for integration.", 3); + } + elsif ( $approval eq 'integrated' ) { + print_error("Child workspace '$child' is already integrated.", 3) unless $opt_force; + } + elsif ( $approval eq 'canceled' ) { + print_error("Child workspace '$child' has been canceled.", 3); + } + elsif ( $approval eq 'nominated' ) { + print_message("Child workspace '$child' is nominated for integration, proceeding ..."); + } + else { + # can't happen + print_error("Internal error: can't get approval status for '$child'.", 3); + } + + my ($ntotal_merged, $ntotal_new, $ntotal_removed, $ntotal_conflicts, $ntotal_alerts) = + (0, 0, 0, 0, 0); + foreach (@modules) { + my($nmerged, $nnew, $nremoved, $nconflicts, $nalerts) = integrate_module($cws, $dir, $_); + $ntotal_new += $nnew; + $ntotal_removed += $nremoved; + $ntotal_merged += $nmerged; + $ntotal_conflicts += $nconflicts; + $ntotal_alerts += $nalerts; + } + + print "All modules: $ntotal_new new, $ntotal_removed removed, $ntotal_merged merge(s), $ntotal_conflicts conflicts(s). $ntotal_alerts alert(s)\n"; + + # set CWS status + if ( !$opt_no_set_integrated ) { + if ( $cws->set_integrated() ) { + print_message("\nSet child workspace status to: integrated."); + } + else { + print_error("Could not set child workspace status to integrated.", 0); + } + } +} + +# Analyze child workspace module +sub analyze_module +{ + my $cws = shift; + my $dir = shift; + my $module = shift; + + print_message("========== Analyzing module '$module' =========="); + + my $cvs_module = get_cvs_module($cws, $module); + if ( !$cvs_module ) { + print_error("Failure during analysis of '$module', skipping.", 0); + plog("A\t$module: analysis failed!"); + return (0, 0, 0, 0, 1); + } + my $changed_files_ref = get_changed_files($cws, $cvs_module); + + if ( !defined($changed_files_ref) ) { + print_warning("Analysis of module '$module' failed."); + return undef; + } + + my ($master_branch_tag, $cws_branch_tag, $cws_root_tag) = $cws->get_tags(); + my ($nnew, $nremoved, $nmerged, $nconflicts, $nalerts) = (0, 0, 0, 0, 0); + if ( @{$changed_files_ref} ) { + # ok we've got changed files + # to check for conflicts we check out the module on the master branch + # and update all changed files against the child workspace branch + my $save_dir; + if ( !$opt_fast ) { + STDOUT->autoflush(1); + print_message("Check out for conflict check ..."); + my $co_ref = $cvs_module->checkout($dir, $master_branch_tag); + STDOUT->autoflush(0); + if ( !@{$co_ref} ) { + print_error("Was not able to checkout module '$module',", 0); + print_error("this might be caused by connection failures or authentication problems.", 0); + print_error("Please check your \$HOME/.cvspass for missing entries!", 50); + } + # save working dir for later perusal + # chdir into module + $save_dir = cwd(); + if ( !chdir("$dir/$module") ) { + print_error("Can't chdir() to '$dir/$module'", 6); + } + } + foreach my $change_ref (@{$changed_files_ref}) { + # Check against vetoed files + foreach my $veto_pattern ( keys %commit_veto_hash ) { + if ( $change_ref->[0] =~ /$veto_pattern/ ) { + print "\tA", "\t", + $change_ref->[0], " def file detected, will be ignored\n"; + plog("A\t$module/$change_ref->[0]: def file detected!"); + $nalerts++; + } + } + if ( !defined($change_ref->[1]) && !defined($change_ref->[2]) ) { + # removed file + print "\tR", "\t", $change_ref->[0], "\n"; + $nremoved++; + } + elsif ( !defined($change_ref->[1]) ) { + # new file + print "\tN","\t", $change_ref->[0], "\t", $change_ref->[2], "\n"; + $nnew++; + } + else { + # modified file + if ( $opt_fast ) { + print "\tM", "\t", $change_ref->[0], "\t", + $change_ref->[1], " -> ", + $change_ref->[2], "\n"; + $nmerged++; + } + else { + my $archive = $change_ref->[0]; + if ( !-e $archive ) { + # changes have been made on the CWS for + # a file which has been removed on the MWS + print "\tA", "\t", + $change_ref->[0], " file removed on MWS but changed on CWS\n"; + plog("A\t$module/$change_ref->[0]: file removed on MWS but changed on CWS. Please check!"); + $nalerts++; + } + my $cvs_archive = get_cvs_archive($archive); + my $rc = update_file($cvs_archive, $cws_branch_tag, $cws_root_tag); + if ( $rc eq 'merged' ) { + print "\tM", "\t", $change_ref->[0], "\t", + $change_ref->[1], " -> ", + $change_ref->[2], "\n"; + $nmerged++; + } + elsif ( $rc eq 'conflict' ) { + print "\tC", "\t", $change_ref->[0], "\t", + $change_ref->[1], " -> ", + $change_ref->[2], "\n"; + plog("C\t$module/$change_ref->[0]: conflict!"); + $nconflicts++; + } + else { + print_error("update_file() operation failed.", 6); + } + } + } + } + # chdir back + chdir($save_dir) if( !$opt_fast ); + } + + # emit some statistics + my $merge_str = $opt_fast ? 'change(s)' : 'clean merge(s)'; + my $stats = "'$module': $nmerged $merge_str, $nnew new, "; + $stats .= "$nremoved removed"; + $stats .= $opt_fast ? '' : ", $nconflicts conflict(s), $nalerts alert(s)"; + print_message($stats); + + return ($nmerged, $nnew, $nremoved, $nconflicts, $nalerts); +} + +# Integrate child workspace module. +sub integrate_module +{ + # TODO break integrate_module() down into several routines + my $cws = shift; + my $dir = shift; + my $module = shift; + + print_message("========== Integrating module '$module' =========="); + + my $cvs_module = get_cvs_module($cws, $module); + if ( !$cvs_module ) { + print_error("Failure during integration of '$module', skipping.", 0); + plog("A\t$module: integration failed!"); + return (0, 0, 0, 0, 1); + } + my $changed_files_ref = get_changed_files($cws, $cvs_module); + + if ( !defined($changed_files_ref) ) { + print_warning("Integration of module '$module' failed."); + return undef; + } + my $child = $cws->child(); + + my ($master_branch_tag, $cws_branch_tag, $cws_root_tag) = $cws->get_tags(); + + # statistics counters + my ($nnew, $nremoved, $nmerged, $nconflicts, $nalerts) = (0, 0, 0, 0, 0); + if ( @{$changed_files_ref} ) { + # ok we've got changed files + STDOUT->autoflush(1); + print_message("Checking out ..."); + $cvs_module->checkout($dir, $master_branch_tag); + STDOUT->autoflush(0); + # save working dir for later perusal + my $save_dir = cwd(); + # chdir into module + if ( !chdir("$dir/$module") ) { + print_error("Can't chdir() to '$dir/$module'", 0); + } + COMMIT: foreach my $change_ref (@{$changed_files_ref}) { + my $archive = $change_ref->[0]; + # Check against vetoed files + foreach my $veto_pattern ( keys %commit_veto_hash ) { + if ( $archive =~ /$veto_pattern/ ) { + print "\tA", "\t", + $archive, " def file detected. skipped\n"; + plog("C\t$module/$archive: def file detected!"); + $nalerts++; + next COMMIT; # jump to next changed file + } + } + if ( defined($change_ref->[2]) && !-d dirname($archive) ) + { + if ( defined($change_ref->[1]) ) { + } + else { + # A new file appeared in a directory which has not yet + # been added to our local CVS tree. + sanitize_cvs_hierarchy($archive); + } + } + my $cvs_archive = get_cvs_archive($archive); + # Determine the branch root of the CWS branch and the master branch + my $branch_rev = $cvs_archive->get_branch_rev($cws_branch_tag); + my $master_branch_rev = $cvs_archive->get_branch_rev($master_branch_tag); + if ( !$branch_rev ) { + # can't happen + print_error("Internal error: can't determine CWS branch root", 0); + } + my @merge_comments; + push(@merge_comments, get_revision_comments($cvs_archive, $branch_rev)); + my $change_type; + if ( !defined($change_ref->[1]) && !defined($change_ref->[2]) ) { + # removed file + push(@merge_comments, "INTEGRATION: CWS $child ($branch_rev); FILE REMOVED\n"); + $change_type = 'removed'; + } + elsif ( !defined($change_ref->[1]) ) { + # new file + push(@merge_comments, "INTEGRATION: CWS $child ($branch_rev); FILE ADDED\n"); + $change_type = 'new'; + } + else { + # modified file + push(@merge_comments, "INTEGRATION: CWS $child ($branch_rev); FILE MERGED\n"); + $change_type = 'changed'; + } + + # write out merge comment file + my $merge_comment_file = $archive . '.mergecomment'; + if ( !open(COMMENTFILE, ">$merge_comment_file") ) { + print_error("$script_name: can't open $merge_comment_file: $!", 0); + } + print COMMENTFILE reverse @merge_comments; + close(COMMENTFILE); + + # get the revision authors and taskids + my $revision_authors_ref = get_revision_authors($cvs_archive, $branch_rev); + my $revision_taskids_ref = get_revision_taskids($cvs_archive, $branch_rev); + + # do the update + my $new_revision; + my $rc = update_file($cvs_archive, $cws_branch_tag, $cws_root_tag); + if ( !$rc ) { + print_error("Update operation for file '$archive' failed for unknown reasons.", 0); + plog("$module/$archive: update operation failed for unknown reasons, can't commit changes!"); + } + elsif ( $rc eq 'merged' ) { + # commit merges + ($rc, $new_revision) = commit_file($cvs_archive, $merge_comment_file); + unless ( $rc eq 'success' || $rc eq 'nothingcomitted' ) { + print_error("Can't commit changes to '$archive'", 0); + plog("\t$module/$archive: can't commit changes!"); + next; + } + print "\tN\t$archive\n" and $nnew++ if $change_type eq 'new'; + print "\tR\t$archive\n" and $nremoved++ if $change_type eq 'removed'; + print "\tM\t$archive\n" and $nmerged++ if $change_type eq 'changed'; + unlink($merge_comment_file) if $rc eq 'success'; + } + elsif ( $rc eq 'conflict' ) { + print "\tC\t$archive\n"; + plog("C\t$module/$archive: conflict!"); + $nconflicts++; + + # TODO: clean up this mess + # Find out what the new revision will be after the conflict has been + # solved. We are going to report it to EIS even if the commit + # has not yet been done + my $last_rev; + if ( !$master_branch_rev ) { + # master branch is head branch + $last_rev = $cvs_archive->get_head(); + } + else { + my $revs_ref = $cvs_archive->get_sorted_revs(); + foreach my $rev (@{$revs_ref}) { + if ( $rev =~ /^$master_branch_rev\.\d+/ ) { + $last_rev = $rev; + } + } + } + my @rev_field = split(/\./, $last_rev); + $rev_field[-1]++; + $new_revision = join('.', @rev_field); + } + else { + # can't happen + print_error("Internal error: update failed for unknown reasons", 0); + } + + # register new revision with EIS + $cws->add_file($module, $archive, $new_revision, + $revision_authors_ref, $revision_taskids_ref); + + } + # chdir back + chdir($save_dir); + } + + # emit some statistics + print "'$module': $nnew new, $nremoved removed, $nmerged merge(s), $nconflicts conflicts(s). $nalerts alert(s)\n"; + return ($nmerged, $nnew, $nremoved, $nconflicts, $nalerts); +} + +# Get all revision comments on child workspace branch. +sub get_revision_comments +{ + my $cvs_archive = shift; + my $branch_rev = shift; + + # Collect all the logging information of the revisions on the branch + my @merge_comment = (); + my $revs_ref = $cvs_archive->get_sorted_revs(); + foreach my $rev (@{$revs_ref}) { + if ( $rev =~ /^$branch_rev\.\d+/ ) { + my $log_ref = $cvs_archive->get_data_by_rev()->{$rev}; + my $comment = "$log_ref->{'DATE'} $log_ref->{'AUTHOR'} $rev: $log_ref->{'COMMENT'}"; + if ( $log_ref !~ /^RESYNC:/ ) { + push(@merge_comment, $comment); + } + } + } + wantarray ? @merge_comment : \@merge_comment; +} + +sub get_revision_authors +{ + my $cvs_archive = shift; + my $branch_rev = shift; + + # Collect all the authors of the revisions on the branch + my @authors; + my %authors_hash; + my $revs_ref = $cvs_archive->get_sorted_revs(); + foreach my $rev (@{$revs_ref}) { + if ( $rev =~ /^$branch_rev\.\d+/ ) { + my $log_ref = $cvs_archive->get_data_by_rev()->{$rev}; + $authors_hash{$log_ref->{'AUTHOR'}}++; + } + } + push(@authors, sort keys %authors_hash); + wantarray ? @authors : \@authors; +} + +sub get_revision_taskids +{ + my $cvs_archive = shift; + my $branch_rev = shift; + + # Collect all the taskids of the revisions on the branch + my @task_ids; + my %task_ids_hash; + my $revs_ref = $cvs_archive->get_sorted_revs(); + foreach my $rev (@{$revs_ref}) { + if ( $rev =~ /^$branch_rev\.\d+/ ) { + my $log_ref = $cvs_archive->get_data_by_rev()->{$rev}; + my @ids = extract_taskids($log_ref->{'COMMENT'}); + foreach (@ids) { + $task_ids_hash{$_}++; + } + } + } + push(@task_ids, sort keys %task_ids_hash); + wantarray ? @task_ids : \@task_ids; +} + +# Extract task ids from revision comment. +sub extract_taskids +{ + # Task ids can be of the form: + # #12345#,#4711# pr #12345,4711# + # Optionally task ids may be prefixed with 'i' for issuezilla- + # We may have to cope with a bit of white space, too. + my $comment = shift; + + my @ids; + my @candidates; + if ( @candidates = ($comment =~ /#([i\d\s,]+)#/gi) ) { + foreach my $candidate (@candidates) { + my @field = split(/,/, $candidate); + foreach (@field) { + tr/ //d; + push(@ids, $_) if /^i?\d+$/i ; + } + } + } + wantarray ? @ids : \@ids; +} + + +# Update file and report findings. +sub update_file +{ + + my $cvs_archive = shift; + my $cws_branch_tag = shift; + my $cws_root_tag = shift; + + my $file = $cvs_archive->name(); + my $merge_option = ''; + if ( -e $file ) { + # find out if we need to use the '-kk' flag for merging + my ($status, $working_rev, $repository_rev, $sticky_tag, $branch_rev, + $sticky_date, $sticky_options) = $cvs_archive->status(); + if ( $status eq 'unkownfailure' || $status eq 'connectionfailure' ) { + print_error("can't get status of '$file': $status", 0); + return undef; + } + $merge_option = ($sticky_options eq 'kb') ? '' : '-kk'; + } + + my $rc = $cvs_archive->update("$merge_option -j$cws_root_tag -j$cws_branch_tag"); + if ( $rc eq 'success' ) { + return 'merged'; + } + elsif ( $rc eq 'conflict' ) { + return 'conflict'; + } + else { + return undef; + } +} + +sub commit_file +{ + my $cvs_archive = shift; + my $merge_comment_file = shift; + + my ($rc, $new_revision) = $cvs_archive->commit("-F $merge_comment_file"); + return ($rc, $new_revision); +} + +# Returns changed files for module. +sub get_changed_files +{ + my $cws = shift; + my $cvs_module = shift; + + my ($master_branch_tag, $cws_branch_tag, $cws_root_tag) = $cws->get_tags(); + + $cvs_module->verbose(1); + STDOUT->autoflush(1); + print_message("Retrieving changes ..."); + my $changed_files_ref = $cvs_module->changed_files($cws_root_tag,$cws_branch_tag); + STDOUT->autoflush(0); + return $changed_files_ref; +} + +# New files may be in new CVS subdirectories. +# Check if the CVS subdir is available or +# add it to the local CVS tree +sub sanitize_cvs_hierarchy +{ + my $file = shift; + + my $cvs_dir = dirname($file); + return if $cvs_dir eq '.'; # no need to check current dir + + my @elements = split(/\//, $cvs_dir); + + my $save_dir = cwd(); + + foreach ( @elements ) { + if ( ! -d $_ ) { + my $rc = mkdir($_); + print_error("can create directory '$_': $!", 9) unless $rc; + # TODO use a Cvs method for this + print_error("Operation not (yet) supported on Windows", 9) if $^O eq 'MSWin32'; + system("cvs.clt2 add $_ > /dev/null 2>&1 "); + } + if ( !chdir($_) ) { + print_error("Can't chdir() to '$_'", 9); + } + } + + # chdir back + chdir($save_dir); +} + +# Retrieve CvsModule object for passed module. +sub get_cvs_module +{ + my $cws = shift; + my $module = shift; + + my $cvs_module = CvsModule->new(); + my ($method, $vcsid, $server, $repository); + if ( defined($log) ) { + ($method, $vcsid, $server, $repository) = get_cvs_root($cws, $module); + } + else { + # For now just take the configured OOo sever. Later we might implement a mechanism were + # only known OOo modules are fetched from the OOo server, the rest from a local + # server + my $config = CwsConfig::get_config(); + ($method, $vcsid, $server, $repository) = ($config->get_cvs_server_method(), + $config->get_cvs_server_id(), + $config->get_cvs_server(), + $config->get_cvs_server_repository()); + } + + return undef if !($method && $vcsid && $server && $repository); + + $cvs_module->module($module); + $cvs_module->cvs_method($method); + $cvs_module->vcsid($vcsid); + $cvs_module->cvs_server($server); + $cvs_module->cvs_repository($repository); + + return $cvs_module; +} + +# Return Cvs object for passed file. +sub get_cvs_archive +{ + my $file = shift; + + my $cvs_archive = Cvs->new(); + $cvs_archive->name($file); + + return $cvs_archive; +} + +# Find out which CVS server holds the module, returns +# the elements of CVSROOT. +sub get_cvs_root +{ + require EnvHelper; import EnvHelper; + my $cws = shift; + my $module = shift; + + my $master = $cws->master(); + + my $vcsid = $ENV{VCSID}; + if ( !$vcsid ) { + print_error("Can't determine VCSID. Please use setsolar.", 5); + } + + my $workspace_db = EnvHelper::get_workspace_db(); + if ( !$workspace_db ) { + print_error("Can't load workspace database.", 4); + } + + my $key = "$master/drives/o:/projects/$module/scs"; + my $cvsroot = $workspace_db->get_value($key); + + if ( !$cvsroot ) { + print_error("No such module '$module' for '$master' in workspace database.", 0); + return (undef, undef, undef, undef); + } + + my ($dummy1, $method, $user_at_server, $repository) = split(/:/, $cvsroot); + my ($dummy2, $server) = split(/@/, $user_at_server); + + if ( ! ($method && $server && $repository ) ) { + print_error("Can't determine CVS server for module '$module'.", 0); + return (undef, undef, undef, undef); + } + + return ($method, $vcsid, $server, $repository); +} + +# problem logging +{ + my @problem_log = (); + + sub plog + { + my $message = shift; + + push(@problem_log, $message); + } + + sub print_plog + { + if ( @problem_log ) { + print_message("========== Problem Log =========="); + foreach ( @problem_log ) { + print "\t$_\n"; + } + print_message("========== End Problem Log =========="); + } + } +} + +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"; + $log->end_log_extended($script_name,$vcsid,$message) if defined($log); + exit($error_code); + } + return; +} + +sub usage +{ + if ( $mode eq 'cwsintegrate' ) { + print STDERR "Usage: cwsintegrate [-h] [-d dir] [-q] [-F] <all|module> ... \n"; + print STDERR "Integrate one or more child workspace modules into master workspace.\n"; + print STDERR "Options:\n"; + print STDERR "\t-h \tprint this help\n"; + print STDERR "\t-d dir\tscratch space\n"; + print STDERR "\t-q \tdo not set child workspace status to 'integrated'\n"; + print STDERR "\t-F\tdo integration even if status is already 'integrated'\n"; + } + else { + print STDERR "Usage: cwsanalyze [-h] [-d dir] [-n] <all|module> ... \n"; + print STDERR "Analyze one or more child workspace modules.\n"; + print STDERR "Options:\n"; + print STDERR "\t-h \tprint this help\n"; + print STDERR "\t-d dir\tscratch space\n"; + print STDERR "\t-n\tdisable conflict check (no need for checkout)\n"; + print STDERR "The -d and -n options are mutually exclusive.\n"; + } +} diff --git a/solenv/bin/cwscreate b/solenv/bin/cwscreate new file mode 100755 index 000000000000..9d3f45a87624 --- /dev/null +++ b/solenv/bin/cwscreate @@ -0,0 +1,6 @@ +#!/bin/sh +if [ x${SOLARENV}x = xx ]; then + echo No environment found, please use 'configure' or 'setsolar' + exit 1 +fi +exec perl -w $SOLARENV/cwscreate.pl "$@" diff --git a/solenv/bin/cwscreate.pl b/solenv/bin/cwscreate.pl new file mode 100755 index 000000000000..20b43299f3fd --- /dev/null +++ b/solenv/bin/cwscreate.pl @@ -0,0 +1,659 @@ +: +eval 'exec perl -wS $0 ${1+"$@"}' + if 0; +#************************************************************************* +# +# $RCSfile: cwscreate.pl,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:23:20 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + +# +# cwscreate.pl - create child workspaces +# + +use strict; +use Getopt::Long; +use Cwd; +use IO::Handle; +use Sys::Hostname; +use File::Spec; + +#### module lookup + +use lib ("$ENV{SOLARENV}/bin/modules"); +if (defined $ENV{COMMON_ENV_TOOLS}) { + unshift(@INC, "$ENV{COMMON_ENV_TOOLS}/modules"); +}; +use Cws; +use CvsModule; +use CwsConfig; +eval { require Logging; import Logging; }; +# $log variable is only defined in SO environment... +my $log = undef; +$log = Logging->new() if (!$@); +use GenInfoParser; + +######### Interrupt handler ######### +$SIG{'INT'} = 'INT_handler' if defined($log); + +#### script id ##### + +( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; + +my $script_rev; +my $id_str = ' $Revision: 1.2 $ '; +$id_str =~ /Revision:\s+(\S+)\s+\$/ + ? ($script_rev = $1) : ($script_rev = "-"); + +print "$script_name -- version: $script_rev\n"; + +#### hardcoded globals ##### + +my $b_server_wnt = 'r:/b_server/config'; +my $b_server_unx = $ENV{ENV_ROOT} . '/b_server/config' if defined $ENV{ENV_ROOT}; +$b_server_unx = '/so/env/b_server/config' if ! -d $b_server_unx; + +#### globals ##### + +my $force_checkout = ''; +my $opt_dir = ''; # optional directory argument; +my $opt_platformlist; # optional platform argument; +my @opt_platforms = (); # optional platform argument; +my @args_bak = @ARGV; # store the @ARGS here for logging +my $is_debug = 0; +my $umask = umask(); +if ( !defined($umask) ) { + $umask = 22; +} +my $vcsid = $ENV{VCSID}; # user for logging +$vcsid = "unkown" if ( !$vcsid ); + +# modules to be obligatory copied to each cws +my %obligatory_modules = (); +$obligatory_modules{'solenv'}++; +$obligatory_modules{'res'}++; +$obligatory_modules{'so_res'}++; +$obligatory_modules{'instset'}++; +$obligatory_modules{'instsetoo'}++; +$obligatory_modules{'smoketest'}++; +$obligatory_modules{'smoketest_oo'}++; +$obligatory_modules{'test10'}++; + +my $parameter_list = $log->array2string(";",@args_bak) if defined($log); + +#### main ##### +my ($cws, $wslocation, $is_promotion) = parse_options(); +my $success = defined($log) ? copy_workspace($cws, $wslocation) : update_workspace($cws, $wslocation); +if ( $success ) { + register_workspace($cws, $is_promotion); +} +$log->end_log_extended($script_name,$vcsid,"success") if defined($log); +exit(0); + +#### subroutines #### + +sub parse_options +{ + # parse options and do some sanity checks + # returns freshly allocated Cws reference + my $help; + my $success; + $success = GetOptions('d=s' => \$opt_dir, 'p=s' => \$opt_platformlist, 'h' => \$help, '-a' => \$force_checkout); + if ( $help || !$success || $#ARGV > 2 ) { + usage(); + exit(1); + } + my $masterws = uc(shift @ARGV); + my $milestone = shift @ARGV; + my $childws = shift @ARGV; + + if ( ! ($masterws && $milestone && $childws) ) { + print STDERR "please specify master, milestone and child workspace\n"; + usage(); + exit(1); + } + + if ( $opt_dir && !-d $opt_dir ) { + print STDERR "'$opt_dir' is not a directory\n"; + usage(); + exit(1); + } + + # check if child workspace name is sane + if ( $childws !~ /^[a-z][a-z0-9]*$/ ) { + print_error("Invalid child workspace name '$childws'.\nCws names should contain lowercase letters and digits, starting with a letter.", 3); + } + + # check if environment matches masterws and milestone + if ($masterws ne $ENV{WORK_STAMP}) + { + if (defined $ENV{UPDMINOR} && $milestone ne $ENV{UPDMINOR}) { + print_error("Please set an environment matching your targeted milestone", 2); + }; + } + + # check if master is known + my $result = undef; + my $master = Eis::to_string($masterws); + my $eis = Cws::eis(); + eval { $result = $eis->getCurrentMilestone($master) }; + if ( !defined $result ) { + print_error("Master workspace '$masterws' not found in database.", 4); + }; + + my $cws = Cws->new(); + $cws->master($masterws); + $cws->child($childws); + $log->start_log_extended($script_name,$parameter_list,$masterws,$childws) if defined($log); + + # check if child workspace already exists + my $eis_id = $cws->eis_id(); + if ( !defined($eis_id) ) { + print_error("Connection with EIS database failed.", 6); + } + + my $is_promotion = 0; + if ( $eis_id > 0 ) { + if ( $cws->get_approval() eq 'planned' ) { + print "Scheduling promotion of child workspace '$childws' from 'planned' to 'new'.\n"; + $is_promotion++; + } + else { + print_error("Child workspace '$childws' for master workspace '$masterws' already exists.", 7); + } + } + else { + # check if child workspace name is still available + if ( !$cws->is_cws_name_available()) { + print_error("Child workspace name '$childws' is already in use.", 7); + } + } + + # set milestone + # TODO check validity of milestone + $cws->milestone($milestone); + + # check if suggested platforms exist + if ( $opt_platformlist ) { + my $push_pro; + my $push_nonpro; + my @platforms = split( /,/ , $opt_platformlist ); + + foreach ( @platforms ) + { + my $result; + my @found_dirs = (); + my $master = $cws->master(); + + # find valid platforms to copy + $result = opendir( SOLVER, "$wslocation/$master"); + if ( !$result ){ print_error ("Root dir of master workspace not accessible: $!", 1) } + closedir( SOLVER ); + my $check_dir = "$wslocation/$master/$_/inc.$milestone"; + if ( -d "$check_dir" ) { + push @opt_platforms, $_ ; + if ( $check_dir =~ /\.pro\/[^\/]+$/ ) { + $push_pro = 1 ; + } else { + $push_nonpro = 1 ; + } + } else { + print_error ("\"$_\" is not a valid platform. Please try again!", 1) + } + } + push @opt_platforms, "common" if $push_nonpro; + push @opt_platforms, "common.pro" if $push_pro ; + } + return ($cws, $wslocation, $is_promotion); +} + +sub get_workspace_lst +{ + # get the workspace list ('stand.lst'), either from 'localini' + # or, if this is not possible, from 'globalini' + + my $home; + if ( $^O eq 'MSWin32' ) { + $home = $ENV{TEMP}; + } + else { + $home = $ENV{HOME}; + } + my $localini = "$home/localini"; + if ( ! -f "$localini/stand.lst" ) { + my $globalini = get_globalini(); + return "$globalini/stand.lst"; + } + return "$localini/stand.lst"; +} + +sub get_globalini +{ + # get 'globalini' - either by environment variable or the default + my $globalini; + + $globalini = $ENV{GLOBALINI}; + + # default + if ( !defined($globalini) ) { + $globalini = ( $^O eq 'MSWin32' ) + ? $b_server_wnt : $b_server_unx; + } + return $globalini; +} + +# +# procedure checks if all modules are in the +# workspace and issues warning(s) about missing ones +# +sub check_cvs_update { + my ($cvs_aliases, $updated_modules, $master_tag) = @_; + my @missing_modules = (); + foreach my $module (split( /\s+/, $$cvs_aliases{'OpenOffice'})) { + next if ($module eq '-a'); + next if (defined $$updated_modules{$module}); + push (@missing_modules, $module); + }; + if (scalar @missing_modules) { + print_warning("The following modules are missing in your workspace,"); + print_warning("this might not be a problem - check out missing modules with tag '$master_tag':"); + print "@missing_modules\n"; + }; +}; + +sub update_workspace { + my $cws = shift; + my $stand_dir = $ENV{SRC_ROOT}; + if (!opendir(SOURCES, $stand_dir)) { + print_error ("Environment variable SRC_ROOT points to not accesible diretory: $!", 1) + } + my @dir_content = readdir(SOURCES); + close SOURCES; + my $master_tag = $cws->get_master_tag(); + my $config = CwsConfig::get_config; + my $cvs_module = CvsModule->new(); + $cvs_module->cvs_method($config->get_cvs_server_method()); + $cvs_module->vcsid($config->get_cvs_server_id()); + $cvs_module->cvs_server($config->get_cvs_server()); + $cvs_module->cvs_repository($config->get_cvs_server_repository()); + my %cvs_aliases = $cvs_module->get_aliases_hash(); + my %updated_modules = (); + my @warnings = (); + if ( @dir_content ) { + print_message("Updating workspace in '$stand_dir' to revision '$master_tag'."); + } + foreach my $module (@dir_content) { + next if (!defined $cvs_aliases{$module}); + if (!-d "$stand_dir/$module/CVS") { + push(@warnings, "Cannot update module $module\n"); + next; + }; + $cvs_module->module($module); + print "\tUpdating '$module' ...\n"; + my $result = $cvs_module->update($stand_dir, $master_tag); + $cvs_module->handle_update_infomation($result); + $updated_modules{$module}++; + }; + print $_ foreach (@warnings); + check_cvs_update(\%cvs_aliases, \%updated_modules, $master_tag); + return '1'; +}; + +sub copy_workspace +{ + require sync_dir; import sync_dir; + use File::Path; + use File::Basename; + use File::Copy; + use File::Glob; + + no warnings; + + # setup childworkspace in given location + my $cws = shift; + my $wslocation = shift; + my $master = $cws->master(); + my $child = $cws->child(); + my $milestone = $cws->milestone(); + my $dir = $opt_dir ? $opt_dir : cwd(); + my $success = 1; + my $accessmaster = 1; + + # Ause: Deine Spielwiese + my $result = 0; + my $platform = ""; + my @found_platforms = (); + my $dir_candidate = ""; + + # hardcoded list of files which do not belong to any module delivery + my @xtra_files = ( "*.mk", "*.flg", "libCrun*", "libgcc*", "libstdc*", "OOoRunner.jar" ); + + # find location of master + if ( "$wslocation" eq "" ) + { + print "No access to matser workspace.\n"; + $accessmaster = 0; + } + else + { + print "location of master: \"$wslocation\"\n"; + } + # append master name to keep setsolar happy + $dir .= "/$child/$master"; + + if ( $accessmaster ) + { + # find platforms to copy + if ( $#opt_platforms != -1 ) { + @found_platforms = map( lc, @opt_platforms ); + } else { + $result = opendir( SOLVER, "$wslocation/$master"); + if ( !$result ){ print_error ("Root dir of master workspace not accessible: $!", 1) }; + my @found_dirs = readdir( SOLVER ); + closedir( SOLVER ); + foreach $dir_candidate ( @found_dirs ) + { + if ( -d "$wslocation/$master/$dir_candidate/inc.$milestone" ) + { + push @found_platforms, $dir_candidate; + } + } + if ( !@found_platforms ) + { + print_error("No valid output tree to copy", 0); + $success = 0; + } + } + # copy solver + $sync_dir::do_keepzip = 1; + my $btarget = "instset"; + foreach $platform ( @found_platforms ) + { + %sync_dir::done_hash = (); + print "Create copy of solver for $platform ( ~ 1GB disk space needed !)\n"; + my $zipsource = "$wslocation/$master/$platform/zip.$milestone"; + my $copy_dest = "$dir/$platform/zip.$milestone"; + if ( -d "$dir/$platform" ) + { + # print_error ("$dir/$platform : Please restart on a clean directory tree!", 1); + } + if ( ! -d $copy_dest ) + { + $result = mkpath($copy_dest, 0, 0777-$umask); + if ( !$result ){ print_error ("Cannot create output tree $copy_dest : $!", 1) }; + } + + my $unzip_dest = $copy_dest; + $unzip_dest =~ s/(.*)\/.*$/$1/; + + if ( ! -e "$unzip_dest/prepared" ) { + $result = sync_dir::prepare_minor_unzip( $unzip_dest, ".".$milestone ); + open( PREPARED, ">$unzip_dest/prepared"); + close( PREPARED ); + } + + STDOUT->autoflush(1); + $result = &sync_dir::recurse_unzip( $zipsource, $copy_dest, $btarget ); + STDOUT->autoflush(0); + if ( $result ) + { + # renaming back before exit + $result = sync_dir::finish_minor_unzip( $unzip_dest, ".".$milestone ); + print_error ("Copying files to $copy_dest failed : $!", 1); + } + $result = sync_dir::finish_minor_unzip( $unzip_dest, ".".$milestone ); + unlink "$unzip_dest/prepared.$milestone" if -e "$unzip_dest/prepared.$milestone"; + + } + foreach my $oneextra ( @xtra_files ) + { + my @globlist = glob( "$wslocation/$master/[!s]*/*.$milestone/$oneextra" ); + if ( $#globlist == -1 ) { + print "tried $oneextra in $wslocation/$master/[!s]*/*.$milestone/$oneextra\n"; + } + foreach my $onefile ( @globlist ) + { + my $destfile = $onefile; + $destfile =~ s#$wslocation/$master#$dir#; + + if ( -d dirname( $destfile )) + { + $result = copy $onefile, $destfile; + if ( !$result ){ print_error ("Copying $onefile to CWS failed: $!", 1) }; + } + } + } + } + + # create links & copy all projects from %obligatory_modules + my $src_dest = "$dir/src.$milestone"; + +# print "@found_sdirs\n"; + if ( ! -d $src_dest ) + { + $result = mkpath($src_dest, 0, 0777-$umask); + if ( !$result ){ print_error ("Cannot create source tree $src_dest : $!", 1) }; + } + + if ( $accessmaster ) + { + $result = opendir( SOURCE, "$wslocation/$master/src.$milestone"); + if ( !$result ){ print_error ("Source dir of master workspace not accessible: $!", 1) }; + my @found_sdirs = readdir( SOURCE ); + closedir( SOURCE ); + + if ( !@found_sdirs ) + { + print_error("No valid source tree to copy", 0); + $success = 0; + } + foreach my $onesdir ( @found_sdirs ) + { + next if ( $onesdir =~ /^\.+$/ ); + + # copy modules which are required to be accessable with their + # orginal name without .lnk extension + if (defined $obligatory_modules{$onesdir}) { + ©prj_module($onesdir, $src_dest); + next ; + }; + if ( -d "$wslocation/$master/src.$milestone/$onesdir" ) + { + if ( -l "$src_dest/$onesdir.lnk" && + readlink( "$src_dest/$onesdir.lnk" ) eq "$wslocation/$master/src.$milestone/$onesdir" ) + { + next; + } else { + # better... + $result = symlink( "$wslocation/$master/src.$milestone/$onesdir", "$src_dest/$onesdir.lnk"); + } + if ( !$result ) { + print_error ( "Couldn't create link from $wslocation/$master/src.$milestone/$onesdir to $src_dest/$onesdir", 0); + $success = 0; + }; + } + } + } + # if we get here no critical error happend +# return 0; # ause - disable all further steps + return $success; +} + +# +# Procedure copies module to specified path +# +sub copyprj_module { + + require CopyPrj; import CopyPrj; + + my $module_name = shift; + my $src_dest = shift; + + # hash, that should contain all the + # data needed by CopyPrj module + my %ENVHASH = (); + my %projects_to_copy = (); + $ENVHASH{'projects_hash'} = \%projects_to_copy; + $ENVHASH{'no_otree'} = 1; + $ENVHASH{'no_path'} = 1; + $ENVHASH{'only_otree'} = 0; + $ENVHASH{'only_update'} = 1; + $ENVHASH{'last_minor'} = 0; + $ENVHASH{'spec_src'} = 0; + $ENVHASH{'dest'} = "$src_dest"; + $ENVHASH{'prj_to_copy'} = ''; + $ENVHASH{'i_server'} = ''; + $ENVHASH{'current_dir'} = cwd(); + $ENVHASH{'remote'} = ''; + $ENVHASH{'force_checkout'} = 1 if ($force_checkout); + + $projects_to_copy{$module_name}++; + + CopyPrj::copy_projects(\%ENVHASH); + +}; + +sub register_workspace +{ + # register child workspace with eis + my $cws = shift; + + my $milestone = $cws->milestone(); + my $child = $cws->child(); + my $master = $cws->master(); + + # collect some misc. information + my $hostname = hostname(); + my $dir = $opt_dir ? $opt_dir : cwd(); + my $abspath = File::Spec->rel2abs("$dir/$child"); + my $vcsid = $ENV{VCSID}; + + if ( $is_promotion ) { + my $rc = $cws->promote($vcsid, "$hostname:$abspath"); + + if ( !$rc ) { + print_error("Failed to promote child workspace '$child' to status 'new'.\n", 5); + } + else { + print "\n***** Successfully ***** promoted child workspace '$child' to status 'new'.\n"; + print "Milestone: '$milestone'.\n"; + return 1; + } + } + else { + + my $eis_id = $cws->register($vcsid, "$hostname:$abspath"); + + if ( !defined($eis_id) ) { + print_error("Failed to register child workspace '$child' for master '$master'.", 5); + } + else { + print "\n***** Successfully ***** registered child workspace '$child'\n"; + print "for master workspace '$master' (milestone '$milestone').\n"; + print "Child workspace Id: $eis_id.\n"; + return 1; + } + } + return 0; +} + +sub print_error +{ + my $message = shift; + my $error_code = shift; + + print STDERR "$script_name: "; + print STDERR "ERROR: $message\n"; + + if ( $error_code ) { + print STDERR "\n***** FAILURE: $script_name aborted. *****\n"; + $log->end_log_extended($script_name,$vcsid,$message) if defined($log); + exit($error_code); + } +} + +sub print_message +{ + my $message = shift; + + print "$script_name: "; + print "$message\n"; + return; +} + +sub print_warning +{ + my $message = shift; + + print STDERR "$script_name: "; + print STDERR "WARNING: $message\n"; + return; +} + +sub usage +{ + print STDERR "Usage: cwscreate [-a] [-d dir] [-p <p1,...>] <mws_name> <milestone> <cws_name>\n"; + print STDERR "Creates a new child workspace <cws_name> for\n"; + print STDERR "milestone <milestone> of master workspace <mws_name>.\n"; + print STDERR "Options:\n"; + print STDERR " -h help\n"; + print STDERR " -a use cvs checkout instead of copying\n"; + print STDERR " -d dir create workspace in directory dir\n"; + print STDERR " -p p1,p2,p3 only create workspace for specified platforms\n"; +} diff --git a/solenv/bin/cwsquery b/solenv/bin/cwsquery new file mode 100755 index 000000000000..4aa0eb9c6eac --- /dev/null +++ b/solenv/bin/cwsquery @@ -0,0 +1,6 @@ +#!/bin/sh +if [ x${SOLARENV}x = xx ]; then + echo No environment found, please use 'configure' or 'setsolar' + exit 1 +fi +exec perl -w $SOLARENV/cwsquery.pl "$@" diff --git a/solenv/bin/cwsquery.pl b/solenv/bin/cwsquery.pl new file mode 100644 index 000000000000..c3ce3da27955 --- /dev/null +++ b/solenv/bin/cwsquery.pl @@ -0,0 +1,281 @@ +: +eval 'exec perl -wS $0 ${1+"$@"}' + if 0; +#************************************************************************* +# +# $RCSfile: cwsquery.pl,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:23:20 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + +# +# cwsquery.pl - query misc. information from CWS +# + +use strict; +use Getopt::Long; +use Cwd; + +#### module lookup + +use lib ("$ENV{SOLARENV}/bin/modules"); +if (defined $ENV{COMMON_ENV_TOOLS}) { + unshift(@INC, "$ENV{COMMON_ENV_TOOLS}/modules"); +}; +use Cws; + +#### script id ##### + +( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; + +my $script_rev; +my $id_str = ' $Revision: 1.2 $ '; +$id_str =~ /Revision:\s+(\S+)\s+\$/ + ? ($script_rev = $1) : ($script_rev = "-"); + +print STDERR "$script_name -- version: $script_rev\n"; + +#### global ##### + +my $is_debug = 1; # enable debug +my $opt_master = ''; # option: master workspace +my $opt_child = ''; # option: child workspace + +# list of available query modes +my @query_modes = qw(modules taskids state latest); +my %query_modes_hash = (); +foreach (@query_modes) { + $query_modes_hash{$_}++; +} + +#### main ##### + +my $query_mode = parse_options(); +query_cws($query_mode); +exit(0); + +#### subroutines #### + +sub query_cws +{ + my $query_mode = shift; + # get master and child workspace + my $masterws = $opt_master ? uc($opt_master) : $ENV{WORK_STAMP}; + my $childws = $opt_child ? $opt_child : $ENV{CWS_WORK_STAMP}; + + if ( !defined($masterws) ) { + print_error("Can't determine master workspace environment.\n" + . "Please initialize environment with setsolar ...", 1); + } + + if ( !defined($childws) && $query_mode ne 'latest' ) { + print_error("Can't determine child workspace environment.\n" + . "Please initialize environment with setsolar ...", 1); + } + + my $cws = Cws->new(); + $cws->child($childws); + $cws->master($masterws); + + no strict; + &{"query_".$query_mode}($cws); + exit(0) +} + +sub query_modules +{ + my $cws = shift; + + if ( is_valid_cws($cws) ) { + my @modules = $cws->modules(); + print_message("Modules:"); + foreach (@modules) { + 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) { + print "$_\n"; + } + } + return; +} + +sub query_state +{ + my $cws = shift; + + if ( is_valid_cws($cws) ) { + my $state = $cws->get_approval(); + if ( !$state ) { + print_error("Internal error: can't get approval status.", 3); + } else { + print_message("Approval status:"); + print "$state\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 resync: '$masterws $latest'"); + } + else { + print_error("Can't determine latest milestone of '$masterws' available for resync.", 3); + } + + 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_message("Master workspace '$masterws', child workspace '$childws':"); + return 1; +} + +sub parse_options +{ + # parse options and do some sanity checks + my $help = 0; + my $success = GetOptions('h' => \$help, 'm=s' => \$opt_master, 'c=s'=> \$opt_child); + if ( $help || !$success || $#ARGV < 0 ) { + usage(); + exit(1); + } + + # there will be more query modes over time + if ( !exists $query_modes_hash{lc($ARGV[0])} ) { + usage(); + exit(1); + } + return lc($ARGV[0]); +} + +sub print_message +{ + my $message = shift; + + print STDERR "$script_name: "; + print STDERR "$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 "Usage: cwsquery [-h] [-m master] [-c child] <modules|taskIDs|state>\n"; + print STDERR " cwsquery [-h] [-m master] <latest>\n"; + print STDERR "Query child workspace for miscancellous information.\n"; + print STDERR "Modes:\n"; + print STDERR "\tmodules\t\tquery modules added to the CWS\n"; + print STDERR "\ttaskids\t\tquery taskids to be handled on the CWS\n"; + print STDERR "\tstate\t\tquery approval status of CWS\n"; + print STDERR "\tlatest\t\tquery the latest milestone available for resync\n"; + print STDERR "Options:\n"; + print STDERR "\t-h\t\thelp\n"; + print STDERR "\t-m master\toverride MWS specified in environment\n"; + print STDERR "\t-c child\toverride CWS specified in environment\n"; + print STDERR "Examples:\n"; + print STDERR "\tcwsquery modules \n"; + print STDERR "\tcwsquery -m SRX644 -c uno4 modules \n"; + print STDERR "\tcwsquery -m SRX645 -c pmselectedfixes state\n"; + print STDERR "\tcwsquery taskids\n"; + print STDERR "\tcwsquery -m SRC680 latest\n"; + +} diff --git a/solenv/bin/cwsresync b/solenv/bin/cwsresync new file mode 100755 index 000000000000..ddf23453e92d --- /dev/null +++ b/solenv/bin/cwsresync @@ -0,0 +1,6 @@ +#!/bin/sh +if [ x${SOLARENV}x = xx ]; then + echo No environment found, please use 'configure' or 'setsolar' + exit 1 +fi +exec perl -w $SOLARENV/cwsresync.pl "$@" diff --git a/solenv/bin/cwsresync.pl b/solenv/bin/cwsresync.pl new file mode 100755 index 000000000000..ec34d27c0ed4 --- /dev/null +++ b/solenv/bin/cwsresync.pl @@ -0,0 +1,1754 @@ +: +eval 'exec perl -wS $0 ${1+"$@"}' + if 0; +#************************************************************************* +# +# $RCSfile: cwsresync.pl,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:23:20 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + +# +# cwsresync.pl - sync child workspace modules/files with newer +# milestones of master workspace +# + +use strict; +use Cwd; +use File::Basename; +use File::Copy; +use File::Find; +use File::Glob; +use File::Path; +use Getopt::Long; +use IO::Handle; + +#### module lookup + +use lib ("$ENV{SOLARENV}/bin/modules"); +if (defined $ENV{COMMON_ENV_TOOLS}) { + unshift(@INC, "$ENV{COMMON_ENV_TOOLS}/modules"); +}; + +use Cws; +eval { require Logging; import Logging; }; +my $log = undef; +$log = Logging->new() if (!$@); + +eval { + require EnvHelper; import EnvHelper; + require CopyPrj; import CopyPrj; +}; +use CvsModule; +use Cvs; +use GenInfoParser; +use CwsConfig; + +#### script id ##### + +( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; + +my $script_rev; +my $id_str = ' $Revision: 1.2 $ '; +$id_str =~ /Revision:\s+(\S+)\s+\$/ + ? ($script_rev = $1) : ($script_rev = "-"); + +print "$script_name -- version: $script_rev\n"; + +#### hardcoded globals ##### + +my @xtra_files = ( "*.mk", "*.flg", "libCrun*", "libgcc*", "libstdc*", "OOoRunner.jar" ); +my $platform_resynced_flag = ".cwsresync_complete"; + +# modules to be obligatory copied to each cws +my %obligatory_modules = (); +$obligatory_modules{'solenv'}++; +$obligatory_modules{'res'}++; +$obligatory_modules{'so_res'}++; +$obligatory_modules{'instset'}++; +$obligatory_modules{'instsetoo'}++; +$obligatory_modules{'smoketest'}++; +$obligatory_modules{'smoketest_oo'}++; +$obligatory_modules{'test10'}++; + +#### global ##### + +my $is_debug = 0; # misc traces for debugging purposes +my $opt_commit = 0; # commit changes +my $opt_merge = 0; # merge from MWS into CWS +my $opt_link = 0; # relink modules, update solver +my $remove_trees = 0; # remove output trees & solver (OO option) +my %global_stats = (); # some overall stats +my @args_bak = @ARGV; # store the @ARGS here for logging + +my $umask = umask(); +if ( !defined($umask) ) { + $umask = 22; +} +my $force_checkout = ''; + +#### main ##### +my $parameter_list = $log->array2string(";",@args_bak) if (defined $log); + +my ($dir, $milestone, @args) = parse_options(); +my $cws = get_and_verify_cws(); +my @action_list = parse_args($cws, $dir, @args); +walk_action_list($cws, $dir, $milestone, @action_list); +&log_stats(); +exit(0); + +#### subroutines #### + +sub log_stats + { + my $statistic_log_message; + $statistic_log_message = "success : "; + $statistic_log_message .= "merge mode : " if $opt_merge; + $statistic_log_message .= "commit mode : " if $opt_commit; + $statistic_log_message .= "link mode : " if $opt_link; + $statistic_log_message .= "remove output trees mode : " if $remove_trees; + $statistic_log_message .= "new: $global_stats{'new'} " if $global_stats{'new'}; + $statistic_log_message .= "removed: $global_stats{'removed'} " if $global_stats{'removed'}; + $statistic_log_message .= "merged: $global_stats{'merged'} " if $global_stats{'merged'}; + $statistic_log_message .= "moved: $global_stats{'moved'} " if $global_stats{'moved'}; + $statistic_log_message .= "conflicts: $global_stats{'conflict'} " if $global_stats{'conflict'}; + $statistic_log_message .= "alerts: $global_stats{'alert'} " if $global_stats{'alert'}; + $statistic_log_message .= "failures: $global_stats{'failure'} " if $global_stats{'failure'}; + $log->end_log_extended($script_name,"unknown",$statistic_log_message) if (defined $log); +} ##create_log_stats + +# Get child workspace from environment. +sub get_and_verify_cws +{ + my $childws = $ENV{CWS_WORK_STAMP}; + my $masterws = $ENV{WORK_STAMP}; + + if ( !defined($childws) || !defined($masterws) ) { + print_error("Can't determine child workspace environment.\n" + . "Please initialize environment with setsolar ...", 1); + } + + my $cws = Cws->new(); + $cws->child($childws); + $cws->master($masterws); + $log->start_log_extended($script_name,$parameter_list,$masterws,$childws) if (defined $log); + + # check if we got a valid child workspace + my $id = $cws->eis_id(); + print "Master: $masterws, Child: $childws, $id\n" if $is_debug; + if ( !$id ) { + print_error("Child workspace $childws for master workspace $masterws not found in EIS database.", 2); + } + return $cws; +} + +# Parse options and do some sanity checks; +sub parse_options +{ my $dir = 0; + my $help = 0; + my $success = GetOptions('h' => \$help, 'd=s' => \$dir, + 'm=s' => \$opt_merge, 'c' => \$opt_commit, 'l=s' => \$opt_link, + '-a' => \$force_checkout, '-r' => \$remove_trees); + if ( !$success || $help ) { + usage(); + exit(1); + } + + # some sanity checks + if ( !($opt_merge || $opt_commit || $opt_link || $remove_trees) ) { + print_error("Please specify one of '-m', '-c', '-l'.", 0) if defined($log); + print_error("Please specify one of '-m', '-c', '-l', '-r'.", 0) if !defined($log); + usage(); + exit(1); + } + + if ( ($opt_merge || $opt_commit) && !@ARGV ) { + usage(); + exit(1); + } + + my $qualified_milestone = $opt_merge || $opt_link; + if ( !check_milestone($qualified_milestone) ) { + print_error("Invalid milestone '$qualified_milestone'.", 0); + usage(); + exit(1); + } + + if ( ($opt_merge && $opt_commit) || + ($opt_merge && $opt_link) || + ($opt_commit && $opt_link) ) + { + print_error("The options '-m milestone', '-c', '-l milestone' are mutally exclusive.", 0); + usage(); + exit(1); + } + + if ( $opt_link && $dir ) { + print_error("The options '-l milestone' and '-d' are mutally exclusive.", 0); + usage(); + exit(1); + } + + $dir = $dir ? $dir : cwd(); + + # check directory + if ( ! -d $dir ) { + print_error("'$dir' is not a directory.", 1); + } + if ( ! -w $dir ) { + print_error("Can't write to directory '$dir'.", 1); + } + + return ($dir, $qualified_milestone, @ARGV); +} + +# Parse and verify args. Check that all necessary preconditions are fullfilled +# and fill the action_list +sub parse_args +{ + my $cws = shift; + my $dir = shift; + my @args = @_; + + # For each entry in the args list we'll prepare a corresponding entry + # in the action list. An arg may be a module, a dir in a cvs module + # or a file in a cvs module. With each arg is an action associated, + # this may be 'resync_module_action', 'resync_dir_action', 'resync_file_action', + # 'commit_dir_action', 'commit_file_action' or 'relink_cws_action' depending on the + # type of the arg and the operation mode + + # The action list has the following format + # $action_list [$i] = [$arg, $action] + my @action_list = (); + + # The 'merge' and 'commit' modes share quite a bit of logic. The 'link' mode + # is completely independent + + if ( (@args > 0) && ($opt_link || $remove_trees)) { + print_error("Invalid argument.", 0); + usage(); + exit(1); + } + if ( $opt_link ) { + push(@action_list, [undef, 'relink_cws_action']); + } elsif ($remove_trees) { + push(@action_list, [undef, 'remove_output_trees']); + } + else { + # Sanity check + if ( @args > 1) { + foreach (@args) { + if ($_ eq 'all') { + print_error("either specify 'all' or a list of modules/files.", 1); + } + } + } + + + if ( is_in_module($dir) ) { + # check arguments for inside module operation + check_or_exit($cws, $dir, @args); + foreach my $arg (@args) { + if ( -f $arg ) { + my $action = $opt_commit ? 'commit_file_action' : 'resync_file_action'; + push(@action_list, [$arg, $action]); + } + else { + my $action = $opt_commit ? 'commit_dir_action' : 'resync_dir_action'; + push(@action_list, [$arg, $action]); + } + } + } + else { + my @modules = expand_and_verify_modules($cws, @args); + # check arguments for modules level operation + if ( is_scratch_dir($dir) ) { + my $action = $opt_commit ? 'commit_dir_action' : 'resync_module_action'; + foreach (@modules) { + push(@action_list, [$_, $action]); + } + } + else { + check_or_exit($cws, $dir, @modules); + my $action = $opt_commit ? 'commit_dir_action' : 'resync_dir_action'; + foreach (@modules) { + push(@action_list, [$_, $action]); + } + } + } + } + return @action_list; +} + +# Check if all arguments are physically present on the disk +# either as files or directories +sub check_or_exit +{ + my $cws = shift; + my $dir = shift; + my @args = @_; + + my $error; + + foreach my $arg (@args) { + if ( ! -e "$dir/$arg" ) { + print_error("Can't find '$dir/$arg': $!", 0); + $error++; + } + } + if ( $error ) { + print_error("Please run '$script_name -m' either in an empty scratch directory,", 0); + print_error("or in a diretory containing all specified modules,", 0); + print_error("or, if inside a module,", 0); + print_error("make certain that all specified files/directories exist.", 2); + } + + foreach my $arg (@args) { + my $cvs_dir = "$dir/$arg"; + $cvs_dir = dirname("$cvs_dir") if -f $cvs_dir; + if ( !check_sticky_tag($cws, $cvs_dir) ) { + print_error("'$cvs_dir' has not the required sticky tag.", 3); + } + } + return; +} + +# Check if we operate inside a module. +sub is_in_module +{ + my $dir = shift; + return -d "$dir/CVS" ? 1 : 0; +} + +# Check if directory contains modules +sub is_modules_level +{ + my $dir = shift; + + return 0 if is_in_module($dir); + + my @cvsdirs = glob("$dir/*/CVS"); + return @cvsdirs ? 1 : 0; +} + +# Check if directory is a scratch directory +sub is_scratch_dir +{ + my $dir = shift; + return (is_in_module($dir) || is_modules_level($dir)) ? 0 : 1; +} + +# Check if requested modules are registered with child workspace. +sub expand_and_verify_modules +{ + my $cws = shift; + my @modules = @_; + + my @registered_modules = $cws->modules(); + my $child = $cws->child(); + + # call with empty modules list + return @registered_modules if $modules[0] eq 'all'; + + # create hash for easier searching + my %registered_modules_hash = (); + for (@registered_modules) { + $registered_modules_hash{$_}++; + } + + foreach (@modules) { + if ( !exists $registered_modules_hash{$_} ) { + print_error("Module '$_' is not registered for child '$child'.", 2); + } + } + return @modules; +} + +# Process the action list +sub walk_action_list +{ + my $cws = shift; + my $dir = shift; + my $qualified_milestone = shift; + my @action_list = @_; + + foreach my $entry_ref (@action_list) { + no strict; # disable strict refs for the next call + &{$entry_ref->[1]}($cws, $dir, $qualified_milestone, $entry_ref->[0]); + } + + # emit some stats + print_message(" ========== Totals: ==========") if scalar(%global_stats); + if ( $opt_merge) { + print_message("New file(s): $global_stats{'new'}") if $global_stats{'new'}; + print_message("Remove file(s): $global_stats{'removed'}") if $global_stats{'removed'}; + print_message("Merge file(s): $global_stats{'merged'}") if $global_stats{'merged'}; + print_message("Conflict(s): $global_stats{'conflict'}") if $global_stats{'conflict'}; + print_message("Move tag(s): $global_stats{'moved'}") if $global_stats{'moved'}; + print_message("Alert(s): $global_stats{'alert'}") if $global_stats{'alert'}; + print_message("Failure(s): $global_stats{'failure'}") if $global_stats{'failure'}; + } + else { + print_message("New file(s): $global_stats{'new'}") if $global_stats{'new'}; + print_message("Removed file(s): $global_stats{'removed'}") if $global_stats{'removed'}; + print_message("Merged file(s): $global_stats{'merged'}") if $global_stats{'merged'}; + print_message("Moved tag(s): $global_stats{'moved'}") if $global_stats{'moved'}; + print_message("Failure(s): $global_stats{'failure'}") if $global_stats{'failure'}; + } + return; +} + +# Merge a whole module in scratch space. Please note that merging +# a complete module is always done via resync_dir_action if it already +# exists on disk. +sub resync_module_action +{ + my $cws = shift; + my $dir = shift; + my $qualified_milestone = shift; + my $module = shift; + + my ($master_branch_tag, $cws_branch_tag, $cws_anchor_tag) = $cws->get_tags(); + my $milestone_tag = get_milestone_tag($cws, $qualified_milestone); + my $cvs_module = get_cvs_module($cws, $module); + STDOUT->autoflush(1); + print_message("Check out module '$module' ..."); + $cvs_module->verbose(1); + my $co_ref = $cvs_module->checkout($dir, $cws_branch_tag, ''); + STDOUT->autoflush(0); + if ( !@{$co_ref} ) { + print_error("Was not able to checkout module '$module',", 0); + print_error("this might be caused by connection failures or authentication problems. That also can be caused by cvs mirror. If you recently added this module, please wait for your mirror server to syncronize", 0); + print_error("Please check your \$HOME/.cvspass for missing entries!", 50); + } + + my $changes_ref = get_changed_files($cvs_module, $cws_anchor_tag, $milestone_tag); + + my $save_dir = cwd(); + # chdir into module + if ( !chdir("$dir/$module") ) { + print_error("Can't chdir() to '$dir/$module'", 6); + } + + my %stats; + foreach my $file_ref (@{$changes_ref}) { + my $rc = merge_file($cws_anchor_tag, $milestone_tag, $file_ref); + $stats{$rc}++; + $global_stats{$rc}++; + } + + # chdir back + chdir($save_dir); + print_message(" ========== '$module' stats: ==========") if scalar(%stats); + print_message("New file(s): $stats{'new'}") if $stats{'new'}; + print_message("Remove file(s): $stats{'removed'}") if $stats{'removed'}; + print_message("Merge file(s): $stats{'merged'}") if $stats{'merged'}; + print_message("Conflict(s): $stats{'conflict'}") if $stats{'conflict'}; + print_message("Move tag(s): $stats{'moved'}") if $stats{'moved'}; + print_message("Alert(s): $stats{'alert'}") if $stats{'alert'}; + print_message("Failure(s): $stats{'failure'}") if $stats{'failure'}; + return; +} + +# resync_dir_action: not yet implemented +sub resync_dir_action +{ + my $cws = shift; + my $dir = shift; + my $qualified_milestone = shift; + my $cvs_dir = shift; + + print_error("Resyncing directories is not yet supported.", 0); + print_error("Please resync either complete modules in a scratch", 0); + print_error("directory or resync files,", 99); + + return; +} + +sub resync_file_action +{ + my $cws = shift; + my $dir = shift; + my $qualified_milestone = shift; + my $file = shift; + + my ($master_branch_tag, $cws_branch_tag, $cws_anchor_tag) = $cws->get_tags(); + my $milestone_tag = get_milestone_tag($cws, $qualified_milestone); + my $cvs_archive = get_cvs_archive($file); + + my $tags_ref = $cvs_archive->get_tags(); + my $old_rev = $tags_ref->{$cws_anchor_tag}; + my $new_rev = $tags_ref->{$milestone_tag}; + + # File has been removed on master + if ( !$new_rev ) { + $old_rev = undef; # follow the example of get_changed_files() reg. removed files + } + + # skip files which are up to date with milestone + if ( $old_rev eq $new_rev ) { + print_message("\tResyncing '$file': skip (old rev. and new rev. are identical)."); + return; + } + + my $rc = merge_file($cws_anchor_tag, $milestone_tag, [$file, $old_rev, $new_rev], $cvs_archive); + $global_stats{$rc}++; + return; +} + +sub commit_dir_action +{ + my $cws = shift; + my $dir = shift; + my $qualified_milestone = shift; # unused and not initialized + my $cvs_dir = shift; + + print_message("========== Commit changes to '$cvs_dir': =========="); + + my $save_dir = cwd(); + + # chdir into module + if ( !chdir("$dir/$cvs_dir") ) { + print_error("Can't chdir() to '$cvs_dir'", 6); + } + + local @main::changed_files; + find(\&wanted, '.'); + + my %stats; + my $rc; + foreach (@main::changed_files) { + $rc = commit_file($cws, $_); + $stats{$rc}++; + $global_stats{$rc}++; + } + # chdir back + chdir($save_dir); + + print_message(" ========== '$cvs_dir' stats: ==========") if scalar(%stats); + print_message("New file(s): $stats{'new'}") if $stats{'new'}; + print_message("Remove file(s): $stats{'removed'}") if $stats{'removed'}; + print_message("Merge file(s): $stats{'merged'}") if $stats{'merged'}; + print_message("Move tag(s): $stats{'moved'}") if $stats{'moved'}; + print_message("Failure(s): $stats{'failure'}") if $stats{'failure'}; + + return; +} + + +sub commit_file_action +{ + my $cws = shift; + my $dir = shift; + my $qualified_milestone = shift; # unused and not initialized + my $file = shift; + + my $save_dir = cwd(); + # chdir into the reference dir + if ( !chdir("$dir") ) { + print_error("Can't chdir() to '$dir'", 6); + } + my $rc = commit_file($cws, $file); + $global_stats{$rc}++; + # chdir back + chdir($save_dir); + return; +} + +# TODO: put into module later... see also cwsadd.pl +sub get_mws_location +{ + use GenInfoParser; + + my $masterws = shift; + my $result = 0; + + my $workspace_lst = EnvHelper::get_workspace_lst(); + my $workspace_db = GenInfoParser->new(); + $result = $workspace_db->load_list($workspace_lst); + if ( !$result ) { + print_message("Can't load workspace list '$workspace_lst'."); + return ""; + } + my $workspace = $workspace_db->get_key($masterws); + print_error("Master workspace '$masterws' not found in '$workspace_lst' database.", 3) if ( !$workspace ); + + my $wslocation = $workspace_db->get_value($masterws."/Drives/o:/UnixVolume"); + print_error("Location of master workspace '$masterws' not found in '$workspace_lst' database.", 3) if ( !defined($wslocation) ) ; + + if (! -d $wslocation) { + print_message("Master workspace not found!") ; + return ""; + } + return $wslocation; +} + +sub remove_module +{ + my $module_p = shift; + + my $result = 0; + + if ( -l $module_p ) { + print "unlink module $module_p\n" if $is_debug; + $result |= ! unlink $module_p; + } + if ( -l $module_p.".lnk" ) { + print "unlink module $module_p.lnk\n" if $is_debug; + $result |= ! unlink "$module_p.lnk"; + } + if ( -d $module_p ) { + print "rm -rf $module_p\n" if $is_debug; + $result |= system("rm -rf $module_p"); + + } elsif ( -e $module_p ) { + print "no idea what this is... $module_p\n" if $is_debug; + print_error("Couldn't remove $module_p\[.lnk\]. Giving up.", 1); + } + return $result; +} + +# +# Procedure copies module to specified path +# +sub copyprj_module +{ + + my $module_name = shift; + my $src_dest = shift; + print "copyprj $module_name\n"; + + # hash, that should contain all the + # data needed by CopyPrj module + my %ENVHASH = (); + my %projects_to_copy = (); + $ENVHASH{'projects_hash'} = \%projects_to_copy; + $ENVHASH{'no_otree'} = 1; + $ENVHASH{'no_path'} = 1; + $ENVHASH{'only_otree'} = 0; + $ENVHASH{'only_update'} = 1; + $ENVHASH{'last_minor'} = 0; + $ENVHASH{'spec_src'} = 0; + $ENVHASH{'dest'} = "$src_dest"; + $ENVHASH{'prj_to_copy'} = ''; + $ENVHASH{'i_server'} = ''; + $ENVHASH{'current_dir'} = cwd(); + $ENVHASH{'remote'} = ''; + $ENVHASH{'force_checkout'} = 1 if ($force_checkout); + + $projects_to_copy{$module_name}++; + + CopyPrj::copy_projects(\%ENVHASH); + +}; + +sub get_platforms_hash { + my $cws = shift; + my $minor_mk_name = $ENV{UPD} . 'minor.mk'; + my @files; + my %platforms = (); + find sub { push @files, $File::Find::name if -f _ && /$minor_mk_name/ }, $ENV{SOLARVER}; + foreach my $entry (@files) { + do { + $entry = dirname($entry); + } while ($entry =~ /[\\\/]inc[\.\w+]?$/o); + $platforms{basename($entry)}++; + }; + $platforms{$ENV{INPATH}}++; + return %platforms; +} + +# +# remove all output trees +# +sub remove_output_trees { + my $cws = shift; + my %platforms = get_platforms_hash($cws); + my $stand_dir = $ENV{SRC_ROOT}; + if (!opendir(SOURCE_ROOT, $stand_dir)) { + print_error ("Root dir of child workspace not accessible: $!", 1); + }; + my @found_dirs = readdir(SOURCE_ROOT); + closedir SOURCE_ROOT; + my $module_dir = ''; + my @warnings = (); + foreach my $module (@found_dirs) { + $module_dir = "$stand_dir/$module"; + next if (!-d $module_dir); + print_message("Removing output trees from $module..."); + foreach my $plarform (keys %platforms) { + my $output_tree = "$module_dir/$plarform"; + next if (!-d $output_tree); + if (!rmtree($output_tree, 0, 1)) { + push(@warnings, $output_tree); + }; + } + }; + print_message("Removing solver ..."); + foreach my $platform (keys %platforms) { + my $output_tree = $ENV{SOLARVERSION} . "/$platform"; + next if (!-d $output_tree); + if (!rmtree($output_tree, 0, 1)) { + push(@warnings, $output_tree); + }; + }; + print_warning("'$_' cannot be deleted. Please remove it manually") foreach(@warnings); + print_message("Please run configure & bootstrap again\n") if !defined($log); +}; + +# +# Update the sources to the correspondent master tag +# +sub update_sources { + my ($cws, $new_master, $milestone) = @_; + my @added_modules = $cws->modules(); + my %added_modules_hash = (); + my ($master_branch_tag, $cws_branch_tag, $cws_root_tag) = $cws->get_tags($new_master, $milestone); + my $master_milestone_tag = $cws->get_master_tag($new_master, $milestone); + my $stand_dir = $ENV{SRC_ROOT}; + $added_modules_hash{$_}++ foreach (@added_modules); + if (!opendir(SOURCE_ROOT, $stand_dir)) { + print_error("Root dir of child ($stand_dir) workspace not accessible: $!", 1); + }; + my @found_dirs = readdir(SOURCE_ROOT); + closedir SOURCE_ROOT; + my $cvs_module = CvsModule->new(); + my %cvs_aliases = $cvs_module->get_aliases_hash(); + my $result = ''; + foreach my $module (@found_dirs) { + next if (!-d $stand_dir . "/$module/CVS"); + print "\tUpdating '$module'"; + $cvs_module->module($module); + if (defined $added_modules_hash{$module}) { + print " with '$cws_branch_tag' ...\n"; + $result = $cvs_module->update($stand_dir, $cws_branch_tag, '-dP'); + delete $added_modules_hash{$module}; + } elsif (defined $cvs_aliases{$module}) { + print " with $master_milestone_tag' ...\n"; + $result = $cvs_module->update($stand_dir, $master_milestone_tag, '-dP'); + } else { + print_warning("... Unknown module. Skipping..."); + next; + }; + $cvs_module->handle_update_infomation($result); + }; + register_cws_milestone($cws, $new_master, $milestone); + return; +}; + +sub register_cws_milestone { + my ($cws, $new_master, $milestone) = @_; + my $push_return = ''; + if ( $cws->master() ne $new_master ) { + $push_return = $cws->master($new_master); + if ($push_return ne $new_master) { + print_error("Couldn't push new milestone to database", 1); + }; + } + $push_return = $cws->milestone( $milestone ); + if ( $push_return ne $milestone ) { + print_error("Couldn't push new milestone to database", 1); + } + print_message("Current milestone of CWS updated to '$milestone'."); + print_message("Remove the old and most likely incompatible module output trees and solver with:"); + print_message("\tcwsresync -r"); + + +} + +# Implements the link action: relink all modules and update solver +sub relink_cws_action +{ + my $cws = shift; + my $dir = shift; # ignore, this is never set + my $qualified_milestone = shift; + + my $cws_master = $cws->master(); + + my ($new_master, $milestone); + if ( $qualified_milestone =~ /:/ ) { + ($new_master, $milestone) = split(/:/, $qualified_milestone); + } + else { + $new_master = $cws_master; + $milestone = $qualified_milestone; + } + + # ause: Deine Spielwiese + + no warnings; + my $result = 0; + my $success = 0; + my $sourceroot; + my $mws_location; + my $mws_accessible = 0; + my $dest_dir; + my @found_platforms; + my @opt_platforms; + my $found_resync_flags = 0; + + print_message("Doing some checks ..."); + + # hack to get the mileston :-((((( + if ( ! defined($cws->milestone())) + { + $cws->milestone($ENV{UPDMINOR});# = $ENV{UPDMINOR}; + } + + # milestone is different from the current milestone + if ( "$new_master" eq "$cws_master" ) { + print_error("Child workspace \"".$cws->child()."\" already based on milestone \"$milestone\"", 1) if $cws->milestone() eq $milestone; + } + return update_sources($cws, $new_master, $milestone) if (!defined $log); # HACK + + # SOURCE_ROOT set correct + print_error("Environment variable \"SOURCE_ROOT\" not set.", 1) if ! defined($ENV{SOURCE_ROOT}); + $sourceroot = $ENV{SOURCE_ROOT}; + print_error("Environment variable \"SOURCE_ROOT\" pointing to something incorrect.", 1) if ! -d "$sourceroot/".$cws_master."/src.".$cws->milestone(); + + # desired milestone doesn't exist in cws dir or mws changes + if ( "$new_master" eq "$cws_master" ) { + print_error("Looks like there is already a milestone \"$milestone\" in $sourceroot/".$cws_master.".", 1) if -d "$sourceroot/".$cws_master."/src.$milestone"; + + my @checklist = glob( "$sourceroot/$cws_master/*/inc.$milestone/*.mk" ); + print_message("Looks like there is already a milestone \"$milestone\" in $sourceroot/".$cws_master." output trees.") if $#checklist != -1; + } + + # mws filesystem accessible + $mws_location = get_mws_location($new_master); + if ( "$mws_location" ne "" ) { + # our OS isn't windows + if ( $^O =~ "MSWin32" ) + { + print_error("Sorry! not for windows",2); + } + $mws_accessible = 1; + } else { + print_message("Trying without access to master workspace."); + $mws_accessible = 0; + } + + #check if sourceroot points to mws location + print "$sourceroot <-> $mws_location\n" if $is_debug; + my $mws_location_string = $mws_location; + if ( $mws_location_string =~ /\/net/ ) { + my @tmplst = split /\//, $mws_location; + print "list @tmplst\n" if $is_debug; + shift @tmplst; + shift @tmplst; + shift @tmplst; + print "list @tmplst\n" if $is_debug; + $mws_location_string = "/".join '/', @tmplst; + } + print "$sourceroot <-> $mws_location_string\n" if $is_debug; + if ( $sourceroot =~ /$mws_location_string/ ) { + print_error ("Root dir of child workspace and master directory are too similar\n$sourceroot <-> *$mws_location_string", 1) + } + + print_message("Updating solver."); + if ( $mws_accessible ) + { + require sync_dir; import sync_dir; + #TODO: check for complete mws milestone + + print_message("Removing previous solver..."); + # find all existing output trees in cws + $result = opendir( SOLVER, "$sourceroot/".$cws_master); + if ( !$result ){ print_error ("Root dir of child workspace not accessible: $!", 1) }; + my @found_dirs = readdir( SOLVER ); + closedir( SOLVER ); + + foreach my $dir_candidate ( @found_dirs ) + { + #remove . and .. + next if ( $dir_candidate eq "." || $dir_candidate eq ".." ); + # check for the remains of previous tries... + if ( -d "$sourceroot/$cws_master/$dir_candidate/inc.$milestone") { + # check if there is a complete tree + if ( -f "$sourceroot/$cws_master/$dir_candidate/inc.$milestone/$platform_resynced_flag" ) { + $found_resync_flags++; + next; + } + # try to remove rubbish... + $result = system("rm -rf $sourceroot/$cws_master/$dir_candidate/*.$milestone"); + if ( $result ) { + print_error( "Couldn't cleanup \"$sourceroot/$cws_master/$dir_candidate/*.$milestone\". Please do manually!", 1 ); + } + # ...and fake the old minor. + $result = mkpath( "$sourceroot/".$cws_master."/$dir_candidate/inc.".$cws->milestone(), 0, 0777-$umask); + } + if ( -d "$sourceroot/".$cws_master."/$dir_candidate/inc.".$cws->milestone() ) + { + push @found_platforms, $dir_candidate; + } + } + if ( !@found_platforms ) + { + print_message("No output trees to remove"); + $success = 0; + } + + # remove them + $result = 0; + foreach my $platform ( @found_platforms ) { + next if ( -f "$sourceroot/$cws_master/$platform/inc.$milestone/$platform_resynced_flag" ); + print_message("Removing $platform"); + if ( -d "$sourceroot/$cws_master/$platform") { + # make sure it's recognized when restarting + my $tmp_result = mkpath( "$sourceroot/$cws_master/$platform/inc.$milestone", 0, 0777-$umask); + $result |= system("rm -rf $sourceroot/$cws_master/$platform/*.".$cws->milestone()); + } else { + print_error("\"$sourceroot/$cws_master/$platform\" isn't a directory,", 0); + print_error("trying to rename...", 0); + $result |= system("mv $sourceroot/$cws_master/$platform $sourceroot/$cws_master/$platform.renamed"); + } + } + + print_error("Couldn\'t remove existing solver on child workspace.", 1) if $result; + + # find all existing output trees in mws or use list + # no opt list yet - take the trees that were use before resync + @opt_platforms = @found_platforms; + @found_platforms = (); + # find platforms to copy + if ( $#opt_platforms != -1 || $found_resync_flags > 0 ) { + @found_platforms = map( lc, @opt_platforms ); + } else { + print_error("this is an implementaion bug!", 1); + } + # copy all wanted output trees + $sync_dir::do_keepzip = 1; + my $btarget = "instset"; + foreach my $platform ( @found_platforms ) + { + # don't copy tree that was already successfull + next if ( -f "$sourceroot/$cws_master/$platform/inc.$milestone/$platform_resynced_flag" ); + %sync_dir::done_hash = (); + print "Create copy of solver for $platform ( ~ 1GB disk space needed !)\n"; + my $zipsource = "$mws_location/".$new_master."/$platform/zip.$milestone"; + my $copy_dest = "$sourceroot/".$cws_master."/$platform/zip.$milestone"; + if ( -d "$sourceroot/".$cws_master."/$platform" ) + { + # print_error ("$dir/$platform : Please restart on a clean directory tree!", 1); + } + if ( ! -d $copy_dest ) + { + $result = mkpath($copy_dest, 0, 0777-$umask); + if ( !$result ){ print_error ("Cannot create output tree $copy_dest : $!", 1) }; + } + + my $unzip_dest = $copy_dest; + $unzip_dest =~ s/(.*)\/.*$/$1/; + + if ( ! -e "$unzip_dest/prepared" ) { + $result = sync_dir::prepare_minor_unzip( $unzip_dest, ".".$milestone ); + open( PREPARED, ">$unzip_dest/prepared"); + close( PREPARED ); + } + + STDOUT->autoflush(1); + $result = &sync_dir::recurse_unzip( $zipsource, $copy_dest, $btarget ); + STDOUT->autoflush(0); + if ( $result ) + { + # renaming back before exit + $result = sync_dir::finish_minor_unzip( $unzip_dest, ".".$milestone ); + print_error ("Copying files to $copy_dest failed : $!", 1); + } + $result = sync_dir::finish_minor_unzip( $unzip_dest, ".".$milestone ); + unlink "$unzip_dest/prepared.$milestone" if -e "$unzip_dest/prepared.$milestone"; + open( COMPLETE, ">$sourceroot/$cws_master/$platform/inc.$milestone/$platform_resynced_flag"); + close( COMPLETE ); + + } + foreach my $oneextra ( @xtra_files ) + { + my @globlist = glob( "$mws_location/".$new_master."/[!s]*/*.$milestone/$oneextra" ); + if ( $#globlist == -1 ) { + print "tried $oneextra in $mws_location/".$new_master."/[!s]*/*.$milestone/$oneextra\n"; + } + foreach my $onefile ( @globlist ) + { + my $destfile = $onefile; + my $m_dir = "$mws_location/".$new_master; + my $c_dir = "$sourceroot/".$cws_master; + $destfile =~ s#$m_dir#$c_dir#; + + if ( -d dirname( $destfile )) + { + $result = copy( $onefile, $destfile); + if ( !$result ){ print_error ("Copying $onefile to CWS failed: $!", 1) }; + } + } + } + + } else { + print_error("solver tree resync without mws access not yet implemented", 5); + } + print_message("Recreating CWS source tree with MWS milestone '$milestone'."); + if ( $mws_accessible ) { + # all but added modules + my @added_modules = $cws->modules(); + my %modules_hash =(); + print "debug: added modules: @added_modules\n" if $is_debug; + $result = opendir( SOURCE, "$mws_location/".$new_master."/src.".$milestone); + if ( !$result ){ print_error ("Source dir of master workspace not accessible: $!", 1) }; + my @mws_found_modules = readdir( SOURCE ); + closedir( SOURCE ); + foreach my $module (@mws_found_modules) { $modules_hash{$module}++; } + delete $modules_hash{"."}; + delete $modules_hash{".."}; + foreach my $module (@added_modules) { delete $modules_hash{$module}; } + + if ( !scalar(keys(%modules_hash)) ) + { + print_error("No valid source tree to copy", 0); + $success = 0; + } + print "debug: number of modules left: ".scalar(keys(%modules_hash))."\n" if $is_debug; + # now remove them + print_message("Removing old modules"); + $dest_dir = "$sourceroot/".$cws_master."/src.".$cws->milestone(); + $result = 0; + + # don't touch solenv if added + if ( defined $modules_hash{"solenv"} ) { + # backup "solenv" for restarting... + $result = system("mv $dest_dir/solenv $dest_dir/solenv.keep"); + print_error("Couldn't backup \"solenv\". You better check your tree...", 1) if $result; + } + + foreach my $module ( keys %modules_hash ) { + my $module_path = $dest_dir."/$module"; + $result |= remove_module( $module_path ); + } + + print_error("Couldn\'t cleanup source tree. Please check.", 1) if ( $result ); + + # copy instset, res, solenv, link all missing + # preparing pseudo environment for copyprj + $ENV{SRC_ROOT}="$mws_location/".$new_master."/src.$milestone"; + + $success = 1; + foreach my $module ( keys %modules_hash ) { + # copy modules which are required to be accessable with their + # orginal name without .lnk extension + if (defined $obligatory_modules{$module}) { + ©prj_module($module, $dest_dir); + next ; + }; + if ( -d "$mws_location/".$new_master."/src.$milestone/$module" ) { + if ( -l "$dest_dir/$module.lnk" && + readlink( "$dest_dir/$module.lnk" ) eq "$mws_location/".$new_master."/src.$milestone/$module" ) + { + next; + } else { + # better... + $result = symlink( "$mws_location/".$new_master."/src.$milestone/$module", "$dest_dir/$module.lnk"); + } + if ( !$result ) { + print_error ( "Couldn't create link from $mws_location/".$new_master."/src.$milestone/$module to $dest_dir/$module", 0); + $success = 0; + } + } + } + if ( defined $modules_hash{"solenv"} ) { + my $solenv_path = $dest_dir."/solenv.keep"; + $result |= remove_module( $solenv_path ); + } + + } else { + print_error("source tree resync without mws access not yet implemented", 5); + # remove all but added modules + # checkout all missing + } + + # rename src.* directory + rename $dest_dir, "$sourceroot/".$cws_master."/src.$milestone"; + + # TODO: check if return equals $milestone + my $push_return = $cws->milestone( $milestone ); + if ( $push_return ne $milestone ) { + print_error("Couldn't push new milestone to database"); + } else { + print_message("Successfully pushed new milestone to database"); + } + + # master changed? + if ( $cws_master ne $new_master ) { + # push new master if different + my $push_return = $cws->master( $new_master ); + if ( $push_return ne $new_master ) { + print_error("Couldn't push new milestone to database"); + } + + # rename WORKSPACE directory if different + chdir ($sourceroot) if ( cwd() eq "$sourceroot/cws_master" ); + rename "$sourceroot/$cws_master", "$sourceroot/$new_master"; + chdir ("$sourceroot/$new_master") if ( cwd() eq "$sourceroot" ); + } else { + print_message("Successfully pushed new master to database"); + } + + # resync done. now remove all $platform_resynced_flag + my @completelist = glob( "$sourceroot/$new_master/*/inc.$milestone/$platform_resynced_flag" ); + unlink( @completelist ); + return; +} + +# Low level merge file routine: +# Merge changes on master copy into the child copy of the file. +# Parameter $cvs_archive is optional and can be used to pass already available +# CVS archive objects to this routine. If not set it will create a new CVS +# archive object from the file named in $file_ref[0]. +# +# Note: The parameters are somewhat redundant. +# We do need both, the tags and the revisions which corresponds to the tags as +# parameter to this method. The tags are needed for proper CVS operation +# (think of added and removed files), the corresponding revisions are needed for +# informational purposes. It would be possible to look them up on a file by file +# basis via the tags but this is quite expensive. Considers this an optimization +# hack +sub merge_file +{ + my $cws_anchor_tag = shift; + my $milestone_tag = shift; + my $file_ref = shift; + my $cvs_archive = shift; + + my $file = $file_ref->[0]; + my $old_rev = $file_ref->[1]; + my $new_rev = $file_ref->[2]; + + my ($new_file, $removed_file); + print "\tResyncing '$file' "; + if ( !$old_rev && !$new_rev ) { + print "remove file: "; + $removed_file++; + } + elsif ( !$old_rev ) { + print "($new_rev) new file: "; + $new_file++; + } + else { + print "($old_rev-$new_rev): "; + } + + # Initialize CVS archive object if not passed to routine + $cvs_archive = get_cvs_archive($file) if !$cvs_archive; + + my ($status, $working_rev, $repository_rev, $sticky_tag, $branch_rev, + $sticky_date, $sticky_options); + + # A fresh CVS checkout with a branch label is always 'pruned'. Sanitize + # CVS hierarchy so that we can write out our .resync-files in any case. + sanitize_cvs_hierarchy($file); + if ( $new_file ) { + # Check if file has been added on two CWSs, once in this CWS + # and once in an already integrated CWS. + if ( -e $file ) { + # We alert the user and skip the file. + print "file has been added independently in MWS and CWS. Skipping. Please check!.\n"; + return 'alert'; + } + else { + write_resync_comment($file, 'new', undef, $new_rev); + print "added, schedule move tag.\n"; + return 'new'; + } + } + elsif ( $removed_file ) { + my $rc = $cvs_archive->update("-j$cws_anchor_tag -j$milestone_tag"); + if ( $rc eq 'success' ) { + print "removed, schedule commit.\n"; + write_resync_comment($file, 'removed', undef, undef); + return 'removed'; + } + else { + print "failure!\n"; + print_error("INTERNAL ERROR: can't resync file.", 0); + return 'failure'; + } + } + else{ + # Get status of file to be merged + ($status, $working_rev, $repository_rev, $sticky_tag, $branch_rev, + $sticky_date, $sticky_options) = $cvs_archive->status(); + if ( $status eq 'Up-to-date' && ! -e $file ) { + # Special case: file has been removed in CWS but there + # were changes between old and new MWS milestones. + # Resolution: Do nothing, skip this file. The file + # remains being removed on this CWS. + print "removed in CWS, but changes in MWS are pending. Please check!.\n"; + return 'alert'; + } + if ( $status eq 'unkownfailure' ) { + print_error("can't get status of '$file': $status", 0); + return 'failure'; + } + if ( $status eq 'Locally Modified' ) { + print_error("Can't merge locally modified file!", 0); + return 'failure'; + } + } + + # Check if we can get by by just moving the branch and the anchor tag + if ( !$removed_file && !$new_file && defined($branch_rev) + && $branch_rev =~ /$working_rev\.\d+/ ) { + write_resync_comment($file, 'moved', $old_rev, $new_rev); + print "schedule move tag.\n"; + return 'moved'; + } + + my $rc; + my $success; + if ( $sticky_options eq 'kb' ) { + # We got changes pending in the MWS and we + # have changes in the CWS. Since we can't merge + # binary files we give up here. Sure, we could + # either favor the MWS or the CWS version, but + # there is no way to decide which one is better. + # We alert the user and skip the file. + if ( 1 ) { # TODO check for file mode with explicit version selection + print "binary file has been changed in CWS and in MWS. Skipping. Please check!.\n"; + return 'alert'; + } + else { + # TODO implement explicit retrieval of version if in file mode and + # user requested either the CWS or MWS version + $rc = $cvs_archive->update("-j$cws_anchor_tag -j$milestone_tag"); + if ( $rc ne 'success' ) { + print "failure!\n"; + print_error("INTERNAL ERROR: can't resync binary file.", 0); + return 'failure'; + } + write_resync_comment($file, 'binary', undef, $new_rev); + print "binary, taking $new_rev.\n"; + $success = 'binary'; + } + } + else { + # option -kk needed for clean merge in source files + $rc = $cvs_archive->update("-kk -j$cws_anchor_tag -j$milestone_tag"); + if ( $rc eq 'success' ) { + print "merged, schedule commit.\n"; + $success = 'merged' + } + elsif ( $rc eq 'conflict' ) { + print "conflict, schedule commit after resolution.\n"; + $success = 'conflict'; + } + else { + print "failure!\n"; + print_error("INTERNAL ERROR: can't resync file.", 0); + return 'failure'; + } + write_resync_comment($file, 'merged', $old_rev, $new_rev); + } + return $success; +} + +# Low level commit file routine: +# Commits file to the childworkspace or move tags +# Requires a valid .resync file next to the CVS file +sub commit_file +{ + my $cws = shift; + my $file = shift; + + if ( !open(CHECKIN, "<$file.resync" ) ) { + print_error("can't open $file.resync: $!", 0); + return 'failure'; + } + my @resync_comment = <CHECKIN>; + close(CHECKIN); + + my ($type, $old_rev, $new_rev); + if ( $resync_comment[0] =~ /^RESYNC (\w+) ([\w\.]+) ([\w\.]+)$/ ) { + $type = lc($1); + $old_rev = $2; + $new_rev = $3; + } + else { + print_error("$file.resync has an invalid format", 0); + return 'failure'; + } + + if ( $type eq 'moved' || $type eq 'new') { + # just move the tags, no cvs->commit() + print "\tCommit '$file': move tag: "; + my $rc = move_tags($cws, $file, $new_rev); + if ( $rc ) { + print_error("can't unlink $file.resync: $!.", 0) unless unlink("$file.resync"); + } + return $rc ? 'moved' : 'failure'; + } + else { + # cvs->commit() + my $comment; + if ( $type eq 'merged' ) { + $comment = "RESYNC: ($old_rev-$new_rev); FILE MERGED\n"; + } + elsif ( $type eq 'binary' ) { + $comment = "RESYNC: ($new_rev); BINARY\n"; + } + elsif ( $type eq 'removed' ) { + $comment = "RESYNC:; FILE REMOVED\n"; + } + else { + # can't happen + print_error("internal_error commit_file(): unkown type: $type", 0); + } + + # prepare commit comment + shift(@resync_comment); shift(@resync_comment); + unshift(@resync_comment, $comment); + + print "\tCommit '$file': "; + my $rc = ci_file($cws, $file, $new_rev, \@resync_comment); + if ( $rc ) { + print_error("can't unlink $file.resync: $!.", 0) unless unlink("$file.resync"); + } + return $rc ? $type : 'failure'; + } + + return 'failure'; # should never be reached +} + +# Move CWS tags to new revision. +sub move_tags +{ + my $cws = shift; + my $file = shift; + my $new_rev = shift; + + my ($master_branch_tag, $cws_branch_tag, $cws_anchor_tag) = $cws->get_tags(); + my $cvs_archive = get_cvs_archive($file); + + my $rc = $cvs_archive->update("-r$new_rev"); + if ( $rc ne 'success' ) { + print_error("updating '$file' to new revision '$new_rev' failed.", 0); + return 0; + } + + $rc = $cvs_archive->tag($cws_branch_tag, '-F -b'); + if ( $rc ne 'success' ) { + print_error("Tagging '$file': tag operation returned: '$rc'.", 0); + print "failed!\n"; + return 0; + } + $rc = $cvs_archive->tag($cws_anchor_tag, '-F'); + if ( $rc ne 'success' ) { + print "failed!\n"; + print_error("Tagging '$file': tag operation returned: '$rc'.", 0); + return 0; + } + + $rc = $cvs_archive->update("-r$cws_branch_tag"); + if ( $rc ne 'success' ) { + print "failed!\n"; + print_error("updating '$file' to '$cws_branch_tag' failed.", 0); + return 0; + } + print "OK.\n"; + return 1; +} + +sub ci_file +{ + my $cws = shift; + my $file = shift; + my $new_rev = shift; + my $comment_ref = shift; + + my ($master_branch_tag, $cws_branch_tag, $cws_anchor_tag) = $cws->get_tags(); + + my $cvs_archive = get_cvs_archive($file); + + my ($rc, $rev); + my $skip_commit = 0; + if ( $new_rev eq 'none' && ! -e $file ) { + # check if file has been locally removed + my $status = $cvs_archive->status(); + if ( $status eq 'Up-to-date' ) { + # Ok, file has been removed on MWS and it has been also + # removed on the CWS. A commit will fail in this case + # so we don't bother. + $rev = 'nothing to remove'; + $skip_commit = 1; + } + } + + if ( !$skip_commit ) { + # comments may be huge, use a tempfile instead of passing + # them via the command line to the cvs client + if ( !open(COMMIT, ">$file.comment") ) { + print_error("can't open file '$file.comment'", 7); + } + print COMMIT @{$comment_ref}; + close(COMMIT); + ($rc, $rev) = $cvs_archive->commit("-F $file.comment"); + if ( !($rc eq 'success' || $rc eq 'nothingcommitted') ) { # nothingcommitted valid here + print "failed!\n"; + print_error("can't commit file '$file': $rc", 0); + return 0; + } + print_error("can't unlink $file.comment: $!.", 0) unless unlink("$file.comment"); + $rev = 'nothing to commit' if $rc eq 'nothingcommitted'; + } + + if ( $new_rev eq 'none' ) { + # Uh oh, file has been removed in master workspace. + # There is no easy way to find out in which revision + # exactly the file has been removed, but we know that + # it must be the top level revision of the master branch. + # In this case we can set the Anchor tag to the revision + # which corresponds to the head of the master branch. + $new_rev = $master_branch_tag ? $master_branch_tag : 'HEAD'; + } + + # tag with the anchor tag + $rc = $cvs_archive->tag("-F -r$new_rev $cws_anchor_tag"); + if ( $rc ne 'success' ) { + print "failed!\n"; + print_error("Tagging '$file': tag operation returned: '$rc'.", 0); + return 0; + } + print "$rev: OK.\n"; + return 1; +} + +sub write_resync_comment +{ + my $file = shift; + my $type = shift; + my $old_rev = shift || 'none'; + my $new_rev = shift || 'none'; + + if ( !open(RESYNC_COMMENT, ">$file.resync") ) { + print_error("can't open file '$file.resync'", 7); + } + my $uctype = uc($type); + print RESYNC_COMMENT "RESYNC $uctype $old_rev $new_rev\n"; + if ( $type ne 'moved' ) { + print RESYNC_COMMENT "Everything below this line will be added to the revision comment.\n"; + } + close(RESYNC_COMMENT); +} + +# Check if the CVS subdir is available or +# add it to the local CVS tree +sub sanitize_cvs_hierarchy +{ + my $file = shift; + + my $cvs_dir = dirname($file); + return if $cvs_dir eq '.'; # no need to check current dir + return if -d $cvs_dir; # directory exists, nothing to do + + my @elements = split(/\//, $cvs_dir); + + my $save_dir = cwd(); + + foreach ( @elements ) { + if ( ! -d $_ ) { + my $rc = mkdir($_); + print_error("can create directory '$_': $!", 9) unless $rc; + # TODO use a Cvs method for this + my $config = CwsConfig::get_config(); + my $cvs_binary = $config->cvs_binary(); + system("$cvs_binary add $_ > /dev/null 2>&1 "); + } + if ( !chdir($_) ) { + print_error("Can't chdir() to '$_'", 9); + } + } + + # chdir back + chdir($save_dir); +} + +sub wanted { + my $file = $_; + + my ($name, $path, $suffix) = fileparse($file,'\.\w+') if -f $file; + + if ( defined($suffix) && $suffix eq '.resync' ) { + my $cvs_file; + if ( length($File::Find::dir) > 2 ) { + my $dir = substr($File::Find::dir, 2); + $cvs_file = "$dir/$name"; + } + else { + $cvs_file = $name; + } + push(@main::changed_files, $cvs_file); + } +} + +sub check_sticky_tag +{ + my $cws = shift; + my $cvs_dir = shift; + + my ($master_branch_tag, $cws_branch_tag, $cws_anchor_tag) = $cws->get_tags(); + if ( !open(CVSTAG, "<$cvs_dir/CVS/Tag") ) { + print_error("'$cvs_dir': can't determine sticky tag.", 0); + return 0; + } + my @lines = <CVSTAG>; + close(CVSTAG); + + if ( $lines[0] =~ /^T$cws_branch_tag/ ) { + return 1; + } + else { + print_error("'$cvs_dir': wrong sticky tag, need '$cws_branch_tag'", 0); + return 0; + } +} + +# some simple checks on the plausibility of the specified milestone +sub check_milestone +{ + # TODO needs more checks based on EIS + my $qualified_milestone = shift; + + return 0 if $qualified_milestone =~ /-/; + if ( $qualified_milestone =~ /:/ ) { + my ($master, $milestone) = split(/:/, $qualified_milestone); + return 0 unless ( $master && $milestone ); + } + return 1; +} + +# Returns milestone tag determined from the +# full qualified milestone name. +sub get_milestone_tag +{ + my $cws = shift; + my $qualified_milestone = shift; + + if ( $qualified_milestone =~ /:/ ) { + my ($master, $milestone) = split(/:/, $qualified_milestone); + return uc($master) . "_$milestone"; + } + else { + return $cws->master() . "_$milestone"; + } +} + +# Returns changed files +sub get_changed_files +{ + my $cvs_module = shift; + my $old_tag = shift; + my $new_tag = shift; + + $cvs_module->verbose(1); + STDOUT->autoflush(1); + print_message("Retrieving changes ..."); + my $changed_files_ref = $cvs_module->changed_files($old_tag, $new_tag); + STDOUT->autoflush(0); + return $changed_files_ref; +} + +# Retrieve CvsModule object for passed module. +sub get_cvs_module +{ + my $cws = shift; + my $module = shift; + + my $cvs_module = CvsModule->new(); + my ($method, $vcsid, $server, $repository); + if ( defined($log) ) { + ($method, $vcsid, $server, $repository) = get_cvs_root($cws, $module); + } + else { + # For now just take the configured OOo sever. Later we might implement a mechanism were + # only known OOo modules are fetched from the OOo server, the rest from a local + # server + my $config = CwsConfig::get_config(); + ($method, $vcsid, $server, $repository) = ($config->get_cvs_server_method(), + $config->get_cvs_server_id(), + $config->get_cvs_server(), + $config->get_cvs_server_repository()); + } + + return undef if !($method && $vcsid && $server && $repository); + + $cvs_module->module($module); + $cvs_module->cvs_method($method); + $cvs_module->vcsid($vcsid); + $cvs_module->cvs_server($server); + $cvs_module->cvs_repository($repository); + + return $cvs_module; +} + +# Return Cvs object for passed file. +sub get_cvs_archive +{ + my $file = shift; + + my $cvs_archive = Cvs->new(); + $cvs_archive->name($file); + + return $cvs_archive; +} + +# Find out which CVS server holds the module, returns +# the elements of CVSROOT. +sub get_cvs_root +{ + my $cws = shift; + my $module = shift; + + my $master = $cws->master(); + + my $vcsid = $ENV{VCSID}; + if ( !$vcsid ) { + print_error("Can't determine VCSID. Please use setsolar.", 5); + } + + my $workspace_lst = EnvHelper::get_workspace_lst(); + my $workspace_db = GenInfoParser->new(); + my $success = $workspace_db->load_list($workspace_lst); + if ( !$success ) { + print_error("Can't load workspace list '$workspace_lst'.", 4); + } + + my $key = "$master/drives/o:/projects/$module/scs"; + my $cvsroot = $workspace_db->get_value($key); + + if ( !$cvsroot ) { + print_error("No such module '$module' for '$master' in workspace database.", 0); + return (undef, undef, undef, undef); + } + + my ($dummy1, $method, $user_at_server, $repository) = split(/:/, $cvsroot); + my ($dummy2, $server) = split(/@/, $user_at_server); + + if ( ! ($method && $server && $repository ) ) { + print_error("Can't determine CVS server for module '$module'.", 0); + return (undef, undef, undef, undef); + } + + return ($method, $vcsid, $server, $repository); +} + + +sub print_message +{ + my $message = shift; + + print "$script_name: "; + 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"; + $log->end_log_extended($script_name,"unknown",$message) if (defined $log); + exit($error_code); + } + return; +} + +sub usage +{ + print STDERR "Usage:\n"; + print STDERR "cwsresync [-h] [-a] [-d dir] -m <milest.> <all|mod.|dir|file> [mod.|dir|file ...]\n"; + print STDERR "cwsresync [-h] [-d dir] -r|-c <all|module|dir|file> [module|dir|file ...]\n"; + print STDERR "cwsresync [-h] -l <milestone>\n"; + print STDERR "Synchronize child workspace mod./dirs/files "; + print STDERR "with the latest master workspace changes \n"; + print STDERR "Options:\n"; + print STDERR "\t-h\t\thelp\n"; + print STDERR "\t-d dir\t\toperate in directory dir\n"; + print STDERR "\t-m milestone\tmerge changes from MWS into CWS\n"; + print STDERR "\t-c\t\tcommit the merged files to CWS\n"; + print STDERR "\t-l milestone\trenew solver, relink modules to new milestone\n" if defined($log); + print STDERR "\t-l milestone\tregister new milestone with database\n" if !defined($log); + print STDERR "\t-r\t\tremove solver and module output trees, update milestone information\n" if !defined($log); + print STDERR "\t-a\t\tuse cvs checkout instead of copying\n" if defined($log); + print STDERR "Notes:\n"; + print STDERR "\tA Milestone on a different MWS can be specified as <MWS:milestone>.\n"; + print STDERR "Examples:\n"; + print STDERR "\tcwsresync -m SRX645:m1 all \n"; + print STDERR "\tcwsresync -c all \n"; + print STDERR "\tcwsresync -l SRX645:m1 \n" if defined($log); + print STDERR "\tcwsresync -r\n" if !defined($log); +} diff --git a/solenv/bin/modules/Cvs.pm b/solenv/bin/modules/Cvs.pm index 2efc7c7d59da..14fff8b1e52e 100644 --- a/solenv/bin/modules/Cvs.pm +++ b/solenv/bin/modules/Cvs.pm @@ -2,9 +2,9 @@ # # $RCSfile: Cvs.pm,v $ # -# $Revision: 1.15 $ +# $Revision: 1.16 $ # -# last change: $Author: hr $ $Date: 2004-03-02 13:26:40 $ +# last change: $Author: hr $ $Date: 2004-06-26 00:20:18 $ # # The Contents of this file are made available subject to the terms of # either of the following licenses @@ -68,6 +68,8 @@ package Cvs; use strict; +use CwsConfig; + ##### ctor #### sub new @@ -78,11 +80,12 @@ sub new $self->{NAME} = undef; $self->{HEAD} = undef; $self->{FLAGS} = undef; - if ( $ENV{CVS_BINARY} ) { - $self->{CVS_BINARY} = $ENV{CVS_BINARY}; + my $conf = CwsConfig::get_config(); + if ( $conf->cvs_binary() ) { + $self->{CVS_BINARY} = $conf->cvs_binary(); } else { - if ($^O eq "MSWin32" || $^O eq "os2" ) { + if ($^O eq "MSWin32" ) { $self->{CVS_BINARY} = "cvsclt2.exe"; } else { diff --git a/solenv/bin/modules/CvsModule.pm b/solenv/bin/modules/CvsModule.pm new file mode 100755 index 000000000000..c173c6f4ff13 --- /dev/null +++ b/solenv/bin/modules/CvsModule.pm @@ -0,0 +1,857 @@ +#************************************************************************* +# +# $RCSfile: CvsModule.pm,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:20:18 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + + +# +# CvsModule.pm - package for manipulating CVS modules +# + +package CvsModule; +use strict; + +use Benchmark; +use Carp; +use Cwd; +use FileHandle; +use File::Find; +use CwsConfig; + +my $config = CwsConfig::get_config(); + +my %CvsModuleClassData = ( + CVS_BINARY => $config->cvs_binary(), # name of cvs binary + CVS_REMOTE => $config->get_cvs_server(), # name of remote server + CVS_REMOTE_REPOSITORY => $config->get_cvs_server_repository(), # remote repository + CVS_MIRROR => $config->get_cvs_mirror(), # local cvsup mirror + CVS_MIRROR_REPOSITORY => $config->get_cvs_server_repository(), # mirror repository + VCSID => $config->get_cvs_server_id() # VCSID of CVS user +); + +##### ctor #### + +sub new +{ + my $invocant = shift; + my $class = ref($invocant) || $invocant; + my $self = {}; + $self->{MODULE} = undef; # module name + $self->{VERBOSE} = 0; # verbose diagnostics + $self->{CVS_SERVER} = undef; # name of CVS server + $self->{CVS_METHOD} = undef; # checkout method + $self->{CVS_REPOSITORY} = undef; # CVS reposiory + $self->{DEFS_CACHE} = undef; # cache for module definitions + bless ($self, $class); + return $self; +} + +#### instance data accessor methods #### + +# generate remaining instance data accessor methods +# if this looks strange see 'perldoc perltootc' +for my $datum (qw(module verbose)) { + no strict "refs"; + *$datum = sub { + my $self = shift; + $self->{uc($datum)} = shift if @_; + return $self->{uc($datum)}; + } +} + +# if this looks strange see 'perldoc perltootc' +for my $datum (qw(cvs_server cvs_method cvs_repository)) { + no strict "refs"; + *$datum = sub { + my $self = shift; + my $ucdatum = uc($datum); + if ( @_ ) { + $self->{$ucdatum} = shift if @_; + } + else { + $self->get_root() unless $self->{$ucdatum}; + } + return $self->{$ucdatum}; + } +} + +#### class data accessor methods + +# generate class data accessor methods +for my $ucdatum (keys %CvsModuleClassData) { + my $datum = lc($ucdatum); + no strict "refs"; + *$datum = sub { + shift; # ignore calling class/object + return $CvsModuleClassData{$ucdatum}; + } +} + +# +# this procedure provides common output +# the result of update method +# +sub handle_update_infomation { + my ($self, $updated_files_ref) = @_; + my ($updated, $merged, $conflicts); + if ( $updated_files_ref eq 'invaildpath' || $updated_files_ref eq 'cantchdir') { + die('ERROR: Can\'t chdir() into module'. $self->module()); + } + else { + foreach ( @$updated_files_ref ) { + print "\t$_->[1]\t$_->[0]\n"; + if ( $_->[1] eq 'P' || $_->[1] eq 'U' ) { + $updated++; + } + elsif ( $_->[1] eq 'M' ) { + $merged++; + } + elsif ( $_->[1] eq 'C' ) { + $conflicts++; + } + else { + # can't happen + die("ERROR: internal error in update_module()"); + } + } + } + print("\t\tUpdated: $updated\n") if $updated; + print("\t\tMerged: $merged\n") if $merged; + print("\t\tConflict(s): $conflicts\n") if $conflicts; + return ($updated, $merged, $conflicts); +}; + +# +# this procedure patches CVS/Root file in module current path +# actions available: 'user' 'server'. Default - both +# +sub patch_cvs_root_file { + my ($self, $path, $action) = @_; + my @files; + find sub { push @files, $File::Find::name if -d _ && /CVS$/}, + $path . '/' . $self->module(); + foreach my $cvs_dir (@files) { + my $root_file = "$cvs_dir/Root"; + next if (!-f $root_file); + if (!open(ROOT, "<$cvs_dir/Root")) { + die("ERROR: can't open $root_file"); + } + my $line = <ROOT>; + close(ROOT); + + # patch root + $action = '' if (!defined $action); + if ($action ne 'server') { + # in this case patching user won't be the wrong thing + die ("Wrong format $root_file") if ($line !~ /:(\w+)@/o); + $line = "$`:" . $self->vcsid(). "\@$'"; + } + if ($action ne 'user') { + # in this case patching server won't be the wrong thing either + die ("Wrong format $root_file") if ($line !~ /@/o); + $line = "$`\@" . $self->cvs_server() . ":" . $self->cvs_repository() . "\n"; + } + open(ROOT, ">$root_file") or die ("ERROR: can't write $root_file"); + print ROOT $line; + close(ROOT); + }; +}; + +#### additional public methods #### + +#### instance methods ##### + +# Checkout module to specified scratch area +# If CVS_SERVER matches CVS_REMOTE do a checkout +# from CVS_MIRROR first and than update/checkout +# via CVS_SERVER. +# Otherwise do direct checkout. +# Returns a list of entries corresponding to the files which have been +# checked out or 'nofilesupdated' +# The entries of the returned list have the form [$file, 'U'] +sub checkout +{ + my $self = shift; + my $path = shift; + my $tag = shift; + my $options = shift; + + + my $module = $self->module(); + + if ( !$module ) { + carp("ERROR: no module for checkout specified"); + return "modulenotset"; + } + if ( ! -d $path ) { + carp("ERROR: invalid local path for checkout specified"); + return "invalidpath"; + } + + # chdir to checkout area + my $saved_cwd = cwd(); + if ( !chdir($path) ) { + carp("ERROR: can't chdir() to $path"); + return "cantchdir"; + } + + my $from_mirror = 0; + my $update_only = 0; + if ( $self->cvs_server() eq $self->cvs_remote() && defined($self->cvs_mirror()) ) { + # check if module has already been checked out + $from_mirror = 1; + if ( -r "$module/CVS/Root" ) { + open(ROOT, "<$module/CVS/Root"); + my @lines = <ROOT>; + close(ROOT); + if ( $lines[0] =~ $self->cvs_server() ) { + $update_only = 1; + $from_mirror = 0; + } + } + } + + my $dirs_ref; + my $files_ref; + if ( $from_mirror ) { + ($dirs_ref, $files_ref) = $self->do_checkout($self->cvs_mirror(), $tag, $options); + if ( @{$dirs_ref} ) { + my $mirror = $self->cvs_mirror(); + my $remote = $self->cvs_remote(); + my $mirror_rep = $self->cvs_mirror_repository(); + my $remote_rep = $self->cvs_remote_repository(); + $self->patch_root($mirror, $remote, $mirror_rep, $remote_rep, $dirs_ref); + } + chdir($module); + # FIXME We should add an option '-d' here to add directories which + # have been added to the server but not yet synced to the mirror, + # Unfortunately a bug in CVS prevents us from doing so. + my $updated_files_ref; + my $updated_dirs_ref; + my %files_hash; + ($updated_dirs_ref, $updated_files_ref) = $self->do_update('', $options); + if ( @{$updated_files_ref} ) { + # Ok, something changed in the mean time + # create hash for faster searching + foreach (@{$files_ref}) { + $files_hash{$_->[0]}++; + } + # iterate over updated files from remote and add them if they + # are not yet in $files_ref + foreach (@{$updated_files_ref}) { + push(@{$files_ref}, $_) if !exists $files_hash{$_->[0]}; + } + } + } + else { + if ( $update_only ) { + chdir($module); + ($dirs_ref, $files_ref) = $self->do_update($tag, $options); + } + else { + ($dirs_ref, $files_ref) = $self->do_checkout($self->cvs_server(), $tag, $options); + } + } + + # chdir() back + chdir($saved_cwd); + return defined($files_ref) ? $files_ref : 'nofilesupdated'; +} + +# Update module. +# Returns a list of entries corresponding to the files which have been +# updated or 'nofilesupdated'. +# The entries of the returned list have the form [$file, 'U|P|M|C']. +sub update +{ + my $self = shift; + my $path = shift; + my $tag = shift; + my $options = shift; + + + my $module = $self->module(); + + if ( !$module ) { + carp("ERROR: no module for checkout specified"); + return "modulenotset"; + } + if ( !-d "$path/$module" ) { + carp("ERROR: can't find '$path/$module'"); + return "invalidpath"; + } + + # chdir to update area + my $saved_cwd = cwd(); + if ( !chdir("$path/$module") ) { + carp("ERROR: can't chdir() to '$path/$module'"); + return "cantchdir"; + } + + my ($dirs_ref, $files_ref) = $self->do_update($tag, $options); + + # chdir() back + chdir($saved_cwd); + return defined($files_ref) ? $files_ref : 'nofilesupdated'; +} + +# Find all changed files in a module vs. a specfic tag +# return a LoL: [name of file, rev_old, rev_new]. +sub changed_files +{ + my $self = shift; + my $tag_old = shift; + my $tag_new = shift; + + my $module = $self->module(); + my $cvs_binary = $self->cvs_binary(); + + my $root = $self->get_rcmd_root(); + + $tag_old = '-r' . $tag_old; + $tag_new = '-r' . $tag_new; + my $verbose = $self->verbose(); + my ($t1, $t0); + if ( $verbose > 1 ) { + $t0 = Benchmark->new(); + autoflush STDOUT 1; + print "checking for changed files in module '$module'; $tag_old $tag_new\n"; + } + + my @changed_files = (); + open(RDIFF, "$cvs_binary -d $root rdiff -s $tag_old $tag_new $module 2>&1 |"); + while(<RDIFF>) { + # TODO more error checking + if ( /^cvs server: Diffing (.*)$/ ) { + print "." if $verbose; + } + if ( /\[rdiff aborted\]: connect to/ ) { + carp("ERROR: connection to server failed"); + return 'connectionfailure'; + } + if ( /^File (.+?) / ) { + my $file_name = $1; + my ($rev_old, $rev_new); + if ( /changed from revision ([\d\.]+) to ([\d\.]+)/ ) { + $rev_old = $1; + $rev_new = $2; + } + elsif ( /is new; current revision ([\d\.]+)/ ) { + $rev_new = $1; + $rev_old = undef; + } + elsif ( /is removed; not included in release tag/ ) { + $rev_new = undef; + $rev_old = undef; + } + else { + carp("ERROR: unexpected output from rdiff"); + } + + $file_name = $self->strip_module_from_path($file_name); + push(@changed_files, [$file_name, $rev_old, $rev_new]); + } + } + close(RDIFF); + print "\n" if $verbose; + if ( $verbose > 1) { + $t1 = Benchmark->new(); + print "rdiff time: " . timestr(timediff($t1, $t0),'nop') . "\n"; + autoflush STDOUT 0 + } + return wantarray ? @changed_files : \@changed_files; +} + +# Tag all files in module with given tag, +# returns number of newly tagged files and number, +# of warnings/errors due to already existing tags. +sub tag +{ + my $self = shift; + my $path = shift; + my $tag = shift; + my $options = shift; + + my $module = $self->module(); + my $cvs_binary = $self->cvs_binary(); + + my $branch = ($options && $options =~ /-b/) ? '-b' : ''; + my $force = ($options && $options =~ /-F/) ? '-F' : ''; + + my $verbose = $self->verbose(); + my ($t1, $t0); + if ( $verbose > 1) { + $t0 = Benchmark->new(); + autoflush STDOUT 1; + print "tag module '$module' with " ; + print $branch ? "branch " : ""; + print "tag '$tag'\n"; + } + my $tagged_files = 0; + my $tag_errors = 0; + my $saved_cwd = cwd(); + if ( !chdir("$path/$module") ) { + carp("ERROR: can't chdir to directory $path/$module"); + return (undef, undef); + } + open(TAG, "$cvs_binary tag $force $branch $tag 2>&1 |"); + while(<TAG>) { + # TODO error checking + if ( /^cvs server: Tagging (.*)$/ ) { + print "." if $verbose; + } + elsif ( /^T / ) { + $tagged_files++; + } + elsif ( /^W / ) { + # can't move tag because tag already exists and + # force option -F not specified + my $line = $_; + $line =~ s/^W //; + chomp($line); + carp("ERROR: " . "$line"); + $tag_errors++; + } + } + close(TAG); + print "\n" if $verbose; + if ( $verbose > 1) { + $t1 = Benchmark->new(); + print "tagging time: " . timestr(timediff($t1, $t0),'nop') . "\n"; + autoflush STDOUT 0 + } + chdir($saved_cwd); + return ($tagged_files, $tag_errors); +} + +sub get_aliases_hash { + my $self = shift; + my $cvs_binary = $self->cvs_binary(); + my $method = $self->cvs_method(); + my $server = $self->cvs_server(); + my $repository = $self->cvs_repository(); + my $vcsid = $self->vcsid(); + my $root = ":$method:$vcsid\@$server:$repository"; + my $commando = "$cvs_binary -d $root checkout -c"; + if(!open(CHECKOUT, "$commando 2>&1 |")) { + die("Cannot run $commando"); + }; + my %aliases_hash = (); + my $last_alias = ''; + my $string = ''; + while(<CHECKOUT>) { + if (/^(\S+)\s+(.+)$/o) { + $last_alias = $1; + $string = $2; + } elsif (/^(\s+)(.+)$/o && $last_alias) { + $string = $aliases_hash{$last_alias} . " $2"; + } else { + $last_alias = ''; + next; + }; + $aliases_hash{$last_alias} = $string; + }; + close CHECKOUT; + return %aliases_hash; +}; + +#### private helper methods ##### + +sub do_checkout +{ + my $self = shift; + my $server = shift; + my $tag = shift || ''; + my $options = shift || ''; + + my $vcsid = $self->vcsid(); + + if ( !$vcsid ) { + carp("ERROR: VCSID not set"); + return "invalidvcsid"; + } + + my $module = $self->module(); + my $cvs_binary = $self->cvs_binary(); + my $method = $self->cvs_method(); + my $repository = $self->cvs_repository(); + my $root = ":$method:$vcsid\@$server:$repository"; + + $tag = '-r' . $tag if $tag ne ''; + + # do the checkout + my @updated_dirs; + my @updated_files; + my $verbose = $self->verbose(); + my ($t1, $t0); + if ( $verbose > 1) { + $t0 = Benchmark->new(); + autoflush STDOUT 1; + print "checkout module '$module' from $server'\n"; + } + open(CHECKOUT, "$cvs_binary -d $root checkout $tag $options $module 2>&1 |"); + while(<CHECKOUT>) { + # TODO error checking + if ( /^cvs server: Updating (.*)$/ ) { + print "." if $verbose; + push(@updated_dirs, $1); + } + if ( /^([U|M|P|C]) (.*)$/ ) { + push(@updated_files, [$2, $1]); + } + } + close(CHECKOUT); + print "\n" if $verbose; + if ( $verbose > 1 ) { + $t1 = Benchmark->new(); + print "checkout time: " . timestr(timediff($t1, $t0),'nop') . "\n"; + autoflush STDOUT 0; + } + return (\@updated_dirs, \@updated_files); +} + +sub do_update +{ + my $self = shift; + my $tag = shift; + my $options = shift; + + my $module = $self->module(); + my $cvs_binary = $self->cvs_binary(); + + $options = $options ? $options : ''; + $tag = '-r' . $tag if $tag ne ''; + + # sever for update is never a mirror, always the 'real' server + my $server = $self->cvs_server(); + + # do the update + my @updated_dirs; + my @updated_files; + my $verbose = $self->verbose(); + my ($t1, $t0); + if ( $verbose > 1) { + $t0 = Benchmark->new(); + autoflush STDOUT 1; + print "update module '$module' from '$server'\n"; + } + open(UPDATE, "$cvs_binary -z6 update $tag $options 2>&1 |"); + while(<UPDATE>) { + # TODO error checking + if ( /^cvs server: Updating (.*)$/ ) { + print "." if $verbose; + push(@updated_dirs, $1); + } + if ( /^([U|M|P|C]) (.*)$/ ) { + push(@updated_files, [$2, $1]); + } + } + close(UPDATE); + print "\n" if $verbose; + if ( $verbose > 1) { + $t1 = Benchmark->new(); + print "update time: " . timestr(timediff($t1, $t0),'nop') . "\n"; + autoflush STDOUT 0 + } + return (\@updated_dirs, \@updated_files); +} + +sub get_root +{ + # Try two methods to determine CVS root. + my $self = shift; + my $module = $self->module(); + + my $cvs_root; + if ( $module && -r "$module/CVS/Root" ) { + # Test if there is a checked out module. + open(ROOT, "<$module/CVS/Root"); + my @root = <ROOT>; + close(ROOT); + $cvs_root = $root[0]; + } + else { + # alternatively check CVSROOT environment variable + $cvs_root = $ENV{CVSROOT}; + } + + if ( $cvs_root ) { + my ($dummy, $method, $vcsid_server, $repository) = split(/:/, $cvs_root); + my ($vcsid, $server) = split('@', $vcsid_server); + if ( !($method && $vcsid && $server && $repository) ) { + carp("ERROR: can't determine CVS Server"); + return; + } + # sanity check + if ( $vcsid ne $self->vcsid() ) { + carp("ERROR: environment VCSID and CVS server root differ"); + return; + } + $self->cvs_method($method); + $self->cvs_server($server); + $self->cvs_repository($repository); + return; + } + return; +} + +sub patch_root +{ + # Patch the server part of the root from old to new. + shift; # ignore invocant + my $old_server = shift; + my $new_server = shift; + my $old_rep = shift; + my $new_rep = shift; + my $dirs_ref = shift; + + foreach (@{$dirs_ref}) { + # pruned directories may not exist + if ( -d $_ ) { + my $root = "$_/CVS/Root"; + open(ROOT, "<$root") or carp("ERROR: can't open $root"); + my $line = <ROOT>; + close(ROOT); + + # patch root + $line =~ s/$old_server/$new_server/o; # note: evaluate reg exp. only once + open(ROOT, ">$root") or carp("ERROR: can't write $root"); + print ROOT $line; + close(ROOT); + # repository will usually not change + if ( $old_rep ne $new_rep ) { + my $rep = "$_/CVS/Repository"; + open(REPOSITORY, "<$rep") or carp("ERROR: can't open $rep"); + my $line = <REPOSITORY>; + close(REPOSITORY); + + # patch rep + $line =~ s/$old_rep/$new_rep/o; # note: evaluate reg exp. only once + open(REPOSITORY, ">$rep") or carp("ERROR: can't write $rep"); + print REPOSITORY $line; + close(REPOSITORY); + } + } + } +} + +# get the root for r-type commands +sub get_rcmd_root +{ + my $self = shift; + + my $vcsid = $self->vcsid(); + + if ( !$vcsid ) { + carp("ERROR: VCSID not set"); + return "invalidvcsid"; + } + + my $method = $self->cvs_method(); + my $repository = $self->cvs_repository(); + my $server = $self->cvs_server(); + my $remote = $self->cvs_remote(); + my $root = ":$method:$vcsid\@$server:$repository"; + + + # FIXME OOo's CVS server is pretty much broken. It's impossible + # to use the r-type CVS commands (rtag, rdiff) with the regular cvs root. + # We have to patch the cvs root. This horrendous hack should be removed as + # soon as the server is fixed + if ( $server =~ /$remote/o ) { + $repository = '/shared/data/helm/cvs/repository'; + $root = ":$method:$vcsid\@$server:$repository"; + if ( !is_valid_login($root) ) { + print STDERR "\nThe cvs rdiff command is broken for the OOo CVS server.\n"; + print STDERR "To fix this problem you have to issue the following cvs login command:\n\n"; + print STDERR " cvs -d $root login\n\n"; + print STDERR "The password is your ususal OOo password.\n\n"; + exit(1); + } + } + + return $root; +} + +# Check if a valid login command has been +# issued for the root which is passed +# as argument. +# Needed for r-type command hack. sigh. +sub is_valid_login +{ + my $root = shift; + + my $home = $ENV{HOME}; + open(CVSPASSWD, "<$home/.cvspass") or return 0; + my @lines = <CVSPASSWD>; + close(CVSPASSWD); + + my $is_valid = 0; + foreach (@lines) { + if ( $_ =~ /$root/o ) { + $is_valid = 1; + last; + } + } + + return $is_valid; +} + +# Returns a hash_ref with alias for all modules +sub get_module_definitions +{ + my $self = shift; + + my $cvs_binary = $self->cvs_binary(); + my $root = $self->get_rcmd_root(); + + my @entries; + open(MODULESLIST, "$cvs_binary -d $root checkout -c 2>&1 |"); + while(<MODULESLIST>) { + chomp(); + # TODO more error checking + if ( /\[checkout aborted\]: connect to/ ) { + carp("ERROR: connection to server failed"); + return 'connectionfailure'; + } + # Module list format: + # A entry starts on the first column, otherwise + # we have a continuation line + if ( /^\S/ ) { + push(@entries, $_); + } + else { + $entries[-1] .= $_; + } + } + close(MODULESLIST); + + my %mod_defs; + foreach ( @entries ) { + my ($name, $definition, $extra) = split(' ', $_); + if ( $extra || $definition =~ /&/ ) { + # if the entries splits in more than + # two entries or the definition + # contains an ampersand than this can't + # be a regular module definition + next; + } + $mod_defs{$name} = $definition; + } + return \%mod_defs; +} + +# Strip elements from the front of a path to yield +# a filename relative to module. If this fails retrieve +# the module list from the server and determine the number +# of path elements to be stripped from the the module +# definition. +sub strip_module_from_path +{ + my $self = shift; + my $file = shift; + + my $module = $self->module; + + # Test if the file name is of the form + # project/module/pathelem/..../filename <= OOo server + # module/pathelem/.../filename <= local server + # where project and module can be identical + # If the test fails try as last resort to + # retrieve the module list from the server and + # determine the number of path elements to be stripped + # from the the module definition. + # + my @elems = split(/\//, $file); + + my $elem = shift @elems; + if ( $elem eq $module ) { + $elem = shift @elems; + if ( $elem ne $module ) { + unshift(@elems, $elem); + } + return join('/', @elems); + } + else { + $elem = shift @elems; + if ( $elem eq $module ) { + return join('/', @elems); + } + else { + # try the module definitions from the module list + if ( !defined($self->{DEFS_CACHE}) ) { + $self->{DEFS_CACHE} = $self->get_module_definitions(); + } + if ( exists $self->{DEFS_CACHE}->{$module} ) { + my $definition = $self->{DEFS_CACHE}->{$module}; + $file =~ /^$definition\/(.*)$/; + return $1; + } + else { + carp("ERROR: internal error in strip_module_from_path()"); + return $file; + } + } + } +} + +#### + +1; # needed by "use" or "require" diff --git a/solenv/bin/modules/Cws.pm b/solenv/bin/modules/Cws.pm new file mode 100755 index 000000000000..7d875eea9845 --- /dev/null +++ b/solenv/bin/modules/Cws.pm @@ -0,0 +1,1170 @@ +#************************************************************************* +# +# $RCSfile: Cws.pm,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:20:18 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + + +# +# Cws.pm - package for accessing/manipulating child workspaces +# + +# TODO: needs some cleanup + +package Cws; +use strict; + +use Eis; +use CwsConfig; +use Carp; +use URI::Escape; + +my $config = CwsConfig::get_config(); + +##### class data ##### + +my %CwsClassData = ( + # EIS database connectivity + EIS_URI => 'urn:ChildWorkspaceDataService', + EIS_PROXY_LIST => $config->cws_db_url_list_ref(), + NET_PROXY => $config->net_proxy(), + EIS => undef +); + +##### ctor ##### + +sub new +{ + my $invocant = shift; + my $class = ref($invocant) || $invocant; + my $self = {}; + # instance data + # initialize CWS name from environment + $self->{CHILD} = undef; # name of child workspace + $self->{MASTER} = undef; # name of master workspace + $self->{EIS_ID} = undef; # id of child workspace in EIS + $self->{FILES} = undef; # list of files registered with child + # any file can be registered multiple times + $self->{PATCH_FILES} = undef # list of product patch files registered with + # child, each file can be added only once + $self->{MILESTONE} = undef; # master milestone to which child is related + $self->{MODULES} = undef; # list of modules belonging to child + $self->{TASKIDS} = undef; # list of tasks registered with child + bless($self, $class); + return $self; +} + +#### methods to access instance data #### + +# Get the EIS ID for child workspace, +# return value: undef => not yet asked EIS for ID +# or connection failed +# 0 => queried EIS but didn't find such +# a child workspace for this master +# silently ignore any parameter, only the EIS database, +# hands out EIS IDs. +sub eis_id +{ + my $self = shift; + if ( !defined($self->{EIS_ID} ) ) { + $self->{EIS_ID} = $self->get_eis_id(); + } + return $self->{EIS_ID}; +} + +# Generate remaining instance data accessor methods; +# if this looks strange see 'perldoc perltootc' + +# Accessor methods for single value instance data +for my $datum (qw(master milestone)) { + no strict "refs"; + *$datum = sub { + my $self = shift; + my $ucdatum = uc($datum); + if ( @_ ) { + # set item in database + my $item = shift; + # if we already have a valid EIS registered CWS then reset EIS value + # otherwise just set member to the given value + if ( !$self->{uc($datum)} # keep order of evaluation + || !$self->eis_id() + || $self->set_item_in_eis($datum, $item) ) + { + $self->{uc($datum)} = $item; + + } + } + else { + if ( !defined($self->{$ucdatum} ) ) { + # fetch item from database + $self->{$ucdatum} = $self->fetch_item_from_eis($datum); + } + } + return $self->{uc($datum)}; + } +} + +# Accessor methods for instance data consisting of item lists +# like modules and taskids +for my $datum (qw(files patch_files modules taskids)) { + no strict "refs"; + *$datum = sub { + # get current item list + # fetch list from EIS database if called the first time + my $self = shift; + my $ucdatum = uc($datum); + if ( !defined($self->{$ucdatum}) ) { + # fetch item list from databse + $self->{$ucdatum} = $self->fetch_items_from_eis($datum); + return undef if !defined($self->{$ucdatum}); + } + return wantarray ? @{$self->{$ucdatum}} : $self->{$ucdatum} + } +} + +for my $datum (qw(child)) { + no strict "refs"; + *$datum = sub { + my $self = shift; + $self->{uc($datum)} = shift if @_; + return $self->{uc($datum)}; + } +} + + +#### additional public methods #### + +# Query if CWS name is still available. Does not yet register +# anything with EIS. +sub is_cws_name_available +{ + my $self = shift; + + my $is_available = $self->is_cws_name_available_in_eis(); + return $is_available; +} + +# Register new child workspace with the EIS database. +sub register +{ + my $self = shift; + my $vcsid = shift; + my $location = shift; + + my $child_id = $self->register_child_with_eis($vcsid, $location); + return $child_id; +} + +# Promote a child workspace with status 'planned' to a full CWS +sub promote +{ + my $self = shift; + my $vcsid = shift; + my $location = shift; + + my $rc = $self->promote_child_in_eis($vcsid, $location); + return $rc; +} + +# New style add_module method. Takes an additional bool indicating if +# a module is public or private. Obsoletes add_modules() +sub add_module +{ + my $self = shift; + my $module = shift; + my $public = shift; + + my $items_ref = $self->add_items('modules', $public, $module); + if ( $items_ref->[0] eq $module ) { + return 1; # module has been added + } + elsif ( defined($items_ref) ) { + return 0; # module was already add + } + return undef; # something went wrong +} + +# Add module to modules list. +sub add_modules +{ + my $self = shift; + + my $items_ref = $self->add_items('modules', undef, @_); + return undef unless defined($items_ref); + return wantarray ? @{$items_ref} : $items_ref; +} + +# Add tasksids to taskids list. +sub add_taskids +{ + my $self = shift; + my $vcsid = shift; + + my $items_ref = $self->add_items('taskids', $vcsid, @_); + return undef unless defined($items_ref); + return wantarray ? @{$items_ref} : $items_ref; +} + +# Add a file to the files list. +sub add_file +{ + my $self = shift; + my $module = shift; + my $file = shift; + my $revision = shift; + my $authors_ref = shift; + my $taskids_ref = shift; + my $archive_path = shift; + + my $files_ref = $self->files(); + + if ( $self->add_file_to_eis($module, $file, $revision, + $authors_ref, $taskids_ref, $archive_path) ) + { + push(@{$files_ref}, $file); + return 1; + } + return 0; +} + +# Add a file to the patch file list. +sub add_patch_file +{ + my $self = shift; + my $file = shift; + + my $patch_files_ref = $self->patch_files(); + + foreach (@{$patch_files_ref}) { + return 0 if $file eq $_; + } + + if ( $self->add_patch_file_to_eis($file) ) + { + push(@{$patch_files_ref}, $file); + return 1; + } + return 0; +} + +# +# Procedure retrieves the stand which +# is based on cvs head (not branch) +# +sub get_cvs_head { + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->getCVSHead() }; + if ( $@ ) { + carp("ERROR: get_eis_id(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +}; + +sub get_master_tag { + my ($self, $master, $milestone) = @_; + $master = $self->master() if (!defined $master); + $milestone = $self->milestone() if (!defined $milestone); + return uc($master) . '_' . lc($milestone); +}; + +# Returns the branch and root tags for child workspace. +sub get_tags +{ + my $self = shift; + + # check if child workspace is valid + my $id = $self->eis_id(); + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + # check in environment if master is on the the HEAD branch + my $cvs_head = get_cvs_head(); + my $current_master = $self->master(); + my $creation_master = $self->get_creation_master(); + if ( !$creation_master ) { + carp("ERROR: Can't determine creation MWS.\n"); + return undef; + } + + my $master_branch_tag + = (lc($current_master) eq lc($cvs_head)) ? '' : 'mws_' . lc($current_master); + my $cws_branch_tag = 'cws_' . lc($creation_master) . '_' . lc($self->child()); + my $cws_root_tag = uc($cws_branch_tag) . "_ANCHOR"; + + return ($master_branch_tag, $cws_branch_tag, $cws_root_tag); +} + +# Get child workspace approval status, +# return values can be: +# 'planned', 'new', 'nominated', 'integrated' +# and undef in case of error. +sub get_approval +{ + my $self = shift; + + return $self->get_status_from_eis(); +} + +# Set child workspace approval status +# to 'integrated'. Return true if successful +# or undef in case of error +sub set_integrated +{ + my $self = shift; + + return $self->set_status_in_eis(); +} + +# Set child workspace integration milestone +# Return true if successful or undef in case of error +sub set_integration_milestone +{ + my $self = shift; + my $milestone = shift; + my $buildid = shift; + + return $self->set_integration_milestone_in_eis($milestone, $buildid); +} + +# Get the MWS on which a CWS was created +sub get_creation_master +{ + my $self = shift; + + return $self->get_creation_master_from_eis(); +} + +#### public class methods #### + +# Query master milestone combination for being used by an +# active CWS +sub is_milestone_used +{ + my $self = shift; + my $master = shift; + my $milestone = shift; + + return $self->get_is_milestone_used_from_eis($master, $milestone); +} + +# Set current milestone for MWS. +sub set_current_milestone +{ + my $self = shift; + my $master = shift; + my $milestone = shift; + + return $self->set_current_milestone_in_eis($master, $milestone); +} + +# Get current milestone for MWS. +sub get_current_milestone +{ + my $self = shift; + my $master = shift; + + return $self->get_current_milestone_from_eis($master); +} + +# Get all child workspaces which have been integrated on a +# given master and milestone. +sub get_integrated_cws +{ + my $self = shift; + my $master = shift; + my $milestone = shift; + + return wantarray ? @{$self->get_childworkspaces_for_milestone($master, $milestone)} + : $self->get_childworkspaces_for_milestone($master, $milestone); +} + +sub set_log_entry +{ + my $self = shift; + my $commandline = shift; + my $vcsid = shift; + my $start = shift; + my $stop = shift; + my $comment = shift; + return $self->set_log_entry_in_eis($commandline, $vcsid, $start, $stop, $comment); +} + +sub set_log_entry_extended +{ + my $self = shift; + my $commandname = shift; + my $parameter = shift; + my $vcsid = shift; + my $start = shift; + my $stop = shift; + my $comment = shift; + my $mastername = shift; + my $childname = shift; +#set_log_entry_extended_in_eis($commandname, $parameter, $vcsid, $start, $stop, $comment, $mastername, $childname); + return $self->set_log_entry_extended_in_eis($commandname, $parameter, $vcsid, $start, $stop, $comment, $mastername, $childname); +} + + +#### private #### + +# class data accessor methods +sub eis +{ + shift; # ignore calling class/object + $CwsClassData{EIS} = shift if @_; + if ( !defined($CwsClassData{EIS}) ) { + $CwsClassData{EIS} = init_eis_connector(); + } + return $CwsClassData{EIS}; +} + +# generate remaining class data accessor methods +# if this looks strange see 'perldoc perltootc' +for my $datum (qw(eis_uri eis_proxy_list net_proxy)) { + no strict "refs"; + *$datum = sub { + shift; # ignore calling class/object + return $CwsClassData{uc($datum)}; + } +} + +#### helper methods #### + +# instance methods + +# Add item to items list, +# update eis database, +# returns a list of newly added items, +# specifying an existing item is not an +# error, but it want appear in the return list. +sub add_items +{ + my $self = shift; + my $type = shift; + my $optional_data = shift; + + my $items_ref; + if ( $type eq 'modules' ) { + $items_ref = $self->modules(); + } + elsif ( $type eq 'taskids' ) { + $items_ref = $self->taskids(); + } + else { + # fall through, can't happen + carp("ERROR: wrong item type\n"); + return undef; + } + + my $item; + my @new_items = (); + return undef if !defined($items_ref); + # find which items which are not already in items list + ITEM: while ( $item = shift ) { + foreach ( @{$items_ref} ) { + next ITEM if $_ eq $item; + } + push(@new_items, $item); + } + if ( $#new_items > -1 ) { + # add items to database + if ( $self->add_items_to_eis($type, $optional_data, \@new_items) ) { + push(@{$items_ref}, @new_items); + } + else { + # something went wrong + return undef; + } + } + return \@new_items; +} + +# Get EIS id for workspace from EIS database +sub get_eis_id +{ + my $self = shift; + my $eis = Cws::eis(); + + # It's not an error if one of these is unset, so don't carp(). + if ( !$self->master() || !$self->child() ) { + return undef; + } + + my $master = Eis::to_string($self->master()); + my $child = Eis::to_string($self->child()); + + my $result; + eval { $result = $eis->getChildWorkspaceId($master, $child) }; + if ( $@ ) { + carp("ERROR: get_eis_id(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub fetch_item_from_eis +{ + my $self = shift; + my $type = shift; + + my $eis = Cws::eis(); + my $id = $self->eis_id(); + + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + my $result; + if ( $type eq 'milestone' ) { + eval { $result = $eis->getMilestone($id) }; + } + elsif ( $type eq 'master' ) { + # master can't be queried from the EIS database, + # just return what already in member + return $self->{MASTER} + } + else { + # fall through, can't happen + carp("ERROR: wrong item type\n"); + return undef; + } + if ( $@ ) { + carp("ERROR: fetch_item(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub set_item_in_eis +{ + my $self = shift; + my $type = shift; + my $item = shift; + + my $eis = Cws::eis(); + my $id = $self->eis_id(); + + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + # make certain that the item is a string, otherwise + # autotyping will occasionally choose the wrong type + $item = Eis::to_string($item); + + my $result; + if ( $type eq 'milestone' ) { + eval { $result = $eis->setMilestone($id, $item) }; + } + elsif ( $type eq 'master' ) { + eval { $result = $eis->setMasterWorkspace($id, $item) }; + } + else { + # fall through, can't happen + carp("ERROR: wrong item type\n"); + return 0; + } + + if ( $@ ) { + carp("ERROR: set_item(): EIS database transaction failed. Reason:\n$@\n"); + return undef; + } + return 1 if $result; + return 0; +} + +sub fetch_items_from_eis +{ + my $self = shift; + my $type = shift; + + my $eis = Cws::eis(); + my $id = $self->eis_id(); + + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + my $result; + if ( $type eq 'modules' ) { + eval { $result = $eis->getModules($id) }; + } + elsif ( $type eq 'taskids' ) { + eval { $result = $eis->getTaskIds($id) }; + } + elsif ( $type eq 'files' ) { + eval { $result = $eis->getFiles($id) }; + } + elsif ( $type eq 'patch_files' ) { + eval { $result = $eis->getOutputFiles($id) }; + } + else { + # fall through, can't happen + carp("ERROR: wrong item type\n"); + return undef; + } + if ( $@ ) { + carp("ERROR: fetch_item(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub add_items_to_eis +{ + my $self = shift; + my $type = shift; + my $optional_data = shift; + my $item_ref = shift; + + my $eis = Cws::eis(); + my $id = $self->eis_id(); + + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + # make certain that all items are strings, otherwise + # autotyping will occasionally choose the wrong type + my @items = (); + foreach ( @{$item_ref} ) { + push(@items, Eis::to_string($_)); + } + + my $result; + if ( $type eq 'modules' ) { + if ( defined($optional_data) ) { + # add a module new style, with public attribute + eval { $result = $eis->addModule($id, $items[0], $optional_data) }; + } + else { + # old style, add a list of modules + eval { $result = $eis->addModules($id, \@items) }; + } + } + elsif ( $type eq 'taskids' ) { + eval { $result = $eis->addTaskIds($id, \@items, $optional_data) }; + } + else { + # fall through, can't happen + carp("ERROR: wrong item type\n"); + return 0; + } + + if ( $@ ) { + carp("ERROR: add_item(): EIS database transaction failed. Reason:\n$@\n"); + return undef; + } + return 1 if $result; + return 0; +} + +sub add_file_to_eis +{ + my $self = shift; + my $module = shift; + my $file = shift; + my $revision = shift; + my $authors_ref = shift; + my $taskids_ref = shift; + my $archive_path = shift; + + + my $eis = Cws::eis(); + my $id = $self->eis_id(); + + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + # make certain that all task_ids are strings, otherwise + # autotyping will choose the wrong type + # Note: I think typing just the first element should suffice, but ... + my @taskids = (); + foreach ( @{$taskids_ref} ) { + push(@taskids, Eis::to_string($_)); + } + # HACK Its possible that we get no valid taskid. + # Autotyping will fail for a list without elements; + if ( !@taskids ) { + push(@taskids, Eis::to_string('')); + } + + # same for revision + $revision = Eis::to_string($revision); + + if ( !$archive_path ) { + $archive_path = Eis::to_string(''); + } + + my $result; + eval { + $result = $eis->addFile($id, $module, $file, $archive_path, + $revision, $authors_ref, \@taskids) + }; + if ( $@ ) { + carp("ERROR: add_file(): EIS database transaction failed. Reason:\n$@\n"); + return undef; + } + return 1 if $result; + return 0; +} + +sub add_patch_file_to_eis +{ + my $self = shift; + my $file = shift; + + my $eis = Cws::eis(); + my $id = $self->eis_id(); + + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + my $result; + eval { $result = $eis->addOutputFile($id, $file) }; + if ( $@ ) { + carp("ERROR: add_patch_file(): EIS database transaction failed. Reason:\n$@\n"); + return undef; + } + return $1;# appOutputFile has void as return value ... +} + +sub is_cws_name_available_in_eis +{ + my $self = shift; + + if ( !$self->master() ) { + carp("ERROR: master workspace name not set\n"); + return undef; + } + + if ( !$self->child() ) { + carp("ERROR: child workspace name not set\n"); + return undef; + } + + my $eis = Cws::eis(); + my $master = Eis::to_string($self->master()); + my $child = Eis::to_string($self->child()); + + my $result; + eval { $result = $eis->isChildWorkspaceUnique($master, $child) }; + if ( $@ ) { + carp("ERROR: is_cws_name_available(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub register_child_with_eis +{ + my $self = shift; + my $vcsid = shift; + my $location = shift; + + if ( !$self->master() ) { + carp("ERROR: master workspace name not set\n"); + return undef; + } + + if ( !$self->milestone() ) { + carp("ERROR: master milestone not set\n"); + return undef; + } + + if ( !$self->child() ) { + carp("ERROR: child workspace name not set\n"); + return undef; + } + + $vcsid = '' unless $vcsid; + $location = '' unless $location; + + my $eis = Cws::eis(); + my $master = Eis::to_string($self->master()); + my $milestone = Eis::to_string($self->milestone()); + my $child = Eis::to_string($self->child()); + + $vcsid = Eis::to_string($vcsid); + $location = Eis::to_string($location); + + my $result; + eval { + $result = $eis->createChildWorkspace($master, $milestone, $child, + $vcsid, $location) + }; + + if ( $@ ) { + carp("ERROR: create_child_wortkspace(): EIS database transaction failed. Reason:\n$@\n"); + return undef; + } + # set EIS_ID directly, since $self->eis_id() is not + # supposed to take parameters. + $self->{EIS_ID} = $result; + return $result; +} + +sub promote_child_in_eis +{ + my $self = shift; + my $vcsid = shift; + my $location = shift; + + my $eis = Cws::eis(); + my $id = $self->eis_id(); + + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + if ( !$self->milestone() ) { + carp("ERROR: master milestone not set\n"); + return undef; + } + + my $milestone = Eis::to_string($self->milestone()); + + $vcsid = '' unless $vcsid; + $location = '' unless $location; + + $vcsid = Eis::to_string($vcsid); + $location = Eis::to_string($location); + + my $result; + eval { + $result = $eis->initializeChildWorkspace($id, $milestone, $vcsid, $location) + }; + + eval { $result = $eis->getStatus($id) }; + if ( $@ ) { + carp("ERROR: promote(): EIS database transaction failed. Reason:\n$@\n"); + return 0; + } + return 1; +} + +# Get child workspace approval status from EIS, +# return undef in case of error. +sub get_status_from_eis +{ + my $self = shift; + + # check if child workspace is valid + my $id = $self->eis_id(); + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->getStatus($id) }; + if ( $@ ) { + carp("ERROR: get_status(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +# Get child workspace approval status from EIS, +# return undef in case of error. +sub set_status_in_eis +{ + my $self = shift; + my $status = shift; + my $method = 'set'; + $method .= (defined $status) ? $status : 'Integrated'; + + # check if child workspace is valid + my $id = $self->eis_id(); + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + my $eis = Cws::eis(); + my $result; + if (defined $status) { + eval { $result = $eis->setFixedOnMaster($id) }; + } else { + eval { $result = $eis->setIntegrated($id) }; + } + if ( $@ ) { + carp("ERROR: $method(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +# Get child workspace approval status from EIS, +# return undef in case of error. +sub set_integration_milestone_in_eis +{ + my $self = shift; + my $milestone = shift; + my $buildid = shift; + + # check if child workspace is valid + my $id = $self->eis_id(); + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + my $eis = Cws::eis(); + + # just in case ... + if ( !defined($milestone) ) { + $milestone = Eis::to_string(''); + } + # $buildid must be transfered as string + if ( !defined($buildid) ) { + $buildid = Eis::to_string(''); + } + else { + $buildid = Eis::to_string($buildid); + } + + my $result; + eval { $result = $eis->setIntegrationMilestone($id, $milestone, $buildid) }; + if ( $@ ) { + carp("ERROR: set_integration_milestone(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub set_current_milestone_in_eis +{ + my $self = shift; + my $master = shift; + my $milestone = shift; + + $master = Eis::to_string($master); + $milestone = Eis::to_string($milestone); + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->setCurrentMilestone( $master, $milestone ) }; + if ( $@ ) { + carp("ERROR: set_current_milestone(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub get_current_milestone_from_eis +{ + my $self = shift; + my $master = shift; + + $master = Eis::to_string($master); + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->getCurrentMilestone( $master ) }; + if ( $@ ) { + carp("ERROR: get_current_milestone(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub get_is_milestone_used_from_eis +{ + my $self = shift; + my $master = shift; + my $milestone = shift; + + $master = Eis::to_string($master); + $milestone = Eis::to_string($milestone); + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->isMilestoneInUse($master, $milestone) }; + if ( $@ ) { + carp("ERROR: is_milestone(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub get_childworkspaces_for_milestone +{ + my $self = shift; + my $master = shift; + my $milestone = shift; + + $master = Eis::to_string($master); + $milestone = Eis::to_string($milestone); + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->searchChildWorkspacesForMilestone($master, $milestone) }; + if ( $@ ) { + carp("ERROR: get_childworkspaces_for_milestone(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; +} + +sub get_creation_master_from_eis +{ + my $self = shift; + + # check if child workspace is valid + my $id = $self->eis_id(); + if ( !$id ) { + carp("ERROR: Childworkspace not (yet) registered with EIS.\n"); + return undef; + } + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->getCreationMasterWorkspace($id) }; + if ( $@ ) { + carp("ERROR: get_creation_master(): EIS database transaction failed. Reason:\n$@\n"); + } + return $result; + +} + +#logging +sub set_log_entry_in_eis +{ + my $self = shift; + my $commandline = shift; + my $vcsid = shift; + my $start = shift; + my $end = shift; + my $comment = shift; + + $commandline = SOAP::Data->type(string => $commandline); + $comment = SOAP::Data->type(string => $comment); + + # *format* for $start and $end = "2003-05-28 12:34:59"; + +#===================================================== + #TO DO: + #experimenell fr saubere schnittstelle + #$start = SOAP::Data->type(dateTime => $start); + #$end = SOAP::Data->type(dateTime => $end); +#===================================================== + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->storeCommandLogEntry( $commandline, $vcsid, $start, $end, $comment ) }; + if ( $@ ) { + carp("ERROR: set_log_entry(): Logging failed. Reason:\n$@\n"); + } + return $result; +} + +#set_log_entry_extended_in_eis($commandname, $parameter, $vcsid, $start, $stop, $comment, $mastername, $childname); +sub set_log_entry_extended_in_eis +{ + my $self = shift; + my $commandname = shift; + my $parameter = shift; + my $vcsid = shift; + my $start = shift; + my $end = shift; + my $comment = shift; + my $mastername = shift; + my $childname = shift; + + $commandname = SOAP::Data->type(string => $commandname); + $parameter = SOAP::Data->type(string => $parameter); + $comment = SOAP::Data->type(string => $comment); + $mastername = SOAP::Data->type(string => $mastername); + $childname = SOAP::Data->type(string => $childname); + + # *format* for $start and $end = "2003-05-28 12:34:59"; + +#===================================================== + #TO DO: + #experimenell fr saubere schnittstelle + #$start = SOAP::Data->type(dateTime => $start); + #$end = SOAP::Data->type(dateTime => $end); +#===================================================== + + my $eis = Cws::eis(); + my $result; + eval { $result = $eis->storeCommandLogEntry($commandname, $parameter, $vcsid, $start, $end, $comment, $mastername, $childname) }; + if ( $@ ) { + carp("ERROR: set_log_entry_extended(): Logging failed. Reason:\n$@\n"); + } + return $result; +} + + +#### class methods #### + +sub init_eis_connector +{ + my $eis = Eis->new( uri => Cws::eis_uri(), + proxy_list => Cws::eis_proxy_list(), + net_proxy => Cws::net_proxy() + ); + return $eis; +} + +#### + +1; # needed by "use" or "require" diff --git a/solenv/bin/modules/CwsConfig.pm b/solenv/bin/modules/CwsConfig.pm new file mode 100644 index 000000000000..de04294d4793 --- /dev/null +++ b/solenv/bin/modules/CwsConfig.pm @@ -0,0 +1,396 @@ +#************************************************************************* +# +# $RCSfile: CwsConfig.pm,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:20:18 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + + +# +# CwsConfig.pm - package for read CWS config data +# + +package CwsConfig; +use strict; + +use Carp; +use Config::Tiny; +use URI::Escape; + +##### ctor #### + +sub new +{ + my $invocant = shift; + my $class = ref($invocant) || $invocant; + my $self = {}; + $self->{_CONFIG_FILE} = undef; # config file + $self->{VCSID} = undef; # VCSID + $self->{CWS_DB_URL_LIST_REF} = undef; # list of CWS DB servers + $self->{NET_PROXY} = undef; # network proxy + $self->{CWS_SERVER_ROOT} = undef; # cvs server + $self->{CWS_MIRROR_ROOT} = undef; # mirror of cvs server + $self->{CWS_LOCAL_ROOT} = undef; # local cvs server + bless ($self, $class); + return $self; +} + +sub vcsid +{ + my $self = shift; + + if ( !defined($self->{VCSID}) ) { + # environment overrides config file + my $vcsid = $ENV{VCSID}; + if ( !defined($vcsid) ) { + # check config file + my $config_file = $self->get_config_file(); + $vcsid = $config_file->{CWS_CONFIG}->{'CVS_ID'}; + if ( !defined($vcsid) ) { + # give up + croak("ERROR: no CVS_ID entry found in '\$HOME/.cwsrc'.\n" ); + } + } + $self->{VCSID} = $vcsid; + } + return $self->{VCSID}; +} + +sub cws_db_url_list_ref +{ + my $self = shift; + + if ( !defined($self->{CWS_DB_URL_LIST_REF}) ) { + my $config_file = $self->get_config_file(); + + my $i = 1; + my @cws_db_servers; + + while ( 1 ) { + my $val = $config_file->{CWS_CONFIG}->{"CWS_DB_SERVER_$i"}; + last if !defined($val); + push(@cws_db_servers, $val); + $i++; + } + + if ( !@cws_db_servers) { + croak("ERROR: no CWS_DB_SERVER_* entry found in '\$HOME/.cwsrc'.\n" ); + } + + if ( $cws_db_servers[0] =~ /^https:\/\// ) { + my $id = $self->vcsid(); + my $password = $config_file->{CWS_CONFIG}->{'CVS_PASSWORD'}; + + if ( !defined($password) ) { + croak("ERROR: no CVS_PASSWORD entry found in '\$HOME/.cwsrc'.\n" ); + } + + # We are going to stuff $id and $password in an URL, do proper escaping. + $id = uri_escape($id); + $password = uri_escape($password); + + foreach ( @cws_db_servers ) { + s/^https:\/\//https:\/\/$id:$password@/; + } + } + + $self->{CWS_DB_URL_LIST_REF} = \@cws_db_servers; + } + return $self->{CWS_DB_URL_LIST_REF}; +} + +sub net_proxy +{ + my $self = shift; + + if ( !defined($self->{NET_PROXY}) ) { + my $config_file = $self->get_config_file(); + my $net_proxy = $config_file->{CWS_CONFIG}->{'PROXY'}; + if ( !defined($net_proxy) ) { + $net_proxy = ""; + } + $self->{NET_PROXY} = $net_proxy; + } + return $self->{NET_PROXY} ? $self->{NET_PROXY} : undef; +} + +sub cvs_binary +{ + my $self = shift; + + if ( !defined($self->{CVS_BINARY}) ) { + my $config_file = $self->get_config_file(); + my $cvs_binary = $config_file->{CWS_CONFIG}->{'CVS_BINARY'}; + if ( !defined($cvs_binary) ) { + # defaults + $cvs_binary = ($^O eq 'MSWin32') ? 'cvs.exe' : 'cvs'; + } + # special case ... don't ask ... + if ($cvs_binary =~ /cvs.clt2/ && $^O eq 'MSWin32') { + $cvs_binary = 'cvsclt2.exe'; + } + $self->{CVS_BINARY} = $cvs_binary; + } + return $self->{CVS_BINARY}; +} + +sub cvs_server_root +{ + my $self = shift; + + if ( !defined($self->{CVS_SERVER_ROOT}) ) { + my $config_file = $self->get_config_file(); + my $cvs_server_root = $config_file->{CWS_CONFIG}->{'CVS_SERVER_ROOT'}; + if ( !defined($cvs_server_root) ) { + # give up, this is a mandatory entry + croak("ERROR: can't parse CVS_SERVER_ROOT entry in '\$HOME/.cwsrc'.\n"); + } + $self->{CVS_SERVER_ROOT} = $cvs_server_root; + } + return $self->{CVS_SERVER_ROOT}; +} + +sub cvs_mirror_root +{ + my $self = shift; + + if ( !defined($self->{CVS_MIRROR_ROOT}) ) { + my $config_file = $self->get_config_file(); + my $cvs_mirror_root = $config_file->{CWS_CONFIG}->{'CVS_MIRROR_ROOT'}; + if ( !defined($cvs_mirror_root) ) { + $cvs_mirror_root = ""; + } + $self->{CVS_MIRROR_ROOT} = $cvs_mirror_root; + } + return $self->{CVS_MIRROR_ROOT} ? $self->{CVS_MIRROR_ROOT} : undef; +} + +sub cvs_local_root +{ + my $self = shift; + + if ( !defined($self->{CVS_LOCAL_ROOT}) ) { + my $config_file = $self->get_config_file(); + my $cvs_local_root = $config_file->{CWS_CONFIG}->{'CVS_LOCAL_ROOT'}; + if ( !defined($cvs_local_root) ) { + $cvs_local_root = ""; + } + $self->{CVS_LOCAL_ROOT} = $cvs_local_root; + } + return $self->{CVS_LOCAL_ROOT} ? $self->{CVS_LOCAL_ROOT} : undef; +} + +sub get_cvs_server +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); + return $server; +} + +sub get_cvs_mirror +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); + return $server; +} + +sub get_cvs_local +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); + return $server; +} + +sub get_cvs_server_method +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); + return $method; +} + +sub get_cvs_mirror_method +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); + return $method; +} + +sub get_cvs_local_method +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); + return $method; +} + +sub get_cvs_server_repository +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); + return $repository; +} + +sub get_cvs_mirror_repository +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); + return $repository; +} + +sub get_cvs_local_repository +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); + return $repository; +} + +sub get_cvs_server_id +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); + return $id; +} + +sub get_cvs_mirror_id +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); + return $id; +} + +sub get_cvs_local_id +{ + my $self = shift; + + my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); + return $id; +} + +#### class methods ##### +sub get_config +{ + my $config = CwsConfig->new(); + return $config; +} + +sub split_root +{ + my $root = shift; + my $type = shift; + + if ( !defined($root) ) { + return (undef, undef, undef, undef); + } + + my ($dummy, $method, $id_at_host, $repository) = split(/:/, $root); + my ($id, $server); + if ( $id_at_host ) { + ($id, $server) = split(/@/, $id_at_host); + } + if ( !defined($method) || !defined($id) || !defined($server) || !defined($repository) ) { + # give up + print "$method, $id, $server, $repository\n"; + croak("ERROR: can't parse CVS_".$type."_ROOT entry in '\$HOME/.cwsrc'.\n"); + } + return ($method, $id, $server, $repository); +} + +#### private helper methods #### + +sub get_config_file +{ + my $self = shift; + + if ( !defined $self->{_CONFIG_FILE} ) { + $self->parse_config_file(); + } + return $self->{_CONFIG_FILE}; +} + +sub parse_config_file +{ + my $self = shift; + + my $config_file; + # check for config files + if ( -e "$ENV{HOME}/.cwsrc" ) { + $config_file = Config::Tiny->read("$ENV{HOME}/.cwsrc"); + } + elsif ( -e "$ENV{COMMON_ENV_TOOLS}/cwsrc" ) { + $config_file = Config::Tiny->read("$ENV{COMMON_ENV_TOOLS}/cwsrc"); + } + else { + croak("ERROR: can't find CWS config file '\$HOME/.cwsrc'.\n"); + } + + croak("ERROR: can't read CWS config file '\$HOME/.cwsrc'.\n") if !defined($config_file); + + $self->{_CONFIG_FILE}=$config_file; +} + +1; # needed by "use" or "require" diff --git a/solenv/bin/modules/Eis.pm b/solenv/bin/modules/Eis.pm new file mode 100755 index 000000000000..11beaf1cbedc --- /dev/null +++ b/solenv/bin/modules/Eis.pm @@ -0,0 +1,224 @@ +#************************************************************************* +# +# $RCSfile: Eis.pm,v $ +# +# $Revision: 1.2 $ +# +# last change: $Author: hr $ $Date: 2004-06-26 00:20:19 $ +# +# The Contents of this file are made available subject to the terms of +# either of the following licenses +# +# - GNU Lesser General Public License Version 2.1 +# - Sun Industry Standards Source License Version 1.1 +# +# Sun Microsystems Inc., October, 2000 +# +# GNU Lesser General Public License Version 2.1 +# ============================================= +# Copyright 2000 by Sun Microsystems, Inc. +# 901 San Antonio Road, Palo Alto, CA 94303, USA +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License version 2.1, as published by the Free Software Foundation. +# +# This library 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 for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, +# MA 02111-1307 USA +# +# +# Sun Industry Standards Source License Version 1.1 +# ================================================= +# The contents of this file are subject to the Sun Industry Standards +# Source License Version 1.1 (the "License"); You may not use this file +# except in compliance with the License. You may obtain a copy of the +# License at http://www.openoffice.org/license.html. +# +# Software provided under this License is provided on an "AS IS" basis, +# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, +# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS, +# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING. +# See the License for the specific provisions governing your rights and +# obligations concerning the Software. +# +# The Initial Developer of the Original Code is: Sun Microsystems, Inc.. +# +# Copyright: 2000 by Sun Microsystems, Inc. +# +# All Rights Reserved. +# +# Contributor(s): _______________________________________ +# +# +# +#************************************************************************* + + +# +# Eis.pm - package for accessing/manipulating the EIS database via SOAP +# + +package Eis; +use strict; + +use SOAP::Lite; +use Class::Struct; +use Carp; + +# Declaration of class Eis together with ctor and accessors. +# See 'perldoc Class::Struct' for details + +struct Eis => [ + # public members + uri => '$', # name of webservice + proxy_list => '@', # list of proxy URLs + current_proxy => '$', # current proxy (index in proxy_list) + net_proxy => '$', # network proxy to pass through firewall + # private members + eis_connector => '$' # SOAP connector to EIS database +]; + +#### public methods #### + +# Any not predeclared method call to this package is +# interpreted as a SOAP method call. We use the AUTOLOAD +# mechanism to intercept these calls and delgate them +# to the eis_connector. +# See the 'Camel Book', 3rd edition, page 337 for an +# explanation of the AUTOLOAD mechanism. +sub AUTOLOAD +{ + my $self = shift; + my $callee = $Eis::AUTOLOAD; # $callee now holds the name of + # called subroutine + # + return if $callee =~ /::DESTROY$/; + $callee = substr($callee, 5); + + my $sl = $self->eis_connector(); + if ( !$sl ) { + $sl = $self->init_eis_connector(); + $self->eis_connector($sl); + } + + my $response; + while ( 1 ) { + # Call callee() on web service. + eval { $response = $sl->$callee(@_) }; + if ( $@ ) { + # Transport error (server not available, timeout, etc). + # Use backup server. + print STDERR ("Warning: web service unavailable. Trying backup server.\n"); + if ( !$self->set_next_proxy() ) { + # All proxies tried, out of luck + carp("ERROR: Connection to EIS database failed.\n"); + return undef; + } + } + else { + last; + } + } + + if ( $response->fault() ) { + my $fault_msg = get_soap_fault_message($response); + die $fault_msg; # throw $fault_msg as exception + } + else { + return $response->result(); + } +} + +#### public class methods #### + +# Turn scalar into SOAP string. +sub to_string +{ + my $value = shift; + + return SOAP::Data->type(string => $value); +} + +#### non public instance methods #### + +# Initialize SOAP connection to EIS. +sub init_eis_connector +{ + my $self = shift; + + # Init current_proxy with first element of the proxy list. + my $current = $self->current_proxy(0); + + if ( !$self->uri() ) { + carp("ERROR: web service URI not set."); + return undef; + } + + if ( !$self->proxy_list->[$current] ) { + carp("ERROR: proxy list not proper initialized."); + return undef; + } + + # might be needed to get through a firewall + if ( defined($self->net_proxy()) ) { + $ENV{HTTPS_PROXY}=$self->net_proxy(); + } + + my $proxy = $self->proxy_list()->[$current]; + return create_eis_connector($self->uri(), $proxy); +} + +# Advance one entry in proxy list. +sub set_next_proxy +{ + my $self = shift; + + my @proxies = @{$self->proxy_list()}; + my $current = $self->current_proxy(); + + if ( $current == $#proxies ) { + return 0; + } + else { + $self->current_proxy(++$current); + my $next_proxy = $self->proxy_list()->[$current]; + $self->eis_connector()->proxy($next_proxy); + return 1; + } +} + +#### misc #### + +# Create new SOAP EIS conector. +sub create_eis_connector +{ + my $uri = shift; + my $proxy = shift; + + my $sl = SOAP::Lite + -> uri($uri) + -> proxy($proxy); + + return $sl; +} + +# Retrieve SOAP fault message. +sub get_soap_fault_message +{ + my $faulty_response = shift; + my $fault_msg = join(', ', $faulty_response->faultcode(), + $faulty_response->faultstring(), + $faulty_response->faultdetail()); + return $fault_msg; +} + +#### + +1; # needed by "use" or "require" |