Commits

Vladimir Glazunov  committed 55a26aa Merge

CWS-TOOLING: integrate CWS hr68

  • Participants
  • Parent commits 49fb9fd, 0376a51

Comments (0)

Files changed (1)

File solenv/bin/cws.pl

 use Getopt::Long;
 use File::Basename;
 use File::Path;
+use File::Copy; 
 use Cwd;
 use Benchmark;
 
 # TODO: replace dummy vales with actual SVN->hg and source_config migration milestones
 my $dev300_migration_milestone = 'm64';
 my $dev300_source_config_milestone = 'm65';
-my $ooo320_migration_milestone = 'm999';
+my $ooo320_migration_milestone = 'm13';
 my $ooo320_source_config_milestone = 'm999';
 
 # valid command with possible abbreviations
                         'create', 
                         'fetch',  'f', 
                         'rebase', 'rb',
-                        'analyze', 'an',
                         'query', 'q',
                         'task', 't',
                         'integrate',
                             'fetch'      => ['help', 'switch', 'milestone', 'childworkspace','platforms','quiet',
                                             'onlysolver'],
                             'rebase'     => ['help', 'milestone','commit'],
-                            'analyze'    => ['help'],
                             'query'      => ['help', 'milestone','masterworkspace','childworkspace'],
                             'task'       => ['help'],
                             'integrate'  => ['help', 'childworkspace'],
     elsif ($command eq 'rb') {
         $command = 'rebase';
     }
-    elsif ($command eq 'an') {
-        $command = 'analyze';
-    }
     elsif ($command eq 'q') {
         $command = 'query';
     }
     close(HGRC);
 }
 
-sub is_hg_strip_available
-{
-    my $profile = hg_show();
-
-    foreach (@{$profile}) {
-        if ( $_ =~ /hgext.mq=/ ) {
-            return 1;
-        }
-    }
-    return 0;
-}
-
-sub hg_clone_repository
+sub hg_clone_cws_or_milestone
 {
     my $rep_type             = shift;
     my $cws                  = shift;
             print STDERR "CWS-DEBUG: not a directory '$master_local_source'\n";
         }
     }
-
-    # clone from local source if possible, otherwise from LAN source
-    if ( -d $master_local_source && can_use_hardlinks($master_local_source, dirname($target)) ) {
-        hg_local_clone_repository($master_local_source, $target, $milestone_tag);
-    }
-    else {
-        hg_lan_clone_repository($master_lan_source, $target, $milestone_tag);
-    }
-
-    # now pull from the remote cws outgoing repository if it already contains something
+    
+    my $pull_from_remote = 0;
+    my $cws_remote_source;
     if ( !$clone_milestone_only ) {
-        my $cws_remote_source = "$hg_remote_source/cws/" . $cws->child();
+        $cws_remote_source = "$hg_remote_source/cws/" . $cws->child();
 
         # The outgoing repository might not yet be available. Which is not
         # an error. Since pulling from the cws outgoing URL results in an ugly
-        # and hardly understandable error message, we check for the availaility
+        # and hardly understandable error message, we check for availibility
         # first. TODO: incorporate configured proxy instead of env_proxy. Use
         # a dedicated request and content-type to find out if the repo is there 
         # instead of parsing the content of the page
+        print_message("... check availibility of 'outgoing' repository '$cws_remote_source'.");
         require LWP::Simple;
         my $content = LWP::Simple::get($cws_remote_source);
         my $pattern = "<title>cws/". $cws->child();
         if ( $content =~ /$pattern/ ) {
-            hg_remote_pull_repository($cws_remote_source, $target);
+            $pull_from_remote = 1;
         }
         else {
-            print_message("The 'outgoing' repository '$cws_remote_source' is not accessible/available");
+            print_message("... 'outgoing' repository '$cws_remote_source' is not accessible/available yet.");
         }
+    }
+    
+    # clone repository (without working tree if we still need to pull from remote)
+    my $clone_with_update = !$pull_from_remote;
+    hg_clone_repository($master_local_source, $master_lan_source, $target, $milestone_tag, $clone_with_update);
+
+    # now pull from the remote cws outgoing repository if its already available
+    if ( $pull_from_remote ) {
+        hg_remote_pull_repository($cws_remote_source, $target);
+    }
+
+    # if we fetched a CWS adorn the result with push-path and hooks
+    if ( $cws_remote_source ) {
         hgrc_append_push_path_and_hooks($target, $cws_remote_source);
     }
 
