Subversion Repositories DevTools

Rev

Go to most recent revision | Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
392 dpurdie 1 
########################################################################
2 
# Copyright (C) 1998-2012 Vix Technology, All rights reserved
3 
#
4 
# Module name   : cc2svn_importpackage.pl
5 
# Module type   : Makefile system
6 
# Compiler(s)   : Perl
7 
# Environment(s): jats
8 
#
9 
# Description   : Get package information for a package name specified on the
10 
#                 command line.
11 
#
12 
#                 Determine the package id
13 
#                 Locate all packages that have the same package name
14 
#                 Determine essential packages
15 
#                 Prune uneeded packages
16 
#
17 
#                 Pump it into SVN
18 
#
19 
#                 Project Based Pumping, creating branches as needed
20 
#
21 
#......................................................................#
22 
 
23 
require 5.006_001;
24 
use strict;
25 
use warnings;
26 
use JatsError;
27 
use JatsRmApi;
28 
use FileUtils;
29 
use JatsSystem;
30 
use HTTP::Date;
31 
use JatsProperties;
32 
use JatsEnv;
33 
use ConfigurationFile;
34 
use JatsSvn qw(:All);
1197 dpurdie 35 
use JatsLocateFiles;
392 dpurdie 36 
 
37 
 
38 
#use Data::Dumper;
39 
use Fcntl ':flock'; # import LOCK_* constants
40 
use Cwd;
41 
use DBI;
42 
use Getopt::Long;
43 
use Pod::Usage;                             # required for help support
44 
 
45 
#
46 
#   Options
47 
#
48 
my $opt_help = 0;
49 
my $opt_manual = 0;
50 
my $opt_verbose = 0;
51 
my $opt_repo_base = 'AUPERASVN01/';
52 
my $opt_repo = '';
53 
my $opt_flat;
54 
my $opt_test;
55 
my $opt_reuse;
56 
my $opt_age;
57 
my $opt_dump = 0;
58 
my $opt_images = 0;
59 
my $opt_retaincount = 2;
60 
my $opt_pruneModeString;
61 
my $opt_listTags;
62 
my $opt_name;
63 
my $opt_log = 0;
64 
my @opt_tip;
65 
my $opt_postimage = 1;
66 
my $opt_workDir = '/work';
67 
my $opt_vobMap;
1197 dpurdie 68 
my $opt_preserveProjectBase;
69 
my $opt_ignoreProjectBaseErrors;
1270 dpurdie 70 
my $opt_delete;
392 dpurdie 71 
 
72 
################################################################################
73 
#   List of Projects Suffixes and Branch Names to be used within SVN
74 
#
75 
#       Name        - Name of branch for the project
76 
#       Trunk       - Can be a trunk project
77 
#                     First one seen will be placed on the trunk
78 
#                     Others will create project branches
79 
#
80 
my $ProjectTrunk;
81 
my %ProjectsBaseCreated;
82 
my %Projects = (
83 
    '.sea'      => { Name => 'Seattle' },
84 
    '.coct'     => { Name => 'CapeTown' },
85 
    '.sls'      => { Name => 'Stockholm' },
86 
    '.syd'      => { Name => 'Sydney' },
87 
    '.vtk'      => { Name => 'Vasttrafik' },
88 
    '.bei'      => { Name => 'Beijing' },
89 
    '.bkk'      => { Name => 'Bangkok' },
90 
    '.ndl'      => { Name => 'NewDelhi' },
91 
    '.nzs'      => { Name => 'NewZealandStageCoach' },
92 
    '.wdc'      => { Name => 'Washington' },
93 
    '.oso'      => { Name => 'Oslo' },
94 
    '.lvs'      => { Name => 'LasVegas' },
95 
    '.mlc'      => { Name => 'BeijingMlc' },
96 
    '.sfo'      => { Name => 'SanFrancisco' },
97 
    '.sg'       => { Name => 'Singapore' },
98 
    '.gmp'      => { Name => 'GmpteProject' },
99 
    '.ssw'      => { Name => 'UkStageCoach' },
100 
    '.uk'       => { Name => 'UkProject' },
101 
    '.pmb'      => { Name => 'Pietermaritzburg' },
102 
    '.vps'      => { Name => 'VixPayments' },
103 
    '.ncc'      => { Name => 'NSWClubCard' },
104 
    '.rm'       => { Name => 'Rome' },
105 
    'unknown'   => { Name => 'UnknownProject' },
106 
 
107 
    '.ebr'      => { Name => 'eBrio' , Trunk => 1 },
108 
    '.mas'      => { Name => 'Mass'  , Trunk => 1 },
109 
    '.cr'       => { Name => 'Core'  , Trunk => 1 },
110 
    '.cots'     => { Name => 'Cots'  , Trunk => 1 },
111 
    '.tool'     => { Name => 'Tools' , Trunk => 1 },
112 
);
113 
 
114 
my %suffixFixup = (
115 
    '.sf'           => '.sfo',
116 
    '.vt'           => '.vtk',
117 
    '.lv'           => '.lvs',
118 
    '.was'          => '.wdc',
119 
    '.uk.1'         => '.uk',
120 
    '.ssts.demo'    => '.ssts',
121 
    '.u244.syd'     => '.syd',
122 
    '.pxxx.sea'     => '.sea',
123 
    '.pxxx.syd'     => '.syd',
124 
    '.pxxx.sydddd'  => '.syd',
125 
    '.oslo'         => '.oso',
126 
);
127 
 
128 
my %specialPackages = (
1197 dpurdie 129 
    'core_devl' =>  ',all,protected,',
130 
#    'core_devl' =>  ',all,',
392 dpurdie 131 
    'daf_utils_mos' => ',flat,',
132 
    'mos_packager'  => ',all,',
395 dpurdie 133 
 
134 
    # Need to be handled in a special manner
135 
    # Not done by this utility
136 
    #
137 
    'linux_drivers_eb5600'  => ',protected,',
138 
    'linux_drivers_viper'   => ',protected,',
139 
    'linux_drivers_cobra'   => ',protected,',
140 
    'linux_drivers_bcp4600' => ',protected,',
141 
    'linux_drivers_etx86'   => ',protected,',
142 
    'linux_drivers_tp5600'  => ',protected,',
143 
 
1197 dpurdie 144 
    'ftp'                   => 'SetProjectBase,',
145 
 
146 
    'icl'                   => 'IgnoreProjectBase,',
147 
    'itso'                  => 'IgnoreProjectBase,',
148 
    'daf_osa_mos'           => 'IgnoreProjectBase,',
149 
    'daf_utils_mos'         => 'IgnoreProjectBase,',
150 
    'itso_ud'               => 'IgnoreProjectBase,',
151 
#    'mos_api'               => 'IgnoreProjectBase,',
152 
#    'mos_fonts'             => 'IgnoreProjectBase,',
153 
#    'sntp'                  => 'IgnoreProjectBase,',
154 
#    'time_it'               => 'IgnoreProjectBase,',
155 
 
392 dpurdie 156 
);
157 
 
158 
my %notCots = (
159 
    'isl'       => 1,
160 
);
161 
 
162 
################################################################################
163 
#   Global data
164 
#
165 
my $VERSION = "1.0.0";
166 
my $RM_DB;
167 
my $last_pv_id;
168 
my %pkg_ids;
169 
my $first_pkg_id;
170 
my %versions;
171 
my %suffixes;
172 
my @processOrder;
173 
my @startPoints;
174 
my @allStartPoints;
175 
my @endPoints;
176 
my $now = time();
177 
my $logSummary;
178 
my $firstVersionCreated;
179 
my @EssentialPackages;
180 
my $createBranch;
181 
my $createSuffix;
182 
my $currentBranchName;
183 
my $singleProject;
184 
my $pruneCount = 0;
185 
my $trimCount = 0;
186 
my $badVcsCount = 0;
187 
my $ProjectCount = 0;
188 
my $totalVersions = 0;
189 
my $initialTrees = 0;
190 
my $globalError;
191 
my @unknownProjects;
192 
my %knownProjects;
193 
my $badSingletonCount = 0;
194 
my @flatOrder;
195 
my $pruneMode;
196 
my $pruneModeString;
197 
my $threadId = 0;
198 
my $threadCount;
199 
my %tipVersions;
200 
my $allSvn;
201 
my @multiplePaths;
202 
my @badEssentials;
203 
my %svnData;
204 
my $cwd;
205 
 
206 
my $packageNames;
207 
my @packageNames;
208 
my $multiPackages = -1;
209 
my $visitId = 0;
210 
my $noTransfer;
211 
my $rippleCount = 0;
212 
my $svnRepo;
1270 dpurdie 213 
my $processCount = 0;
214 
my $processTotal = 0;
392 dpurdie 215 
 
216 
our $GBE_RM_URL;
217 
my $UNIX = $ENV{'GBE_UNIX'};
218 
 
219 
my $result = GetOptions (
220 
                "help+"         => \$opt_help,          # flag, multiple use allowed
221 
                "manual:3"      => \$opt_help,
222 
                "verbose:+"     => \$opt_verbose,       # Versose
223 
                "repository:s"  => \$opt_repo,          # Name of repository
224 
                "flat!"         => \$opt_flat,          # Flat structure
225 
                "test!"         => \$opt_test,          # Test operations
226 
                "reuse!"        => \$opt_reuse,         # Reuse ClearCase views
227 
                "age:i"         => \$opt_age,           # Only recent versions
228 
                "dump:1"        => \$opt_dump,          # Dump Data
229 
                "images:1"      => \$opt_images,        # Create DOT images
230 
                "retain:i"      => \$opt_retaincount,   # Retain N packages
231 
                "pruneMode:s"   => \$opt_pruneModeString,
232 
                "listtags:i"    => \$opt_listTags,
233 
                "name:s"        => \$opt_name,          # Alternate output
234 
                "tip:s"         => \@opt_tip,           # Force tip version(s)
235 
                "log!"          => \$opt_log,
1270 dpurdie 236 
                "delete!"       => \$opt_delete,
392 dpurdie 237 
                "postimage!"    => \$opt_postimage,
238 
                'workdir:s'     => \$opt_workDir,
239 
                );
240 
 
241 
#
242 
#   Process help and manual options
243 
#
244 
pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);
245 
pod2usage(-verbose => 1)  if ($opt_help == 2 );
246 
pod2usage(-verbose => 2)  if ($opt_manual || ($opt_help > 2));
247 
 
248 
#
249 
#   Configure the error reporting process now that we have the user options
250 
#
251 
SystemConfig ('ExitOnError' => 1);
252 
ErrorConfig( 'name'    =>'CC2SVN_IMPORT',
253 
             'verbose' => $opt_verbose,
254 
              );
255 
 
256 
Error("Workdir does not exist" ) unless ( -d $opt_workDir );
257 
Error("Specify a package as 'name'" ) unless ( defined $ARGV[0] );
258 
EnvImport('GBE_RM_URL');
259 
$cwd = Getcwd();
260 
 
261 
#
262 
#   Init the pruning mode
263 
#
264 
setPruneMode( $opt_pruneModeString || 'ripple');
265 
 
266 
#
267 
#   Get data for all packages
268 
#
269 
foreach my $packageName ( @ARGV )
270 
{
271 
    next unless ( $packageName );
272 
    Verbose( "Base Package: $packageName");
273 
 
274 
    my $pkg_id = GetPkgIdByName ( $packageName );
275 
    GetData_by_pkg_id ( $pkg_id, $packageName  );
276 
    $pkg_ids{$pkg_id} = 1;
277 
    $first_pkg_id = $pkg_id unless ( $first_pkg_id );
278 
    push @packageNames, $packageName;
279 
    $multiPackages++;
280 
}
281 
 
282 
{
283 
    #
284 
    #   Delete entries that have been created as we read in
285 
    #   data, but don't exist in RM. They will not have a pvid.
286 
    #
287 
    foreach my $entry ( keys(%versions) )
288 
    {
289 
        delete $versions{$entry}
290 
            unless ( exists $versions{$entry}{pvid} );
291 
    }
292 
}
293 
 
294 
$totalVersions = scalar keys %versions;
295 
Error ("No packages specified") unless ( $multiPackages >= 0 );
296 
Warning ("Multiple Packages being processed") if ( $multiPackages > 1 );
297 
$packageNames = join ('_', @packageNames );
298 
$packageNames = $opt_name if ( defined $opt_name );
299 
Message ("PackageName: $packageNames" );
300 
 
301 
#
302 
#   Save logging data
303 
#
304 
if ( $opt_log )
305 
{
306 
    my $opt_logfile = $packageNames . '.import';
307 
    Message ("Logging outout: $opt_logfile" );
308 
    open STDOUT, '>', $opt_logfile  or die "Can't redirect STDOUT: $!";
309 
    open STDERR, ">&STDOUT"         or die "Can't dup STDOUT: $!";
310 
}
311 
 
312 
#
313 
#   Prepare tip version hash
314 
#
315 
$tipVersions{$_} = 1 foreach ( @opt_tip );
316 
 
317 
#
318 
#   Read in external data and massage it all
319 
#
320 
getEssenialPackageVersions();
321 
getVobMapping();
322 
smartPackageType();                 # Determine special prune mode
323 
ReportPathVariance();
324 
massageData();
325 
getSvnData();
326 
smartPackageType();                 # Have another go
327 
 
328 
my @missedTips = keys %tipVersions;
329 
Error ("Specified tip version not found: @missedTips") if ( @missedTips );
330 
 
331 
if ( $opt_flat )
332 
{
333 
#    @flatOrder = sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions);
334 
#    @flatOrder = sort {$versions{$a}{created} cmp $versions{$b}{created}} keys(%versions);
335 
    @flatOrder = sort {$a <=> $b} keys(%versions);
336 
    my $tip = $flatOrder[-1];
337 
    $versions{$tip}{Tip} = 1 if $tip;
338 
}
339 
 
340 
#
341 
#   Generate dumps and images
342 
#
343 
if ( $opt_images )
344 
{
345 
    createImages();
346 
}
347 
 
348 
if ( $opt_dump )
349 
{
350 
    DebugDumpData ("Versions", \%versions );
351 
    DebugDumpData ("Starts", \@startPoints );
352 
    DebugDumpData ("Ends", \@endPoints );
353 
    DebugDumpData ("Suffixes", \%suffixes );
354 
}
355 
 
356 
 
357 
#   Display VCS tags
358 
#
359 
if ( $opt_listTags )
360 
{
361 
    foreach my $entry (sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions) )
362 
    {
363 
        print $versions{$entry}{vcsTag} || '-' ,"\n";
364 
    }
365 
}
366 
exit if ( ($opt_dump > 1) || ($opt_images > 1) );
367 
 
368 
transferPackageToSvn();
369 
 
370 
if ( $opt_postimage )
371 
{
372 
    getSvnData();
373 
    createImages();
374 
}
375 
 
376 
exit 0;
377 
 
378 
#-------------------------------------------------------------------------------
379 
# Function        : transferPackageToSvn
380 
#
381 
# Description     : Transfer the package to SVN
382 
#
383 
# Inputs          :
384 
#
385 
# Returns         :
386 
#
387 
sub transferPackageToSvn
388 
{
389 
    Error ("Repository Path not setup")
390 
        unless ( $svnRepo );
391 
 
392 
    #
393 
    #   Going to do serious work
394 
    #   Need to ensure we have more arguments
395 
    #
396 
    if ( $noTransfer )
397 
    {
398 
        Warning("Protected Package not transferred: $packageNames[0]");
399 
        exit 0;
400 
    }
401 
 
402 
    #
403 
    #   Perform all the work in a package specific subdirectory
404 
    #
405 
    my $workDir = $opt_workDir . '/' . $packageNames;
406 
    mkdir $workDir unless ( -d $workDir );
407 
    chdir $workDir || Error ("Cannot cd to $workDir");
408 
 
409 
    #
410 
    #   Process all packages
411 
    #       Going to create versions based on RM structure
412 
    #       May have several starting points: Process each
413 
    #
414 
    newPackage();
415 
    if ( $opt_flat )
416 
    {
417 
        newProject();
418 
        foreach my $entry (@flatOrder )
419 
        {
420 
            newPackageVersion( $entry, $versions{$entry}{suffix} );
421 
        }
422 
    }
423 
    else
424 
    {
425 
        processBranch(@allStartPoints);
426 
    }
427 
    endPackage();
428 
 
429 
    chdir $cwd || Error ("Cannot cd back to $cwd");
430 
    rmdir $workDir;
431 
    Warning ("Work Directory still exists: $workDir");
432 
    saveData();
433 
}
434 
 
