xref: /aoo41x/main/solenv/bin/cws.pl (revision 7e90fac2)
1#!/usr/bin/perl -w
2#**************************************************************
3#
4#  Licensed to the Apache Software Foundation (ASF) under one
5#  or more contributor license agreements.  See the NOTICE file
6#  distributed with this work for additional information
7#  regarding copyright ownership.  The ASF licenses this file
8#  to you under the Apache License, Version 2.0 (the
9#  "License"); you may not use this file except in compliance
10#  with the License.  You may obtain a copy of the License at
11#
12#    http://www.apache.org/licenses/LICENSE-2.0
13#
14#  Unless required by applicable law or agreed to in writing,
15#  software distributed under the License is distributed on an
16#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
17#  KIND, either express or implied.  See the License for the
18#  specific language governing permissions and limitations
19#  under the License.
20#
21#**************************************************************
22
23
24
25#*************************************************************************
26#
27# cws.pl   - wrap common childworkspace operations
28#
29use strict;
30use Getopt::Long;
31use File::Basename;
32use File::Path;
33use File::Copy;
34use Cwd;
35use Benchmark;
36
37#### module lookup
38my @lib_dirs;
39BEGIN {
40    if ( !defined($ENV{SOLARENV}) ) {
41        die "No environment found (environment variable SOLARENV is undefined)";
42    }
43    push(@lib_dirs, "$ENV{SOLARENV}/bin/modules");
44}
45use lib (@lib_dirs);
46
47use Cws;
48
49#### script id #####
50
51( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;
52
53#### globals ####
54
55# TODO: replace dummy vales with actual source_config migration milestone
56my $ooo320_source_config_milestone = 'm999';
57
58# valid command with possible abbreviations
59my @valid_commands = (
60                        'help', 'h', '?',
61                        'create',
62                        'fetch',  'f',
63                        'query', 'q',
64                        'task', 't',
65                        'eisclone',
66                        'setcurrent'
67                     );
68
69# list the valid options to each command
70my %valid_options_hash = (
71                            'help'       => ['help'],
72                            'create'     => ['help', 'milestone', 'migration', 'hg'],
73                            'fetch'      => ['help', 'milestone', 'childworkspace','platforms','noautocommon',
74                                            'quiet', 'onlysolver', 'additionalrepositories'],
75                            'query'      => ['help', 'milestone','masterworkspace','childworkspace'],
76                            'task'       => ['help'],
77                            'setcurrent' => ['help', 'milestone'],
78                            'eisclone'   => ['help']
79                         );
80
81my %valid_commands_hash;
82for (@valid_commands) {
83    $valid_commands_hash{$_}++;
84}
85
86#  set by --debug switch
87my $debug = 0;
88#  set by --profile switch
89my $profile = 0;
90
91
92#### main ####
93
94my ($command, $args_ref, $options_ref) = parse_command_line();
95dispatch_command($command, $args_ref, $options_ref);
96exit(0);
97
98#### subroutines ####
99
100# Parses the command line. does prelimiary argument and option verification
101sub parse_command_line
102{
103    if (@ARGV == 0) {
104        usage();
105        exit(1);
106    }
107
108    my %options_hash;
109    Getopt::Long::Configure ("no_auto_abbrev", "no_ignorecase");
110    my $success = GetOptions(\%options_hash, 'milestone|m=s',
111                                             'masterworkspace|master|M=s',
112                                             'hg',
113                                             'migration',
114                                             'childworkspace|child|c=s',
115                                             'debug',
116                                             'profile',
117                                             'commit|C',
118                                             'platforms|p=s',
119                                             'additionalrepositories|r=s',
120                                             'noautocommon|x=s',
121                                             'onlysolver|o',
122                                             'quiet|q',
123                                             'help|h'
124                            );
125
126    my $command = shift @ARGV;
127
128    if (!exists $valid_commands_hash{$command}) {
129        print_error("Unkown command: '$command'\n");
130        usage();
131        exit(1);
132    }
133
134    if ($command eq 'h' || $command eq '?') {
135        $command = 'help';
136    }
137    elsif ($command eq 'f') {
138        $command = 'fetch';
139    }
140    elsif ($command eq 'q') {
141        $command = 'query';
142    }
143    elsif ($command eq 't') {
144        $command = 'task';
145    }
146
147    # An unkown option might be accompanied with a valid command.
148    # Show the command specific help
149    if ( !$success ) {
150        do_help([$command])
151    }
152
153    verify_options($command, \%options_hash);
154    return ($command, \@ARGV, \%options_hash);
155}
156
157# Verify options against the valid options list.
158sub verify_options
159{
160    my $command     = shift;
161    my $options_ref = shift;
162
163    my $valid_command_options_ref = $valid_options_hash{$command};
164
165    my %valid_command_options_hash;
166    foreach (@{$valid_command_options_ref}) {
167        $valid_command_options_hash{$_}++;
168    }
169
170    # check all specified options against the valid options for the sub command
171    foreach (keys %{$options_ref}) {
172        if ( /debug/ ) {
173            $debug = 1;
174            next;
175        }
176        if ( /profile/ ) {
177            $profile = 1;
178            next;
179        }
180        if (!exists $valid_command_options_hash{$_}) {
181            print_error("can't use option '--$_' with subcommand '$command'.", 1);
182        }
183    }
184
185}
186
187# Dispatches to the do_xxx() routines depending on command.
188sub dispatch_command
189{
190    my $command     = shift;
191    my $args_ref    = shift;
192    my $options_ref = shift;
193
194    no strict 'refs';
195    &{"do_".$command}($args_ref, $options_ref);
196}
197
198# Returns the global cws object.
199BEGIN {
200my $the_cws;
201
202    sub get_this_cws {
203        if (!defined($the_cws)) {
204            $the_cws = Cws->new();
205            return $the_cws;
206        }
207        else {
208            return $the_cws;
209        }
210    }
211}
212
213# Returns a list of the master workspaces.
214sub get_master_workspaces
215{
216    my $cws = get_this_cws();
217    my @masters = $cws->get_masters();
218
219    return wantarray ? @masters : \@masters;
220}
221
222# Checks if master argument is a valid MWS name.
223BEGIN {
224    my %master_hash;
225
226    sub is_master
227    {
228        my $master_name = shift;
229
230        if (!%master_hash) {
231            my @masters = get_master_workspaces();
232            foreach (@masters) {
233                $master_hash{$_}++;
234            }
235        }
236        return exists $master_hash{$master_name} ? 1 : 0;
237    }
238}
239
240# Fetches the current CWS from environment, returns a Cws object
241sub get_cws_from_environment
242{
243    my $child  = $ENV{CWS_WORK_STAMP};
244    my $master = $ENV{WORK_STAMP};
245
246    if ( !$child ) {
247        print_error("Environment variable CWS_WORK_STAMP is not set. Please set it to your CWS name.", 2);
248    }
249
250    if ( !$master ) {
251        print_error("Environment variable WORK_STAMP is not set. Please set it to the MWS name.", 2);
252    }
253
254    my $cws = get_this_cws();
255    $cws->child($child);
256    $cws->master($master);
257
258    # Check if we got a valid child workspace.
259    my $id = $cws->eis_id();
260    if ( $debug ) {
261        print STDERR "CWS-DEBUG: ... master: $master, child: $child, $id\n";
262    }
263    if ( !$id ) {
264        print_error("Child workspace $child for master workspace $master not found in EIS database.", 2);
265    }
266    return ($cws);
267}
268
269# Fetches the CWS by name, returns a Cws object
270sub get_cws_by_name
271{
272    my $child  = shift;
273
274    my $cws = get_this_cws();
275    $cws->child($child);
276
277    # Check if we got a valid child workspace.
278    my $id = $cws->eis_id();
279    if ( $debug ) {
280        print STDERR "CWS-DEBUG: child: $child, $id\n";
281    }
282    if ( !$id ) {
283        print_error("Child workspace $child not found in EIS database.", 2);
284    }
285
286    # Update masterws part of Cws object.
287    my $masterws = $cws->get_mws();
288    if ( $cws->master() ne $masterws ) {
289        # can this still happen?
290        if ( $debug ) {
291            print STDERR "CWS-DEBUG: get_cws_by_name(): fixup of masterws in cws object detected\n";
292        }
293        $cws->master($masterws);
294    }
295    return ($cws);
296}
297
298# Register child workspace with eis.
299sub register_child_workspace
300{
301    my $cws          = shift;
302    my $scm          = shift;
303    my $is_promotion = shift;
304
305    my $milestone = $cws->milestone();
306    my $child     = $cws->child();
307    my $master    = $cws->master();
308
309    # TODO: introduce a EIS_USER in the configuration, which should be used here
310    my $config = CwsConfig->new();
311    my $vcsid  = $config->vcsid();
312    # TODO: there is no real need for socustom anymore, should go ASAP
313    my $socustom = $config->sointernal();
314
315    if ( !$vcsid ) {
316        if ( $socustom ) {
317            print_error("Can't determine owner for CWS '$child'. Please set VCSID environment variable.", 11);
318        }
319        else {
320            print_error("Can't determine owner for CWS '$child'. Please set CVS_ID entry in \$HOME/.cwsrc.", 11);
321        }
322    }
323
324    if ( $is_promotion ) {
325        my $rc = $cws->set_scm($scm);
326        if ( !$rc ) {
327            print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12);
328        }
329
330        $rc = $cws->promote($vcsid, "");
331
332        if ( !$rc ) {
333            print_error("Failed to promote child workspace '$child' to status 'new'.\n", 12);
334        }
335        else {
336            print "\n***** Successfully ***** promoted child workspace '$child' to status 'new'.\n";
337            print "Milestone: '$milestone'.\n";
338        }
339    }
340    else {
341
342        my $eis_id = $cws->register($vcsid, "");
343
344        if ( !defined($eis_id) ) {
345            print_error("Failed to register child workspace '$child' for master '$master'.", 12);
346        }
347        else {
348            my $rc = $cws->set_scm($scm);
349            if ( !$rc ) {
350                print_error("Failed to set the SCM property '$scm' on child workspace '$child'.\nContact EIS administrator!\n", 12);
351            }
352            print "\n***** Successfully ***** registered child workspace '$child'\n";
353            print "for master workspace '$master' (milestone '$milestone').\n";
354            print "Child workspace Id: $eis_id.\n";
355        }
356    }
357    return 0;
358}
359
360sub print_time_elapsed
361{
362    my $t_start = shift;
363    my $t_stop  = shift;
364
365    my $time_diff = timediff($t_stop, $t_start);
366    print_message("... finished in " . timestr($time_diff));
367}
368
369sub hgrc_append_push_path_and_hooks
370{
371    my $target     = shift;
372    my $cws_source = shift;
373
374    $cws_source =~ s/http:\/\//ssh:\/\/hg@/;
375    if ( $debug ) {
376        print STDERR "CWS-DEBUG: hgrc_append_push_path_and_hooks(): default-push path: '$cws_source'\n";
377    }
378    if ( !open(HGRC, ">>$target/.hg/hgrc") ) {
379        print_error("Can't append to hgrc file of repository '$target'.\n", 88);
380    }
381    print HGRC "default-push = " . "$cws_source\n";
382    print HGRC "[extensions]\n";
383    print HGRC "hgext.win32text=\n";
384    print HGRC "[hooks]\n";
385    print HGRC "# Reject commits which would introduce windows-style CR/LF files\n";
386    print HGRC "pretxncommit.crlf = python:hgext.win32text.forbidcrlf\n";
387    close(HGRC);
388}
389
390sub hg_clone_cws_or_milestone
391{
392    my $rep_type             = shift;
393    my $cws                  = shift;
394    my $target               = shift;
395    my $clone_milestone_only = shift;
396
397    my ($hg_local_source, $hg_lan_source, $hg_remote_source);
398    my $config = CwsConfig->new();
399
400    $hg_local_source = $config->get_hg_source(uc $rep_type, 'LOCAL');
401    $hg_lan_source = $config->get_hg_source(uc $rep_type, 'LAN');
402    $hg_remote_source = $config->get_hg_source(uc $rep_type, 'REMOTE');
403
404    my $masterws = $cws->master();
405    my ($master_local_source, $master_lan_source);
406
407    $master_local_source = "$hg_local_source/" . $masterws;
408    $master_lan_source = "$hg_lan_source/" . $masterws;
409
410    my $milestone_tag;
411    if ( $clone_milestone_only ) {
412        $milestone_tag = uc($masterws) . '_' . $clone_milestone_only;
413    }
414    else {
415        my @tags = $cws->get_tags();
416        $milestone_tag = $tags[3];
417    }
418
419    if ( $debug ) {
420        print STDERR "CWS-DEBUG: master_local_source: '$master_local_source'\n";
421        print STDERR "CWS-DEBUG: master_lan_source: '$master_lan_source'\n";
422        if ( !-d $master_local_source ) {
423            print STDERR "CWS-DEBUG: not a directory '$master_local_source'\n";
424        }
425    }
426
427    my $pull_from_remote = 0;
428    my $cws_remote_source;
429    if ( !$clone_milestone_only ) {
430        if ($rep_type eq "ooo" || $rep_type eq "so")
431        {
432            $cws_remote_source = "$hg_remote_source/cws/" . $cws->child();
433        }
434        # e.g. cws_l10n
435        else
436        {
437            $cws_remote_source = "$hg_remote_source/cws_".$rep_type."/" . $cws->child();
438        }
439
440        # The outgoing repository might not yet be available. Which is not
441        # an error. Since pulling from the cws outgoing URL results in an ugly
442        # and hardly understandable error message, we check for availibility
443        # first. TODO: incorporate configured proxy instead of env_proxy. Use
444        # a dedicated request and content-type to find out if the repo is there
445        # instead of parsing the content of the page
446        print_message("... check availibility of 'outgoing' repository '$cws_remote_source'.");
447        require LWP::Simple;
448        my $content = LWP::Simple::get($cws_remote_source);
449        my $pattern = "<title>cws/". $cws->child();
450        my $pattern2 = "<title>cws_".$rep_type."/". $cws->child();
451        if ( $content && ($content =~ /$pattern/ || $content =~ /$pattern2/) ) {
452            $pull_from_remote = 1;
453        }
454        else {
455            print_message("... 'outgoing' repository '$cws_remote_source' is not accessible/available yet.");
456        }
457    }
458
459    # clone repository (without working tree if we still need to pull from remote)
460    my $clone_with_update = !$pull_from_remote;
461    hg_clone_repository($master_local_source, $master_lan_source, $target, $milestone_tag, $clone_with_update);
462
463    # now pull from the remote cws outgoing repository if its already available
464    if ( $pull_from_remote ) {
465        hg_remote_pull_repository($cws_remote_source, $target);
466    }
467
468    # if we fetched a CWS adorn the result with push-path and hooks
469    if ( $cws_remote_source ) {
470        hgrc_append_push_path_and_hooks($target, $cws_remote_source);
471    }
472
473    # update the result if necessary
474    if ( !$clone_with_update ) {
475        hg_update_repository($target);
476    }
477
478}
479
480sub hg_clone_repository
481{
482    my $local_source    = shift;
483    my $lan_source    = shift;
484    my $dest          = shift;
485    my $milestone_tag = shift;
486    my $update        = shift;
487
488    my $t1 = Benchmark->new();
489    my $source;
490    my $clone_option = $update ? '' : '-U ';
491    if ( -d $local_source && can_use_hardlinks($local_source, $dest) ) {
492        $source = $local_source;
493        if ( !hg_milestone_is_latest_in_repository($local_source, $milestone_tag) ) {
494                $clone_option .= "-r $milestone_tag";
495        }
496        print_message("... clone LOCAL repository '$local_source' to '$dest'");
497    }
498    else {
499        $source = $lan_source;
500        $clone_option .= "-r $milestone_tag";
501        print_message("... clone LAN repository '$lan_source' to '$dest'");
502    }
503    hg_clone($source, $dest, $clone_option);
504
505    my $t2 = Benchmark->new();
506    print_time_elapsed($t1, $t2) if $profile;
507}
508
509sub hg_remote_pull_repository
510{
511    my $remote_source = shift;
512    my $dest          = shift;
513
514    my $t1 = Benchmark->new();
515    print_message("... pull from REMOTE repository '$remote_source' to '$dest'");
516    hg_pull($dest, $remote_source);
517    my $t2 = Benchmark->new();
518    print_time_elapsed($t1, $t2) if $profile;
519}
520
521sub hg_update_repository
522{
523    my $dest          = shift;
524
525    my $t1 = Benchmark->new();
526    print_message("... update repository '$dest'");
527    hg_update($dest);
528    my $t2 = Benchmark->new();
529    print_time_elapsed($t1, $t2) if $profile;
530}
531
532sub hg_milestone_is_latest_in_repository
533{
534    my $repository = shift;
535    my $milestone_tag = shift;
536
537    # Our milestone is the lastest thing in the repository
538    # if the parent of the repository tip is adorned
539    # with the milestone tag.
540    my $tags_of_parent_of_tip = hg_parent($repository, 'tip', "--template='{tags}\\n'");
541    if ( $tags_of_parent_of_tip =~ /\b$milestone_tag\b/ ) {
542        return 1;
543    }
544    return 0;
545}
546
547# Check if clone source and destination are on the same filesystem,
548# in that case hg clone can employ hard links.
549sub can_use_hardlinks
550{
551    my $source = shift;
552    my $dest = shift;
553
554    if ( $^O eq 'cygwin' ) {
555        # no hard links on windows
556        return 0;
557    }
558    # st_dev is the first field return by stat()
559    my @stat_source = stat($source);
560    my @stat_dest = stat(dirname($dest));
561
562    if ( $debug ) {
563        my $source_result = defined($stat_source[0]) ? $stat_source[0] : 'stat failed';
564        my $dest_result = defined($stat_dest[0]) ? $stat_dest[0] : 'stat failed';
565        print STDERR "CWS-DEBUG: can_use_hardlinks(): source device: '$stat_source[0]', destination device: '$stat_dest[0]'\n";
566    }
567    if ( defined($stat_source[0]) && defined($stat_dest[0]) && $stat_source[0] == $stat_dest[0] ) {
568        return 1;
569    }
570    return 0;
571}
572
573sub query_cws
574{
575    my $query_mode = shift;
576    my $options_ref = shift;
577    # get master and child workspace
578    my $masterws  = exists $options_ref->{'masterworkspace'} ? uc($options_ref->{'masterworkspace'}) : $ENV{WORK_STAMP};
579    my $childws   = exists $options_ref->{'childworkspace'} ? $options_ref->{'childworkspace'} : $ENV{CWS_WORK_STAMP};
580    my $milestone = exists $options_ref->{'milestone'} ? $options_ref->{'milestone'} : 'latest';
581
582    if ( !defined($masterws) && $query_mode ne 'masters') {
583        print_error("Can't determine master workspace environment.\n", 30);
584    }
585
586    if ( ($query_mode eq 'integratedinto' || $query_mode eq 'incompatible' || $query_mode eq 'taskids' || $query_mode eq 'status' || $query_mode eq 'current' || $query_mode eq 'owner' || $query_mode eq 'qarep' || $query_mode eq 'issubversion' || $query_mode eq 'ispublic' || $query_mode eq 'build') && !defined($childws) ) {
587        print_error("Can't determine child workspace environment.\n", 30);
588    }
589
590    my $cws = Cws->new();
591    if ( defined($childws) ) {
592        $cws->child($childws);
593    }
594    if ( defined($masterws) ) {
595        $cws->master($masterws);
596    }
597
598    no strict;
599    &{"query_".$query_mode}($cws, $milestone);
600    return;
601}
602
603sub query_integratedinto
604{
605    my $cws = shift;
606
607    if ( is_valid_cws($cws) ) {
608        my $milestone = $cws->get_milestone_integrated();
609        print_message("Integrated into:");
610        print defined($milestone) ? "$milestone\n" : "unkown\n";
611    }
612    return;
613}
614
615sub query_incompatible
616{
617    my $cws = shift;
618
619    if ( is_valid_cws($cws) ) {
620        my @modules = $cws->incompatible_modules();
621        print_message("Incompatible Modules:");
622        foreach (@modules) {
623            if ( defined($_) ) {
624                print "$_\n";
625            }
626        }
627    }
628    return;
629}
630
631sub query_taskids
632{
633    my $cws = shift;
634
635    if ( is_valid_cws($cws) ) {
636        my @taskids = $cws->taskids();
637        print_message("Task ID(s):");
638        foreach (@taskids) {
639            if ( defined($_) ) {
640                print "$_\n";
641            }
642        }
643    }
644    return;
645}
646
647sub query_status
648{
649    my $cws = shift;
650
651    if ( is_valid_cws($cws) ) {
652        my $status = $cws->get_approval();
653        if ( !$status ) {
654            print_error("Internal error: can't get approval status.", 3);
655        } else {
656            print_message("Approval status:");
657            print "$status\n";
658        }
659    }
660    return;
661}
662
663sub query_scm
664{
665    my $cws = shift;
666    my $masterws = $cws->master();
667    my $childws  = $cws->child();
668
669    if ( is_valid_cws($cws) ) {
670        my $scm = $cws->get_scm();
671        if ( !defined($scm) ) {
672            print_error("Internal error: can't retrieve scm info.", 3);
673        } else {
674                print_message("Child workspace uses '$scm'.");
675        }
676    }
677    return;
678}
679
680sub query_ispublic
681{
682    my $cws = shift;
683    my $masterws = $cws->master();
684    my $childws  = $cws->child();
685
686    if ( is_valid_cws($cws) ) {
687        my $ispublic = $cws->get_public_flag();
688        if ( !defined($ispublic) ) {
689            print_error("Internal error: can't get isPublic flag.", 3);
690        } else {
691            if ( $ispublic==1 ) {
692                print_message("Child workspace is public");
693            } else {
694                print_message("Child workspace is internal");
695            }
696        }
697    }
698
699    return;
700}
701
702sub query_current
703{
704    my $cws = shift;
705
706    if ( is_valid_cws($cws) ) {
707        my $milestone = $cws->milestone();
708        if ( !$milestone ) {
709            print_error("Internal error: can't get current milestone.", 3);
710        } else {
711            print_message("Current milestone:");
712            print "$milestone\n";
713        }
714    }
715    return;
716}
717
718sub query_owner
719{
720    my $cws = shift;
721
722    if ( is_valid_cws($cws) ) {
723        my $owner = $cws->get_owner();
724        print_message("Owner:");
725        if ( !$owner ) {
726            print "not set\n" ;
727        } else {
728            print "$owner\n";
729        }
730    }
731    return;
732}
733
734sub query_qarep
735{
736    my $cws = shift;
737
738    if ( is_valid_cws($cws) ) {
739        my $qarep = $cws->get_qarep();
740        print_message("QA Representative:");
741        if ( !$qarep ) {
742            print "not set\n" ;
743        } else {
744            print "$qarep\n";
745        }
746    }
747    return;
748}
749
750
751sub query_build
752{
753    my $cws = shift;
754
755    if ( is_valid_cws($cws) ) {
756        my $build = $cws->get_build();
757        print_message("Build:");
758        if ( $build ) {
759            print "$build\n";
760        }
761    }
762    return;
763}
764
765sub query_latest
766{
767    my $cws = shift;
768
769    my $masterws = $cws->master();
770    my $latest = $cws->get_current_milestone($masterws);
771
772
773    if ( $latest ) {
774        print_message("Master workspace '$masterws':");
775        print_message("Latest milestone available for update:");
776        print "$masterws $latest\n";
777    }
778    else {
779        print_error("Can't determine latest milestone of '$masterws' available for update.", 3);
780    }
781
782    return;
783}
784
785sub query_masters
786{
787    my $cws = shift;
788
789    my @mws = $cws->get_masters();
790    my $list="";
791
792    if ( @mws ) {
793        foreach (@mws) {
794            if ( $list ne "" ) {
795                $list .= ", ";
796            }
797            $list .= $_;
798        }
799        print_message("Master workspaces available: $list");
800    }
801    else {
802        print_error("Can't determine masterworkspaces.", 3);
803    }
804
805    return;
806}
807
808sub query_milestones
809{
810    my $cws = shift;
811    my $masterws = $cws->master();
812
813    my @milestones = $cws->get_milestones($masterws);
814    my $list="";
815
816    if ( @milestones ) {
817        foreach (@milestones) {
818            if ( $list ne "" ) {
819                $list .= ", ";
820            }
821            $list .= $_;
822        }
823        print_message("Master workspace '$masterws':");
824        print_message("Milestones known on Master: $list");
825    }
826    else {
827        print_error("Can't determine milestones of '$masterws'.", 3);
828    }
829
830    return;
831}
832
833sub query_ispublicmaster
834{
835    my $cws = shift;
836    my $masterws = $cws->master();
837
838    my $ispublic = $cws->get_publicmaster_flag();
839    my $list="";
840
841    if ( defined($ispublic) ) {
842        print_message("Master workspace '$masterws':");
843        if ( !defined($ispublic) ) {
844            print_error("Internal error: can't get isPublicMaster flag.", 3);
845        } else {
846            if ( $ispublic==1 ) {
847                print_message("Master workspace is public");
848            } else {
849                print_message("Master workspace is internal");
850            }
851        }
852    }
853    else {
854        print_error("Can't determine isPublicMaster flag of '$masterws'.", 3);
855    }
856
857    return;
858}
859
860sub query_buildid
861{
862    my $cws       = shift;
863    my $milestone = shift;
864
865    my $masterws = $cws->master();
866    if ( $milestone eq 'latest' ) {
867        $milestone = $cws->get_current_milestone($masterws);
868    }
869
870    if ( !$milestone ) {
871        print_error("Can't determine latest milestone of '$masterws'.", 3);
872    }
873
874    if ( !$cws->is_milestone($masterws, $milestone) ) {
875        print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3);
876    }
877
878    my $buildid = $cws->get_buildid($masterws, $milestone);
879
880
881    if ( $buildid ) {
882        print_message("Master workspace '$masterws':");
883        print_message("BuildId for milestone '$milestone':");
884        print("$buildid\n");
885    }
886
887    return;
888}
889
890sub query_integrated
891{
892    my $cws       = shift;
893    my $milestone = shift;
894
895    my $masterws = $cws->master();
896    if ( $milestone eq 'latest' ) {
897        $milestone = $cws->get_current_milestone($masterws);
898    }
899
900    if ( !$milestone ) {
901        print_error("Can't determine latest milestone of '$masterws'.", 3);
902    }
903
904    if ( !$cws->is_milestone($masterws, $milestone) ) {
905        print_error("Milestone '$milestone' is no a valid milestone of '$masterws'.", 3);
906    }
907
908    my @integrated_cws = $cws->get_integrated_cws($masterws, $milestone);
909
910
911    if ( @integrated_cws ) {
912        print_message("Master workspace '$masterws':");
913        print_message("Integrated CWSs for milestone '$milestone':");
914        foreach (@integrated_cws) {
915            print "$_\n";
916        }
917    }
918
919    return;
920}
921
922sub query_approved
923{
924    my $cws       = shift;
925
926    my $masterws = $cws->master();
927
928    my @approved_cws = $cws->get_cws_with_state($masterws, 'approved by QA');
929
930    if ( @approved_cws ) {
931        print_message("Master workspace '$masterws':");
932        print_message("CWSs approved by QA:");
933        foreach (@approved_cws) {
934            print "$_\n";
935        }
936    }
937
938    return;
939}
940
941sub query_nominated
942{
943    my $cws       = shift;
944
945    my $masterws = $cws->master();
946
947    my @nominated_cws = $cws->get_cws_with_state($masterws, 'nominated');
948
949    if ( @nominated_cws ) {
950        print_message("Master workspace '$masterws':");
951        print_message("Nominated CWSs:");
952        foreach (@nominated_cws) {
953            print "$_\n";
954        }
955    }
956
957    return;
958}
959
960sub query_ready
961{
962    my $cws       = shift;
963
964    my $masterws = $cws->master();
965
966    my @ready_cws = $cws->get_cws_with_state($masterws, 'ready for QA');
967
968    if ( @ready_cws ) {
969        print_message("Master workspace '$masterws':");
970        print_message("CWSs ready for QA:");
971        foreach (@ready_cws) {
972            print "$_\n";
973        }
974    }
975
976    return;
977}
978
979sub query_new
980{
981    my $cws       = shift;
982
983    my $masterws = $cws->master();
984
985    my @ready_cws = $cws->get_cws_with_state($masterws, 'new');
986
987    if ( @ready_cws ) {
988        print_message("Master workspace '$masterws':");
989        print_message("CWSs with state 'new':");
990        foreach (@ready_cws) {
991            print "$_\n";
992        }
993    }
994
995    return;
996}
997
998sub query_planned
999{
1000    my $cws       = shift;
1001
1002    my $masterws = $cws->master();
1003
1004    my @ready_cws = $cws->get_cws_with_state($masterws, 'planned');
1005
1006    if ( @ready_cws ) {
1007        print_message("Master workspace '$masterws':");
1008        print_message("CWSs with state 'planned':");
1009        foreach (@ready_cws) {
1010            print "$_\n";
1011        }
1012    }
1013
1014    return;
1015}
1016
1017sub is_valid_cws
1018{
1019    my $cws = shift;
1020
1021    my $masterws = $cws->master();
1022    my $childws  = $cws->child();
1023    # check if we got a valid child workspace
1024    my $id = $cws->eis_id();
1025    if ( !$id ) {
1026        print_error("Child workspace '$childws' for master workspace '$masterws' not found in EIS database.", 2);
1027    }
1028    print STDERR "Master workspace '$masterws', child workspace '$childws'\n";
1029    return 1;
1030}
1031
1032sub query_release
1033{
1034    my $cws = shift;
1035
1036    if ( is_valid_cws($cws) ) {
1037        my $release = $cws->get_release();
1038            print_message("Release target:");
1039        if ( !$release ) {
1040            print "not set\n";
1041        } else {
1042            print "$release\n";
1043        }
1044    }
1045    return;
1046}
1047
1048sub query_due
1049{
1050    my $cws = shift;
1051
1052    if ( is_valid_cws($cws) ) {
1053        my $due = $cws->get_due_date();
1054            print_message("Due date:");
1055        if ( !$due ) {
1056            print "not set\n";
1057        } else {
1058            print "$due\n";
1059        }
1060    }
1061    return;
1062}
1063
1064sub query_due_qa
1065{
1066    my $cws = shift;
1067
1068    if ( is_valid_cws($cws) ) {
1069        my $due_qa = $cws->get_due_date_qa();
1070            print_message("Due date (QA):");
1071        if ( !$due_qa ) {
1072            print "not set\n";
1073        } else {
1074            print "$due_qa\n";
1075        }
1076    }
1077    return;
1078}
1079
1080sub query_help
1081{
1082    my $cws = shift;
1083
1084    if ( is_valid_cws($cws) ) {
1085        my $help = $cws->is_helprelevant();
1086            print_message("Help relevant:");
1087        if ( !$help ) {
1088            print "false\n";
1089        } else {
1090            print "true\n";
1091        }
1092    }
1093    return;
1094}
1095
1096sub query_ui
1097{
1098    my $cws = shift;
1099
1100    if ( is_valid_cws($cws) ) {
1101        my $help = $cws->is_uirelevant();
1102            print_message("UI relevant:");
1103        if ( !$help ) {
1104            print "false\n";
1105        } else {
1106            print "true\n";
1107        }
1108    }
1109    return;
1110}
1111
1112sub verify_milestone
1113{
1114    my $cws = shift;
1115    my $qualified_milestone = shift;
1116
1117    my $invalid = 0;
1118    my ($master, $milestone);
1119    $invalid++ if $qualified_milestone =~ /-/;
1120
1121    if ( $qualified_milestone =~ /:/ ) {
1122        ($master, $milestone) = split(/:/, $qualified_milestone);
1123        $invalid++ unless ( $master && $milestone );
1124    }
1125    else {
1126        $milestone = $qualified_milestone;
1127    }
1128
1129    if ( $invalid ) {
1130        print_error("Invalid milestone", 0);
1131        usage();
1132        exit(1);
1133    }
1134
1135    $master = $cws->master() if !$master;
1136    if ( !$cws->is_milestone($master, $milestone) ) {
1137        print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 21);
1138    }
1139    return ($master, $milestone);
1140}
1141
1142sub relink_workspace {
1143    my $linkdir = shift;
1144    my $restore = shift;
1145
1146    # The list of obligatorily added modules, build will not work
1147    # if these are not present.
1148    my %added_modules_hash;
1149    if (defined $ENV{ADDED_MODULES}) {
1150        for ( split(/\s/, $ENV{ADDED_MODULES}) ) {
1151            $added_modules_hash{$_}++;
1152        }
1153    }
1154
1155    # clean out pre-existing linkdir
1156    my $bd = dirname($linkdir);
1157    if ( !opendir(DIR, $bd) ) {
1158        print_error("Can't open directory '$bd': $!.", 44);
1159    }
1160    my @old_link_dirs = grep { /^src.m\d+/ } readdir(DIR);
1161    close(DIR);
1162
1163    if ( @old_link_dirs > 1 ) {
1164        print_error("Found more than one old link directories:", 0);
1165        foreach (@old_link_dirs) {
1166            print STDERR "@old_link_dirs\n";
1167        }
1168        if ( $restore ) {
1169            print_error("Please remove all old link directories but the last one", 67);
1170        }
1171    }
1172
1173    # Originally the extension .lnk indicated a linked module. This turned out to be
1174    # not an overly smart choice. Cygwin has some heuristics which regards .lnk
1175    # files as Windows shortcuts, breaking the build. Use .link instead.
1176    # When in restoring mode still consider .lnk as link to modules (for old CWSs)
1177    my $old_link_dir = "$bd/" . $old_link_dirs[0];
1178    if ( $restore ) {
1179        if ( !opendir(DIR, $old_link_dir) ) {
1180            print_error("Can't open directory '$old_link_dir': $!.", 44);
1181        }
1182        my @links = grep { !(/\.lnk/ || /\.link/)   } readdir(DIR);
1183        close(DIR);
1184        # everything which is not a link to a directory can't be an "added" module
1185        foreach (@links) {
1186            next if /^\./;
1187            my $link = "$old_link_dir/$_";
1188            if ( -s $link && -d $link ) {
1189                $added_modules_hash{$_} = 1;
1190            }
1191        }
1192    }
1193    print_message("... removing '$old_link_dir'");
1194    rmtree([$old_link_dir], 0);
1195
1196    print_message("... (re)create '$linkdir'");
1197    if ( !mkdir("$linkdir") ) {
1198        print_error("Can't create directory '$linkdir': $!.", 44);
1199    }
1200    if ( !opendir(DIR, "$bd/ooo") ) {
1201        print_error("Can't open directory '$bd/sun': $!.", 44);
1202    }
1203    my @ooo_top_level_dirs = grep { !/^\./ } readdir(DIR);
1204    close(DIR);
1205    if ( !opendir(DIR, "$bd/sun") ) {
1206        print_error("Can't open directory '$bd/sun': $!.", 44);
1207    }
1208    my @so_top_level_dirs = grep { !/^\./ } readdir(DIR);
1209    close(DIR);
1210    my $savedir = getcwd();
1211    if ( !chdir($linkdir) ) {
1212        print_error("Can't chdir() to directory '$linkdir': $!.", 44);
1213    }
1214    my $suffix = '.link';
1215    foreach(@ooo_top_level_dirs) {
1216        if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE'  ) {
1217            next;
1218        }
1219        my $target = $_;
1220        if ( -d "../ooo/$_" && !exists $added_modules_hash{$_} ) {
1221            $target .= $suffix;
1222        }
1223        if ( !symlink("../ooo/$_", $target) ) {
1224            print_error("Can't symlink directory '../ooo/$_ -> $target': $!.", 44);
1225        }
1226    }
1227    foreach(@so_top_level_dirs) {
1228        if ( $_ eq 'REBASE.LOG' || $_ eq 'REBASE.CONFIG_DONT_DELETE'  ) {
1229            next;
1230        }
1231        my $target = $_;
1232        if ( -d "../sun/$_" && !exists $added_modules_hash{$_} ) {
1233            $target .= $suffix;
1234        }
1235        if ( !symlink("../sun/$_", $target) ) {
1236            print_error("Can't symlink directory '../sun/$_ -> $target': $!.", 44);
1237        }
1238    }
1239    if ( !chdir($savedir) ) {
1240        print_error("Can't chdir() to directory '$linkdir': $!.", 44);
1241    }
1242}
1243
1244sub fetch_external_tarballs
1245{
1246    my $source_root_dir = shift;
1247    my $external_tarballs_source = shift;
1248
1249    my $ooo_external_file = "$source_root_dir/ooo/ooo.lst";
1250    my $sun_external_file = "$source_root_dir/sun/sun.lst";
1251    my $sun_path          = "$source_root_dir/sun";
1252
1253    my @external_sources_list;
1254    push(@external_sources_list, read_external_file($ooo_external_file));
1255    if ( -d $sun_path ) {
1256        if ( -e $sun_external_file ) {
1257            push(@external_sources_list, read_external_file($sun_external_file));
1258        }
1259        else {
1260            print_error("Can't find external file list '$sun_external_file'.", 8);
1261        }
1262    }
1263
1264    my $ext_sources_dir = "$source_root_dir/ext_sources";
1265    print_message("Copy external tarballs to '$ext_sources_dir'");
1266    if ( ! -d $ext_sources_dir) {
1267        if ( !mkdir($ext_sources_dir) ) {
1268            print_error("Can't create directory '$ext_sources_dir': $!.", 44);
1269        }
1270    }
1271    foreach (@external_sources_list) {
1272        if ( ! copy("$external_tarballs_source/$_", $ext_sources_dir) ) {
1273            print_error("Can't copy file '$external_tarballs_source' -> '$ext_sources_dir': $!", 0);
1274        }
1275    }
1276    return;
1277}
1278
1279sub read_external_file
1280{
1281    my $external_file = shift;
1282
1283    my @external_sources;
1284    open(EXT, "<$external_file") or print_error("Can't open file '$external_file' for reading: $!", 98);
1285    while(<EXT>) {
1286        if ( !/^http:/ ) {
1287            chomp;
1288            push(@external_sources, $_);
1289        }
1290    }
1291    close(EXT);
1292    return @external_sources;
1293}
1294
1295sub update_solver
1296{
1297    my $platform      = shift;
1298    my $source        = shift;
1299    my $solver        = shift;
1300    my $milestone     = shift;
1301    my $source_config = shift;
1302
1303    my @zip_sub_dirs = ('bin', 'doc', 'idl', 'inc', 'lib', 'par', 'pck', 'pdb', 'pus', 'rdb', 'res', 'xml', 'sdf');
1304
1305    use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
1306
1307    my $platform_solver = "$solver/$platform";
1308
1309    if ( -d $platform_solver ) {
1310        print_message("... removing old solver for platform '$platform'");
1311        if ( !rmtree([$platform_solver]) ) {
1312            print_error("Can't remove directory '$platform_solver': $!.", 44);
1313        }
1314    }
1315
1316    if ( !mkdir("$platform_solver") ) {
1317        print_error("Can't create directory '$platform_solver': $!.", 44);
1318    }
1319
1320    my $platform_source = "$source/$platform/zip.$milestone";
1321    if ( !opendir(DIR, "$platform_source") ) {
1322        print_error("Can't open directory '$platform_source': $!.", 44);
1323    }
1324    my @zips = grep { /\.zip$/ } readdir(DIR);
1325    close(DIR);
1326
1327    my $nzips = @zips;
1328    print_message("... unzipping $nzips zip archives for platform '$platform'");
1329
1330
1331    foreach(@zips) {
1332        my $zip = Archive::Zip->new();
1333        unless ( $zip->read( "$platform_source/$_" ) == AZ_OK ) {
1334            print_error("Can't read zip file '$platform_source/$_': $!.", 44);
1335        }
1336        # TODO: check for erorrs
1337        foreach (@zip_sub_dirs) {
1338            my $extract_destination = $source_config ? "$platform_solver/$_" : "$platform_solver/$_.$milestone";
1339            unless ( $zip->extractTree($_, $extract_destination) == AZ_OK ) {
1340                print_error("Can't extract stream from zip file '$platform_source/$_': $!.", 44);
1341            }
1342        }
1343     }
1344}
1345
1346# TODO: special provisions for "source_config" migration, remove this
1347# some time after migration
1348sub get_source_config_for_milestone
1349{
1350    my $masterws = shift;
1351    my $milestone = shift;
1352
1353    my $milestone_sequence_number = extract_milestone_sequence_number($milestone);
1354    my $ooo320_migration_sequence_number = extract_milestone_sequence_number($ooo320_source_config_milestone);
1355
1356    my $source_config = 1;
1357    if ( $masterws eq 'OOO320' ) {
1358        if ( $milestone_sequence_number < $ooo320_migration_sequence_number ) {
1359            $source_config = 0;
1360        }
1361    }
1362    return $source_config;
1363}
1364
1365sub extract_milestone_sequence_number
1366{
1367    my $milestone = shift;
1368
1369    my $milestone_sequence_number;
1370    if ( $milestone =~ /m(\d+)/ ) {
1371        $milestone_sequence_number = $1;
1372    }
1373    else {
1374        print_error("can't extract milestone sequence number from milestone '$milestone'", 99);
1375    }
1376    return $milestone_sequence_number;
1377}
1378
1379# Executes the help command.
1380sub do_help
1381{
1382    my $args_ref    = shift;
1383    my $options_ref = shift;
1384
1385    if (@{$args_ref} == 0) {
1386        print STDERR "usage: cws <subcommand> [options] [args]\n";
1387        print STDERR "Type 'cws help <subcommand>' for help on a specific subcommand.\n";
1388        print STDERR "\n";
1389        print STDERR "Available subcommands:\n";
1390        print STDERR "\thelp (h,?)\n";
1391        print STDERR "\tcreate\n";
1392        print STDERR "\tfetch (f)\n";
1393        print STDERR "\tquery (q)\n";
1394        print STDERR "\ttask (t)\n";
1395        print STDERR "\tsetcurrent\n";
1396        print STDERR "\teisclone *** release engineers only ***\n";
1397    }
1398
1399    my $arg = $args_ref->[0];
1400
1401    if (!defined($arg) || $arg eq 'help') {
1402        print STDERR "help (h, ?): Describe the usage of this script or its subcommands\n";
1403        print STDERR "usage: help [subcommand]\n";
1404    }
1405    elsif ($arg eq 'create') {
1406        print STDERR "create: Create a new child workspace\n";
1407        print STDERR "usage: create [-m milestone] <master workspace> <child workspace>\n";
1408        print STDERR "\t-m milestone:          Milestone to base the child workspace on. If ommitted the\n";
1409        print STDERR "\t                       last published milestone will be used.\n";
1410        print STDERR "\t--milestone milestone: Same as -m milestone.\n";
1411    }
1412    elsif ($arg eq 'task') {
1413        print STDERR "task: Add a task to a child workspace\n";
1414        print STDERR "usage: task <task id> [task id ...]\n";
1415    }
1416    elsif ($arg eq 'query') {
1417        print STDERR "query: Query child workspace for miscellaneous information\n";
1418        print STDERR "usage: query [-M master] [-c child] <current|integratedinto|incompatible|owner|qarep|status|taskids>\n";
1419        print STDERR "       query [-M master] [-c child] <release|due|due_qa|help|ui|ispublic|scm|build>\n";
1420        print STDERR "       query [-M master] <latest|milestones|ispublicmaster>\n";
1421        print STDERR "       query  <masters>\n";
1422        print STDERR "       query [-M master] [-m milestone] <integrated|buildid>\n";
1423        print STDERR "       query [-M master] <planned|new|approved|nominated|ready>\n";
1424        print STDERR "\t-M master:\t\toverride MWS specified in environment\n";
1425        print STDERR "\t-c child:\t\toverride CWS specified in environment\n";
1426        print STDERR "\t-m milestone:\t\toverride latest milestone with specified one\n";
1427        print STDERR "\t--master master:\tSame as -M master\t\n";
1428        print STDERR "\t--child child:\t\tSame -c child\n";
1429        print STDERR "\t--milestone milestone:\tSame as -m milestone\n";
1430        print STDERR "Modes:\n";
1431        print STDERR "\tcurrent\t\tquery current milestone of CWS\n";
1432        print STDERR "\tincompatible\tquery modules which should be build incompatible\n";
1433        print STDERR "\towner\t\tquery CWS owner\n";
1434        print STDERR "\tqarep\t\tquery CWS QA Representative\n";
1435        print STDERR "\tstatus\t\tquery approval status of CWS\n";
1436        print STDERR "\ttaskids\t\tquery taskids to be handled on the CWS\n";
1437        print STDERR "\trelease\t\tquery for target release of CWS\n";
1438        print STDERR "\tdue\t\tquery for due date of CWS\n";
1439        print STDERR "\tdue_qa\t\tquery for due date (QA) of CWS\n";
1440        print STDERR "\thelp\t\tquery if the CWS is help relevant\n";
1441        print STDERR "\tui\t\tquery if the CWS is UI relevant\n";
1442        print STDERR "\tbuild\t\tquery build String for CWS\n";
1443        print STDERR "\tlatest\t\tquery the latest milestone available for resync\n";
1444        print STDERR "\tbuildid\t\tquery build ID for milestone\n";
1445        print STDERR "\tintegrated\tquery integrated CWSs for milestone\n";
1446        print STDERR "\tintegratedinto\tquery milestone which CWS was integrated into\n";
1447        print STDERR "\tplanned\t\tquery for planned CWSs\n";
1448        print STDERR "\tnew\t\tquery for new CWSs\n";
1449        print STDERR "\tapproved\tquery CWSs approved by QA\n";
1450        print STDERR "\tnominated\tquery nominated CWSs\n";
1451        print STDERR "\tready\t\tquery CWSs ready for QA\n";
1452        print STDERR "\tispublic\tquery public flag of CWS\n";
1453        print STDERR "\tscm\t\tquery Source Control Management (SCM) system used for CWS\n";
1454        print STDERR "\tmasters\t\tquery available MWS\n";
1455        print STDERR "\tmilestones\tquery which milestones are know on the given MWS\n";
1456        print STDERR "\tispublicmaster\tquery public flag of MWS\n";
1457
1458     }
1459    elsif ($arg eq 'fetch') {
1460        print STDERR "fetch: fetch a milestone or CWS\n";
1461        print STDERR "usage: fetch [-q] [-p platforms] [-r additionalrepositories] [-o] <-m milestone> <workspace>\n";
1462        print STDERR "usage: fetch [-q] [-p platforms] [-r additionalrepositories] [-o] <-c cws> <workspace>\n";
1463        print STDERR "usage: fetch [-q] [-x platforms] [-r additionalrepositories] [-o] <-m milestone> <workspace>\n";
1464        print STDERR "usage: fetch [-q] [-x platforms] [-r additionalrepositories] [-o] <-c cws> <workspace>\n";
1465        print STDERR "usage: fetch [-q] <-m milestone> <workspace>\n";
1466        print STDERR "usage: fetch [-q] <-c cws> <workspace>\n";
1467        print STDERR "\t-m milestone:            Checkout milestone <milestone> to workspace <workspace>\n";
1468        print STDERR "\t                         Use 'latest' for the for lastest published milestone on the current master\n";
1469        print STDERR "\t                         For cross master checkouts use the form <MWS>:<milestone>\n";
1470        print STDERR "\t--milestone milestone:   Same as -m milestone\n";
1471        print STDERR "\t-c childworkspace:       Checkout CWS <childworkspace> to workspace <workspace>\n";
1472        print STDERR "\t--child childworkspace:  Same as -c childworkspace\n";
1473        print STDERR "\t-p platform:             Copy one or more prebuilt platforms 'platform'. \n";
1474        print STDERR "\t                         Separate multiple platforms with commas.\n";
1475        print STDERR "\t                         Automatically adds 'common[.pro]' as required.\n";
1476        print STDERR "\t--platforms platform:    Same as -p\n";
1477        print STDERR "\t-x platform:             Copy one or more prebuilt platforms 'platform'. \n";
1478        print STDERR "\t                         Separate multiple platforms with commas.\n";
1479        print STDERR "\t                         Does not automatically adds 'common[.pro]'.\n";
1480        print STDERR "\t-r additionalrepositories Checkout additional repositories. \n";
1481        print STDERR "\t                         Separate multiple repositories with commas.\n";
1482        print STDERR "\t--noautocommon platform: Same as -x\n";
1483        print STDERR "\t-o:                      Omit checkout of sources, copy only solver. \n";
1484        print STDERR "\t--onlysolver:            Same as -o\n";
1485        print STDERR "\t-q:                      Silence some of the output of the command.\n";
1486        print STDERR "\t--quiet:                 Same as -q\n";
1487    }
1488    elsif ($arg eq 'setcurrent') {
1489        print STDERR "setcurrent: Set the current milestone for the CWS (only hg based CWSs)\n";
1490        print STDERR "usage: setcurrent [-m milestone]\n";
1491        print STDERR "\t-m milestone:           Set milestone to <milestone> to workspace <workspace>\n";
1492        print STDERR "\t                        Use 'latest' for the for lastest published milestone on the current master\n";
1493        print STDERR "\t                        For cross master change use the form <MWS>:<milestone>\n";
1494        print STDERR "\t--milestone milestone:  Same as -m milestone\n";
1495    }
1496    else {
1497        print STDERR "'$arg': unknown subcommand\n";
1498        exit(1);
1499    }
1500    exit(0);
1501}
1502
1503# Executes the create command.
1504sub do_create
1505{
1506    my $args_ref    = shift;
1507    my $options_ref = shift;
1508
1509    if ( exists $options_ref->{'help'} || @{$args_ref} != 2) {
1510        do_help(['create']);
1511    }
1512
1513    if ( exists $options_ref->{'hg'} ) {
1514        print_warning("All childworkspaces are now hosted on Mercurial. The switch --hg is obsolete.");
1515    }
1516
1517    my $master   = uc $args_ref->[0];
1518    my $cws_name = $args_ref->[1];
1519
1520    if (!is_master($master)) {
1521        print_error("'$master' is not a valid master workspace.", 7);
1522    }
1523
1524    # check if cws name fits the convention
1525    if ( $cws_name !~ /^\w[\w\.\#]*$/ ) {
1526        print_error("Invalid child workspace name '$cws_name'.\nCws names should consist of alphanumeric characters, preferable all lowercase and starting with a letter.\nThe characters . and # are allowed if they are not the first character.", 7);
1527    }
1528
1529    my $cws = get_this_cws();
1530    $cws->master($master);
1531    $cws->child($cws_name);
1532
1533    # check if child workspace already exists
1534    my $eis_id = $cws->eis_id();
1535    if ( !defined($eis_id) ) {
1536        print_error("Connection with EIS database failed.", 8);
1537    }
1538
1539    my $is_promotion = 0;
1540    if ( $eis_id > 0 ) {
1541        if ( $cws->get_approval() eq 'planned' ) {
1542            print "Promote child workspace '$cws_name' from 'planned' to 'new'.\n";
1543            $is_promotion++;
1544        }
1545        else {
1546            print_error("Child workspace '$cws_name' already exists.", 7);
1547        }
1548    }
1549    else {
1550        # check if child workspace name is still available
1551        if ( !$cws->is_cws_name_available()) {
1552            print_error("Child workspace name '$cws_name' is already in use.", 7);
1553        }
1554    }
1555
1556    my $milestone;
1557    # verify milestone or query latest milestone
1558    if ( exists $options_ref->{'milestone'} ) {
1559        $milestone=$options_ref->{'milestone'};
1560        # check if milestone exists
1561        if ( !$cws->is_milestone($master, $milestone) ) {
1562            print_error("Milestone '$milestone' is not registered with master workspace '$master'.", 8);
1563        }
1564    }
1565    else {
1566        $milestone=$cws->get_current_milestone($cws->master());
1567    }
1568
1569    # set milestone
1570    $cws->milestone($milestone);
1571
1572    register_child_workspace($cws, 'hg', $is_promotion);
1573
1574    return;
1575}
1576
1577# Executes the fetch command.
1578sub do_fetch
1579{
1580    my $args_ref    = shift;
1581    my $options_ref = shift;
1582
1583    my $time_fetch_start = Benchmark->new();
1584    if ( exists $options_ref->{'help'} || @{$args_ref} != 1) {
1585        do_help(['fetch']);
1586    }
1587
1588    my $milestone_opt = $options_ref->{'milestone'};
1589    my $additional_repositories_opt = $options_ref->{'additionalrepositories'};
1590    $additional_repositories_opt = "", if ( !defined $additional_repositories_opt );
1591    my $child = $options_ref->{'childworkspace'};
1592    my $platforms = $options_ref->{'platforms'};
1593    my $noautocommon = $options_ref->{'noautocommon'};
1594    my $quiet  = $options_ref->{'quiet'}  ? 1 : 0 ;
1595    my $switch = $options_ref->{'switch'} ? 1 : 0 ;
1596    my $onlysolver = $options_ref->{'onlysolver'} ? 1 : 0 ;
1597
1598    if ( !defined($milestone_opt) && !defined($child) ) {
1599        print_error("Specify one of these options: -m or -c", 0);
1600        do_help(['fetch']);
1601    }
1602
1603    if ( defined($milestone_opt) && defined($child) ) {
1604        print_error("Options -m and -c are mutally exclusive", 0);
1605        do_help(['fetch']);
1606    }
1607
1608    if ( defined($platforms) && defined($noautocommon) ) {
1609        print_error("Options -p and -x are mutally exclusive", 0);
1610        do_help(['fetch']);
1611    }
1612
1613    if ( $onlysolver && !(defined($platforms) || defined($noautocommon)) ) {
1614        print_error("Option '-o' is Only usuable combination with option '-p' or '-x'.", 0);
1615        do_help(['fetch']);
1616    }
1617
1618    my $cws = get_this_cws();
1619    my $masterws = $ENV{WORK_STAMP};
1620    if ( !defined($masterws) ) {
1621        print_error("Can't determine current master workspace: check environment variable WORK_STAMP", 21);
1622    }
1623    $cws->master($masterws);
1624    my $milestone;
1625    if( defined($milestone_opt) ) {
1626        if ( $milestone_opt eq 'latest' ) {
1627            $cws->master($masterws);
1628            my $latest = $cws->get_current_milestone($masterws);
1629
1630            if ( !$latest ) {
1631                print_error("Can't determine latest milestone of master workspace '$masterws'.", 22);
1632            }
1633            $milestone = $cws->get_current_milestone($masterws);
1634        }
1635        else {
1636            ($masterws, $milestone) =  verify_milestone($cws, $milestone_opt);
1637        }
1638    }
1639    elsif ( defined($child) ) {
1640        $cws = get_cws_by_name($child);
1641        $masterws = $cws->master(); # CWS can have another master than specified in ENV
1642        $milestone = $cws->milestone();
1643    }
1644    else {
1645        do_help(['fetch']);
1646    }
1647
1648    my $config = CwsConfig->new();
1649    # $so_svn_server is still required to determine if we are in SO environment
1650    # TODO: change this configuration setting to something more meaningful
1651    my $so_svn_server = $config->get_so_svn_server();
1652    my $prebuild_dir = $config->get_prebuild_binaries_location();
1653    my $external_tarball_source = $prebuild_dir;
1654    # Check early for platforms so we can bail out before anything time consuming is done
1655    # in case of a missing platform
1656    my @platforms;
1657    if ( defined($platforms) || defined($noautocommon) ) {
1658        use Archive::Zip; # warn early if module is missing
1659        if ( !defined($prebuild_dir ) ) {
1660            print_error("PREBUILD_BINARIES not configured, can't find platform solvers", 99);
1661        }
1662        $prebuild_dir = "$prebuild_dir/$masterws";
1663
1664        if ( defined($platforms) ) {
1665            @platforms = split(/,/, $platforms);
1666
1667            my $added_product = 0;
1668            my $added_nonproduct = 0;
1669            foreach(@platforms) {
1670                if ( $_ eq 'common.pro' ) {
1671                    $added_product = 1;
1672                    print_warning("'$_' is added automatically to the platform list, don't specify it explicit");
1673                }
1674                if ( $_ eq 'common' ) {
1675                    $added_nonproduct = 1;
1676                    print_warning("'$_' is added automatically to the platform list, don't specify it explicit");
1677                }
1678            }
1679
1680            # add common.pro/common to platform list
1681            if ( $so_svn_server ) {
1682                my $product = 0;
1683                my $nonproduct = 0;
1684                foreach(@platforms) {
1685                    if ( /\.pro$/ ) {
1686                        $product = 1;
1687                    }
1688                    else {
1689                        $nonproduct = 1;
1690                    }
1691                }
1692                unshift(@platforms, 'common.pro') if ($product && !$added_product);
1693                unshift(@platforms, 'common') if ($nonproduct && !$added_nonproduct);
1694            }
1695        }
1696        else {
1697            @platforms = split(/,/, $noautocommon);
1698        }
1699
1700        foreach(@platforms) {
1701            if ( ! -d "$prebuild_dir/$_") {
1702                print_error("Can't find prebuild binaries for platform '$_'.", 22);
1703            }
1704        }
1705
1706    }
1707
1708    my $cwsname = $cws->child();
1709    my $linkdir = $milestone_opt ? "src.$milestone" : "src." . $cws->milestone;
1710
1711    my $workspace = $args_ref->[0];
1712
1713    if ( !$onlysolver ) {
1714        if ( -e $workspace ) {
1715            print_error("File or directory '$workspace' already exists.", 8);
1716        }
1717
1718        my $clone_milestone_only = $milestone_opt ? $milestone : 0;
1719        if ( defined($so_svn_server) ) {
1720            if ( !mkdir($workspace) ) {
1721                print_error("Can't create directory '$workspace': $!.", 8);
1722            }
1723            my $work_master = "$workspace/$masterws";
1724            if ( !mkdir($work_master) ) {
1725                print_error("Can't create directory '$work_master': $!.", 8);
1726            }
1727
1728            my %unique = map { $_ => 1 } split( /,/ , $additional_repositories_opt);
1729            my @unique_repo_list = keys %unique;
1730
1731            if (defined($additional_repositories_opt))
1732            {
1733                foreach my $repo(@unique_repo_list)
1734                {
1735                    # do not double clone ooo and sun
1736                    hg_clone_cws_or_milestone($repo, $cws, "$work_master/".$repo, $clone_milestone_only), if $repo ne "ooo" && $repo ne "sun";
1737                }
1738
1739            }
1740
1741            hg_clone_cws_or_milestone('ooo', $cws, "$work_master/ooo", $clone_milestone_only);
1742            hg_clone_cws_or_milestone('so', $cws, "$work_master/sun", $clone_milestone_only);
1743
1744            if ( get_source_config_for_milestone($masterws, $milestone) ) {
1745                # write source_config file
1746                my $source_config_file = "$work_master/source_config";
1747                if ( !open(SOURCE_CONFIG, ">$source_config_file") ) {
1748                    print_error("Can't create source_config file '$source_config_file': $!.", 8);
1749                }
1750                print SOURCE_CONFIG "[repositories]\n";
1751                print SOURCE_CONFIG "ooo=active\n";
1752                print SOURCE_CONFIG "sun=active\n";
1753                foreach my $repo(@unique_repo_list)
1754                {
1755                    print SOURCE_CONFIG $repo."=active\n", if $repo ne "ooo" || $repo ne "sun";
1756                }
1757                close(SOURCE_CONFIG);
1758            }
1759            else {
1760                my $linkdir = "$work_master/src.$milestone";
1761                if ( !mkdir($linkdir) ) {
1762                    print_error("Can't create directory '$linkdir': $!.", 8);
1763                }
1764                relink_workspace($linkdir);
1765            }
1766        }
1767        else {
1768            hg_clone_cws_or_milestone('ooo', $cws, $workspace, $clone_milestone_only);
1769        }
1770    }
1771
1772    if ( !$onlysolver && defined($external_tarball_source) ) {
1773        my $source_root_dir = "$workspace/$masterws";
1774        $external_tarball_source .= "/$masterws/ext_sources";
1775        if ( -e "$source_root_dir/ooo/ooo.lst" && -d $external_tarball_source ) {
1776            fetch_external_tarballs($source_root_dir, $external_tarball_source);
1777        }
1778    }
1779
1780    if ( defined($platforms) || defined($noautocommon) ) {
1781        if ( !-d $workspace ) {
1782            if ( !mkdir($workspace) ) {
1783                print_error("Can't create directory '$workspace': $!.", 8);
1784            }
1785        }
1786        my $solver = defined($so_svn_server) ? "$workspace/$masterws" : "$workspace/solver";
1787        if ( !-d $solver ) {
1788            if ( !mkdir($solver) ) {
1789                print_error("Can't create directory '$solver': $!.", 8);
1790            }
1791        }
1792        my $source_config = get_source_config_for_milestone($masterws, $milestone);
1793        foreach(@platforms) {
1794            my $time_solver_start = Benchmark->new();
1795            print_message("... copying platform solver '$_'.");
1796            update_solver($_, $prebuild_dir, $solver, $milestone, $source_config);
1797            my $time_solver_stop = Benchmark->new();
1798            print_time_elapsed($time_solver_start, $time_solver_stop) if $profile;
1799        }
1800    }
1801    my $time_fetch_stop = Benchmark->new();
1802    my $time_fetch = timediff($time_fetch_stop, $time_fetch_start);
1803    print_message("cws fetch: total time required " . timestr($time_fetch));
1804}
1805
1806sub do_query
1807{
1808    my $args_ref    = shift;
1809    my $options_ref = shift;
1810
1811    # list of available query modes
1812    my @query_modes = qw(integratedinto incompatible taskids status latest current owner qarep build buildid integrated approved nominated ready new planned release due due_qa help ui milestones masters scm ispublic ispublicmaster);
1813    my %query_modes_hash = ();
1814    foreach (@query_modes) {
1815        $query_modes_hash{$_}++;
1816    }
1817
1818    if ( exists $options_ref->{'help'} || @{$args_ref} != 1) {
1819        do_help(['query']);
1820    }
1821    my $mode = lc($args_ref->[0]);
1822
1823    # cwquery mode 'state' has been renamed to 'status' to be more consistent
1824    # with CVS etc. 'state' is still an alias for 'status'
1825    $mode = 'status' if $mode eq 'state';
1826
1827    # cwquery mode 'vcs' has been renamed to 'scm' to be more consistent
1828    # with general use etc. 'vcs' is still an alias for 'scm'
1829    $mode = 'scm' if $mode eq 'vcs';
1830
1831    # there will be more query modes over time
1832    if ( !exists $query_modes_hash{$mode} ) {
1833        do_help(['query']);
1834    }
1835    query_cws($mode, $options_ref);
1836}
1837
1838sub do_task
1839{
1840    my $args_ref    = shift;
1841    my $options_ref = shift;
1842
1843    if ( exists $options_ref->{'help'} ) {
1844        do_help(['task']);
1845    }
1846
1847    # CWS states for which adding tasks are blocked.
1848    my @states_blocked_for_adding = (
1849                                        "integrated",
1850                                        "nominated",
1851                                        "approved by QA",
1852                                        "cancelled",
1853                                        "finished"
1854                                    );
1855    my $cws = get_cws_from_environment();
1856
1857    # register taskids with EIS database;
1858    # checks taksids for sanity, will notify user
1859    # if taskid is already registered.
1860    my $status = $cws->get_approval();
1861
1862    my $child = $cws->child();
1863    my $master = $cws->master();
1864
1865    my @registered_taskids = $cws->taskids();
1866
1867    # if called without ids to register just query for tasks
1868    if ( @{$args_ref} == 0 ) {
1869        print_message("Task ID(s):");
1870        foreach (@registered_taskids) {
1871            if ( defined($_) ) {
1872                print "$_\n";
1873            }
1874        }
1875    }
1876
1877    if ( !defined($status) ) {
1878        print_error("Can't determine status of child workspace `$child`.", 20);
1879    }
1880
1881    if ( grep($status eq $_, @states_blocked_for_adding) ) {
1882        print_error("Can't add tasks to child workspace '$child' with state '$status'.", 21);
1883    }
1884
1885    # Create hash for easier searching.
1886    my %registered_taskids_hash = ();
1887    for (@registered_taskids) {
1888        $registered_taskids_hash{$_}++;
1889    }
1890
1891    my @new_taskids = ();
1892    foreach (@{$args_ref}) {
1893        if ( $_ !~ /^([ib]?\d+)$/ ) {
1894            print_error("'$_' is an invalid task ID.", 22);
1895        }
1896        if ( exists $registered_taskids_hash{$1} ) {
1897            print_warning("Task ID '$_' already registered, skipping.");
1898            next;
1899        }
1900        push(@new_taskids, $_);
1901    }
1902
1903    # TODO: introduce a EIS_USER in the configuration, which should be used here
1904    my $config = CwsConfig->new();
1905    my $vcsid  = $config->vcsid();
1906    my $added_taskids_ref = $cws->add_taskids($vcsid, @new_taskids);
1907    if ( !$added_taskids_ref )  {
1908        my $taskids_str = join(" ", @new_taskids);
1909        print_error("Couldn't register taskID(s) '$taskids_str' with child workspace '$child'.", 23);
1910    }
1911    my @added_taskids = @{$added_taskids_ref};
1912    if ( @added_taskids ) {
1913        my $taskids_str = join(" ", @added_taskids);
1914        print_message("Registered taskID(s) '$taskids_str' with child workspace '$child'.");
1915    }
1916    return;
1917}
1918
1919sub do_setcurrent
1920{
1921    my $args_ref    = shift;
1922    my $options_ref = shift;
1923
1924    if ( exists $options_ref->{'help'} || @{$args_ref} != 0) {
1925        do_help(['setcurrent']);
1926    }
1927
1928    if ( !exists $options_ref->{'milestone'} ) {
1929        do_help(['setcurrent']);
1930    }
1931
1932    my $cws = get_cws_from_environment();
1933    my $old_masterws = $cws->master();
1934    my $new_masterws;
1935    my $new_milestone;
1936
1937    my $milestone = $options_ref->{'milestone'};
1938    if ( $milestone eq 'latest' ) {
1939        my $latest = $cws->get_current_milestone($old_masterws);
1940
1941        if ( !$latest ) {
1942            print_error("Can't determine latest milestone of '$old_masterws'.", 22);
1943        }
1944        $new_masterws  = $old_masterws;
1945        $new_milestone = $latest;
1946    }
1947    else {
1948        ($new_masterws, $new_milestone) =  verify_milestone($cws, $milestone);
1949    }
1950
1951    print_message("... updating EIS database");
1952    my $push_return = $cws->set_master_and_milestone($new_masterws, $new_milestone);
1953    # sanity check
1954    if ( $$push_return[1] ne $new_milestone) {
1955        print_error("Couldn't push new milestone '$new_milestone' to database", 0);
1956    }
1957}
1958
1959sub do_eisclone
1960{
1961    my $args_ref    = shift;
1962    my $options_ref = shift;
1963
1964    print_error("not yet implemented.", 2);
1965}
1966
1967sub print_message
1968{
1969    my $message     = shift;
1970
1971    print "$message\n";
1972    return;
1973}
1974
1975sub print_warning
1976{
1977    my $message     = shift;
1978    print STDERR "$script_name: ";
1979    print STDERR "WARNING: $message\n";
1980    return;
1981}
1982
1983sub print_error
1984{
1985    my $message     = shift;
1986    my $error_code  = shift;
1987
1988    print STDERR "$script_name: ";
1989    print STDERR "ERROR: $message\n";
1990
1991    if ( $error_code ) {
1992        print STDERR "\nFAILURE: $script_name aborted.\n";
1993        exit($error_code);
1994    }
1995    return;
1996}
1997
1998sub usage
1999{
2000        print STDERR "Type 'cws help' for usage.\n";
2001}
2002
2003### HG glue ###
2004
2005sub hg_clone
2006{
2007    my $source  = shift;
2008    my $dest    = shift;
2009    my $options = shift;
2010
2011    if ( $debug ) {
2012        print STDERR "CWS-DEBUG: ... hg clone: '$source -> $dest', options: '$options'\n";
2013    }
2014
2015    # The to be cloned revision might not yet be avaliable. In this case clone
2016    # the available tip.
2017    my @result = execute_hg_command(0, 'clone', $options, $source, $dest);
2018    if ( defined($result[0]) && $result[0] =~ /abort: unknown revision/ ) {
2019        $options =~ s/-r \w+//;
2020        @result = execute_hg_command(1, 'clone', $options, $source, $dest);
2021    }
2022    return @result;
2023}
2024
2025sub hg_parent
2026{
2027    my $repository  = shift;
2028    my $rev_id = shift;
2029    my $options = shift;
2030
2031    if ( $debug ) {
2032        print STDERR "CWS-DEBUG: ... hg parent: 'repository', revision: '$rev_id', options: $options\n";
2033    }
2034
2035    my @result = execute_hg_command(0, 'parent', "--cwd $repository", "-r $rev_id", $options);
2036    my $line = $result[0];
2037    chomp($line);
2038    return $line;
2039}
2040
2041sub hg_pull
2042{
2043    my $repository  = shift;
2044    my $remote = shift;
2045
2046    if ( $debug ) {
2047        print STDERR "CWS-DEBUG: ... hg pull: 'repository', remote: '$remote'\n";
2048    }
2049
2050    my @result = execute_hg_command(0, 'pull', "--cwd $repository", $remote);
2051    my $line = $result[0];
2052    if ($line =~ /abort: /) {
2053        return undef;
2054    }
2055}
2056
2057sub hg_update
2058{
2059    my $repository  = shift;
2060
2061    if ( $debug ) {
2062        print STDERR "CWS-DEBUG: ... hg update: 'repository'\n";
2063    }
2064
2065    my @result = execute_hg_command(1, 'update', "--cwd $repository");
2066    return @result;
2067}
2068
2069sub hg_show
2070{
2071    if ( $debug ) {
2072        print STDERR "CWS-DEBUG: ... hg show\n";
2073    }
2074    my $result = execute_hg_command(0, 'show', '');
2075    return $result;
2076}
2077
2078sub execute_hg_command
2079{
2080    my $terminate_on_rc = shift;
2081    my $command = shift;
2082    my $options = shift;
2083    my @args = @_;
2084
2085    my $args_str = join(" ", @args);
2086
2087    # we can only parse english strings, hopefully a C locale is available everywhere
2088    $ENV{LC_ALL}='C';
2089    $command = "hg $command $options $args_str";
2090
2091    if ( $debug ) {
2092        print STDERR "CWS-DEBUG: ... execute command line: '$command'\n";
2093    }
2094
2095    my @result;
2096    open(OUTPUT, "$command 2>&1 |") or print_error("Can't execute mercurial command line client", 98);
2097    while (<OUTPUT>) {
2098        push(@result, $_);
2099    }
2100    close(OUTPUT);
2101
2102    my $rc = $? >> 8;
2103
2104    if ( $rc > 0 && $terminate_on_rc) {
2105        print STDERR @result;
2106        print_error("The mercurial command line client failed with exit status '$rc'", 99);
2107    }
2108    return wantarray ? @result : \@result;
2109}
2110
2111
2112# vim: set ts=4 shiftwidth=4 expandtab syntax=perl:
2113