-    # update the result
-    hg_update_repository($target);
+    # update the result if necessary
+    if ( !$clone_with_update ) {
+        hg_update_repository($target);
+    }
 
 }
 
-sub hg_local_clone_repository
+sub hg_clone_repository
 {
-    my $local_source  = shift;
-    my $dest          = shift;
-    my $milestone_tag = shift;
-
-    # fastest way to clone a repository up to a certain milestone
-    # 1) clone w/o -r options (hard links!)
-    # 2) find (local) revision which corresponds to milestone
-    # 3) strip revision+1
-
-    my $t1 = Benchmark->new();
-    print_message("... clone LOCAL repository '$local_source' to '$dest'");
-    hg_clone($local_source, $dest, '-U');
-    my $id_option = "-n -r $milestone_tag";
-    my $revision = hg_ident($dest, $milestone_tag);
-    if ( defined($revision) ) {
-        my $strip_revision = $revision+1;
-        hg_strip($dest, $revision);
-    }
-    my $t2 = Benchmark->new();
-    print_time_elapsed($t1, $t2) if $profile;
-}
-
-sub hg_lan_clone_repository
-{
+    my $local_source    = shift;
     my $lan_source    = shift;
     my $dest          = shift;
     my $milestone_tag = shift;
+    my $update        = shift;
 
     my $t1 = Benchmark->new();
-    print_message("... clone LAN repository '$lan_source' to '$dest'");
-    hg_clone($lan_source, $dest, "-U -r $milestone_tag");
+    my $source;
+    my $clone_option = $update ? '' : '-U ';
+    if ( -d $local_source && can_use_hardlinks($local_source, $dest) ) {
+        $source = $local_source;
+        if ( !hg_milestone_is_latest_in_repository($local_source, $milestone_tag) ) {
+                $clone_option .= "-r $milestone_tag";
+        }
+        print_message("... clone LOCAL repository '$local_source' to '$dest'");
+    }
+    else {
+        $source = $lan_source;
+        $clone_option .= "-r $milestone_tag";
+        print_message("... clone LAN repository '$lan_source' to '$dest'");
+    }
+    hg_clone($source, $dest, $clone_option);
+    
     my $t2 = Benchmark->new();
     print_time_elapsed($t1, $t2) if $profile;
 }
     print_time_elapsed($t1, $t2) if $profile;
 }
 
+sub hg_milestone_is_latest_in_repository
+{
+    my $repository = shift;
+    my $milestone_tag = shift;
+
+    # Our milestone is the lastest thing in the repository
+    # if the parent of the repository tip is adorned
+    # with the milestone tag.
+    my $tags_of_parent_of_tip = hg_parent($repository, 'tip', "--template='{tags}\\n'");
+    if ( $tags_of_parent_of_tip =~ /\b$milestone_tag\b/ ) {
+        return 1;
+    }
+    return 0;
+}
+
 # Check if clone source and destination are on the same filesystem,
 # in that case hg clone can employ hard links.
 sub can_use_hardlinks
     }
     # st_dev is the first field return by stat()
     my @stat_source = stat($source);
-    my @stat_dest = stat($dest);
+    my @stat_dest = stat(dirname($dest));
 
     if ( $debug ) {
-        print STDERR "can_use_hardlinks(): source device: '$stat_source[0]', destination device: '$stat_dest[0]'\n";
+        my $source_result = defined($stat_source[0]) ? $stat_source[0] : 'stat failed';
+        my $dest_result = defined($stat_dest[0]) ? $stat_dest[0] : 'stat failed';
+        print STDERR "CWS-DEBUG: can_use_hardlinks(): source device: '$stat_source[0]', destination device: '$stat_dest[0]'\n";
     }
-    if ( $stat_source[0] == $stat_dest[0] ) {
+    if ( defined($stat_source[0]) && defined($stat_dest[0]) && $stat_source[0] == $stat_dest[0] ) {
         return 1;
     }
     return 0;
     }
 }
 