435 
#-------------------------------------------------------------------------------
436 
# Function        : setPruneMode
437 
#
438 
# Description     : Set the pruning mode
439 
#
440 
# Inputs          : mode                    - Text mode value
441 
#
442 
# Returns         : Nothing
443 
#
444 
sub setPruneMode
445 
{
446 
    my ($mode) = @_;
447 
    my $value;
448 
    if ( $mode )
449 
    {
450 
        if ( $mode =~ m/none/i) {
451 
            $value = 0;
452 
        } elsif ( $mode =~ m/ripple/i) {
453 
            $value = 1;
454 
        } elsif ( $mode =~ m/retain/i) {
455 
            $value = 2;
456 
        } elsif ( $mode =~ m/severe/i) {
457 
            $value = 3;
458 
        } else {
459 
            Error ("Unknown pruning mode", "Use: none, ripple, retain or severe");
460 
        }
461 
 
462 
        $pruneModeString = $mode;
463 
        $pruneMode = $value;
464 
    }
465 
}
466 
 
467 
#-------------------------------------------------------------------------------
468 
# Function        : smartPackageType
469 
#
470 
# Description     : Have a look at the projects in the package set and
471 
#                   attempt to determine what sort of mechanism to use
472 
#
473 
# Inputs          : Uses %suffixes data
474 
#
475 
# Returns         :
476 
#
477 
my $packageType = 'UNKNOWN';
478 
sub smartPackageType
479 
{
480 
    #
481 
    #   Rebuild suffixes hash based on  post massaged versions
482 
    #
483 
    my %suffixes;
484 
    my @unknown;
485 
    foreach my $entry ( keys %versions )
486 
    {
487 
        my $suffix = $versions{$entry}{suffix} || '';
488 
        push (@unknown, $entry) if ($suffix eq 'unknown');
489 
 
490 
        next if ( exists $suffixes{$suffix} );
491 
        next if ( $versions{$entry}{badSingleton} );
492 
        next if ( $versions{$entry}{locked} eq 'N' || $versions{$entry}{isaWip} );
493 
        $suffixes{$suffix} = 1;
494 
        $knownProjects{$suffix}{seen} = 1;
495 
 
496 
    }
497 
 
498 
    #
499 
    #   The 'unknown' suffix is really an 'empty' suffix
500 
    #   Try to be clever
501 
    #       Map unknown to 'cr' or 'mas' if present
502 
    #
503 
    #
504 
    if ( exists $suffixes{'unknown'}  )
505 
    {
506 
        my $new_suffix;
507 
        if ( exists $suffixes{'.cr'} ) {
508 
            $new_suffix = '.cr';
509 
        } elsif ( exists $suffixes{'.mas'} ) {
510 
            $new_suffix = '.mas';
511 
        }
512 
 
513 
        if ( $new_suffix )
514 
        {
515 
            foreach my $entry ( @unknown )
516 
            {
517 
                $versions{$entry}{suffix} = $new_suffix;
518 
            }
519 
            delete $suffixes{'unknown'};
520 
            delete $knownProjects{'unknown'}{seen};
521 
        }
522 
    }
523 
 
524 
    if ( exists $suffixes{'.cots'} && !exists ($notCots{$packageNames}) ) {
525 
        $packageType = 'COTS';
526 
        $Projects{'.cots'}{Trunk} = 1;
527 
        $singleProject = 1;
528 
        $opt_flat = 1 unless defined $opt_flat;
529 
        setPruneMode('none') unless (defined $opt_pruneModeString);
530 
 
531 
    } elsif ( exists $suffixes{'.tool'} ) {
532 
        $packageType = 'TOOL';
533 
        $Projects{'.tool'}{'Trunk'} = 1;
534 
        $singleProject = 1;
535 
        setPruneMode('none') unless (defined $opt_pruneModeString);
536 
#        $opt_flat = 1;
537 
 
538 
    } elsif ( scalar (keys %suffixes ) == 1 ) {
539 
        $packageType = 'SINGLE_PROJECT';
540 
        $singleProject = 1;
541 
 
542 
    } else {
543 
        $packageType = 'MULTIPLE_PROJECT';
544 
    }
545 
 
546 
    #
547 
    #   Some packages are special
548 
    #
549 
 
550 
    if ( $packageNames[0] =~ m'^br_applet_' )
551 
    {
552 
        $opt_flat = 1 unless defined $opt_flat;
553 
    }
554 
 
555 
    if ( exists $specialPackages{$packageNames[0]} )
556 
    {
557 
        my $data = $specialPackages{$packageNames[0]};
558 
        if ( index( $data, ',all' ) >= 0) {
559 
            setPruneMode('none') unless (defined $opt_pruneModeString);
560 
        }
561 
 
562 
        if ( index( $data, 'protected,' ) >= 0) {
563 
            $noTransfer = 1;
564 
        }
565 
 
566 
        if ( index( $data, 'flat,' ) >= 0) {
567 
            $opt_flat = 1;
568 
        }
1197 dpurdie 569 
 
570 
        if ( index( $data, 'SetProjectBase,' ) >= 0) {
571 
            $opt_preserveProjectBase = 1;
572 
            $opt_ignoreProjectBaseErrors = 1;
573 
            Message ("Preserving ProjectBase");
574 
        }
575 
 
576 
        if ( index( $data, 'IgnoreProjectBase,' ) >= 0) {
577 
            $opt_ignoreProjectBaseErrors = 1;
578 
            Message ("Ignore ProjectBase Errors");
579 
        }
580 
 
392 dpurdie 581 
    }
582 
 
583 
    Message("Package Type: $packageType, $pruneModeString");
584 
}
585 
 
586 
 
587 
#-------------------------------------------------------------------------------
588 
# Function        : massageData
589 
#
590 
# Description     : Massage all the data to create a tree of package versions
591 
#                   that can be used to create images as well as an import order
592 
#
593 
# Inputs          :
594 
#
595 
# Returns         :
596 
#
597 
my $reprocess=0;
598 
sub calcLinks
599 
{
600 
    #
601 
    #   Process the 'versions' hash and:
602 
    #   Add back references
603 
    #   Find starts and ends
604 
    #       Entry with no previous
605 
    #       Entry with no next
606 
    #
607 
    $reprocess = 0;
608 
    foreach my $entry ( keys(%versions) )
609 
    {
610 
        foreach ( @{ $versions{$entry}{next}} )
611 
        {
612 
            $versions{$_}{last} = $entry;
613 
        }
614 
    }
615 
    @allStartPoints = ();
616 
    @startPoints = ();
617 
    @endPoints = ();
618 
    foreach my $entry ( keys(%versions) )
619 
    {
620 
        push @startPoints, $entry
621 
            unless ( exists $versions{$entry}{last} || $versions{$entry}{badSingleton} );
622 
 
623 
        push @allStartPoints, $entry
624 
            unless ( exists $versions{$entry}{last} );
625 
 
626 
        push @endPoints, $entry
627 
            unless ( @{$versions{$entry}{next}} > 0  )
628 
    }
629 
}
630 
 
631 
sub massageData
632 
{
633 
    #
634 
    #   Report unknown suffixes
635 
    #   Handle bad, or little known project suffixes by creating them
636 
    #
637 
    foreach my $suffix ( keys %suffixes )
638 
    {
639 
        if ( exists $Projects{$suffix} )
640 
        {
641 
            next;
642 
        }
643 
        Message ("Unknown project suffix: '$suffix'");
644 
        push @unknownProjects, $suffix;
645 
        my $cleanSuffix = ucfirst(lc(substr( $suffix, 1)));
646 
        $Projects{$suffix}{Name} = 'Project_' . $cleanSuffix;
647 
    }
648 
 
649 
    calcLinks();
650 
 
651 
    $initialTrees = scalar @allStartPoints;
652 
    Message ('Total RM versions: ' . $totalVersions );
653 
    Message ('Initial trees: ' . $initialTrees );
654 
    #
655 
    #   Attempt to glue all the start points into one chain.
656 
    #   This should allow us to track projects that branch from each other
657 
    #   in cases where the RM data is incorrect/incomplete
658 
    #       Strays are those that have no next or last
659 
    #
660 
    #   Glue based on Name, then PVID (Creation Order)
661 
    #
662 
    {
663 
        #
664 
        #   Examine threads. If it is a single entry thats bad then drop it
665 
        #   This is simple to do. Should examine all entries, but thats a
666 
        #   bit harder. Perhaps later.
667 
        #
668 
        if (1) {
669 
            Message ("Dropping Bad Singletons");
670 
            my $badSingletons;
671 
            foreach my $entry ( sort {$a <=> $b} @startPoints )
672 
            {
673 
                my $ep = $versions{$entry};
674 
                unless ( $ep->{last} || $ep->{next}[0] )
675 
                {
676 
#                    if (  $ep->{isaWip}  )
677 
                    if ( (exists $ep->{badVcsTag} && $ep->{badVcsTag}) || $ep->{isaWip}  )
678 
                    {
679 
                        $ep->{badSingleton} = 1;
680 
                        $reprocess = 1;
681 
                        $badSingletonCount++;
682 
 
683 
                        # Add to a list of its own.
684 
                        if ( $badSingletons )
685 
                        {
686 
                            push @{$versions{$badSingletons}{next}}, $entry;
687 
                        }
688 
                        $badSingletons = $entry;
689 
                    }
690 
                }
691 
            }
692 
            calcLinks()
693 
                if ( $reprocess );
694 
        }
695 
 
696 
        #
697 
        #   Create simple trees out of the chains
698 
        #   Tree is based on suffix (project) and version
699 
        #
700 
        {
701 
            my %trees;
702 
            Message ("Entries into trees");
703 
            foreach my $single ( @startPoints )
704 
            {
705 
                my $suffix = $versions{$single}{suffix} || '';
706 
                push @{$trees{$suffix}}, $single;
707 
            }
708 
 
709 
            foreach  ( keys %trees )
710 
            {
711 
                my $last;
712 
                foreach my $entry ( sort { $versions{$a}{version} cmp $versions{$b}{version}  } @{$trees{$_}} )
713 
                {
714 
                    if ( $last )
715 
                    {
716 
                        $versions{$last}{MakeTree} = 1;
717 
                        push @{$versions{$last}{next}}, $entry;
718 
                        $reprocess = 1;
719 
                    }
720 
                    $last = $entry;
721 
                }
722 
            }
723 
            calcLinks()
724 
                if ( $reprocess );
725 
        }
726 
 
727 
        #
728 
        #   Have a number of trees that are project related
729 
        #   Attempt to create a single tree by inserting
730 
        #   Secondary trees into the main line at suitable points
731 
        #
732 
        my @AllVersions = sort { $a <=> $b } @startPoints;
733 
        my $lastEntry = shift @AllVersions;
734 
        Error ("Oldest entry has a previous version") if ( $versions{$lastEntry}{last}  );
735 
#print "Oldest: $lastEntry\n";
736 
        #
737 
        #   Insert remaining entries into out list, which is now sorted
738 
        #
739 
        my @completeList;
740 
        foreach my $base ( @AllVersions  )
741 
        {
742 
            push @completeList, recurseList($lastEntry);
743 
            @completeList = sort {$a <=> $b} @completeList;
744 
#            Message("Complete List: ", @completeList);
745 
#            Message("Complete List($completeList[0]) Length: " . scalar @completeList);
746 
            $lastEntry = $base;
747 
 
748 
            my $last;
749 
            foreach my $entry ( @completeList )
750 
            {
751 
                if ( $entry > $base )
752 
                {
753 
                    Error ("Not expecting last to be empty. $base, $entry") unless ( $last );
754 
                    last;
755 
                }
756 
                $last = $entry;
757 
            }
758 
 
759 
            #
760 
            #   Insert at end if point not yet found
761 
            #
762 
#print "Inserting $base at $last\n";
763 
            push @{$versions{$last}{next}}, $base;
764 
            $versions{$base}{GluedIn} = 1;
765 
            $reprocess = 1;
766 
        }
767 
 
768 
        #
769 
        #   Recalc basic links if any processing done
770 
        #
771 
        calcLinks()
772 
            if ( $reprocess );
773 
 
774 
    }
775 
 
776 
 
777 
    #
778 
    #   Remove Dead Ends
779 
    #   Packages that were never released
780 
    #       Not locked, unless essential or a branchpoint
781 
    #   Won't consider these to be mainline path.
782 
    #
783 
    {
784 
        Message ("Remove Dead Ends");
785 
        foreach my $entry ( @endPoints )
786 
        {
787 
            my $deadWood;
788 
            while ( $entry )
789 
            {
790 
                last if ( $versions{$entry}{Essential} );
791 
 
792 
                my @next = @{$versions{$entry}{next}};
793 
                my $count = @next;
794 
                last if ( $count > 1 );
795 
 
796 
                last unless ( $versions{$entry}{locked} eq 'N' || $versions{$entry}{isaWip} );
797 
 
798 
                $versions{$entry}{DeadWood} = 1;
799 
                $trimCount++;
800 
            } continue {
801 
                $entry = $versions{$entry}{last};
802 
            }
803 
        }
804 
    }
805 
 
806 
    #
807 
    #   Walk each starting point list and determine new Projects
808 
    #   branchpoints.
809 
    #
810 
    Message ("Locate Projects branch points");
811 
    foreach my $bentry ( keys(%versions) )
812 
    {
813 
        my $baseSuffix = $versions{$bentry}{suffix};
814 
        foreach my $entry ( @{$versions{$bentry}{next}} )
815 
        {
816 
            if ( $baseSuffix ne $versions{$entry}{suffix})
817 
            {
818 
                unless ( exists $versions{$entry}{DeadWood} || $versions{$entry}{badSingleton} )
819 
                {
820 
#print "--- Project Branch $versions{$entry}{vname}\n";
821 
                    $versions{$entry}{branchPoint} = 1;
822 
                    $versions{$entry}{newSuffix} = 1;
823 
                }
824 
            }
825 
        }
826 
    }
827 
 
828 
    #
829 
    #   Prune
830 
    #   Marks paths to root for all essential packages
831 
    #   Marks the last-N from all essential packages
832 
    #
833 
    if ( $pruneMode )
834 
    {
835 
        Message ("Prune Tree: $pruneModeString");
836 
        foreach ( @EssentialPackages )
837 
        {
838 
            #next unless ( exists $versions{$_} );      # Aleady deleted
839 
 
840 
            # Mark previous-N to be retained as well
841 
            my $entry = $_;
842 
            my $count = 0;
843 
            while ( $entry )
844 
            {
845 
                last if ( $versions{$entry}{KeepMe} );
846 
                unless ( $versions{$entry}{isaRipple} )
847 
                {
848 
                    my $keepFlag = ($count++ < $opt_retaincount);
849 
                    last unless ( $keepFlag );
850 
                    $versions{$entry}{KeepMe} = $keepFlag;
851 
                }
852 
                $entry = $versions{$entry}{last}
853 
            }
854 
        }
855 
 
856 
        #
857 
        #   Keep versions that are common parents to Essential Versions
858 
        #       Mark paths through the tree to essential versions
859 
        #       Mark nodes with the number of essential versions that they sprout
860 
        #   Don't do it if we are ripple pruning
861 
        #
862 
        Message ("Prune Tree keep common parents");
863 
        if ( $pruneMode != 1 )
864 
        {
865 
            foreach my $entry ( @endPoints )
866 
            {
867 
                my $hasEssential = 0;
868 
                $visitId++;
869 
                while ( $entry )
870 
                {
871 
                    $hasEssential = 1 if ( exists ($versions{$entry}{Essential}) && $versions{$entry}{Essential} );
872 
                    if ( $hasEssential )
873 
                    {
874 
                        if ( @{$versions{$entry}{next}} > 1 )
875 
                        {
876 
                            $versions{$entry}{EssentialSplitPoint}++;
877 
                        }
878 
                        last if ( exists $versions{$entry}{EssentialPath} );
879 
                        $versions{$entry}{EssentialPath} = 1;
880 
                    }
881 
 
882 
                    if ( ($versions{$entry}{visitId} || 0) == $visitId )
883 
                    {
884 
                        DebugDumpData ("Versions", \%versions );
885 
                        Warning ("Circular dependency");
886 
                        last;
887 
                    }
888 
                    $versions{$entry}{visitId} = $visitId;
889 
 
890 
                    $entry = $versions{$entry}{last};
891 
                }
892 
            }
893 
        }
894 
 
895 
        #
896 
        #   Keep first version of each ripple. Must keep first
897 
        #   Group ripples together so that they can be proccessed at the same time
898 
        #
899 
        calcRippleGroups()
900 
            if ( $pruneMode == 1);
901 
 
902 
        #
903 
        #   Delete all nodes that are not marked for retention
904 
        #   This is rough on the tree
905 
        #
906 
        Message ("Prune Tree Deleting");
907 
 
908 
        # 0 - Keep me
909 
        # 1 - Prune me
910 
        sub pruneMe
911 
        {
912 
            my ($entry) = @_;
913 
 
914 
            return 0 unless ( exists $versions{$entry} );
915 
            return 0 unless ( $versions{$entry}{last} );
916 
            return 0 if ( ($pruneMode == 2) && exists $versions{$entry}{KeepMe} );
917 
            return 0 if ( exists $versions{$entry}{Essential} );
918 
            return 0 if ( $versions{$entry}{newSuffix} );
919 
            return 0 if ( $versions{$entry}{newSuffix} && (exists $versions{$entry}{EssentialPath}) );
920 
#            return 1 if ( exists $versions{$entry}{DeadWood} );
921 
            return 0 if ( exists $versions{$entry}{EssentialSplitPoint} && $versions{$entry}{EssentialSplitPoint} > 1 );
922 
            return 0 if ( exists $versions{$entry}{keepLowestRipple} &&  $versions{$entry}{keepLowestRipple} );
923 
            return 0 if ( ($pruneMode == 1) && ! $versions{$entry}{isaRipple} );
924 
            return 1;
925 
        }
926 
 
927 
        foreach my $entry ( keys(%versions) )
928 
        {
929 
#last;
930 
            next unless ( pruneMe($entry) );
931 
#print "--- Prune: $versions{$entry}{vname}\n";
932 
 
933 
            # Delete the current node
934 
            #
935 
            my @newNext;
936 
            $pruneCount++;
937 
            my $last = $versions{$entry}{last};
938 
            foreach ( @{$versions{$last}{next}} )
939 
            {
940 
                next if ( $_ == $entry );
941 
                push @newNext, $_;
942 
            }
943 
            foreach ( @{$versions{$entry}{next}} )
944 
            {
945 
                push @newNext, $_;
946 
                $versions{$_}{last} = $last;
947 
            }
948 
 
949 
            @{$versions{$last}{next}} = @newNext;
950 
            delete $versions{$entry};
951 
        }
952 
 
953 
        # Recalculate endpoints
954 
        calcLinks();
955 
    }
956 
    else
957 
    {
958 
        #   No rippling happening
959 
        #   Some process still need to happen
960 
        #
961 
        calcRippleGroups();
962 
    }
963 
 
964 
    #
965 
    #   Calculate best through-path for branches in the tree
966 
    #   Attempt to keep that 'max' version on the mainline
967 
    #   May be modified by -tip=nnnn
968 
    #
969 
    #   For each leaf (end point), walk backwards and mark each node with the
970 
    #   max version see. If we get to a node which already has been marked then
971 
    #   stop if our version is greater. We want the value to be the max version
972 
    #   to a leaf
973 
    #
974 
    #   Account for 'suffix'. When suffix changes, then the 'max' version must
975 
    #   be recalculated
976 
    #
977 
 
978 
    Message ("Calculate Max Version");
979 
    my $maxVersion;
980 
 
981 
    foreach my $entry ( @endPoints )
982 
    {
983 
        my $lastSuffix;
984 
        my $forceTip;
985 
        while ( $entry )
986 
        {
987 
            if (!defined($lastSuffix) || ($versions{$entry}{suffix} ne $lastSuffix) )
988 
            {
989 
                $maxVersion = '0';
990 
                $visitId++;
991 
                $forceTip = ( exists $tipVersions{$versions{$entry}{vname}} );
992 
                delete $tipVersions{$versions{$entry}{vname}};
993 
                $maxVersion = '999.999.999.999.zzz' if ( $forceTip );
994 
                $lastSuffix = $versions{$entry}{suffix};
995 
#print "---Tip Found\n" if $forceTip;
996 
            }
997 
 
998 
            # Detect circular dependencies
999 
            if ( ($versions{$entry}{visitId} || 0) == $visitId )
1000 
            {
1001 
                DebugDumpData ("Circular dependency: Versions", \%versions );
1002 
                Warning ("Circular dependency");
1003 
                last;
1004 
            }
1005 
            $versions{$entry}{visitId} = $visitId;
1006 
 
1007 
            my $thisVersion = $versions{$entry}{version} || '';
1008 
            if ( $thisVersion gt $maxVersion )
1009 
            {
1010 
                $maxVersion = $thisVersion;
1011 
            }
1012 
 
1013 
            if ( exists $versions{$entry}{maxVersion} )
1014 
            {
1015 
                if ( $versions{$entry}{maxVersion} gt $maxVersion )
1016 
                {
1017 
                    last;
1018 
                }
1019 
            }
1020 
 
1021 
            $versions{$entry}{maxVersion} = $maxVersion;
1022 
            $entry = $versions{$entry}{last};
1023 
        }
1024 
    }
1025 
 
1026 
 
1027 
    #
1028 
    #   Locate all instances where a package-version branches
1029 
    #   Determine the version that should be on the non-branching path
1030 
    #
1031 
    #   Reorder the 'next' list so that the first item is the non-branching
1032 
    #   path. This will be used in the data-insertion phase to simplify the
1033 
    #   processing.
1034 
    #
1035 
    Message ("Calculate package version branches");
1036 
    foreach my $entry ( sort {$a <=> $b} keys(%versions) )
1037 
    {
1038 
        calculateWalkOrder($entry);
1039 
    }
1040 
 
1041 
    #
1042 
    #   Mark Project Branch Tips as they will be in the Repository
1043 
    #   Find each project head and walk primary entry to the end.
1044 
    #
1045 
    foreach my $entry ( keys(%versions) )
1046 
    {
1047 
        #
1048 
        #   Root of each tree is 'new'
1049 
        #
1050 
        unless ( defined $versions{$entry}{last})
1051 
        {
1052 
            unless ( $versions{$entry}{badSingleton} )
1053 
            {
1054 
                $versions{$entry}{newSuffix} = 1;
1055 
            }
1056 
        }
1057 
 
1058 
        #
1059 
        #   Update stats
1060 
        #
1061 
        $badVcsCount++ if ( $versions{$entry}{badVcsTag} );
1062 
        $ProjectCount++ if ( $versions{$entry}{newSuffix} );
1063 
        next if ( $opt_flat );
1064 
 
1065 
        next unless ($versions{$entry}{newSuffix} );
1066 
#print "--- Project new Suffix $versions{$entry}{vname}\n";
1067 
 
1068 
 
1069 
        my $suffix = $versions{$entry}{suffix};
1070 
        $knownProjects{$suffix}{count}++;
1071 
 
1072 
        my $next = $versions{$entry}{next}[0];
1073 
        my $tip;
1074 
        while ( $next )
1075 
        {
1076 
            last if ( $suffix ne $versions{$next}{suffix} );
1077 
            $tip = $next unless (exists ($versions{$next}{DeadWood}) || $versions{$next}{badSingleton});
1078 
            $next = $versions{$next}{next}[0];
1079 
        }
1080 
 
1081 
        $versions{$tip}{Tip} = 1 if $tip;
1082 
    }
1083 
 
1084 
    unless ( $opt_flat )
1085 
    {
1086 
        my $finalTrees = scalar @startPoints;
1087 
        Warning ("Still have multiple trees: $finalTrees") unless ( $finalTrees == 1 );
1088 
    }
1089 
 
1090 
    #
1091 
    #   Display warnings about multiple
1092 
    #
1093 
    foreach ( sort keys %knownProjects )
1094 
    {
1095 
        my $count = $knownProjects{$_}{count} || 0;
1096 
        Warning ("Multiple Project Roots: $_ ($count)" )
1097 
            if ( $count > 1 );
1098 
    }
1099 
 
1100 
    #
1101 
    #   Display warnings about Bad Essential Packages
1102 
    #
1103 
    $allSvn = 1;
1104 
    foreach my $entry ( keys(%versions) )
1105 
    {
1106 
        $rippleCount++ if ( exists($versions{$entry}{isaRipple}) && $versions{$entry}{isaRipple} );
1107 
        $allSvn = 0 unless ( $versions{$entry}{isSvn} );
1108 
        next unless ( exists $versions{$entry}{Essential}  );
1109 
        next unless ( $versions{$entry}{badVcsTag}  );
1110 
        push @badEssentials, $entry;
1111 
        Warning ("BadVCS Essential: " . GetVname($entry))
1112 
    }
1113 
 
1114 
    #
1115 
    #   All done
1116 
    #
1270 dpurdie 1117 
    $processTotal = scalar keys %versions;
1118 
    Message("Retained entries: $processTotal" );
392 dpurdie 1119 
    Message("Pruned entries: $pruneCount");
1120 
    Message("Deadwood entries: $trimCount");
1121 
    Message("Bad Singletons: $badSingletonCount");
1122 
    Message("Ripples: $rippleCount");
1123 
}
1124 
 
1125 
sub calculateWalkOrder
1126 
{
1127 
    my ($entry) = @_;
1128 
    my @next = @{$versions{$entry}{next}};
1129 
    my $count = @next;
1130 
    my @ordered;
1131 
    my $main;
1132 
 
1133 
    if ( $count > 1 )
1134 
    {
1135 
        # Array to hash to simplify removal
1136 
        my %nexts = map { $_ => 1 } @next;
1137 
        foreach my $e ( @next )
1138 
        {
1139 
 
1140 
            #
1141 
            #   Locate branch points that are not a part of a new project
1142 
            #   These will not be preferred paths for walking
1143 
            #
1144 
            if ( !defined($versions{$e}{branchPoint}) && $versions{$entry}{suffix} ne $versions{$e}{suffix} )
1145 
            {
1146 
                unless ( exists $versions{$e}{DeadWood} || $versions{$e}{badSingleton}  )
1147 
                {
1148 
#print "--- Project Branch (1) $versions{$e}{vname}\n";
1149 
                    $versions{$e}{branchPoint} = 1;
1150 
                    $versions{$e}{newSuffix} = 1;
1151 
                }
1152 
            }
1153 
 
1154 
            #
1155 
            #   Remove those that already have a branch,
1156 
            #
1157 
            if ( $versions{$e}{branchPoint} || $versions{$e}{newSuffix} || $versions{$e}{DeadWood}  )
1158 
            {
1159 
                push @ordered, $e;
1160 
                delete $nexts{$e};
1161 
            }
1162 
        }
1163 
        #
1164 
        #   Select longest arm as the non-branching path
1165 
        #   Note: Reverse sort order
1166 
        #         Done so that 'newest' item is given preference
1167 
        #         to the main trunk in cases where all subtrees are
1168 
        #         the same length
1169 
        #
1170 
        my $maxData = '';
1171 
        my $countEntry;
1172 
        foreach my $e ( sort {$b <=> $a} keys %nexts )
1173 
        {
1174 
            if ( $versions{$e}{maxVersion} gt $maxData )
1175 
            {
1176 
                $maxData = $versions{$e}{maxVersion};
1177 
                $countEntry = $e;
1178 
            }
1179 
        }
1180 
        if ($countEntry)
1181 
        {
1182 
            $main = $countEntry;
1183 
            delete $nexts{$countEntry};
1184 
        }
1185 
 
1186 
        #
1187 
        #   Append the remaining
1188 
        #
1189 
        push @ordered, keys %nexts;
1190 
 
1191 
        #
1192 
        #   Re-order 'next' so that the main path is first
1193 
        #   Sort (non main) by number
1194 
        #
1195 
        @ordered = sort {$a <=> $b} @ordered;
1196 
        unshift @ordered, $main if ( $main );
1197 
        @{$versions{$entry}{next}} = @ordered;
1198 
 
1199 
        #
1200 
        #   Ensure all except the first are a branch point
1201 
        #   First may still be a branch point
1202 
        #
1203 
        shift @ordered;
1204 
        foreach my $e ( @ordered )
1205 
        {
1206 
            $versions{$e}{branchPoint} = 1;
1207 
        }
1208 
    }
1209 
}
1210 
 
1211 
#-------------------------------------------------------------------------------
1212 
# Function        : calcRippleGroups
1213 
#
1214 
# Description     : Locate and mark ripple groups
1215 
#                   packages that are ripples fo each other
1216 
#                       Keep first version of each ripple. Must keep first
1217 
#                       Group ripples together so that they can be
1218 
#                       proccessed at the same time
1219 
#
1220 
# Inputs          :
1221 
#
1222 
# Returns         :
1223 
#
1224 
sub calcRippleGroups
1225 
{
1226 
    my %rippleVersions;
1227 
    foreach my $entry ( keys(%versions) )
1228 
    {
1229 
        my $ep = $versions{$entry};
1230 
        if ( defined $ep->{buildVersion} )
1231 
        {
1232 
            my $suffix = $ep->{suffix};
1233 
            my ($major, $minor, $patch, $build) = @{$ep->{buildVersion}};
1234 
#print "--- $major, $minor, $patch, $build, $suffix\n";
1235 
            $rippleVersions{$suffix}{"$major.$minor.$patch"}{count}++;
1236 
            my $rp = $rippleVersions{$suffix}{"$major.$minor.$patch"};
1237 
            $rp->{list}{$entry} = 1;
1238 
 
1239 
            next if ( $ep->{badVcsTag} );
1240 
            next if ( $ep->{locked} eq 'N');
1241 
            if (!defined ($rp->{min}) || $rp->{min} > $build )
1242 
            {
1243 
                $rp->{pvid} = $entry;
1244 
                $rp->{min} = $build;
1245 
            }
1246 
        }
1247 
    }
1248 
#            DebugDumpData("rippleVersions", \%rippleVersions );
1249 
 
1250 
    while ( my($suffix, $e1) = each %rippleVersions )
1251 
    {
1252 
        while ( my( $mmp, $e2) = each %{$e1} )
1253 
        {
1254 
            next unless ( exists  $e2->{pvid} );
1255 
            my $entry = $e2->{pvid};
1256 
            if ( !exists $versions{$entry} )
1257 
            {
1258 
                Error ("Internal: Expected entry not found: $entry, $mmp");
1259 
            }
1260 
 
1261 
            $versions{$entry}{keepLowestRipple} = 1;
1262 
#print "--- Keep Riple $versions{$entry}{vname}\n";
1263 
 
1264 
            #
1265 
            #   Update entry with list of associated ripples, removing lowest
1266 
            #
1267 
            delete $e2->{list}{$entry};
1268 
            my @rippleList = sort keys %{$e2->{list}};
1269 
            if ( @rippleList)
1270 
            {
1271 
#DebugDumpData("LIST: $entry", $e2->{list}, \@rippleList  );
1272 
                @{$versions{$entry}{rippleList}} = @rippleList;
1273 
            }
1274 
        }
1275 
    }
1276 
}
1277 
 
1278 
#-------------------------------------------------------------------------------
1279 
# Function        : processBranch
1280 
#
1281 
# Description     : Process one complete branch within the tree of versions
1282 
#                   May be called recursivly to walk the tree
1283 
#
1284 
# Inputs          : Array of package-version ID to process
1285 
#
1286 
# Returns         : Nothing
1287 
#
1288 
 
1289 
sub processBranch
1290 
{
1291 
    foreach my $entry ( @_ )
1292 
    {
1293 
        #
1294 
        #   Do we need to create a branch before we can process this package
1295 
        #
1296 
        if ( $versions{$entry}{newSuffix} || $versions{$entry}{branchPoint} )
1297 
        {
1298 
            newProject();
1299 
            $createBranch = 1;
1300 
            $createSuffix = 1 if $versions{$entry}{newSuffix};
1301 
        }
1302 
 
1303 
        newPackageVersion( $entry );
1304 
no warnings "recursion";
1305 
        processBranch (@{$versions{$entry}{next}});
1306 
    }
1307 
}
1308 
 