+sub fetch_external_tarballs
+{
+    my $source_root_dir = shift;
+    my $external_tarballs_source = shift;
+
+    my $ooo_external_file = "$source_root_dir/ooo/ooo.lst";
+    my $sun_external_file = "$source_root_dir/sun/sun.lst";
+    my $sun_path          = "$source_root_dir/sun";
+
+    my @external_sources_list;
+    push(@external_sources_list, read_external_file($ooo_external_file));
+    if ( -d $sun_path ) {
+        if ( -e $sun_external_file ) {
+            push(@external_sources_list, read_external_file($sun_external_file));
+        }
+        else {
+            print_error("Can't find external file list '$sun_external_file'.", 8);
+        }
+    }
+    
+    my $ext_sources_dir = "$source_root_dir/ext_sources";
+    print_message("Copy external tarballs to '$ext_sources_dir'");
+    if ( ! -d $ext_sources_dir) {
+        if ( !mkdir($ext_sources_dir) ) {
+            print_error("Can't create directory '$ext_sources_dir': $!.", 44);
+        }
+    }
+    foreach (@external_sources_list) {
+        if ( ! copy("$external_tarballs_source/$_", $ext_sources_dir) ) {
+            print_error("Can't copy file '$external_tarballs_source' -> '$ext_sources_dir': $!", 0);
+        }
+    }
+    return;
+}
+
+sub read_external_file
+{
+    my $external_file = shift;
+
+    my @external_sources;
+    open(EXT, "<$external_file") or print_error("Can't open file '$external_file' for reading: $!", 98);
+    while(<EXT>) {
+        if ( !/^http:/ ) {
+            chomp;
+            push(@external_sources, $_);
+        }
+    }
+    close(EXT);
+    return @external_sources;
+}
+
 sub update_solver
 {
     my $platform      = shift;
         print STDERR "\thelp (h,?)\n";
         print STDERR "\tcreate\n";
         print STDERR "\tfetch (f)\n";
-        print STDERR "\trebase (rb)\n";
-        print STDERR "\tanalyze (an)\n";
+        print STDERR "\trebase (rb) (SVN only)\n";
         print STDERR "\tquery (q)\n";
         print STDERR "\ttask (t)\n";
-        print STDERR "\tcdiff (cd)\n";
+        print STDERR "\tcdiff (cd) (SVN only)\n";
         print STDERR "\tsetcurrent\n";
         print STDERR "\tintegrate *** release engineers only ***\n";
         print STDERR "\teisclone *** release engineers only ***\n";
 
      }
     elsif ($arg eq 'fetch') {
-        print STDERR "THE USER-INTERFACE TO THIS SUBCOMMAND IS LIKELY TO CHANGE IN FUTURE\n";
         print STDERR "fetch: fetch a milestone or CWS\n";
         print STDERR "usage: fetch [-q] [-s] [-p platforms] [-o] <-m milestone> <workspace>\n";
         print STDERR "usage: fetch [-q] [-s] [-p platforms] [-o] <-c cws> <workspace>\n";
         print STDERR "\t--quiet:                Same as -q\n";
     }
     elsif ($arg eq 'rebase') {
-        print STDERR "rebase: Rebase a child workspace to a new milestone\n";
+        print STDERR "rebase: Rebase a child workspace to a new milestone (SVN only)\n";
         print STDERR "usage: rebase <-m milestone> <workspace>\n";
         print STDERR "usage: rebase <-C> <workspace>\n";
         print STDERR "\t-m milestone:          Merge changes on MWS into CWS up to and including milestone <milestone>\n";
         print STDERR "\t--commit:               Same as -C\n"
     }
     elsif ($arg eq 'cdiff') {
-        print STDERR "cdiff: Show changes on CWS relative to current milestone\n";
+        print STDERR "cdiff: Show changes on CWS relative to current milestone (SVN only)\n";
         print STDERR "usage: cdiff [-M master] [-c child] [--files] [--modules]\n";
         print STDERR "\t-M master:\t\toverride MWS specified in environment\n";
         print STDERR "\t-c child:\t\toverride CWS specified in environment\n";
     }
 }
 
-sub do_analyze
-{
-    my $args_ref    = shift;
-    my $options_ref = shift;
-
-    print_error("not yet implemented.", 2);
-}
-
 sub do_integrate
 {
     my $args_ref    = shift;
         print STDERR "CWS-DEBUG: SCM: $scm\n";
     }
 
-    if ( $scm eq 'HG' ) {
-        if ( !is_hg_strip_available() ) {
-            print_error("The 'cws fetch' command requires that 'hg strip' is enabled", 0);
-            print_error("Please add the following lines to your hg profile (\$HOME/.hgrc)", 0);
-            print_error("[extensions]", 0);
-            print_error("hgext.mq=", 33);
-        }
-    }
-
     my $config = CwsConfig->new();
     my $ooo_svn_server = $config->get_ooo_svn_server();
     my $so_svn_server = $config->get_so_svn_server();