1309 
#-------------------------------------------------------------------------------
1310 
# Function        : newPackageVersion
1311 
#
1312 
# Description     : Create a package version
1313 
#
1314 
# Inputs          : $entry              - Ref to entry being proccessed
1315 
#
1316 
# Returns         :
1317 
#
1318 
sub newPackageVersion
1319 
{
1320 
    my ($entry) = @_;
1321 
    my %data;
1322 
    my $flags = 'e';
1323 
    my $rv = 1;
1324 
    my $startTime = time();
1325 
    my $timestamp = localtime;
1326 
 
1327 
    $data{rmRef} = 'ERROR';
1328 
    $data{tag} = 'ERROR';
1329 
 
1330 
    #
1331 
    #   If its been processed then fake that its been done
1332 
    #   May have been a ripple that we processed
1333 
    #
1270 dpurdie 1334 
    return if ($versions{$entry}{Processed});
1335 
    $processCount++;
392 dpurdie 1336 
    Message ("------------------------------------------------------------------" );
1270 dpurdie 1337 
    Message ("Package $processCount of $processTotal");
1338 
 
392 dpurdie 1339 
    Message ("New package-version: " . GetVname($entry) . " Tag: " . $versions{$entry}{vcsTag} );
1340 
 
1341 
 
1342 
    #
1343 
    #   If we have a global error,then we pretend to process, but we
1344 
    #   report errors for the logging system
1345 
    #
1346 
    unless ( $globalError )
1347 
    {
1348 
        #
1349 
        #   Call worker function
1350 
        #   It will exist on any error so that it can be logged
1351 
        #
1352 
        $rv = newPackageVersionBody( \%data, @_ );
1353 
        $globalError = 1 if ( $rv >= 10 );
1354 
    }
1355 
 
1356 
    #
1357 
    #   Highlight essential packages that failed to transfer
1358 
    #
1359 
    if ( $globalError ) {
1360 
        $flags = 'e';
1361 
    } elsif ( $rv && ( exists $versions{$entry}{Essential} ) ) {
1362 
        $flags = 'X';
1363 
    } elsif ( $rv ) {
1364 
        $flags = 'E';
1365 
    } else {
1366 
        $flags = 'G';
1367 
    }
1368 
 
1369 
    #
1370 
    #   Always log results to a file
1371 
    #   Flags:
1372 
    #       e - Error: Global Fatal causes other versions to be ignored
1373 
    #       X - Essential Package NOT proccessed
1374 
    #       E - Error processing package
1375 
    #       G - Good
1376 
    #
1377 
    my $duration = time() - $startTime;
1378 
    my $line = join(';',
1379 
            $flags,
1380 
            $entry,
1381 
            $packageNames,
1382 
            $versions{$entry}{vname},
1383 
            $data{rmRef},
1384 
            $data{tag},
1385 
            $timestamp,
1386 
            $duration,
1387 
            $data{errStr} || ''
1388 
            );
1389 
    logToFile( $cwd . '/importsummary.txt', ";$line;");
1390 
 
1391 
    #
1392 
    #   Sava data
1393 
    #
1394 
    $versions{$entry}{rmRef} = $data{rmRef};
1395 
    $versions{$entry}{errStr} = $data{errStr};
1396 
    $versions{$entry}{errFlags} = $flags;
1197 dpurdie 1397 
    $versions{$entry}{BadProjectBase} = $data{BadProjectBase};
1398 
 
392 dpurdie 1399 
    #
1400 
    #   Delete the created view
1401 
    #   Its just a directory, so delete it
1402 
    #
1403 
    if ( $data{ViewRoot} && -d $data{ViewRoot})
1404 
    {
1405 
        RmDirTree ($data{ViewRoot} ) if ( !$opt_reuse || $rv );
1406 
    }
1407 
 
1408 
 
1409 
    #
1410 
    #   If this version has any 'ripples' then process them while we have the
1411 
    #   main view. Note the ripple list may contain entries that do not
1412 
    #   exist - they will have been pruned.
1413 
    #
1414 
    foreach my $rentry ( @{$versions{$entry}{rippleList}} )
1415 
    {
1416 
        next unless( exists $versions{$rentry} );
1417 
 
1418 
        if ($versions{$rentry}{Processed})
1419 
        {
1420 
            Warning ("Ripple Processed before main entry");
1421 
            $versions{$rentry}{rippleProcessed} = 1;
1422 
        }
1423 
 
1424 
        Message ("Proccessing associated Ripple: " . GetVname($rentry));
1425 
        newPackageVersion($rentry);
1426 
    }
1427 
}
1428 
 
1429 
#-------------------------------------------------------------------------------
1430 
# Function        : newPackageVersionBody
1431 
#
1432 
# Description     : Perform the bulk of the work in creating a new PackageVersion
1433 
#                   Designed to return on error and have error processing
1434 
#                   performed by caller
1435 
#
1436 
# Inputs          : $data               - Shared data
1437 
#                   $entry              - Package entry to process
1438 
#
1439 
# Returns         : Error Code
1440 
#                         0 - All is well
1441 
#                       <10 - Recoveralble error
1442 
#                       >10 - Fatal error
1443 
#
1444 
sub newPackageVersionBody
1445 
{
1446 
    my ($data, $entry) = @_;
1447 
    my $rv;
1448 
    my $cc_label;
1449 
    my $cc_path;
1450 
 
1451 
    #
1452 
    #   Init Data
1453 
    #
1454 
    $data->{rmRef} = 'ERROR';
1455 
    $data->{tag} = '';
1456 
    $data->{ViewRoot} = undef;
1457 
    $data->{ViewPath} = undef;
1458 
    $data->{flags} = undef;
1459 
    $data->{errStr} = '';
1460 
    $versions{$entry}{Processed} = 1;
1461 
 
1462 
 
1463 
    SystemConfig ('ExitOnError' => 0);
1464 
 
1465 
    push @processOrder, $entry;
1466 
    return 0 if ( $opt_test );
1467 
 
1468 
#   Keep DeadWood. May be a WIP
1469 
#    if ( exists $versions{$entry}{DeadWood} && $versions{$entry}{DeadWood} )
1470 
#    {
1471 
#        $data->{errStr} = 'Package is DeadWood';
1472 
#        return 3;
1473 
#    }
1474 
 
1475 
    #
1476 
    #   Determine version information
1477 
    #
1478 
    $data->{tag} = $versions{$entry}{vcsTag} || '';
1479 
    if ( $versions{$entry}{badVcsTag} )
1480 
    {
1481 
        Warning ("Error: Bad VcsTag for: " . GetVname($entry),
1482 
                 "Tag: $data->{tag}" );
1483 
        $data->{errStr} = 'VCS Tag Marked as Bad';
1484 
        return 1;
1485 
    }
1486 
 
1487 
 
1488 
    $data->{tag} =~ m~^(.+?)::(.*?)(::(.+))?$~;
1489 
    $cc_label = $4;
1490 
    $cc_path = $2;
1491 
    $cc_path = '/' . $cc_path;
1492 
    $cc_path =~ tr~\\/~/~s;
1493 
 
1494 
    #
1495 
    #   Correct well known path mistakes
1496 
    #
394 dpurdie 1497 
    $cc_path =~ s~/MASS_Dev/Bus/~/MASS_Dev_Bus/~i;
392 dpurdie 1498 
    $cc_path =~ s~/MASS_Dev_Bus/Cbp/~/MASS_Dev_Bus/CBP/~i;
1499 
    $cc_path =~ s~/MREF_Package/ergpostmongui$~/MREF_Package/ergpostmongui~i;
1270 dpurdie 1500 
    $cc_path =~ s~/MREF_21/MREF_Package/~/MREF_Package/~i;
392 dpurdie 1501 
 
1270 dpurdie 1502 
 
392 dpurdie 1503 
#print "--- Path: $cc_path, Label: $cc_label\n";
1504 
 
1505 
    #
1506 
    #   Create CC view
1507 
    #   Import into Subversion View
1508 
    #
1509 
    $data->{ViewRoot} = $opt_name ? $opt_name : "$cc_label";
1197 dpurdie 1510 
    $data->{ViewPath} =  $data->{ViewRoot} . $cc_path;
1511 
 
1512 
    if ( $opt_preserveProjectBase )
1513 
    {
1514 
        my $cc_vob = $cc_path;
1515 
        $cc_vob =~ s~^/~~;
1516 
        $cc_vob =~ s~/.*~~;
1517 
        $data->{ViewPath} =  $data->{ViewRoot} . '/' . $cc_vob;
1518 
        Message ("Preserving Project Base");
1519 
    }
392 dpurdie 1520 
    $data->{ViewPath} =~  tr~/~/~s;
1521 
 
1522 
    if ( $opt_reuse && -d $data->{ViewPath}  )
1523 
    {
1524 
        Message ("Reusing view: $cc_label");
1525 
    }
1526 
    else
1527 
    {
1528 
        my @args;
1529 
        push (@args, '-view', $opt_name ) if ( defined $opt_name );
1530 
        $rv = JatsToolPrint ( 'jats_ccrelease', '-extractfiles', '-root=.' , '-noprefix',
1531 
                    "-label=$cc_label" ,
1532 
                    "-path=$cc_path",
1533 
                    @args
1534 
                    );
1535 
 
1536 
        unless ( -d $data->{ViewPath}  )
1537 
        {
1538 
            $data->{errStr} = 'Failed to extract files from CC';
1539 
            return 2;
1540 
        }
1541 
    }
1542 
 
1197 dpurdie 1543 
 
392 dpurdie 1544 
    #
1197 dpurdie 1545 
    #   Some really ugly packages make use of a Jats feature called 'SetProjectBase'
1546 
    #   Detect such packages as we will need to handle them differently
1547 
    #   Can't really handle it on the fly
1548 
    #   All we can do is detct it and report it - at the moment
1549 
    #
1550 
    if (detectProjectBaseUsage($data, $cc_path) )
1551 
    {
1552 
        unless ( $opt_ignoreProjectBaseErrors )
1553 
        {
1554 
            $data->{BadProjectBase}++;
1555 
            $data->{errStr} = 'Bad usage of ProjectBase detected';
1556 
            return 14;
1557 
        }
1558 
    }
1559 
 
1560 
    #
392 dpurdie 1561 
    #   Have a CC view
1562 
    #   Now we can create the SVN package and branching point before we
1563 
    #   import the CC data into SVN
1564 
    #
1565 
    my @args;
1566 
 
1567 
    #
1568 
    #   Calculate args for functions
1569 
    #
1570 
    my $author = $versions{$entry}{created_id};
1571 
    if ( $author )
1572 
    {
1573 
        push @args, '-author', $author;
1574 
    }
1575 
    my $created = $versions{$entry}{created};
1576 
    if ( $created )
1577 
    {
1578 
        $created =~ s~ ~T~;
1579 
        $created .= '00000Z';
1580 
        push @args, '-date', $created;
1581 
    }
1582 
 
1583 
    my $log = $versions{$entry}{comment};
1584 
    if ( $log )
1585 
    {
1586 
        push @args, '-log', $log;
1587 
    }
1588 
 
1589 
    #
1590 
    #   Create package skeleton if needed
1591 
    #
1592 
    $rv = createPackage( $author, $created);
1593 
    if ( $rv )
1594 
    {
1595 
        $data->{errStr} = 'Failed to create Package';
1596 
        return 10;
1597 
    }
1598 
 
1599 
    #
1600 
    #   Calculate the label for the target package
1601 
    #   Use format <packageName>_<PackageVersion>
1602 
    #   Need to handle WIPs too.
1603 
    #
1604 
    my $import_label = saneLabel($entry);
1605 
 
1606 
    #
1607 
    #   May need to create the branchpoint
1608 
    #   The process is delayed until its needed so avoid creating unneeded
1609 
    #   branch points
1610 
    #
1611 
    if ( $createBranch )
1612 
    {
1613 
        $rv = createBranchPoint ($entry, $author, $created);
1614 
        $createBranch = 0;
1615 
        $createSuffix = 0;
1616 
        if ( $rv )
1617 
        {
1618 
            $data->{errStr} = 'Failed to create Branch Point';
1619 
            return 11;
1620 
        }
1621 
    }
1622 
    push @args, "-branch=$currentBranchName" if ( defined $currentBranchName );
1623 
 
1624 
    my $datafile = "importdata.$import_label.properties";
1625 
    $rv = JatsToolPrint ( 'jats_svn', 'import', '-reuse' ,
1626 
                    "-package=$svnRepo/$packageNames",
1627 
                    "-dir=$data->{ViewPath}",
1628 
                    "-label=$import_label",
1629 
                    "-datafile=$datafile",
1630 
                    @args,
1631 
                     );
1632 
 
1633 
    if ( $rv )
1634 
    {
1635 
        $data->{errStr} = 'Failed to import to SVN';
1636 
        return 12;
1637 
    }
1638 
 
1639 
    $versions{$entry}{TagCreated} = 1;
1640 
    $firstVersionCreated = $entry unless ( $firstVersionCreated );
1641 
 
1642 
    #
1643 
    #   Read in the Rm Reference
1644 
    #   Retain entries in a global file
1645 
    #
1646 
    if ( -f $datafile  )
1647 
    {
1648 
        my $rmData = JatsProperties::New($datafile);
1649 
        $data->{rmRef} = 'SVN::' . $rmData->getProperty('subversion.tag');
1650 
    }
1651 
 
1652 
    unless ( $data->{rmRef}  )
1653 
    {
1654 
        $data->{errStr} = 'Failed to determin Rm Reference';
1655 
        return 13;
1656 
    }
1657 
 
1658 
    Message ("RM Ref: $data->{rmRef}");
1659 
    unlink $datafile;
1660 
 
1661 
    #
1662 
    #   All is good
1663 
    #
1664 
    $data->{errStr} = '';
1665 
    return 0;
1666 
}
1667 
 
1668 
 
1669 
#-------------------------------------------------------------------------------
1670 
# Function        : newProject
1671 
#
1672 
# Description     : Start a new project within a package
1673 
#
1674 
# Inputs          :
1675 
#
1676 
# Returns         :
1677 
#
1678 
sub newProject
1679 
{
1680 
#    Message ("---- New Project");
1681 
    $createSuffix = 0;
1682 
 
1683 
    #
1684 
    #   New project
1685 
    #   Kill the running import directory
1686 
    #
1687 
    RmDirTree ('SvnImportDir');
1688 
}
1689 
 
1690 
#-------------------------------------------------------------------------------
1691 
# Function        : newPackage
1692 
#
1693 
# Description     : Start processing a new package
1694 
#
1695 
# Inputs          :
1696 
#
1697 
# Returns         :
1698 
#
1699 
my $createPackageDone;
1700 
sub newPackage
1701 
{
1702 
#    Message( "---- New Package");
1703 
 
1704 
    #
1705 
    #   Create a package specific log file
1706 
    #
1707 
    $logSummary = $packageNames . ".summary.log";
1708 
    unlink $logSummary;
1709 
    Message( "PackageName: $packageNames");
1710 
    $createPackageDone = 1;
1711 
    $createBranch = 0;
1712 
    $createSuffix = 0;
1713 
 
1714 
    #
1715 
    #   First entry being created
1716 
    #   Prime the work area
1717 
    #
1718 
    RmDirTree ('SvnImportDir');
1719 
}
1720 
 
1721 
#-------------------------------------------------------------------------------
1722 
# Function        : createPackage
1723 
#
1724 
# Description     : Create a new Package in SVN
1725 
#                   Called before any serious SVN operation to ensure that the
1726 
#                   package has been created. Don't create a package until
1727 
#                   we expect to put something into it.
1728 
#
1729 
#                   Will only create a package once
1730 
 
1731 
#
1732 
# Inputs          : $author         - Who done it
1733 
#                   $date           - When
1734 
#
1735 
# Returns         :
1736 
#
1737 
sub createPackage
1738 
{
1739 
    my ($author, $date) = @_;
1740 
    my @opts;
1741 
    push (@opts, '-date', $date) if ( $date );
1742 
    push (@opts, '-author', $author) if ( $author );
1743 
    #
1744 
    #   Only do once
1745 
    #
1746 
    return unless ( $createPackageDone );
1747 
    $createPackageDone = 0;
1748 
 
1270 dpurdie 1749 
    #
1750 
    #   Real import
1751 
    #       Do not Delete package if it exists
1752 
    #       Package must NOT exist
1753 
    #
392 dpurdie 1754 
    Message ("Creating new SVN package: $packageNames");
1270 dpurdie 1755 
    if ( $opt_delete )
1756 
    {
1757 
        Message ("Delete existing version of package: $packageNames");
1758 
        JatsToolPrint ( 'jats_svn', 'delete-package', '-noerror',  "$svnRepo/$packageNames" );
1759 
    }
1760 
    JatsToolPrint ( 'jats_svn', 'create', "$svnRepo/$packageNames", '-new', @opts );
392 dpurdie 1761 
}
1762 
 
1763 
 
1764 
#-------------------------------------------------------------------------------
1765 
# Function        : createBranchPoint
1766 
#
1767 
# Description     : Create a branch point for the current work
1768 
#                   Perform the calculation to determine the details of
1769 
#                   the branch point. The work will only be done when its
1770 
#                   needed. This will avoid the creation of branchpoints
1771 
#                   that are not used.
1772 
#
1773 
# Inputs          : $entry                  Entry being processed
1774 
#                   $author         - Who done it
1775 
#                   $date           - When
1776 
#
1777 
# Returns         :
1778 
#
1779 
sub createBranchPoint
1780 
{
1781 
    my ($entry, $author, $date) = @_;
1782 
    my $forceNewProject;
1783 
 
1784 
#    Message ("---- Create Branch Point");
1785 
 
1786 
    #
1787 
    #   Find previous good tag
1788 
    #   We are walking a tree so something should have been created, but
1789 
    #   the one we want may have had an error
1790 
    #
1791 
    #   Walk backwards looking for one that has been created
1792 
    #
1793 
    my $last = $versions{$entry}{last};
1794 
    while ( $last )
1795 
    {
1796 
        unless ( $versions{$last}{TagCreated} )
1797 
        {
1798 
            $last = $versions{$last}{last};
1799 
        }
1800 
        else
1801 
        {
1802 
            last;
1803 
        }
1804 
    }
1805 
 
1806 
    #
1807 
    #   If we have walked back to the base of the tree
1808 
    #   If we transferred any software at all, then use the first
1809 
    #   version as the base for this disconnected version
1810 
    #
1811 
    #   Otherwise we create a new, and empty, view
1812 
    #
1813 
    unless ( $last )
1814 
    {
1815 
        if ( $firstVersionCreated )
1816 
        {
1817 
            Warning ("Cannot find previous version to branch. Use first version");
1818 
            $last = $firstVersionCreated;
1819 
        }
1820 
        else
1821 
        {
1822 
            Warning ("Forcing First instance of a Project");
1823 
            $forceNewProject = 1;
1824 
        }
1825 
    }
1826 
 
1827 
    #
1828 
    #   Determine source name
1829 
    #   This MUST have been created before we can branch
1830 
    #
1831 
    my $src_label;
1832 
    $src_label = saneLabel($last) if $last;
1833 
 
1834 
    #
1835 
    #   Create target name
1836 
    #
1837 
    my $tgt_label;
1838 
    if ( $forceNewProject || $versions{$entry}{newSuffix} || $createSuffix || !defined $src_label )
1839 
    {
1840 
        #
1841 
        #   Create target name based on project
1842 
        #
1843 
        return if ( $singleProject );
1844 
 
1845 
        my $suffix = $versions{$entry}{suffix};
1846 
        if ( $suffix )
1847 
        {
1848 
            Error ("Unknown Project: $suffix") unless ( defined $Projects{$suffix} );
1849 
 
1850 
            #
1851 
            #   If this project can be considered to be a truck, then 'claim' the
1852 
            #   truck for the first created element.
1853 
            #
1854 
            if ( $Projects{$suffix}{Trunk} )
1855 
            {
1856 
                # This project can use the trunk, if it has not been allocated.
1857 
                $ProjectTrunk = $suffix unless ( defined $ProjectTrunk );
1858 
 
1859 
                #
1860 
                #   If this package has multiple instances of the potential
1861 
                #   trunk, then don't place either of them on the trunk as it
1862 
                #   may cause confusion
1863 
                #
1864 
                if ($knownProjects{$suffix}{count} < 2 )
1865 
                {
1866 
                    if ( $suffix eq $ProjectTrunk )
1867 
                    {
1868 
                        return unless $currentBranchName;
1869 
                    }
1870 
                }
1871 
            }
1872 
 
1873 
            $tgt_label = $Projects{$suffix}{Name};
1874 
            $tgt_label = $versions{$entry}{name} . '_' . $tgt_label if ($multiPackages);
1875 
            if ( !exists $ProjectsBaseCreated{$tgt_label}  )
1876 
            {
1877 
                $ProjectsBaseCreated{$tgt_label} = 1;
1878 
            }
1879 
            else
1880 
            {
1881 
                #   Project Base Already taken
1882 
                #   Have disjoint starting points
1883 
                $tgt_label .= '.' . $ProjectsBaseCreated{$tgt_label} ++;
1884 
            }
1885 
        }
1886 
        else
1887 
        {
1888 
            #
1889 
            #   No suffix in use
1890 
            #
1891 
            #   Currently not handled
1892 
            #   May have to force the use of the trunk
1893 
            #
1894 
            Error ("INTERNAL ERROR: No suffix present");
1895 
        }
1896 
    }
1897 
    else
1898 
    {
1899 
        $tgt_label = saneLabel($entry, $src_label . '_for_');
1900 
    }
1901 
 
1902 
    #
1903 
    #   Save branch name for use when populating sandbox
1904 
    #
1905 
    $currentBranchName = $tgt_label;
1906 
 
1907 
    #
1908 
    #   Perform the branch
1909 
    #
1910 
    if ( defined $src_label )
1911 
    {
1912 
        my @opts;
1913 
        push (@opts, '-date', $date) if ( $date );
1914 
        push (@opts, '-author', $author) if ( $author );
1915 
 
1916 
        JatsToolPrint ( 'jats_svnlabel',
1917 
                        '-packagebase', "$svnRepo/$packageNames",
1918 
                        'tags/' . $src_label,
1919 
                        '-branch',
1920 
                        '-clone', $tgt_label,
1921 
                        @opts
1922 
                      );
1923 
    }
1924 
}
1925 
 
1926 
 
1927 
#-------------------------------------------------------------------------------
1928 
# Function        : endPackage
1929 
#
1930 
# Description     : End of package processing
1931 
#                   Clean up and display problems
1932 
#
1933 
# Inputs          :
1934 
#
1935 
# Returns         :
1936 
#
1937 
sub endPackage
1938 
{
1939 
    RmDirTree ('SvnImportDir');
1940 
 
1941 
    #
1942 
    #   Display versions that did get captured
1943 
    #
1944 
    foreach my $entry ( @processOrder )
1945 
    {
1946 
        $versions{$entry}{Scanned} = 1;
1947 
        next unless ( $versions{$entry}{TagCreated} );
1948 
        Warning ("Processed: " . GetVname($entry) . ' :: ' . $versions{$entry}{rmRef} || $versions{$entry}{errStr} || '???' );
1949 
    }
1950 
 
1951 
    #
1952 
    #   Display versions that did not get created
1953 
    #
1954 
    foreach my $entry ( @processOrder )
1955 
    {
1956 
        $versions{$entry}{Scanned} = 1;
1957 
        next if ( $versions{$entry}{TagCreated} );
1958 
        Warning ("Not Processed: " . GetVname($entry) );
1959 
    }
1960 
 
1961 
    foreach my $entry ( keys(%versions) )
1962 
    {
1963 
        next if ( $versions{$entry}{Scanned} );
1964 
        Warning ("(E) INTERNAL ERROR. Package Not Processed: " . GetVname($entry) );
1965 
    }
1966 
 
1967 
    Message ("All Done");
1968 
}
1969 
 
1197 dpurdie 1970 
#-------------------------------------------------------------------------------
1971 
# Function        : detectProjectBaseUsage
1972 
#
1973 
# Description     : Detect and report usage of the SetProjectBase directive
1974 
#
1975 
# Inputs          : $data               - Ref to a hash of bits
1976 
#                   $cc_path            - Packages cc_path
1977 
#
1978 
# Returns         : true    - Bad usage (Really good usage not detected)
1979 
#                   false   - Good usage detected
1980 
#
1981 
sub detectProjectBaseUsage
1982 
{
1983 
    my ($data, $cc_path) = @_;
1984 
    my $retval = 0;
1985 
    my $eSuf = $opt_ignoreProjectBaseErrors ? '' : 'Error';
1986 
 
1987 
    #
1988 
    #   Find makefile.pl
1989 
    #
1990 
    Message ("Locate JATS makefiles");
1991 
    my $usesProjectBase = 0;
1992 
    my $definesProjectBase = 0;
1993 
    my $definitionError = 0;
1994 
 
1995 
    my $search = JatsLocateFiles->new("--Recurse=1",
1996 
                                       "--FilterIn=makefile.pl",
1997 
                                       );
1998 
    my @makefiles = $search->search($data->{ViewRoot});
1999 
    foreach my $file ( @makefiles )
2000 
    {
2001 
        if ( open( my $fh, '<', "$data->{ViewRoot}/$file" ) )
2002 
        {
2003 
            while ( <$fh> )
2004 
            {
2005 
                s~\s+$~~;
2006 
                s~^\s+~~;
2007 
                next if ( m~^#~ );
2008 
 
2009 
                if ( m~\$ProjectBase~ )
2010 
                {
2011 
                    $usesProjectBase++;
2012 
                    Message ("Project Base Use: $_");
2013 
                    $data->{UsesProjectBase}++;
2014 
                }
2015 
 
2016 
                if ( m~^SetProjectBase~ )
2017 
                {
2018 
                    $definesProjectBase++;
2019 
                    $data->{DefinesProjectBase}++;
2020 
                    Warning ("Package uses SetProjectBase:",
2021 
                             "Line: " . $_,
2022 
                             "Root: " . "$data->{ViewRoot}",
2023 
                             "File: " . "$data->{ViewRoot}/$file",
2024 
                            );
2025 
 
2026 
                    # The only problem is if the user attempts to escape
2027 
                    # from the root of the view.
2028 
                    #
2029 
                    # Examine the depth of the makefile with the directive
2030 
                    # Examine the depth of the view base
2031 
                    #
2032 
                    #
2033 
                    # Locate the build.pl file
2034 
                    # This is the basis for for the directive
2035 
                    #
2036 
                    my $blevel;
2037 
                    my @bpaths = split ('/', $file );
2038 
                    while ( @bpaths )
2039 
                    {
2040 
                        $bpaths[-1] = 'build.pl';
2041 
                        my $bfile = join '/', @bpaths ;
2042 
                        if ( -f "$data->{ViewRoot}/$bfile" )
2043 
                        {
2044 
                            $blevel = scalar @bpaths;
2045 
                            last;
2046 
                        }
2047 
                        pop @bpaths;
2048 
                    }
2049 
                    unless (defined $blevel)
2050 
                    {
2051 
                        Warning ("SetProjectBase$eSuf calculation failed - can't find build.pl");
2052 
                        $retval = 1;
2053 
                    }
2054 
                    else
2055 
                    {
2056 
                        #
2057 
                        #   Determine the depth of the view root
2058 
                        #   This is given by cc_path, but cc_path has a leading /
2059 
                        #
2060 
                        my @cpaths = split ('/', $cc_path );
2061 
                        my $clevel = (scalar @cpaths) - 1;
2062 
                        my $max_up = $blevel - $clevel - 1;
2063 
 
2064 
                        m~--Up=(\d+)~i;
2065 
                        my $ulevel = $1;
2066 
                        if ( defined $ulevel )
2067 
                        {
2068 
                            my @paths = split ('/', $file );
2069 
                            my $plevel = scalar @paths;
2070 
 
2071 
#print "--- blevel: $blevel\n";
2072 
#print "--- bpaths: @bpaths\n";
2073 
#print "--- ulevel: $ulevel\n";
2074 
#print "--- paths: @paths\n";
2075 
#print "--- plevel: $plevel\n";
2076 
#print "--- cpaths: @cpaths\n";
2077 
#print "--- clevel: $clevel\n";
2078 
#print "--- max_up: $max_up\n";
2079 
 
2080 
                            if ( $ulevel > $max_up )
2081 
                            {
2082 
                                Warning ("SetProjectBase escapes view. MaxUp: $max_up, Up: $ulevel");
2083 
                                $definitionError++;
2084 
                            }
2085 
                        }
2086 
                        else
2087 
                        {
2088 
                            $retval = 1;
2089 
                            Warning ("SetProjectBase$eSuf MAY escape view - can't detect level")
2090 
                        }
2091 
                    }
2092 
                }
2093 
            }
2094 
            close $fh;
2095 
        }
2096 
        else
2097 
        {
2098 
            Warning ("SetProjectBase$eSuf - Cannot open makefile: $file");
2099 
            $retval = 1;
2100 
        }
2101 
    }
2102 
 
2103 
    #
2104 
    #   Detect defined, but not used
2105 
    #
2106 
    if ( $usesProjectBase && ! $definesProjectBase )
2107 
    {
2108 
        Warning ("SetProjectBase - Uses ProjectBase without defining it");
2109 
    }
2110 
 
2111 
    if ( ! $usesProjectBase && $definesProjectBase )
2112 
    {
2113 
        Warning ("SetProjectBase - Defines ProjectBase without using it");
2114 
    }
2115 
 
2116 
    if ( $usesProjectBase && $definesProjectBase && $definitionError )
2117 
    {
2118 
        Warning ("SetProjectBase$eSuf - Problem detected");
2119 
        $retval = 1;
2120 
    }
2121 
    return $retval;
2122 
}
2123 
 
2124 
 
2125 
#-------------------------------------------------------------------------------
2126 
# Function        : JatsToolPrint
2127 
#
2128 
# Description     : Print and Execuate a JatsTool command
2129 
#
2130 
# Inputs          :
2131 
#
2132 
# Returns         :
2133 
#
2134 
 
392 dpurdie 2135 
sub JatsToolPrint
2136 
{
2137 
    Information ("Command: @_");
2138 
    JatsTool @_;
2139 
}
2140 
 
2141 
sub GetVname
2142 
{
2143 
    my ($entry) = @_;
2144 
    my $me = 'NONE';
2145 
    if ( $entry )
2146 
        {
2147 
        $me = $versions{$entry}{vname};
2148 
        unless ( $me )
2149 
        {
2150 
            $me = 'Unknown-' . $entry;
2151 
        }
2152 
    }
2153 
    return $me;
2154 
}
2155 
 
2156 
sub saneLabel
2157 
{
2158 
    my ($entry, $pkgname) = @_;
2159 
    my $me = $versions{$entry}{vname};
2160 
    $pkgname = $versions{$entry}{name} unless ( defined $pkgname );
2161 
 
2162 
    Error ("Package does have a version string: pvid: $entry")
2163 
        unless ( defined $me );
2164 
 
2165 
    #
2166 
    #   Convert Wip format (xxxx) into a string that can be used for a label
2167 
    #
2168 
    if ( $me =~ m~^(.*)\((.*)\)(.*)$~ )
2169 
    {
2170 
        $me = $1 . '_' . $2 . '_' . $3 . '.WIP';
2171 
        $me =~ s~_\.~.~;
2172 
        $me =~ s~^_~~;
2173 
    }
2174 
 
2175 
    #
2176 
    #   Allow for WIPS
2177 
    #   Get rid of multiple '_'
2178 
    #   Replace space with -
2179 
    #
2180 
    $me = $pkgname . '_' . $me;
2181 
    $me =~ tr~ ~-~s;
2182 
    $me =~ tr~-~-~s;
2183 
    $me =~ tr~_~_~s;
2184 
 
2185 
    return $me;
2186 
}
2187 
 
2188 
 
2189 
exit 0;
2190 
 
2191 
 
2192 
#-------------------------------------------------------------------------------
2193 
# Function        : GetPkgIdByName
2194 
#
2195 
# Description     :
2196 
#
2197 
# Inputs          : pkg_name
2198 
#
2199 
# Returns         : pkg_id
2200 
#
2201 
sub GetPkgIdByName
2202 
{
2203 
    my ( $pkg_name ) = @_;
2204 
    my (@row);
2205 
    my $pv_id;
2206 
    my $pkg_id;
2207 
 
2208 
    #
2209 
    #   Establish a connection to Release Manager
2210 
    #
2211 
    connectRM(\$RM_DB) unless ( $RM_DB );
2212 
 
2213 
    #
2214 
    #   Extract data from Release Manager
2215 
    #
2216 
    my $m_sqlstr = "SELECT pkg.PKG_NAME, pkg.PKG_ID" .
2217 
                   " FROM RELEASE_MANAGER.PACKAGES pkg" .
2218 
                   " WHERE pkg.PKG_NAME = \'$pkg_name\'";
2219 
 
2220 
    my $sth = $RM_DB->prepare($m_sqlstr);
2221 
    if ( defined($sth) )
2222 
    {
2223 
        if ( $sth->execute( ) )
2224 
        {
2225 
            if ( $sth->rows )
2226 
            {
2227 
                while ( @row = $sth->fetchrow_array )
2228 
                {
2229 
                    Verbose( "DATA: " . join(',', @row) );
2230 
                    $pkg_id = $row[1] || 0;
2231 
                    last;
2232 
                }
2233 
            }
2234 
            else
2235 
            {
2236 
                Error ("GetPkgIdByName:No Data for package: $pkg_name");
2237 
            }
2238 
            $sth->finish();
2239 
        }
2240 
    }
2241 
    else
2242 
    {
2243 
        Error("GetPkgIdByName:Prepare failure" );
2244 
    }
2245 
 
2246 
    return $pkg_id;
2247 
}
2248 
 
2249 
#-------------------------------------------------------------------------------
2250 
# Function        : GetData_by_pkg_id
2251 
#
2252 
# Description     :
2253 
#
2254 
# Inputs          : pv_id
2255 
#
2256 
# Returns         :
2257 
#
2258 
sub GetData_by_pkg_id
2259 
{
2260 
    my ( $pkg_id, $packageName ) = @_;
2261 
    my (@row);
2262 
 
2263 
    #
2264 
    #   Establish a connection to Release Manager
2265 
    #
2266 
    Message ("Extract package versions from Release Manager: $packageName");
2267 
    connectRM(\$RM_DB) unless ( $RM_DB );
2268 
 
2269 
    #
2270 
    #   Extract data from Release Manager
2271 
    #
2272 
    my $m_sqlstr = "SELECT pkg.PKG_NAME, pv.PKG_VERSION, pkg.PKG_ID, pv.PV_ID, pv.LAST_PV_ID, pv.MODIFIED_STAMP, release_manager.PK_RMAPI.return_vcs_tag(pv.PV_ID), amu.USER_NAME, pv.COMMENTS, pv.DLOCKED, pv.CREATOR_ID ".
2273 
                   " FROM RELEASE_MANAGER.PACKAGES pkg, RELEASE_MANAGER.PACKAGE_VERSIONS pv, ACCESS_MANAGER.USERS amu" .
2274 
                   " WHERE pv.PKG_ID = \'$pkg_id\' AND pkg.PKG_ID = pv.PKG_ID AND amu.USER_ID (+) = pv.CREATOR_ID";
2275 
 
2276 
 
2277 
    my $sth = $RM_DB->prepare($m_sqlstr);
2278 
    if ( defined($sth) )
2279 
    {
2280 
        if ( $sth->execute( ) )
2281 
        {
2282 
            if ( $sth->rows )
2283 
            {
2284 
                while ( @row = $sth->fetchrow_array )
2285 
                {
2286 
                    Verbose( "DATA: " . join(',', @row) );
2287 
                    my $pkg_name = $row[0] || 'Unknown';
2288 
                    my $pkg_ver = $row[1] || 'Unknown';
2289 
                       $pkg_ver =~ s~\s+$~~;
2290 
                       $pkg_ver =~ s~^\s+~~;
2291 
                    my $pv_id = $row[3] || 'Unknown';
2292 
                    my $last_pv_id = $row[4];
2293 
                    my $created =  $row[5] || 'Unknown';
2294 
                    my $vcstag =  $row[6] || 'Unknown';
394 dpurdie 2295 
 
392 dpurdie 2296 
                    my $created_id =  $row[7] || ($row[10] ? "Userid_$row[10]" :'Unknown');
2297 
                    my $comment =  $row[8] || '';
2298 
                    my $locked =  $row[9] || 'N';
2299 
 
2300 
                    #
2301 
                    #   Some developers have a 'special' package version
2302 
                    #   We really need to ignore them
2303 
                    #
2304 
                    next if ( $pkg_ver eq '23.23.23.ssw' );
2305 
 
2306 
                    #
2307 
                    #   Add data to the hash
2308 
                    #       Remove entries that address themselves
2309 
                    #
2310 
                    push (@{$versions{$last_pv_id}{next}}, $pv_id) unless ($pv_id == $last_pv_id || $last_pv_id == 0) ;
2311 
                    $versions{$pv_id}{name} = $pkg_name;
2312 
                    $versions{$pv_id}{pvid} = $pv_id;
2313 
                    $versions{$pv_id}{vname} = $pkg_ver;
2314 
                    $versions{$pv_id}{vcsTag} = $vcstag;
2315 
                    $versions{$pv_id}{created} = $created;
2316 
                    $versions{$pv_id}{created_id} = $created_id;
2317 
                    $versions{$pv_id}{comment} = $comment;
2318 
                    $versions{$pv_id}{locked} = $locked;
2319 
                    $versions{$pv_id}{TimeStamp} = str2time( $created );
2320 
                    $versions{$pv_id}{Age} = ($now - $versions{$pv_id}{TimeStamp}) / (60 * 60 * 24);
2321 
                    $versions{$pv_id}{TooOld} = 1 if ( $opt_age && $opt_age <= $versions{$pv_id}{Age} );
2322 
                    examineVcsTag($pv_id);
2323 
 
2324 
                    #
2325 
                    #   Process version number
2326 
                    #
2327 
                    my ($suffix, $version, $isaR, $isaWip, $buildVersion ) = massageVersion($pkg_ver, $pkg_name);
2328 
 
2329 
                    $versions{$pv_id}{version} = $version;
2330 
                    $versions{$pv_id}{buildVersion} = $buildVersion;
2331 
                    $versions{$pv_id}{isaRipple} = 1 if ( $isaR );
2332 
                    $versions{$pv_id}{isaWip} = 1 if ( $isaWip );
2333 
 
2334 
                    #
2335 
                    #   Process suffix
2336 
                    #
2337 
                    $suffix = 'Unknown' unless ( $suffix );
2338 
                    $suffix = lc ($suffix);
2339 
                    $versions{$pv_id}{suffix} = $suffix;
2340 
                    push @{$suffixes{$suffix}}, $pv_id;
2341 
 
2342 
#                    print "$pkg_name, $pkg_ver, $pv_id, $last_pv_id, $locked, $created, $created_id, $suffix\n";
2343 
                }
2344 
            }
2345 
            else
2346 
            {
2347 
                Error ("GetData_by_pkg_id: No Data: $m_sqlstr");
2348 
            }
2349 
            $sth->finish();
2350 
        }
2351 
        else
2352 
        {
2353 
                Error ("GetData_by_pkg_id: Execute: $m_sqlstr");
2354 
        }
2355 
    }
2356 
    else
2357 
    {
2358 
        Error("GetData_by_pkg_id:Prepare failure" );
2359 
    }
2360 
}
2361 
 
2362 
#-------------------------------------------------------------------------------
2363 
# Function        : massageVersion
2364 
#
2365 
# Description     : Process a version number and return usful bits
2366 
#
2367 
# Inputs          : Version Number
2368 
#                   Package Name - debug only
2369 
#
2370 
# Returns         : An array
2371 
#                       suffix
2372 
#                       multipart version string useful for text comparisons
2373 
#
2374 
sub massageVersion
2375 
{
2376 
    my ($version, $name) = @_;
2377 
    my ($major, $minor, $patch, $build, $suffix);
2378 
    my $result;
2379 
    my $buildVersion;
2380 
    my $isaRipple;
2381 
    my $isaWIP;
2382 
    $build = 0;
2383 
 
2384 
#print "--- $name, $version\n";
2385 
    $version =~ s~^_~~;
2386 
    $version =~ s~^${name}_~~;
2387 
 
2388 
    #
2389 
    #   xxxxxxxxx.nnnn.cots
2390 
    #
2391 
    if ( $version =~ m~(.*)\.cots$~ ) {
2392 
        my $cots_base = $1;
2393 
        $suffix = '.cots';
2394 
        if ( $version =~ m~(.*?)\.([0-9]{4})\.cots$~ )
2395 
        {
2396 
            $result = $1 . sprintf (".%4.4d", $2) . $suffix;
2397 
        }
2398 
        else
2399 
        {
2400 
            $result = $cots_base . '.0000.cots';
2401 
        }
2402 
    }
2403 
    #
2404 
    #   Convert version into full form for comparisions
2405 
    #       nnn.nnn.nnn.[p]nnn.xxx
2406 
    #       nnn.nnn.nnn.[p]nnn-xxx
2407 
    #       nnn.nnn.nnn-[p]nnn.xxx
2408 
    #       nnn.nnn.nnn-[p]nnn-xxx
2409 
    #       nnn.nnn.nnn[p]nnn-xxx
2410 
    #   Don't flag as ripples - they are patches
2411 
    #
2412 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-.p][p]?(\d+)([-.](.*))?$~ ) {
2413 
        $major = $1;
2414 
        $minor = $2;
2415 
        $patch = $3;
2416 
        $build = $4;
2417 
        $suffix = defined $6 ? ".$6" : '';
2418 
        $isaRipple = 0;
2419 
    }