+    my $prebuild_dir = $config->get_prebuild_binaries_location();
     # Check early for platforms so we can bail out before anything time consuming is done
     # in case of a missing platform
     my @platforms;
-    my $prebuild_dir;
     if ( defined($platforms) ) {
         use Archive::Zip; # warn early if module is missing
-        $prebuild_dir = $config->get_prebuild_binaries_location();
-        $masterws = $cws->master();
+        if ( !defined($prebuild_dir ) ) {
+            print_error("PREBUILD_BINARIES not configured, can't find platform solvers", 99);
+        }
         $prebuild_dir = "$prebuild_dir/$masterws";
 
         @platforms = split(/,/, $platforms);
                     $nonproduct = 1;
                 }
             }
-            push(@platforms, 'common.pro') if ($product && !$added_product);
-            push(@platforms, 'common') if ($nonproduct && !$added_nonproduct);
+            unshift(@platforms, 'common.pro') if ($product && !$added_product);
+            unshift(@platforms, 'common') if ($nonproduct && !$added_nonproduct);
         }
 
         foreach(@platforms) {
                     svn_checkout($so_url, "$work_master/sun", $quiet);
                 }
                 else{
-                    hg_clone_repository('ooo', $cws, "$work_master/ooo", $clone_milestone_only); 
-                    hg_clone_repository('so', $cws, "$work_master/sun", $clone_milestone_only);
+                    hg_clone_cws_or_milestone('ooo', $cws, "$work_master/ooo", $clone_milestone_only); 
+                    hg_clone_cws_or_milestone('so', $cws, "$work_master/sun", $clone_milestone_only);
                 }
                 if ( get_source_config_for_milestone($masterws, $milestone) ) {
                     # write source_config file
                     svn_checkout($ooo_url, $workspace, $quiet);
                 }
                 else {
-                    hg_clone_repository('ooo', $cws, $workspace, $clone_milestone_only);
+                    hg_clone_cws_or_milestone('ooo', $cws, $workspace, $clone_milestone_only);
                 }
             }
         }
     }
-    
+
+    if ( !$onlysolver ) {
+        my $source_root_dir = "$workspace/$masterws";
+        my $external_tarball_source = "$prebuild_dir/$masterws/ext_sources";
+        if ( -e "$source_root_dir/ooo/ooo.lst" && defined($prebuild_dir) && -d $external_tarball_source ) {
+            fetch_external_tarballs($source_root_dir, $external_tarball_source);
+        }
+    }
+
     if ( defined($platforms) ) {
         if ( !-d $workspace ) {
             if ( !mkdir($workspace) ) {
         print_error("'$childws' is not a valid CWS name.\n", 30);
     }
 
+    if ( $cws->get_scm() eq 'HG' ) {
+        print_error("cws cdiff is not supported for mercurial based childworkspaces", 80);
+    }
     my $milestone = $cws->milestone();
     
     my $config = CwsConfig->new();
     return @result;
 }
 
-sub hg_ident
+sub hg_parent
 {
     my $repository  = shift;
     my $rev_id = shift;
+    my $options = shift;
 
     if ( $debug ) {
-        print STDERR "CWS-DEBUG: ... hg ident: 'repository', revision: '$rev_id'\n";
+        print STDERR "CWS-DEBUG: ... hg parent: 'repository', revision: '$rev_id', options: $options\n";
     }
 
-    my @result = execute_hg_command(0, 'ident', "--cwd $repository", "-n -r $rev_id");
+    my @result = execute_hg_command(0, 'parent', "--cwd $repository", "-r $rev_id", $options);
     my $line = $result[0];
-    if ($line =~ /abort: unknown revision/) {
-        return undef;
-    }
-    else {
-        chomp($line);
-        return $line;
-    }
-}
-
-sub hg_strip
-{
-    my $repository  = shift;
-    my $rev_id = shift;
-
-    if ( $debug ) {
-        print STDERR "CWS-DEBUG: ... hg strip: 'repository', revision: '$rev_id'\n";
-    }
-
-    my @result = execute_hg_command(1, 'strip', "--cwd $repository", '-n', $rev_id);
-    my $line = $result[0];
-    if ($line =~ /abort: unknown revision/) {
-        return undef;
-    }
-    else {
-        chomp($line);
-        return $line;
-    }
+    chomp($line);
+    return $line;
 }
 
 sub hg_pull