2420 
    #
2421 
    #       nn.nnn.nnnnn.xxx
2422 
    #       nn.nnn.nnnnn-xxx
2423 
    #       nnn.nnn.nnnx.xxx
2424 
    #   Don't flag as ripples - they are patches
2425 
    #
2426 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)\w?([-.](.*))?$~ ) {
2427 
        $major = $1;
2428 
        $minor = $2;
2429 
        $patch = $3;
2430 
        if ( length( $patch) >= 4 )
2431 
        {
2432 
            $build = substr( $patch, -3 ,3);
2433 
            $patch = substr( $patch,  0 ,length($patch)-3);
2434 
        }
2435 
        $suffix = defined $5 ? ".$5" : '';
2436 
    }
2437 
 
2438 
    #
2439 
    #       nnn.nnn.nnn
2440 
    #       nnn.nnn-nnn
2441 
    #       nnn.nnn_nnn
2442 
    #
2443 
    elsif ( $version =~ m~^(\d+)\.(\d+)[-._](\d+)$~ ) {
2444 
        $major = $1;
2445 
        $minor = $2;
2446 
        $patch = $3;
2447 
        $suffix = '';
2448 
    }
2449 
 
2450 
    #
2451 
    #       nnn.nnn.nnn.nnn
2452 
    #       nnn.nnn.nnn-nnn
2453 
    #       nnn.nnn.nnn_nnn
2454 
    #
2455 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-._](\d+)$~ ) {
2456 
        $major = $1;
2457 
        $minor = $2;
2458 
        $patch = $3;
2459 
        $build = $4;
2460 
        $suffix = '';
2461 
        $isaRipple = 0;
2462 
    }
2463 
 
2464 
 
2465 
    #
2466 
    #       nnn.nnn
2467 
    #
2468 
    elsif ( $version =~ m~^(\d+)\.(\d+)$~ ) {
2469 
        $major = $1;
2470 
        $minor = $2;
2471 
        $patch = 0;
2472 
        $suffix = '';
2473 
    }
2474 
    #
2475 
    #       nnn.nnn.xxx
2476 
    #
2477 
    elsif ( $version =~ m~^(\d+)\.(\d+)(\.\w+)$~ ) {
2478 
        $major = $1;
2479 
        $minor = $2;
2480 
        $patch = 0;
2481 
        $suffix = $3;
2482 
    }
2483 
 
2484 
    #
2485 
    #       nnn.nnn.nnnz
2486 
    #
2487 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)([a-z])$~ ) {
2488 
        $major = $1;
2489 
        $minor = $2;
2490 
        $patch = $3;
2491 
        $build = ord($4) - ord('a');
2492 
        $suffix = '.cots';
2493 
        $isaRipple = 0;
2494 
    }
2495 
    #
2496 
    #       ???REV=???
2497 
    #
2498 
    elsif ( $version =~ m~REV=~ ) {
2499 
        $suffix = '.cots';
2500 
        $result = $version . '.0000.cots';
2501 
    }
2502 
 
2503 
    #
2504 
    #   Wip Packages
2505 
    #   (nnnnnn).xxx
2506 
    #   Should be essential, but want to sort very low
2507 
    #
2508 
    elsif ($version =~ m~\((.*)\)(\..*)?~) {
2509 
        $suffix = $2 || '';
2510 
        $result = "000.000.000.000$suffix";
2511 
        $isaWIP = 1;
2512 
    }
2513 
 
2514 
    #
2515 
    #   !current
2516 
    #
2517 
    elsif ($version eq '!current' || $version eq 'current_$USER' || $version eq 'current' || $version eq 'beta' || $version eq 'latest' || $version eq 'beta.cr' || $version eq 'CREATE') {
2518 
        $suffix = '';
2519 
        $result = "000.000.000.000$suffix";
2520 
        $isaWIP = 1;
2521 
    }
2522 
 
2523 
    #
2524 
    #   Also WIP: FINRUN.103649.BEI.WIP
2525 
    elsif ($version =~ m~(\.[a-zA-Z]+)\.WIP$~) {
2526 
        $suffix = lc($1);
2527 
        $result = "000.000.000.000$suffix";
2528 
        $isaWIP = 1;
2529 
    }
2530 
 
2531 
    #
2532 
    #   Also ERGOFSSLS190100_015
2533 
    #   Don't flag as a ripple
2534 
    elsif ($version =~ m~^ERG[A-Z]+(\d\d)(\d\d)(\d\d)[-_](\d+)(\.\w+)?$~) {
2535 
        $major = $1;
2536 
        $minor = $2;
2537 
        $patch = $3;
2538 
        $build = $4;
2539 
        $suffix = $5 || '.sls';
2540 
        $isaRipple = 0;
2541 
    }
2542 
 
2543 
    #
2544 
    #   Stuff we don't yet handle
2545 
    #
2546 
    else  {
2547 
        Warning ("Unknown version number: $name,$version");
2548 
        $version =~ m~(\.\w+)$~;
2549 
        $suffix = $1 || '';
2550 
        $result = $version;
2551 
    }
2552 
 
2553 
    $isaRipple = ($build > 0) unless defined $isaRipple;
2554 
    unless ( $result )
2555 
    {
2556 
        # Major and minor of 99.99 are normally funy versions
2557 
        # Don't make important desicions on them
2558 
        #
2559 
        if ( $major == 99 && $minor == 99 )
2560 
        {
2561 
            $major = 0;
2562 
            $minor = 0;
2563 
            $patch = 0;
2564 
        }
2565 
 
2566 
        $result = sprintf("%3.3d.%3.3d.%3.3d.%3.3d%s", $major,$minor,$patch,$build,$suffix || '.0000');
2567 
        $buildVersion = [ $major, $minor, $patch, $build ];
2568 
    }
2569 
 
2570 
    $suffix = lc( $suffix );
2571 
    if ( exists $suffixFixup{$suffix} )
2572 
    {
2573 
        $suffix = $suffixFixup{$suffix} ;
2574 
    }
2575 
 
2576 
    return ($suffix, $result, $isaRipple, $isaWIP, $buildVersion );
2577 
}
2578 
 
2579 
#-------------------------------------------------------------------------------
394 dpurdie 2580 
# Function        : vcsCleanup
2581 
#
2582 
# Description     : Cleanup and rewrite a vcstag
2583 
#
2584 
#                   DUPLICATED IN:
2585 
#                       - cc2svn_procdata
395 dpurdie 2586 
#                       - cc2svn_importpackage
394 dpurdie 2587 
#
2588 
# Inputs          : vcstag
2589 
#
2590 
# Returns         : Cleaned up vcs tag
2591 
#
2592 
sub vcsCleanup
2593 
{
2594 
    my ($tag) = @_;
2595 
    $tag =~ tr~\\/~/~;
2596 
    if ( $tag =~ m~^CC::~ )
2597 
    {
2598 
        $tag =~ s~CC::\s+~CC::~;
2599 
        $tag =~ s~MASS_Dev_Bus/Cbp/~MASS_Dev_Bus/CBP/~i;
2600 
        $tag =~ s~MASS_Dev_Bus~MASS_Dev_Bus~i;
2601 
        $tag =~ s~/MASS_Dev/Infra~MASS_Dev_Infra~i;
2602 
        $tag =~ s~/MASS_Dev/Bus/web~/MASS_Dev_Bus/web~i;
2603 
 
2604 
        $tag =~ s~/Vastraffik/~/Vasttrafik/~;
2605 
        $tag =~ s~/MREF_Package/ergpostmongui$~/MREF_Package/ergpostmongui~i;
395 dpurdie 2606 
        $tag =~ s~DPC_SWCode/~DPG_SWCode/~i;
394 dpurdie 2607 
    }
2608 
    return $tag;
2609 
}
2610 
 
2611 
#-------------------------------------------------------------------------------
392 dpurdie 2612 
# Function        : examineVcsTag
2613 
#
2614 
# Description     : Examine a VCS Tag and determine if it looks like rubbish
394 dpurdie 2615 
#                   Give it a clean
392 dpurdie 2616 
#
2617 
# Inputs          : $entry
2618 
#
2619 
# Returns         : Will add Data to the $entry
2620 
#
2621 
sub examineVcsTag
2622 
{
2623 
    my ($entry) = @_;
2624 
    my $bad = 0;
394 dpurdie 2625 
 
395 dpurdie 2626 
    $versions{$entry}{vcsTag} = vcsCleanup($versions{$entry}{vcsTag});
2627 
    my $vcstag = $versions{$entry}{vcsTag};
394 dpurdie 2628 
 
392 dpurdie 2629 
    if ( $vcstag =~ m~^SVN::~ ) {
2630 
        $versions{$entry}{isSvn} = 1;
2631 
 
2632 
    } elsif ( $vcstag =~ m~^CC::(.*?)(::(.+))?$~ ) {
2633 
        my $path = $1  || '';
2634 
        my $label = $2 || '';
2635 
        $bad = 1 unless ( $label );
2636 
        $bad = 1 if ( $label =~ m~^N/A$~i || $label  =~ m~^na$~i );
2637 
 
2638 
        $bad = 1 unless ( $path );
2639 
        $bad = 1 if ( $path =~ m~^N/A$~i || $path  =~ m~^na$~i );
2640 
        $bad = 1 if ( $path =~ m~^/dpkg_archive~ || $path  =~ m~^dpkg_archive~ );
2641 
        $bad = 1 if ( $path =~ m~^/devl/~ || $path  =~ m~^devl/~ );
395 dpurdie 2642 
        $bad = 1 if ( $path =~ m~^CVS~ );
392 dpurdie 2643 
        $bad = 1 if ( $path =~ m~^http:~i );
2644 
        $bad = 1 if ( $path =~ m~^[A-Za-z]\:~ );
2645 
        $bad = 1 if ( $path =~ m~^//~ );
394 dpurdie 2646 
        $bad = 1 if ( $path =~ m~^/*none~i );
2647 
        $bad = 1 if ( $path =~ m~^/*NoWhere~i );
2648 
        $bad = 1 if ( $path =~ m~^-$~i );
392 dpurdie 2649 
        $bad = 1 if ( $path =~ m~^cvsserver:~ );
2650 
        $bad = 1 if ( $path =~ m~,\s*module:~ );
2651 
#        $bad = 1 unless ( $path =~ m~^/~ );
2652 
    }
2653 
    else
2654 
    {
2655 
        $bad = 1;
2656 
    }
2657 
    $versions{$entry}{badVcsTag} = 1 if ( $bad );
2658 
}
2659 
 
2660 
#-------------------------------------------------------------------------------
2661 
# Function        : logToFile
2662 
#
2663 
# Description     : Log some data to a named file
2664 
#                   Use file locking to allow multiple process to log
2665 
#
2666 
# Inputs          : $filename           - Name of file to log
2667 
#                   ...                 - Data to log
2668 
#
2669 
# Returns         : Nothing
2670 
#
2671 
sub logToFile
2672 
{
2673 
    my ($file, @data) = @_;
2674 
 
2675 
    open  (LOGFILE, '>>', $file);
2676 
    flock (LOGFILE, LOCK_EX);
2677 
    print  LOGFILE "@data\n";
2678 
    flock (LOGFILE, LOCK_UN);
2679 
    close (LOGFILE);
2680 
}
2681 
 
2682 
#-------------------------------------------------------------------------------
2683 
# Function        : createImages
2684 
#
2685 
# Description     : Create nice images of the RM version tree
2686 
#
2687 
# Inputs          :
2688 
#
2689 
# Returns         :
2690 
#
2691 
sub createImages
2692 
{
2693 
 
2694 
    my $filebase = "${packageNames}";
2695 
    open (FH, '>', "$filebase.dot" ) or die "Cannot open output";
2696 
    print FH "digraph \"${packageNames}\" {\n";
2697 
    #print FH "rankdir=LR;\n";
2698 
    print FH "node[fontsize=16];\n";
2699 
    print FH "node[target=_graphviz];\n";
2700 
#    print FH "subgraph cluster_A {\n";
2701 
#    print FH "node[fontsize=12];\n";
2702 
 
2703 
    {
2704 
        my @text;
2705 
        push @text, $packageNames;
2706 
        push @text, 'HyperLinked to Release Manager';
2707 
        push @text, 'Created:' . localtime();
2708 
        push @text, '|';
2709 
 
2710 
        push @text, 'Total RM versions: ' . $totalVersions;
2711 
        push @text, 'Essential Entries: ' . scalar @EssentialPackages;
2712 
        push @text, 'Initial trees: ' . $initialTrees;
2713 
 
1270 dpurdie 2714 
        push @text, 'Number of Entries: ' . $processTotal;
392 dpurdie 2715 
        push @text, 'Type : ' . $packageType;
2716 
        push @text, 'All versions in Subversion' if ( $allSvn );
2717 
 
2718 
        push @text, '|';
2719 
        push @text, 'Total Project Branches: ' . $ProjectCount;
2720 
        foreach ( sort keys %knownProjects )
2721 
        {
2722 
            my $count = $knownProjects{$_}{count} || 0;
2723 
            if ( $count )
2724 
            {
2725 
                my $text = 'Project Branch: ' . $_;
2726 
                $text .= " (" . $count . ")" if ( $count > 1 );
2727 
                push @text, $text;
2728 
            }
2729 
        }
2730 
 
2731 
        push @text, '|';
2732 
        push @text, 'Bad VCS : ' . $badVcsCount;
2733 
        push @text, 'Bad Singletions : ' . $badSingletonCount;
2734 
        push @text, 'Deadwood entries : ' . $trimCount;
2735 
        push @text, 'Walking Mode : Flat' if ($opt_flat);
2736 
        push @text, 'Pruned Mode : ' . $pruneModeString;
2737 
        push @text, 'Pruned entries : ' . $pruneCount;
2738 
 
2739 
        if ( @unknownProjects )
2740 
        {
2741 
            push @text, '|';
2742 
            push @text, 'Unknown Projects';
2743 
            push @text, 'Unknown Project: ' . $_ foreach (sort @unknownProjects );
2744 
        }
2745 
 
2746 
        #
2747 
        #   Multiple Paths
2748 
        #
2749 
        if ( scalar @multiplePaths > 1 )
2750 
        {
2751 
            push @text, '|';
2752 
            push @text, 'Multiple Paths';
2753 
            push @text, @multiplePaths;
2754 
        }
2755 
 
2756 
        #
2757 
        #   Bad essentials
2758 
        #
2759 
        if ( @badEssentials  )
2760 
        {
2761 
            push @text, '|';
2762 
            push @text, 'Bad Essential Versions';
2763 
            push @text, GetVname($_) foreach ( @badEssentials );
2764 
        }
2765 
 
2766 
        #
2767 
        #   Subversion Data
2768 
        #
2769 
        if ( %svnData )
2770 
        {
2771 
            push @text, '|';
2772 
            push @text, 'Subversion';
2773 
            push @text, 'Trunk used' if exists $svnData{branches}{trunk} ;
2774 
            push @text, 'Labels: ' . scalar keys %{$svnData{tags}} ;
2775 
            push @text, 'Branches: ' . scalar keys %{$svnData{branches}} ;
2776 
        }
2777 
 
2778 
        push @text, '';
2779 
        my $text = join '\l', @text;
2780 
        $text =~ s~\|\\l~|~g;
2781 
 
2782 
        my @attributes;
2783 
        push @attributes, "shape=record";
2784 
        push @attributes, "label=\"{$text}\"";
2785 
        push @attributes, "tooltip=\"$packageNames\"";
2786 
        push @attributes, "URL=\"" . $GBE_RM_URL . "/view_by_version.asp?pkg_id=$first_pkg_id" . "\"";
2787 
        push @attributes, "color=red";
2788 
        my $attr = join( ' ', @attributes);
2789 
 
2790 
        my $tld_done = 'TitleBlock';
2791 
        print FH "$tld_done [$attr]\n";
2792 
    }
2793 
 
2794 
    #
2795 
    #   Generate Legend
2796 
    #
2797 
    {
2798 
        my @text;
2799 
        push @text, 'Legend';
2800 
        push @text, '|';
2801 
        push @text, 'Node Content';
2802 
        push @text, 'Package Version';
2803 
#        push @text, 'Release Manager Ref (pvid)';
2804 
        push @text, 'Creation Date: yyyy-mm-dd';
2805 
        push @text, '(Coded information)';
2806 
        push @text, '|{Code';
2807 
        push @text, '|{N: Not Locked';
2808 
        push @text, 'b: Bad Singleton';
2809 
        push @text, 'B: Bad VCS Tag';
2810 
        push @text, 'D: DeadWood';
1197 dpurdie 2811 
        push @text, 'E: Essential Version';
392 dpurdie 2812 
        push @text, 'G: Glued into Version Tree';
2813 
        push @text, 'S: Splitpoint';
2814 
        push @text, 't: Glued into Project Tree';
2815 
        push @text, 'T: Tip version';
2816 
        push @text, 'V: In SVN';
2817 
        push @text, '+: In Subversion';
2818 
        push @text, '}}';
2819 
 
2820 
        push @text, '|';
2821 
        push @text, 'Outline';
2822 
        push @text, 'Red: Dead or Bad VCS Tag';
2823 
        push @text, 'Orange: Project Branch Root';
2824 
        push @text, 'Green: Ripple Build Version';
2825 
        push @text, 'Blue: Essential Version';
2826 
        push @text, 'Darkmagenta: Entry Glued into tree';
2827 
        push @text, 'Magenta: Entry added to project tree';
2828 
 
2829 
 
2830 
        push @text, '|';
2831 
        push @text, 'Fill';
2832 
        push @text, 'PowderBlue: Essential Version';
2833 
        push @text, 'Red: Bad Essential Version';
2834 
        push @text, 'Light Green: Migrated to SVN';
2835 
#        push @text, 'Red: Entry Glued into tree';
2836 
#        push @text, 'Green: Entry added to project tree';
2837 
 
2838 
        push @text, '|';
2839 
        push @text, 'Shape';
2840 
        push @text, 'Oval: Normal Package Version';
2841 
        push @text, 'Invhouse: Project Branch Root';
2842 
        push @text, 'Octagon: Branch Point';
2843 
        push @text, 'Box: Bad Single version with no history';
2844 
        push @text, 'Doublecircle: Tip of a Project Branch';
2845 
 
2846 
        push @text, '';
2847 
        my $text = join '\l', @text;
2848 
        $text =~ s~\|\\l~|~g;
2849 
        $text =~ s~\}\\l~}~g;
2850 
 
2851 
        my @attributes;
2852 
        push @attributes, "shape=record";
2853 
        push @attributes, "label=\"{$text}\"";
2854 
        push @attributes, "color=red";
2855 
        my $attr = join( ' ', @attributes);
2856 
 
2857 
        my $tld_done = 'LegendBlock';
2858 
        print FH "$tld_done [$attr]\n";
2859 
    }
2860 
 
2861 
#    print FH "\n}\n";
2862 
    print FH "TitleBlock -> LegendBlock [style=invis]\n";
2863 
 
2864 
    sub genLabelText
2865 
    {
2866 
        my ($entry) = @_;
2867 
        my @label;
2868 
        push @label, $versions{$entry}{name} if ( $multiPackages );
2869 
        push @label, $versions{$entry}{vname};
2870 
#        push @label, $entry;       # Add PVID
2871 
        push @label, substr( $versions{$entry}{created}, 0, 10); #  2008-02-19
2872 
#        push @label, 'V=' . $versions{$entry}{maxVersion};
2873 
#        push @label, 'B=' . $versions{$entry}{svnBranchTip} if ( exists $versions{$entry}{svnBranchTip} );
2874 
 
2875 
 
2876 
        my $stateText = '';
2877 
        $stateText .= 'N' if ($versions{$entry}{locked} eq 'N');
2878 
        $stateText .= 'b' if (exists $versions{$entry}{badSingleton});
2879 
        $stateText .= 'B' if (exists $versions{$entry}{badVcsTag});
2880 
        $stateText .= 'G' if (exists $versions{$entry}{GluedIn});
2881 
        $stateText .= 't' if (exists $versions{$entry}{MakeTree});
1197 dpurdie 2882 
        $stateText .= 'E' if (exists $versions{$entry}{Essential});
392 dpurdie 2883 
        $stateText .= 'D' if (exists $versions{$entry}{DeadWood});
2884 
        $stateText .= 'S' if (exists $versions{$entry}{EssentialSplitPoint} && $versions{$entry}{EssentialSplitPoint} > 1 );
2885 
        $stateText .= 'T' if (exists $versions{$entry}{Tip} );
2886 
        $stateText .= 'V' if (exists $versions{$entry}{isSvn} );
2887 
        $stateText .= '+' if (exists $versions{$entry}{svnVersion} );
2888 
#        $stateText .= 's' if (exists $versions{$entry}{branchPoint} );
2889 
#        $stateText .= ' T='. $versions{$entry}{threadId} if (exists $versions{$entry}{threadId});
2890 
#        $stateText .= ' EssentalPath' if (exists $versions{$entry}{EssentialPath});
2891 
#        $stateText .= ' Count='. $versions{$entry}{EssentialSplitPoint} if (exists $versions{$entry}{EssentialSplitPoint});
2892 
#        $stateText .= ' M='. $versions{$entry}{maxVersion} if (exists $versions{$entry}{maxVersion});
2893 
 
2894 
        push @label, "(${stateText})" if ( $stateText );
2895 
 
2896 
        return join ('\n', @label );
2897 
    }
2898 
 
2899 
    sub genAttributes
2900 
    {
2901 
        my ($entry) = @_;
2902 
        my @attributes;
2903 
        push @attributes, 'label="' . genLabelText($entry) . '"';
2904 
        push @attributes, 'URL="' . dotUrl($entry) . '"';
2905 
        push @attributes, 'tooltip="' . "Goto: $versions{$entry}{vname}, PVID=$entry" ,'"';
2906 
        my $shape;
2907 
            $shape = 'box' if ($versions{$entry}{badSingleton});
2908 
            $shape = 'octagon'  if ($versions{$entry}{branchPoint});
2909 
            $shape = 'invhouse' if ($versions{$entry}{newSuffix});
2910 
            $shape = 'doublecircle' if ($versions{$entry}{Tip});
2911 
 
2912 
 
2913 
        push @attributes, 'shape=' . $shape if ( $shape );
2914 
 
2915 
        my $color;
2916 
        my $fill;
2917 
           $color = 'color=green style=bold' if ( $versions{$entry}{isaRipple} );
2918 
           $color = 'color=orange style=bold' if ( $versions{$entry}{newSuffix} );
2919 
           $color = 'color=red style=bold' if ( $versions{$entry}{DeadWood} || $versions{$entry}{badVcsTag} );
2920 
           $color = 'color=blue style=bold' if ( $versions{$entry}{Essential} );
2921 
           $color = 'color=darkmagenta style=bold' if ( $versions{$entry}{GluedIn} );
2922 
           $color = 'color=magenta style=bold' if ( $versions{$entry}{MakeTree} );
2923 
 
2924 
           $fill = 'style=filled fillcolor=powderblue' if ( $versions{$entry}{Essential} );
2925 
           $fill = 'style=filled fillcolor=red' if ( $versions{$entry}{Essential} && $versions{$entry}{badVcsTag} );
2926 
           $fill = 'style=filled fillcolor="#99FF99"' if ( exists $versions{$entry}{svnVersion} );
2927 
 
2928 
 
2929 
        push @attributes, $color if ( $color );
2930 
        push @attributes, $fill if ( $fill );
2931 
 
2932 
        return '[' . join( ' ', @attributes) . ']';
2933 
    }
2934 
 
2935 
    sub genArrowAttributes
2936 
    {
2937 
        my ($not_first, $entry) = @_;
2938 
        my @attributes;
2939 
 
2940 
        push @attributes, 'arrowhead=empty' if ( $not_first );
2941 
        push ( @attributes, 'label="' . $versions{$entry}{svnBranchTip} .'"' ) if ( exists $versions{$entry}{svnBranchTip} );
2942 
 
2943 
        return ('[' . join( ' ', @attributes) . ']') if ( @attributes ) ;
2944 
        return '';
2945 
    }
2946 
 
2947 
    #
2948 
    #   Flat
2949 
    #
2950 
    if ( $opt_flat )
2951 
    {
2952 
        my $last = 0;
2953 
        foreach my $entry (@flatOrder )
2954 
        {
2955 
            if ( $last )
2956 
            {
2957 
                my $me = dotTag($last);
2958 
 
2959 
                print FH pentry($me)  ,' -> ', pentry(dotTag($entry)), genArrowAttributes(0, $entry) ,";\n";
2960 
                print FH pentry($me)  ,genAttributes($last) . ";\n";
2961 
            }
2962 
            $last = $entry;
2963 
        }
2964 
        print FH pentry(dotTag($last))  ,genAttributes($last) . ";\n";
2965 
 
2966 
    }
2967 
    else
2968 
    {
2969 
        foreach my $entry ( sort {$a <=> $b} keys(%versions) )
2970 
        {
2971 
            my $me = dotTag($entry);
2972 
            my @versions = @{ $versions{$entry}{next}};
2973 
            my $ii = 0;
2974 
            foreach ( @versions )
2975 
            {
2976 
                print FH pentry($me)  ," -> ",pentry(dotTag($_)), genArrowAttributes($ii++, $_), ";\n";
2977 
            }
2978 
 
2979 
            print FH pentry($me)  ,genAttributes($entry) . ";\n";
2980 
        }
2981 
    }
2982 
 
2983 
    print FH "\n};\n";
2984 
    close FH;
2985 
 
2986 
    #
2987 
    #   Convert DOT to a SVG
2988 
    #
2989 
    unless ( $UNIX )
2990 
    {
2991 
    print "Generating graphical images\n";
2992 
#    system( "dot $filebase.dot -Tjpg -o$filebase.jpg" );  # -v
2993 
    system( "dot $filebase.dot -Tsvg -o$filebase.svg" );  # -v
2994 
#    unlink("$filebase.dot");
2995 
 
2996 
    #
2997 
    #   Display a list of terminal packages
2998 
    #   These are packages that are not used by any other package
2999 
    #
3000 
    print "\n";
3001 
#    print "Generated: $filebase.dot\n";
3002 
#    print "Generated: $filebase.jpg\n";
3003 
    print "Generated: $filebase.svg\n";
3004 
    }
3005 
    else
3006 
    {
3007 
        print "Generated: $filebase.dot\n";
3008 
    }
3009 
}
3010 
 
3011 
sub dotTag
3012 
{
3013 
    my ($entry) = @_;
3014 
 
3015 
    my $label = '';
3016 
    $label .= $versions{$entry}{name} if $multiPackages;
3017 
    $label .= $versions{$entry}{vname};
3018 
    $label =~ s~[-() ]~_~g;
3019 
    return $label;
3020 
}
3021 
 
3022 
sub dotUrl
3023 
{
3024 
    my ($entry) = @_;
3025 
 
3026 
    my $pv_base = $GBE_RM_URL . "/fixed_issues.asp?pv_id=$entry";
3027 
}
3028 
 
3029 
#-------------------------------------------------------------------------------
3030 
# Function        : pentry
3031 
#
3032 
# Description     : Generate an entry list as text
3033 
#                   Replace "." with "_" since DOT doesn't like .'s
3034 
#                   Seperate the arguments
3035 
#
3036 
# Inputs          : @_          - An array of entries to process
3037 
#
3038 
# Returns         : A string
3039 
#
3040 
sub pentry
3041 
{
3042 
    my ($data) = @_;
3043 
    $data =~ s~\.~_~g;
3044 
    $result = '"' . $data . '"' ;
3045 
    return $result;
3046 
}
3047 
 
3048 
#-------------------------------------------------------------------------------
3049 
# Function        : getVobMapping
3050 
#
3051 
# Description     : Read in Package to Repository Mapping
3052 
#
3053 
# Inputs          :
3054 
#
3055 
# Returns         : Populates %VobMapping
3056 
#                             Mapping of PackageName to RepoName[/Subdir]
3057 
#
3058 
our %ScmRepoMap;
3059 
sub getVobMapping
3060 
{
3061 
    Message ("Read in Vob Mapping");
3062 
 
3063 
    my $fname = 'cc2svn.repo.dat';
3064 
    Error "Cannot locate $fname" unless ( -f $fname );
3065 
    require $fname;
3066 
 
3067 
    Error "Data in $fname is not valid\n"
3068 
        unless ( keys(%ScmRepoMap) >= 0 );
3069 
 
3070 
    $opt_vobMap = $ScmRepoMap{$packageNames}{repo}
3071 
        if (exists $ScmRepoMap{$packageNames});
3072 
 
3073 
    #
3074 
    #   Free the memory
3075 
    #
3076 
    %ScmRepoMap = ();
3077 
 
3078 
    #
3079 
    #   Calculate Target Repo
3080 
    #
3081 
    Warning ("No VOB Mapping found")
3082 
        unless ($opt_vobMap);
3083 
    Error("No repository specified. ie -repo=DevTools or -repo=COTS")
3084 
        unless ( $opt_repo || $opt_vobMap );
3085 
 
3086 
    my $r1 = ($opt_repo || '') . '/' . ($opt_vobMap || '');
3087 
    $r1 =~ s~^/~~;
3088 
    $r1 =~ s~/$~~;
3089 
    $svnRepo = $opt_repo_base . $r1;
3090 
 
3091 
    Verbose( "Repo URL: $svnRepo");
3092 
}
3093 
 
3094 
 
3095 
#-------------------------------------------------------------------------------
3096 
# Function        : getEssenialPackageVersions
3097 
#
3098 
# Description     : Determine the 'Essental' Package Versions
3099 
#                   Read the data in from an external file
3100 
#
3101 
# Inputs          :
3102 
#
3103 
# Returns         : Populates @EssentialPackages
3104 
#
3105 
 
3106 
our %ScmReleases;
3107 
our %ScmPackages;
3108 
our %ScmSuffixes;
3109 
sub getEssenialPackageVersions
3110 
{
3111 
    Message ("Read in Essential Package Versions");
3112 
 
3113 
    my $fname = 'cc2svn.raw.txt';
3114 
    Error "Cannot locate $fname" unless ( -f $fname );
3115 
    require $fname;
3116 
 
3117 
    Error "Data in $fname is not valid\n"
3118 
        unless ( keys(%ScmReleases) >= 0 );
3119 
 
3120 
#    DebugDumpData("ScmReleases", \%ScmReleases );
3121 
#    DebugDumpData("ScmPackages", \%ScmPackages );
3122 
#    DebugDumpData("ScmSuffixes", \%ScmSuffixes );
3123 
 
3124 
    #
3125 
    #   Create a list of essential packages
3126 
    #   Retain packages-versions used in this program
3127 
    #
3128 
    foreach ( keys %ScmPackages )
3129 
    {
3130 
        next unless ( exists  $pkg_ids{ $ScmPackages{$_}{pkgid} } );
3131 
        push @EssentialPackages, $_;
3132 
        Error ("Essential Package Version not in extracted Release Manager Data: $_")
3133 
            unless ( exists $versions{$_} );
3134 
        $versions{$_}{Essential} = 1;
1197 dpurdie 3135 
        #print "ESSENTIAL: $versions{$_}{name} $versions{$_}{vname}\n";
392 dpurdie 3136 
    }
3137 
 
3138 
    #
3139 
    #   Free memory
3140 
    #
3141 
    %ScmReleases = ();
3142 
    %ScmPackages = ();
3143 
    %ScmSuffixes = ();
3144 
 
3145 
#    DebugDumpData("Essential", \@EssentialPackages );
3146 
    Message ("Essential Versions: " . scalar @EssentialPackages );
3147 
}
3148 
 
3149 
#-------------------------------------------------------------------------------
3150 
# Function        : ReportPathVariance
3151 
#
3152 
# Description     : Report variance in paths used by the versions
3153 
#
3154 
# Inputs          :
3155 
#
3156 
# Returns         :
3157 
#
3158 
my %VobPaths;
3159 
sub ReportPathVariance
3160 
{
3161 
    Message ("Detect Multiple Paths");
3162 
    foreach my $entry ( keys(%versions) )
3163 
    {
3164 
        my $e = $versions{$entry};
3165 
        next if ( isSet ($e, 'DeadWood' ) );
3166 
        next if ( isSet ($e, 'badVcsTag') );
3167 
        next if ( isSet ($e, 'isSvn') );
3168 
        my $tag = $e->{vcsTag};
3169 
        next unless ( $tag );
3170 
 
3171 
        $tag =~ m~^(.+?)::(.*?)(::(.+))?$~;
3172 
        my $vcsType = $1;
3173 
        my $cc_label = $4;
3174 
        my $cc_path = $2;
3175 
        $cc_path = '/' . $cc_path;
3176 
        $cc_path =~ tr~\\/~/~s;
3177 
 
3178 
        $VobPaths{$cc_path}++;
3179 
    }
3180 
 
3181 
    @multiplePaths = sort keys %VobPaths;
3182 
    if ( scalar @multiplePaths > 1 )
3183 
    {
3184 
        Warning ("Multiple Paths:" . $_ ) foreach (@multiplePaths);
3185 
    }
3186 
}
3187 
 
3188 
sub isSet
3189 
{
3190 
    my ($base, $element) = @_;
3191 
    return 0 unless ( exists $base->{$element} );
3192 
    return $base->{$element};
3193 
}
3194 
 
3195 
 
3196 
#-------------------------------------------------------------------------------
3197 
# Function        : recurseList
3198 
#
3199 
# Description     : Return a list of all element below a given head element
3200 
#
3201 
# Inputs          : $head               - Head element
3202 
#
3203 
# Returns         : A list, not in any particular order
3204 
#
3205 
 
3206 
our @recurseList;
3207 
sub recurseList
3208 
{
3209 
    @recurseList = ();
3210 
    recurseListBody (@_);
3211 
    return @recurseList;
3212 
}
3213 
sub recurseListBody
3214 
{
3215 
    foreach my $entry ( @_ )
3216 
    {
3217 
        push @recurseList, $entry;
3218 
no warnings "recursion";
3219 
        recurseListBody (@{$versions{$entry}{next}});
3220 
    }
3221 
}
3222 
 
3223 
#-------------------------------------------------------------------------------
3224 
# Function        : getSvnData
3225 
#
3226 
# Description     : Read the SVN tree and see what we have
3227 
#
3228 
# Inputs          :
3229 
#
3230 
# Returns         :
3231 
#
3232 
my @svnDataItems;
3233 
sub getSvnData
3234 
{
3235 
    Message ("Examine Subversion Tree");
3236 
 
3237 
    #
3238 
    #   Re-init data
3239 
    #
3240 
    @svnDataItems = ();
3241 
    %svnData = ();
3242 
 
3243 
    #
3244 
    #   Create an SVN session
3245 
    #
3246 
    return unless ( $svnRepo );
3247 
    my $svn = NewSessionByUrl ( "$svnRepo/$packageNames" );
3248 
    return unless ( $svn );
3249 
 
3250 
    #
3251 
    #   extract data
3252 
    #
3253 
#    DebugDumpData("SVN", $svn );
3254 
    $svn->SvnCmd ( 'log', '-v', '--xml', '--stop-on-copy', $svn->Full()
3255 
                    , { 'credentials' => 1,
3256 
                        'process' => \&ProcessSvnLog,
3257 
                         }
3258 
                        );
3259 
 
3260 
    #
3261 
    #   Process data
3262 
    foreach my $entry ( @svnDataItems )
3263 
    {
3264 
        my $name;
3265 
        my $isaBranch;
3266 
        my $target = $entry->{target};
3267 
        if ( $target =~ m~/tags/(.*)~ ) {
3268 
            $name = $1;
3269 
            $svnData{tags}{$name} = 1;
3270 
        } elsif ( $target =~ m~/branches/(.*)~ )  {
3271 
            $name = $1;
3272 
    #        $branches{$1} = 1;
3273 
        } else {
3274 
            $svnData{nonTag}{$target} = 1;
3275 
        }
3276 
 
3277 
        my $fromBranch;
3278 
        if ( $entry->{fromPath} =~ m~/trunk$~  ) {
3279 
            $fromBranch = 'trunk';
3280 
        } elsif ( $entry->{fromPath} =~ m~/branches/(.*)~ ) {
3281 
            $fromBranch = $1;
3282 
        }
3283 
 
3284 
        if ( defined($fromBranch) && ! exists $svnData{branches}{$fromBranch} )
3285 
        {
3286 
            unless ( $name eq $fromBranch )
3287 
            {
3288 
                $svnData{branches}{$fromBranch} = $name;
3289 
                $svnData{tips}{$name} = $fromBranch;
3290 
            }
3291 
        }
3292 
    }
3293 
#    DebugDumpData("SvnData", \%svnData);
3294 
 
3295 
    foreach my $entry ( keys(%versions) )
3296 
    {
3297 
        my $import_label = saneLabel($entry);
3298 
        delete $versions{$entry}{svnVersion};
3299 
        delete $versions{$entry}{svnBranchTip};
3300 
 
3301 
        if ( exists $svnData{tags}{$import_label} )
3302 
        {
3303 
            $versions{$entry}{svnVersion} = 1;
3304 
        }
3305 
 
3306 
        if ( exists $svnData{tips}{$import_label} )
3307 
        {
3308 
            $versions{$entry}{svnBranchTip} = $svnData{tips}{$import_label};
3309 
        }
3310 
    }
3311 
 
3312 
    Message ( 'Trunk used: ' . (exists $svnData{branches}{trunk} ? 'Yes' : 'No') );
3313 
    Message ( 'Labels    : ' . scalar keys %{$svnData{tags}} );
3314 
    Message ( 'Branches  : ' . scalar keys %{$svnData{branches}} );
3315 
}
3316 
 
3317 
#-------------------------------------------------------------------------------
3318 
# Function        : ProcessSvnLog
3319 
#
3320 
# Description     :
3321 
#                   Parse
3322 
#                       <logentry
3323 
#                          revision="24272">
3324 
#                       <author>bivey</author>
3325 
#                       <date>2005-07-25T15:45:35.000000Z</date>
3326 
#                       <paths>
3327 
#                       <path
3328 
#                          prop-mods="false"
3329 
#                          text-mods="false"
3330 
#                          kind="dir"
3331 
#                          copyfrom-path="/enqdef/branches/Stockholm"
3332 
#                          copyfrom-rev="24271"
3333 
#                          action="A">/enqdef/tags/enqdef_24.0.1.sls</path>
3334 
#                       </paths>
3335 
#                       <msg>COTS/enqdef: Tagged by Jats Svn Import</msg>
3336 
#                       </logentry>
3337 
#
3338 
# Inputs          :
3339 
#
3340 
# Returns         :
3341 
#
3342 
my $entryData;
3343 
sub  ProcessSvnLog
3344 
{
3345 
    my ($self, $line ) = @_;
3346 
#print "----- $line\n";
3347 
    if ( $line =~ m~^<logentry~ ) {
3348 
        $entryData = ();
3349 
 
3350 
    } elsif ( $line =~ m~^\s+revision="(\d+)"~ ) {
3351 
        $entryData->{Rev} = $1;
3352 
 
3353 
    } elsif ( $line =~ m~^\s+copyfrom-path="(.*)"~ ) {
3354 
        $entryData->{fromPath} = $1;
3355 
 
3356 
    } elsif ( $line =~ m~^\s+copyfrom-rev="(\d+)"~ ) {
3357 
        $entryData->{fromRev} = $1;
3358 
 
3359 
    } elsif ( $line =~ m~\s+action=.*?>(.*)</path~ ) {
3360 
        $entryData->{target} = $1;
3361 
 
3362 
    } elsif ( $line =~ m~</logentry~ ) {
3363 
        if ( exists $entryData->{fromPath} )
3364 
        {
3365 
#            DebugDumpData("Data", $entryData);
3366 
            push @svnDataItems, $entryData;
3367 
        }
3368 
    }
3369 
 
3370 
    #
3371 
    #   Return 0 to keep on going
3372 
    return 0;
3373 
}
3374 
 
3375 
 
3376 
 
3377 
#-------------------------------------------------------------------------------
3378 
# Function        : saveData
3379 
#
3380 
# Description     : Save essential data
3381 
#
3382 
# Inputs          :
3383 
#
3384 
# Returns         :
3385 
#
3386 
sub saveData
3387 
{
3388 
    my $file = $cwd . "/${packageNames}.data";
3389 
 
3390 
    Message ("Create: $file");
3391 
    my $fh = ConfigurationFile::New( $file );
3392 
 
3393 
    $fh->DumpData(
3394 
        "\n# ScmVersions.\n#\n",
3395 
        "ScmVersions", \%versions );
3396 
 
3397 
    #
3398 
    #   Close out the file
3399 
    #
3400 
    $fh->Close();
3401 
}
3402 
 
3403 
 
3404 
#-------------------------------------------------------------------------------
3405 
#   Documentation
3406 
#
3407 
 
3408 
=pod
3409 
 
3410 
=for htmltoc    SYSUTIL::cc2svn::
3411 
 
3412 
=head1 NAME
3413 
 
3414 
cc2svn_gendata - CC2SVN tool to import an entire package into SVN
3415 
 
3416 
=head1 SYNOPSIS
3417 
 
3418 
  jats cc2svn_importpackage [options] package_name
3419 
 
3420 
 Options:
3421 
    -help              - brief help message
3422 
    -help -help        - Detailed help message
3423 
    -man               - Full documentation
3424 
    -repository=name   - Specify target repository
3425 
    -[no]flat          - Do not create project tree. Def: -noflat
3426 
    -prunemode=mode    - Mode: none, ripple, retain, severe, Def=ripple
3427 
    -retain=N          - Specify retain count for pruning. Def=2
3428 
    -[no]test          - Do not create packages. Def:-notest
3429 
    -[no]reuse         - Keep and reuse ClearCase views
3430 
    -age=nnDays        - Only keep recent package
3431 
    -dump[=n]          - Dump raw data. N=0,1,2
3432 
    -images[=n]        - Create SVG of version tree. N=0,1,2
3433 
    -name=aaa          - Alternate output package name. Test Only
3434 
    -[no]log           - Write output to log file. Def: -nolog
3435 
    -[no]postimage     - Create image after transger: Def: -post
3436 
    -workdir=path      - Use for temp storage (def:/work)
1270 dpurdie 3437 
    -delete            - Delete SVN package before test
392 dpurdie 3438 
 
3439 
=head1 OPTIONS
3440 
 
3441 
=over 8
3442 
 
3443 
=item B<-help>
3444 
 
3445 
Print a brief help message and exits.
3446 
 
3447 
=item B<-help -help>
3448 
 
3449 
Print a detailed help message with an explanation for each option.
3450 
 
3451 
=item B<-man>
3452 
 
3453 
Prints the manual page and exits.
3454 
 
3455 
=item B<-prunemode=mode>
3456 
 
3457 
This option control the manner in which excess versions will be pruned. Valid
3458 
modes are:
3459 
 
3460 
=over 8
3461 
 
3462 
=item   none
3463 
 
3464 
No pruning will be performed
3465 
 
3466 
=item   ripple
3467 
 
3468 
Non-Essential packages that are ripple builds will be removed.
3469 
 
3470 
=item   retain
3471 
 
3472 
Versions that preceed an Essential version will be retained.
3473 
 
3474 
=item   severe
3475 
 
3476 
Only Essential Versions, and Branching points will be retained.
3477 
 
3478 
=back
3479 
 
3480 
=back
3481 
 
3482 
=head1 DESCRIPTION
3483 
 
3484 
This program is a tool used in the conversion of ClearCase VOBS to subversion.
3485 
It will take a complete package and all relevent versions from ClearCase and
3486 
insert them into subversion in a sessible manner. It will attempt to retain
3487 
file change order and history.
3488 
 
3489 
It will:
3490 
 
3491 
=over 8
3492 
 
3493 
=item *
3494 
 
3495 
Read in the Essential Package Version list.
3496 
 
3497 
=item *
3498 
 
3499 
Extract, from Release Manager, all known versions of the specified package.
3500 
 
3501 
=item *
3502 
 
3503 
It will attempt to determine the type of package: COTS, TOOL, CORE, PROJECT
3504 
and alter the processing accordingly.
3505 
 
3506 
=item *
3507 
 
3508 
It will create a version dependency tree and determine 'new' project branch
3509 
points. It will remove (prune) versions that are excess to requirements.
3510 
 
3511 
=item *
3512 
 
3513 
It will extract source from ClearCase and insert it into SVN, creating
3514 
branches and tags as it goes.
3515 
 
3516 
=back
3517 
 
3518 
The program can also be used to create a SVG image of the version dependency
3519 
tree. This does not work on Linux; only Windows with 'dot' installed.
3520 
 
3521 
=cut
3522