Subversion Repositories DevTools

Rev

Rev 2476 | Rev 2548 | Go to most recent revision | Details | Compare with Previous | 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;
2412 dpurdie 36 
use Encode;
392 dpurdie 37 
 
38 
 
39 
#use Data::Dumper;
40 
use Fcntl ':flock'; # import LOCK_* constants
41 
use Cwd;
42 
use DBI;
43 
use Getopt::Long;
44 
use Pod::Usage;                             # required for help support
1342 dpurdie 45 
use Encode;
392 dpurdie 46 
 
47 
#
48 
#   Options
49 
#
50 
my $opt_help = 0;
51 
my $opt_manual = 0;
52 
my $opt_verbose = 0;
53 
my $opt_repo_base = 'AUPERASVN01/';
54 
my $opt_repo = '';
55 
my $opt_flat;
56 
my $opt_test;
57 
my $opt_reuse;
58 
my $opt_age;
59 
my $opt_dump = 0;
60 
my $opt_images = 0;
61 
my $opt_retaincount = 2;
62 
my $opt_pruneModeString;
63 
my $opt_listTags;
64 
my $opt_name;
65 
my $opt_log = 0;
66 
my @opt_tip;
67 
my $opt_postimage = 1;
68 
my $opt_workDir = '/work';
69 
my $opt_vobMap;
1197 dpurdie 70 
my $opt_preserveProjectBase;
71 
my $opt_ignoreProjectBaseErrors;
2424 dpurdie 72 
my $opt_ignoreMakeProjectErrors;
2489 dpurdie 73 
my $opt_forceProjectBase;
2476 dpurdie 74 
my $opt_ignoreBadPaths;
1270 dpurdie 75 
my $opt_delete;
1272 dpurdie 76 
my $opt_recentAge = 14;             # Days
2412 dpurdie 77 
my $opt_relabel = 0;
2449 dpurdie 78 
my $opt_protected;
79 
my $opt_useSvn = 1;
80 
my $opt_testRmDatabase;
2476 dpurdie 81 
my $opt_extractFromSvn;
392 dpurdie 82 
 
83 
################################################################################
84 
#   List of Projects Suffixes and Branch Names to be used within SVN
85 
#
86 
#       Name        - Name of branch for the project
87 
#       Trunk       - Can be a trunk project
88 
#                     First one seen will be placed on the trunk
89 
#                     Others will create project branches
90 
#
91 
my $ProjectTrunk;
92 
my %ProjectsBaseCreated;
93 
my %Projects = (
94 
    '.sea'      => { Name => 'Seattle' },
95 
    '.coct'     => { Name => 'CapeTown' },
96 
    '.sls'      => { Name => 'Stockholm' },
97 
    '.syd'      => { Name => 'Sydney' },
98 
    '.vtk'      => { Name => 'Vasttrafik' },
99 
    '.bei'      => { Name => 'Beijing' },
100 
    '.bkk'      => { Name => 'Bangkok' },
101 
    '.ndl'      => { Name => 'NewDelhi' },
102 
    '.nzs'      => { Name => 'NewZealandStageCoach' },
103 
    '.wdc'      => { Name => 'Washington' },
104 
    '.oso'      => { Name => 'Oslo' },
105 
    '.lvs'      => { Name => 'LasVegas' },
106 
    '.mlc'      => { Name => 'BeijingMlc' },
107 
    '.sfo'      => { Name => 'SanFrancisco' },
108 
    '.sg'       => { Name => 'Singapore' },
109 
    '.gmp'      => { Name => 'GmpteProject' },
110 
    '.ssw'      => { Name => 'UkStageCoach' },
111 
    '.uk'       => { Name => 'UkProject' },
112 
    '.pmb'      => { Name => 'Pietermaritzburg' },
113 
    '.vps'      => { Name => 'VixPayments' },
114 
    '.ncc'      => { Name => 'NSWClubCard' },
115 
    '.rm'       => { Name => 'Rome' },
2354 dpurdie 116 
    '.vss'      => { Name => 'SmartSite' },
392 dpurdie 117 
    'unknown'   => { Name => 'UnknownProject' },
118 
 
119 
    '.ebr'      => { Name => 'eBrio' , Trunk => 1 },
120 
    '.mas'      => { Name => 'Mass'  , Trunk => 1 },
121 
    '.cr'       => { Name => 'Core'  , Trunk => 1 },
122 
    '.cots'     => { Name => 'Cots'  , Trunk => 1 },
123 
    '.tool'     => { Name => 'Tools' , Trunk => 1 },
124 
);
125 
 
126 
my %suffixFixup = (
127 
    '.sf'           => '.sfo',
128 
    '.vt'           => '.vtk',
129 
    '.lv'           => '.lvs',
130 
    '.was'          => '.wdc',
131 
    '.uk.1'         => '.uk',
132 
    '.ssts.demo'    => '.ssts',
133 
    '.u244.syd'     => '.syd',
134 
    '.pxxx.sea'     => '.sea',
135 
    '.pxxx.syd'     => '.syd',
136 
    '.pxxx.sydddd'  => '.syd',
137 
    '.oslo'         => '.oso',
1272 dpurdie 138 
    '.osl'          => '.oso',
392 dpurdie 139 
);
140 
 
141 
my %specialPackages = (
2319 dpurdie 142 
    'core_devl'           =>  ',all,protected,',
143 
    'daf_utils_mos'       => ',flat,',
144 
    'mos_packager'        => ',all,',
145 
    'cfmgr-cfmgr'         => ',flat,',
146 
    'daf_utils_button_st' => ',flat,',
2354 dpurdie 147 
    'ReleaseName'         => ',flat,',
2393 dpurdie 148 
    'reports'             => ',utf8,',
2403 dpurdie 149 
    'cda_imports'         => ',utf8,',
150 
    'cdxforms'            => ',utf8,',
151 
    'db_cda'              => ',utf8,',
2426 dpurdie 152 
    'CommandServer'       => ',IgnoreMakeProject,',
2438 dpurdie 153 
    'TDSExporterControl'  => ',IgnoreMakeProject,',
154 
    'cdagui'              => ',IgnoreMakeProject,',
395 dpurdie 155 
 
2449 dpurdie 156 
    'daf_bvt'                 => ',IgnoreMakeProject,',  # Look OK
157 
    'daf_dll'                 => ',IgnoreMakeProject,',  # MakeProject not in used makefile
158 
    'PFTPi'                   => ',IgnoreMakeProject,',  # Looks OK
159 
    'PFTPu'                   => ',IgnoreMakeProject,',  # Looks OK
160 
    'WinCEBlocker'            => ',IgnoreMakeProject,',  # Looks OK
161 
    'WinCEDeviceAutoInject'   => ',IgnoreMakeProject,',  # Looks OK
162 
    'WinCEReboot'             => ',IgnoreMakeProject,',  # Looks OK
2403 dpurdie 163 
 
395 dpurdie 164 
 
2489 dpurdie 165 
    'ftp'                   => ',SetProjectBase,',
166 
    'ddu_app_manager'       => ',SetProjectBase,IgnoreMakeProject,',
167 
    'ddu_afc'               => ',SetProjectBase,IgnoreMakeProject,',
168 
    'ddu_dog'               => ',SetProjectBase,IgnoreMakeProject,',
1197 dpurdie 169 
 
170 
    'icl'                   => 'IgnoreProjectBase,',
171 
    'itso'                  => 'IgnoreProjectBase,',
2449 dpurdie 172 
#    'daf_osa_mos'           => 'IgnoreProjectBase,',
1197 dpurdie 173 
    'daf_utils_mos'         => 'IgnoreProjectBase,',
174 
    'itso_ud'               => 'IgnoreProjectBase,',
175 
#    'mos_api'               => 'IgnoreProjectBase,',
176 
#    'mos_fonts'             => 'IgnoreProjectBase,',
177 
#    'sntp'                  => 'IgnoreProjectBase,',
178 
#    'time_it'               => 'IgnoreProjectBase,',
392 dpurdie 179 
);
180 
 
181 
my %notCots = (
182 
    'isl'       => 1,
183 
);
184 
 
1451 dpurdie 185 
my $ukHopsMode = 0;
186 
my %ukHopsReleases = (
187 
    '6222'      => { name => 'MainLine', 'trunk' => 1 },
1453 dpurdie 188 
    '14503'     => { name => 'Hops3' },
189 
    '21864'     => { name => 'Hops3.6' },
190 
    '22303'     => { name => 'Hops3.7' },
1451 dpurdie 191 
    '17223'     => { name => 'Hops4' },
192 
);
193 
 
2016 dpurdie 194 
# The following packages will have the version in the specified release forced to be on the trunk
195 
# A trunk will be forced and the version will be on it.
196 
#   May only work if the version in the release is also a TIP
197 
my %ukHopsTip = (
198 
    'ItsoMessaging'         => '6222',
199 
    'MessageProcessor'      => '6222',
200 
    'StrongNameKey'         => '6222',
201 
);
202 
 
392 dpurdie 203 
################################################################################
204 
#   Global data
205 
#
206 
my $VERSION = "1.0.0";
207 
my $RM_DB;
208 
my $last_pv_id;
209 
my %pkg_ids;
210 
my $first_pkg_id;
211 
my %versions;
212 
my %suffixes;
213 
my @processOrder;
214 
my @startPoints;
215 
my @allStartPoints;
216 
my @endPoints;
217 
my $now = time();
218 
my $logSummary;
219 
my $firstVersionCreated;
220 
my @EssentialPackages;
221 
my $createBranch;
222 
my $createSuffix;
223 
my $currentBranchName;
224 
my $singleProject;
225 
my $pruneCount = 0;
226 
my $trimCount = 0;
227 
my $badVcsCount = 0;
228 
my $ProjectCount = 0;
229 
my $totalVersions = 0;
230 
my $initialTrees = 0;
231 
my $globalError;
232 
my @unknownProjects;
233 
my %knownProjects;
234 
my $badSingletonCount = 0;
235 
my @flatOrder;
236 
my $pruneMode;
237 
my $pruneModeString;
238 
my $threadId = 0;
239 
my $threadCount;
240 
my %tipVersions;
241 
my $allSvn;
242 
my @multiplePaths;
243 
my @badEssentials;
244 
my %svnData;
245 
my $cwd;
2393 dpurdie 246 
my $mustConvertFileNames;
2424 dpurdie 247 
my $workDir;
392 dpurdie 248 
 
249 
my $packageNames;
250 
my @packageNames;
251 
my $multiPackages = -1;
252 
my $visitId = 0;
253 
my $noTransfer;
254 
my $rippleCount = 0;
255 
my $svnRepo;
1270 dpurdie 256 
my $processCount = 0;
257 
my $processTotal = 0;
1272 dpurdie 258 
my $recentCount = 0;
2401 dpurdie 259 
my $packageReLabelCount = 0;
2412 dpurdie 260 
my %saneLabels;
2476 dpurdie 261 
my $adjustedPath = 0;
392 dpurdie 262 
 
263 
our $GBE_RM_URL;
264 
my $UNIX = $ENV{'GBE_UNIX'};
265 
 
266 
my $result = GetOptions (
267 
                "help+"         => \$opt_help,          # flag, multiple use allowed
268 
                "manual:3"      => \$opt_help,
269 
                "verbose:+"     => \$opt_verbose,       # Versose
270 
                "repository:s"  => \$opt_repo,          # Name of repository
1272 dpurdie 271 
                'rbase:s'       => \$opt_repo_base,     # Base of the repo
392 dpurdie 272 
                "flat!"         => \$opt_flat,          # Flat structure
273 
                "test!"         => \$opt_test,          # Test operations
274 
                "reuse!"        => \$opt_reuse,         # Reuse ClearCase views
275 
                "age:i"         => \$opt_age,           # Only recent versions
276 
                "dump:1"        => \$opt_dump,          # Dump Data
277 
                "images:1"      => \$opt_images,        # Create DOT images
278 
                "retain:i"      => \$opt_retaincount,   # Retain N packages
279 
                "pruneMode:s"   => \$opt_pruneModeString,
280 
                "listtags:i"    => \$opt_listTags,
281 
                "name:s"        => \$opt_name,          # Alternate output
282 
                "tip:s"         => \@opt_tip,           # Force tip version(s)
283 
                "log!"          => \$opt_log,
1270 dpurdie 284 
                "delete!"       => \$opt_delete,
392 dpurdie 285 
                "postimage!"    => \$opt_postimage,
286 
                'workdir:s'     => \$opt_workDir,
2403 dpurdie 287 
                'relabel!'      => \$opt_relabel,
2449 dpurdie 288 
                'svn!'          => \$opt_useSvn,
289 
                'testRmDatabase'    => \$opt_testRmDatabase,
2476 dpurdie 290 
                'fromSvn!'          => \$opt_extractFromSvn,
392 dpurdie 291 
                );
292 
 
293 
#
294 
#   Process help and manual options
295 
#
296 
pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);
297 
pod2usage(-verbose => 1)  if ($opt_help == 2 );
298 
pod2usage(-verbose => 2)  if ($opt_manual || ($opt_help > 2));
299 
 
300 
#
301 
#   Configure the error reporting process now that we have the user options
302 
#
303 
SystemConfig ('ExitOnError' => 1);
304 
ErrorConfig( 'name'    =>'CC2SVN_IMPORT',
305 
             'verbose' => $opt_verbose,
306 
              );
307 
 
308 
Error("Workdir does not exist" ) unless ( -d $opt_workDir );
309 
Error("Specify a package as 'name'" ) unless ( defined $ARGV[0] );
310 
EnvImport('GBE_RM_URL');
311 
$cwd = Getcwd();
312 
 
313 
#
2449 dpurdie 314 
#   Allow use of the test database
315 
#   Defaut is live data, but some error recovery stuff can be done via
316 
#   the test database.
317 
#
318 
if ( $opt_testRmDatabase )
319 
{
320 
    Warning ("Using Test Database");
321 
    $ENV{GBE_RM_USERNAME} = 'RELEASE_MANAGER';
322 
    $ENV{GBE_RM_PASSWORD} = 'RELEASE_MANAGER';
323 
    $ENV{GBE_RM_LOCATION} = 'jdbc:oracle:thin:@auperaora07.vix.local:1521:RELMANU1';
324 
}
325 
 
326 
#
392 dpurdie 327 
#   Init the pruning mode
328 
#
329 
setPruneMode( $opt_pruneModeString || 'ripple');
330 
 
331 
#
332 
#   Get data for all packages
333 
#
334 
foreach my $packageName ( @ARGV )
335 
{
336 
    next unless ( $packageName );
337 
    Verbose( "Base Package: $packageName");
338 
 
339 
    my $pkg_id = GetPkgIdByName ( $packageName );
340 
    GetData_by_pkg_id ( $pkg_id, $packageName  );
341 
    $pkg_ids{$pkg_id} = 1;
342 
    $first_pkg_id = $pkg_id unless ( $first_pkg_id );
343 
    push @packageNames, $packageName;
344 
    $multiPackages++;
345 
}
346 
 
347 
{
348 
    #
349 
    #   Delete entries that have been created as we read in
350 
    #   data, but don't exist in RM. They will not have a pvid.
351 
    #
352 
    foreach my $entry ( keys(%versions) )
353 
    {
354 
        delete $versions{$entry}
355 
            unless ( exists $versions{$entry}{pvid} );
356 
    }
357 
}
358 
 
359 
$totalVersions = scalar keys %versions;
360 
Error ("No packages specified") unless ( $multiPackages >= 0 );
361 
Warning ("Multiple Packages being processed") if ( $multiPackages > 1 );
362 
$packageNames = join ('_', @packageNames );
363 
$packageNames = $opt_name if ( defined $opt_name );
364 
Message ("PackageName: $packageNames" );
365 
 
366 
#
367 
#   Save logging data
368 
#
369 
if ( $opt_log )
370 
{
371 
    my $opt_logfile = $packageNames . '.import';
372 
    Message ("Logging outout: $opt_logfile" );
373 
    open STDOUT, '>', $opt_logfile  or die "Can't redirect STDOUT: $!";
374 
    open STDERR, ">&STDOUT"         or die "Can't dup STDOUT: $!";
375 
}
376 
 
377 
#
378 
#   Prepare tip version hash
379 
#
380 
$tipVersions{$_} = 1 foreach ( @opt_tip );
381 
 
382 
#
383 
#   Read in external data and massage it all
384 
#
385 
getEssenialPackageVersions();
386 
getVobMapping();
387 
smartPackageType();                 # Determine special prune mode
388 
ReportPathVariance();
389 
massageData();
390 
getSvnData();
391 
smartPackageType();                 # Have another go
392 
 
393 
my @missedTips = keys %tipVersions;
394 
Error ("Specified tip version not found: @missedTips") if ( @missedTips );
395 
 
396 
if ( $opt_flat )
397 
{
398 
#    @flatOrder = sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions);
399 
#    @flatOrder = sort {$versions{$a}{created} cmp $versions{$b}{created}} keys(%versions);
400 
    @flatOrder = sort {$a <=> $b} keys(%versions);
401 
    my $tip = $flatOrder[-1];
402 
    $versions{$tip}{Tip} = 1 if $tip;
403 
}
404 
 
405 
#
406 
#   Generate dumps and images
407 
#
408 
if ( $opt_images )
409 
{
410 
    createImages();
411 
}
412 
 
413 
if ( $opt_dump )
414 
{
415 
    DebugDumpData ("Versions", \%versions );
416 
    DebugDumpData ("Starts", \@startPoints );
417 
    DebugDumpData ("Ends", \@endPoints );
418 
    DebugDumpData ("Suffixes", \%suffixes );
419 
}
420 
 
421 
 
422 
#   Display VCS tags
423 
#
424 
if ( $opt_listTags )
425 
{
426 
    foreach my $entry (sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions) )
427 
    {
428 
        print $versions{$entry}{vcsTag} || '-' ,"\n";
429 
    }
430 
}
431 
exit if ( ($opt_dump > 1) || ($opt_images > 1) );
432 
 
433 
transferPackageToSvn();
434 
 
435 
if ( $opt_postimage )
436 
{
437 
    getSvnData();
438 
    createImages();
439 
}
440 
 
441 
exit 0;
442 
 
443 
#-------------------------------------------------------------------------------
444 
# Function        : transferPackageToSvn
445 
#
446 
# Description     : Transfer the package to SVN
447 
#
448 
# Inputs          :
449 
#
450 
# Returns         :
451 
#
452 
sub transferPackageToSvn
453 
{
454 
    Error ("Repository Path not setup")
455 
        unless ( $svnRepo );
456 
 
457 
    #
458 
    #   Going to do serious work
459 
    #   Need to ensure we have more arguments
460 
    #
2449 dpurdie 461 
    if ( $opt_protected )
462 
    {
463 
        Warning("Protected Package not transferred: $packageNames[0] - $opt_protected",
464 
                "See cc2svn_protected.txt for details");
465 
        exit 0;
466 
    }
467 
 
392 dpurdie 468 
    if ( $noTransfer )
469 
    {
2449 dpurdie 470 
        Warning("Protected Package not transferred: $packageNames[0]",
471 
                "Configured within this program");
392 dpurdie 472 
        exit 0;
473 
    }
474 
 
475 
    #
476 
    #   Perform all the work in a package specific subdirectory
477 
    #
2424 dpurdie 478 
    $workDir = $opt_workDir . '/' . $packageNames;
392 dpurdie 479 
    mkdir $workDir unless ( -d $workDir );
480 
    chdir $workDir || Error ("Cannot cd to $workDir");
481 
 
482 
    #
483 
    #   Process all packages
484 
    #       Going to create versions based on RM structure
485 
    #       May have several starting points: Process each
486 
    #
487 
    newPackage();
488 
    if ( $opt_flat )
489 
    {
490 
        newProject();
491 
        foreach my $entry (@flatOrder )
492 
        {
493 
            newPackageVersion( $entry, $versions{$entry}{suffix} );
494 
        }
495 
    }
496 
    else
497 
    {
498 
        processBranch(@allStartPoints);
499 
    }
500 
    endPackage();
501 
 
502 
    chdir $cwd || Error ("Cannot cd back to $cwd");
503 
    rmdir $workDir;
504 
    Warning ("Work Directory still exists: $workDir");
505 
    saveData();
506 
}
507 
 
508 
#-------------------------------------------------------------------------------
509 
# Function        : setPruneMode
510 
#
511 
# Description     : Set the pruning mode
512 
#
513 
# Inputs          : mode                    - Text mode value
514 
#
515 
# Returns         : Nothing
516 
#
517 
sub setPruneMode
518 
{
519 
    my ($mode) = @_;
520 
    my $value;
521 
    if ( $mode )
522 
    {
523 
        if ( $mode =~ m/none/i) {
524 
            $value = 0;
525 
        } elsif ( $mode =~ m/ripple/i) {
526 
            $value = 1;
527 
        } elsif ( $mode =~ m/retain/i) {
528 
            $value = 2;
529 
        } elsif ( $mode =~ m/severe/i) {
530 
            $value = 3;
531 
        } else {
532 
            Error ("Unknown pruning mode", "Use: none, ripple, retain or severe");
533 
        }
534 
 
535 
        $pruneModeString = $mode;
536 
        $pruneMode = $value;
537 
    }
538 
}
539 
 
540 
#-------------------------------------------------------------------------------
541 
# Function        : smartPackageType
542 
#
543 
# Description     : Have a look at the projects in the package set and
544 
#                   attempt to determine what sort of mechanism to use
545 
#
546 
# Inputs          : Uses %suffixes data
547 
#
548 
# Returns         :
549 
#
550 
my $packageType = 'UNKNOWN';
551 
sub smartPackageType
552 
{
553 
    #
554 
    #   Rebuild suffixes hash based on  post massaged versions
555 
    #
556 
    my %suffixes;
557 
    my @unknown;
558 
    foreach my $entry ( keys %versions )
559 
    {
560 
        my $suffix = $versions{$entry}{suffix} || '';
561 
        push (@unknown, $entry) if ($suffix eq 'unknown');
562 
 
563 
        next if ( exists $suffixes{$suffix} );
564 
        next if ( $versions{$entry}{badSingleton} );
565 
        next if ( $versions{$entry}{locked} eq 'N' || $versions{$entry}{isaWip} );
566 
        $suffixes{$suffix} = 1;
567 
        $knownProjects{$suffix}{seen} = 1;
568 
 
569 
    }
570 
 
571 
    #
572 
    #   The 'unknown' suffix is really an 'empty' suffix
573 
    #   Try to be clever
574 
    #       Map unknown to 'cr' or 'mas' if present
575 
    #
576 
    #
577 
    if ( exists $suffixes{'unknown'}  )
578 
    {
579 
        my $new_suffix;
580 
        if ( exists $suffixes{'.cr'} ) {
581 
            $new_suffix = '.cr';
582 
        } elsif ( exists $suffixes{'.mas'} ) {
583 
            $new_suffix = '.mas';
584 
        }
585 
 
586 
        if ( $new_suffix )
587 
        {
588 
            foreach my $entry ( @unknown )
589 
            {
590 
                $versions{$entry}{suffix} = $new_suffix;
591 
            }
592 
            delete $suffixes{'unknown'};
593 
            delete $knownProjects{'unknown'}{seen};
594 
        }
595 
    }
596 
 
597 
    if ( exists $suffixes{'.cots'} && !exists ($notCots{$packageNames}) ) {
598 
        $packageType = 'COTS';
599 
        $Projects{'.cots'}{Trunk} = 1;
600 
        $singleProject = 1;
601 
        $opt_flat = 1 unless defined $opt_flat;
602 
        setPruneMode('none') unless (defined $opt_pruneModeString);
603 
 
604 
    } elsif ( exists $suffixes{'.tool'} ) {
605 
        $packageType = 'TOOL';
2016 dpurdie 606 
        $Projects{'.tool'}{Trunk} = 1;
392 dpurdie 607 
        $singleProject = 1;
608 
        setPruneMode('none') unless (defined $opt_pruneModeString);
609 
#        $opt_flat = 1;
610 
 
611 
    } elsif ( scalar (keys %suffixes ) == 1 ) {
612 
        $packageType = 'SINGLE_PROJECT';
613 
        $singleProject = 1;
614 
 
615 
    } else {
616 
        $packageType = 'MULTIPLE_PROJECT';
617 
    }
618 
 
619 
    #
620 
    #   Some packages are special
621 
    #
2393 dpurdie 622 
    if ( $svnRepo =~ m~/Manufacturing(/|$)~ )
623 
    {
624 
        Message ("Set Manufacturing Repo style");
625 
        $opt_flat = 1;
626 
        setPruneMode('none') unless (defined $opt_pruneModeString);
627 
    }
392 dpurdie 628 
 
2393 dpurdie 629 
 
392 dpurdie 630 
    if ( $packageNames[0] =~ m'^br_applet_' )
631 
    {
2393 dpurdie 632 
      $opt_flat = 1 unless defined $opt_flat;
392 dpurdie 633 
    }
634 
 
635 
    if ( exists $specialPackages{$packageNames[0]} )
636 
    {
637 
        my $data = $specialPackages{$packageNames[0]};
638 
        if ( index( $data, ',all' ) >= 0) {
639 
            setPruneMode('none') unless (defined $opt_pruneModeString);
640 
        }
641 
 
642 
        if ( index( $data, 'protected,' ) >= 0) {
643 
            $noTransfer = 1;
644 
        }
645 
 
646 
        if ( index( $data, 'flat,' ) >= 0) {
647 
            $opt_flat = 1;
648 
        }
1197 dpurdie 649 
 
650 
        if ( index( $data, 'SetProjectBase,' ) >= 0) {
651 
            $opt_preserveProjectBase = 1;
652 
            $opt_ignoreProjectBaseErrors = 1;
653 
            Message ("Preserving ProjectBase");
654 
        }
655 
 
656 
        if ( index( $data, 'IgnoreProjectBase,' ) >= 0) {
657 
            $opt_ignoreProjectBaseErrors = 1;
658 
            Message ("Ignore ProjectBase Errors");
659 
        }
660 
 
2424 dpurdie 661 
        if ( index( $data, 'IgnoreMakeProject,' ) >= 0) {
662 
            $opt_ignoreMakeProjectErrors = 1;
663 
            Message ("Ignore MakeProject Usage");
664 
        }
2476 dpurdie 665 
 
666 
        if ( index( $data, 'IgnoreBadPath,' ) >= 0) {
667 
            $opt_ignoreBadPaths = 1;
668 
            Message ("Ignore Bad Paths in makefilest Usage");
669 
        }
2424 dpurdie 670 
 
2393 dpurdie 671 
        if ( index( $data, 'utf8,' ) >= 0) {
672 
            $mustConvertFileNames = 1;
673 
            Message ("Convert filenames to UTF8");
674 
        }
392 dpurdie 675 
    }
676 
 
677 
    Message("Package Type: $packageType, $pruneModeString");
678 
}
679 
 
680 
 
681 
#-------------------------------------------------------------------------------
682 
# Function        : massageData
683 
#
684 
# Description     : Massage all the data to create a tree of package versions
685 
#                   that can be used to create images as well as an import order
686 
#
687 
# Inputs          :
688 
#
689 
# Returns         :
690 
#
691 
my $reprocess=0;
692 
sub calcLinks
693 
{
694 
    #
695 
    #   Process the 'versions' hash and:
696 
    #   Add back references
697 
    #   Find starts and ends
698 
    #       Entry with no previous
699 
    #       Entry with no next
700 
    #
701 
    $reprocess = 0;
702 
    foreach my $entry ( keys(%versions) )
703 
    {
704 
        foreach ( @{ $versions{$entry}{next}} )
705 
        {
706 
            $versions{$_}{last} = $entry;
707 
        }
708 
    }
709 
    @allStartPoints = ();
710 
    @startPoints = ();
711 
    @endPoints = ();
712 
    foreach my $entry ( keys(%versions) )
713 
    {
714 
        push @startPoints, $entry
715 
            unless ( exists $versions{$entry}{last} || $versions{$entry}{badSingleton} );
716 
 
717 
        push @allStartPoints, $entry
718 
            unless ( exists $versions{$entry}{last} );
719 
 
720 
        push @endPoints, $entry
721 
            unless ( @{$versions{$entry}{next}} > 0  )
722 
    }
723 
}
724 
 
725 
sub massageData
726 
{
727 
    #
728 
    #   Report unknown suffixes
729 
    #   Handle bad, or little known project suffixes by creating them
730 
    #
731 
    foreach my $suffix ( keys %suffixes )
732 
    {
733 
        if ( exists $Projects{$suffix} )
734 
        {
735 
            next;
736 
        }
737 
        Message ("Unknown project suffix: '$suffix'");
738 
        push @unknownProjects, $suffix;
739 
        my $cleanSuffix = ucfirst(lc(substr( $suffix, 1)));
740 
        $Projects{$suffix}{Name} = 'Project_' . $cleanSuffix;
741 
    }
742 
 
743 
    calcLinks();
744 
 
745 
    $initialTrees = scalar @allStartPoints;
746 
    Message ('Total RM versions: ' . $totalVersions );
747 
    Message ('Initial trees: ' . $initialTrees );
748 
    #
749 
    #   Attempt to glue all the start points into one chain.
750 
    #   This should allow us to track projects that branch from each other
751 
    #   in cases where the RM data is incorrect/incomplete
752 
    #       Strays are those that have no next or last
753 
    #
754 
    #   Glue based on Name, then PVID (Creation Order)
755 
    #
756 
    {
757 
        #
758 
        #   Examine threads. If it is a single entry thats bad then drop it
759 
        #   This is simple to do. Should examine all entries, but thats a
760 
        #   bit harder. Perhaps later.
761 
        #
762 
        if (1) {
763 
            Message ("Dropping Bad Singletons");
764 
            my $badSingletons;
765 
            foreach my $entry ( sort {$a <=> $b} @startPoints )
766 
            {
767 
                my $ep = $versions{$entry};
768 
                unless ( $ep->{last} || $ep->{next}[0] )
769 
                {
770 
#                    if (  $ep->{isaWip}  )
771 
                    if ( (exists $ep->{badVcsTag} && $ep->{badVcsTag}) || $ep->{isaWip}  )
772 
                    {
773 
                        $ep->{badSingleton} = 1;
774 
                        $reprocess = 1;
775 
                        $badSingletonCount++;
776 
 
777 
                        # Add to a list of its own.
778 
                        if ( $badSingletons )
779 
                        {
780 
                            push @{$versions{$badSingletons}{next}}, $entry;
781 
                        }
782 
                        $badSingletons = $entry;
783 
                    }
784 
                }
785 
            }
786 
            calcLinks()
787 
                if ( $reprocess );
788 
        }
789 
 
790 
        #
791 
        #   Create simple trees out of the chains
792 
        #   Tree is based on suffix (project) and version
793 
        #
794 
        {
795 
            my %trees;
796 
            Message ("Entries into trees");
797 
            foreach my $single ( @startPoints )
798 
            {
799 
                my $suffix = $versions{$single}{suffix} || '';
800 
                push @{$trees{$suffix}}, $single;
801 
            }
802 
 
803 
            foreach  ( keys %trees )
804 
            {
805 
                my $last;
806 
                foreach my $entry ( sort { $versions{$a}{version} cmp $versions{$b}{version}  } @{$trees{$_}} )
807 
                {
808 
                    if ( $last )
809 
                    {
810 
                        $versions{$last}{MakeTree} = 1;
811 
                        push @{$versions{$last}{next}}, $entry;
812 
                        $reprocess = 1;
813 
                    }
814 
                    $last = $entry;
815 
                }
816 
            }
817 
            calcLinks()
818 
                if ( $reprocess );
819 
        }
820 
 
821 
        #
822 
        #   Have a number of trees that are project related
823 
        #   Attempt to create a single tree by inserting
824 
        #   Secondary trees into the main line at suitable points
825 
        #
826 
        my @AllVersions = sort { $a <=> $b } @startPoints;
827 
        my $lastEntry = shift @AllVersions;
828 
        Error ("Oldest entry has a previous version") if ( $versions{$lastEntry}{last}  );
829 
#print "Oldest: $lastEntry\n";
830 
        #
831 
        #   Insert remaining entries into out list, which is now sorted
832 
        #
833 
        my @completeList;
834 
        foreach my $base ( @AllVersions  )
835 
        {
836 
            push @completeList, recurseList($lastEntry);
837 
            @completeList = sort {$a <=> $b} @completeList;
838 
#            Message("Complete List: ", @completeList);
839 
#            Message("Complete List($completeList[0]) Length: " . scalar @completeList);
840 
            $lastEntry = $base;
841 
 
842 
            my $last;
843 
            foreach my $entry ( @completeList )
844 
            {
845 
                if ( $entry > $base )
846 
                {
847 
                    Error ("Not expecting last to be empty. $base, $entry") unless ( $last );
848 
                    last;
849 
                }
850 
                $last = $entry;
851 
            }
852 
 
853 
            #
854 
            #   Insert at end if point not yet found
855 
            #
856 
#print "Inserting $base at $last\n";
857 
            push @{$versions{$last}{next}}, $base;
858 
            $versions{$base}{GluedIn} = 1;
859 
            $reprocess = 1;
860 
        }
861 
 
862 
        #
863 
        #   Recalc basic links if any processing done
864 
        #
865 
        calcLinks()
866 
            if ( $reprocess );
867 
 
868 
    }
869 
 
870 
 
871 
    #
872 
    #   Remove Dead Ends
873 
    #   Packages that were never released
874 
    #       Not locked, unless essential or a branchpoint
875 
    #   Won't consider these to be mainline path.
876 
    #
877 
    {
878 
        Message ("Remove Dead Ends");
879 
        foreach my $entry ( @endPoints )
880 
        {
881 
            my $deadWood;
882 
            while ( $entry )
883 
            {
884 
                last if ( $versions{$entry}{Essential} );
885 
 
886 
                my @next = @{$versions{$entry}{next}};
887 
                my $count = @next;
888 
                last if ( $count > 1 );
889 
 
890 
                last unless ( $versions{$entry}{locked} eq 'N' || $versions{$entry}{isaWip} );
891 
 
892 
                $versions{$entry}{DeadWood} = 1;
893 
                $trimCount++;
894 
            } continue {
895 
                $entry = $versions{$entry}{last};
896 
            }
897 
        }
898 
    }
899 
 
900 
    #
901 
    #   Walk each starting point list and determine new Projects
902 
    #   branchpoints.
903 
    #
904 
    Message ("Locate Projects branch points");
905 
    foreach my $bentry ( keys(%versions) )
906 
    {
907 
        my $baseSuffix = $versions{$bentry}{suffix};
908 
        foreach my $entry ( @{$versions{$bentry}{next}} )
909 
        {
910 
            if ( $baseSuffix ne $versions{$entry}{suffix})
911 
            {
912 
                unless ( exists $versions{$entry}{DeadWood} || $versions{$entry}{badSingleton} )
913 
                {
914 
#print "--- Project Branch $versions{$entry}{vname}\n";
915 
                    $versions{$entry}{branchPoint} = 1;
916 
                    $versions{$entry}{newSuffix} = 1;
917 
                }
918 
            }
919 
        }
920 
    }
1451 dpurdie 921 
 
922 
    #
923 
    #   Mark UkHops special points
924 
    #
925 
    foreach my $entry ( keys(%versions) ) {
926 
        foreach my $rtag_id ( keys %{$versions{$entry}{Releases}}  ) {
927 
            next unless ( exists $ukHopsReleases{$rtag_id} );
928 
            next unless ( $svnRepo =~ m~/ITSO_TRACS$~ );
929 
 
930 
            #
931 
            #   This package is current in a special ukHops release
932 
            #   Need to handle the differently
933 
            #
934 
            my $ukData =  $ukHopsReleases{$rtag_id};
935 
 
936 
            # Mark version we want on the trunk
937 
            # Will calculate tip later
938 
            if ( $ukData->{trunk} )
939 
            {
940 
                #
941 
                #   Can only place on trunk IFF its a tip
942 
                #   May have a WIP.
943 
                #   Solution. Walk to the tip, but only if there is one
944 
                #             path.
945 
                #
946 
                my $end = $entry;
947 
                my $last;
948 
                while ( $end )
949 
                {
950 
                    $last = $end;
951 
                    if ( @{$versions{$end}{next}} > 1)
952 
                    {
953 
                        Warning ("Uk Release. Preferred trunk is not a tip: $versions{$entry}{vname}");
954 
                        last;
955 
                    }
956 
 
957 
                    $end = @{$versions{$end}{next}}[0];
958 
                }
959 
                $versions{$last}{ukTrunk} = 1 ;
960 
            }
961 
 
962 
            #
963 
            #   What to do if the version is in more than one release
964 
            #
965 
            $versions{$entry}{ukBranch}++;
966 
            if ( $versions{$entry}{ukBranch} > 1 )
967 
            {
968 
                Warning ("Version found in multiple Uk Releases - don't know what to do");
969 
            }
970 
 
971 
            #
972 
            #   What to do if the package has multiple version in a release
973 
            #
974 
            $ukData->{count}++;
975 
            if ( $ukData->{count} > 1 )
976 
            {
977 
                Warning ("Package has multiple versions in the one Uk Release: $versions{$entry}{Releases}{$rtag_id}{rname}");
978 
            }
979 
        }
980 
    }
392 dpurdie 981 
 
982 
    #
983 
    #   Prune
984 
    #   Marks paths to root for all essential packages
985 
    #   Marks the last-N from all essential packages
986 
    #
987 
    if ( $pruneMode )
988 
    {
989 
        Message ("Prune Tree: $pruneModeString");
990 
        foreach ( @EssentialPackages )
991 
        {
992 
            #next unless ( exists $versions{$_} );      # Aleady deleted
993 
 
994 
            # Mark previous-N to be retained as well
995 
            my $entry = $_;
996 
            my $count = 0;
997 
            while ( $entry )
998 
            {
999 
                last if ( $versions{$entry}{KeepMe} );
1453 dpurdie 1000 
#                unless ( $versions{$entry}{isaRipple} )
392 dpurdie 1001 
                {
1002 
                    my $keepFlag = ($count++ < $opt_retaincount);
1003 
                    last unless ( $keepFlag );
1004 
                    $versions{$entry}{KeepMe} = $keepFlag;
1005 
                }
1006 
                $entry = $versions{$entry}{last}
1007 
            }
1008 
        }
1009 
 
1010 
        #
1272 dpurdie 1011 
        #   Keep recent versions
1012 
        #       Keep versions created in the last N days
1013 
        #       Will keep recent ripples too
1014 
        #
1015 
        if ( $pruneMode == 1 )
1016 
        {
1017 
            foreach my $entry ( keys(%versions) )
1018 
            {
1019 
                next unless ( $versions{$entry}{Age} <= $opt_recentAge  );
1020 
                $versions{$entry}{keepRecent} = 1;
1021 
                $recentCount++;
1022 
#print "--- Recent version $versions{$entry}{vname}, $versions{$entry}{Age} <= $opt_recentAge\n";
1023 
            }
1024 
 
1025 
#            #
1026 
#            #   Keep the tip of each branch
1027 
#            #
1028 
#            foreach my $entry ( @endPoints )
1029 
#            {
1030 
#                next if exists $versions{$entry}{keepRecent};
1031 
#                $versions{$entry}{keepRecent} = 1;
1032 
##print "--- Tip version $versions{$entry}{vname}\n";
1033 
#            }
1034 
        }
1035 
 
1036 
        #
392 dpurdie 1037 
        #   Keep versions that are common parents to Essential Versions
1038 
        #       Mark paths through the tree to essential versions
1039 
        #       Mark nodes with the number of essential versions that they sprout
1040 
        #   Don't do it if we are ripple pruning
1041 
        #
1042 
        Message ("Prune Tree keep common parents");
1043 
        if ( $pruneMode != 1 )
1044 
        {
1045 
            foreach my $entry ( @endPoints )
1046 
            {
1047 
                my $hasEssential = 0;
1048 
                $visitId++;
1049 
                while ( $entry )
1050 
                {
1051 
                    $hasEssential = 1 if ( exists ($versions{$entry}{Essential}) && $versions{$entry}{Essential} );
1052 
                    if ( $hasEssential )
1053 
                    {
1054 
                        if ( @{$versions{$entry}{next}} > 1 )
1055 
                        {
1056 
                            $versions{$entry}{EssentialSplitPoint}++;
1057 
                        }
1058 
                        last if ( exists $versions{$entry}{EssentialPath} );
1059 
                        $versions{$entry}{EssentialPath} = 1;
1060 
                    }
1061 
 
1062 
                    if ( ($versions{$entry}{visitId} || 0) == $visitId )
1063 
                    {
1064 
                        DebugDumpData ("Versions", \%versions );
1065 
                        Warning ("Circular dependency");
1066 
                        last;
1067 
                    }
1068 
                    $versions{$entry}{visitId} = $visitId;
1069 
 
1070 
                    $entry = $versions{$entry}{last};
1071 
                }
1072 
            }
1073 
        }
1074 
 
1075 
        #
1076 
        #   Keep first version of each ripple. Must keep first
1077 
        #   Group ripples together so that they can be proccessed at the same time
1078 
        #
1079 
        calcRippleGroups()
1080 
            if ( $pruneMode == 1);
1081 
 
1082 
        #
1083 
        #   Delete all nodes that are not marked for retention
1084 
        #   This is rough on the tree
1085 
        #
1086 
        Message ("Prune Tree Deleting");
1087 
 
1088 
        # 0 - Keep me
1089 
        # 1 - Prune me
1090 
        sub pruneMe
1091 
        {
1092 
            my ($entry) = @_;
1093 
 
1094 
            return 0 unless ( exists $versions{$entry} );
1095 
            return 0 unless ( $versions{$entry}{last} );
1454 dpurdie 1096 
#            return 0 if ( ($pruneMode == 2) && exists $versions{$entry}{KeepMe} );
1097 
            return 0 if ( exists $versions{$entry}{KeepMe} );
392 dpurdie 1098 
            return 0 if ( exists $versions{$entry}{Essential} );
1099 
            return 0 if ( $versions{$entry}{newSuffix} );
1100 
            return 0 if ( $versions{$entry}{newSuffix} && (exists $versions{$entry}{EssentialPath}) );
1101 
#            return 1 if ( exists $versions{$entry}{DeadWood} );
1102 
            return 0 if ( exists $versions{$entry}{EssentialSplitPoint} && $versions{$entry}{EssentialSplitPoint} > 1 );
1103 
            return 0 if ( exists $versions{$entry}{keepLowestRipple} &&  $versions{$entry}{keepLowestRipple} );
1104 
            return 0 if ( ($pruneMode == 1) && ! $versions{$entry}{isaRipple} );
1272 dpurdie 1105 
            return 0 if ( exists $versions{$entry}{keepRecent} && $versions{$entry}{keepRecent} );
392 dpurdie 1106 
            return 1;
1107 
        }
1108 
 
1109 
        foreach my $entry ( keys(%versions) )
1110 
        {
1111 
#last;
1112 
            next unless ( pruneMe($entry) );
1113 
#print "--- Prune: $versions{$entry}{vname}\n";
1114 
 
1115 
            # Delete the current node
1116 
            #
1117 
            my @newNext;
1118 
            $pruneCount++;
1119 
            my $last = $versions{$entry}{last};
1120 
            foreach ( @{$versions{$last}{next}} )
1121 
            {
1122 
                next if ( $_ == $entry );
1123 
                push @newNext, $_;
1124 
            }
1125 
            foreach ( @{$versions{$entry}{next}} )
1126 
            {
1127 
                push @newNext, $_;
1128 
                $versions{$_}{last} = $last;
1129 
            }
1130 
 
1131 
            @{$versions{$last}{next}} = @newNext;
1132 
            delete $versions{$entry};
1133 
        }
1134 
 
1135 
        # Recalculate endpoints
1136 
        calcLinks();
1137 
    }
1138 
    else
1139 
    {
1140 
        #   No rippling happening
1141 
        #   Some process still need to happen
1142 
        #
1143 
        calcRippleGroups();
1144 
    }
1145 
 
1146 
    #
2016 dpurdie 1147 
    #   Want some versions to be forced to tip trunk
1148 
    #
1149 
    foreach my $name ( keys %ukHopsTip )
1150 
    {
1151 
        foreach my $entry ( keys(%versions) )
1152 
        {
1153 
            next unless ( $versions{$entry}{name} eq $name  );
1154 
            next unless ( exists $versions{$entry}{Releases}{$ukHopsTip{$name}} );
1155 
 
1156 
            #
1157 
            #   Force this suffix to be the trunk
1158 
            #   Remove all others
1159 
            #
1160 
            foreach my $suffix ( keys %Projects )
1161 
            {
1162 
                delete $Projects{$suffix}{Trunk};
1163 
            }
1164 
            my $suffix = $versions{$entry}{suffix};
1165 
            $Projects{$suffix}{Trunk} = 1;
1166 
        }
1167 
    }
1168 
 
1169 
    #
392 dpurdie 1170 
    #   Calculate best through-path for branches in the tree
1171 
    #   Attempt to keep that 'max' version on the mainline
1172 
    #   May be modified by -tip=nnnn
1173 
    #
1174 
    #   For each leaf (end point), walk backwards and mark each node with the
1175 
    #   max version see. If we get to a node which already has been marked then
1176 
    #   stop if our version is greater. We want the value to be the max version
1177 
    #   to a leaf
1178 
    #
1179 
    #   Account for 'suffix'. When suffix changes, then the 'max' version must
1180 
    #   be recalculated
1181 
    #
1182 
 
1183 
    Message ("Calculate Max Version");
1184 
    my $maxVersion;
1185 
    foreach my $entry ( @endPoints )
1186 
    {
1187 
        my $lastSuffix;
1188 
        my $forceTip;
1189 
        while ( $entry )
1190 
        {
1191 
            if (!defined($lastSuffix) || ($versions{$entry}{suffix} ne $lastSuffix) )
1192 
            {
1193 
                $maxVersion = '0';
1194 
                $visitId++;
1195 
                $forceTip = ( exists $tipVersions{$versions{$entry}{vname}} );
1451 dpurdie 1196 
                $forceTip = 1 if $versions{$entry}{ukTrunk};
392 dpurdie 1197 
                delete $tipVersions{$versions{$entry}{vname}};
1198 
                $maxVersion = '999.999.999.999.zzz' if ( $forceTip );
1199 
                $lastSuffix = $versions{$entry}{suffix};
1200 
#print "---Tip Found\n" if $forceTip;
1201 
            }
1202 
 
1203 
            # Detect circular dependencies
1204 
            if ( ($versions{$entry}{visitId} || 0) == $visitId )
1205 
            {
1206 
                DebugDumpData ("Circular dependency: Versions", \%versions );
1207 
                Warning ("Circular dependency");
1208 
                last;
1209 
            }
1210 
            $versions{$entry}{visitId} = $visitId;
1211 
 
1212 
            my $thisVersion = $versions{$entry}{version} || '';
1213 
            if ( $thisVersion gt $maxVersion )
1214 
            {
1215 
                $maxVersion = $thisVersion;
1216 
            }
1217 
 
1218 
            if ( exists $versions{$entry}{maxVersion} )
1219 
            {
1220 
                if ( $versions{$entry}{maxVersion} gt $maxVersion )
1221 
                {
1222 
                    last;
1223 
                }
1224 
            }
1225 
 
1226 
            $versions{$entry}{maxVersion} = $maxVersion;
1227 
            $entry = $versions{$entry}{last};
1228 
        }
1229 
    }
1230 
 
1231 
 
1232 
    #
1233 
    #   Locate all instances where a package-version branches
1234 
    #   Determine the version that should be on the non-branching path
1235 
    #
1236 
    #   Reorder the 'next' list so that the first item is the non-branching
1237 
    #   path. This will be used in the data-insertion phase to simplify the
1238 
    #   processing.
1239 
    #
1240 
    Message ("Calculate package version branches");
1241 
    foreach my $entry ( sort {$a <=> $b} keys(%versions) )
1242 
    {
1243 
        calculateWalkOrder($entry);
1244 
    }
1245 
 
1246 
    #
1247 
    #   Mark Project Branch Tips as they will be in the Repository
1248 
    #   Find each project head and walk primary entry to the end.
1249 
    #
1250 
    foreach my $entry ( keys(%versions) )
1251 
    {
1252 
        #
1253 
        #   Root of each tree is 'new'
1254 
        #
1255 
        unless ( defined $versions{$entry}{last})
1256 
        {
1257 
            unless ( $versions{$entry}{badSingleton} )
1258 
            {
1259 
                $versions{$entry}{newSuffix} = 1;
1260 
            }
1261 
        }
1262 
 
1263 
        #
1264 
        #   Update stats
1265 
        #
1266 
        $badVcsCount++ if ( $versions{$entry}{badVcsTag} );
1267 
        $ProjectCount++ if ( $versions{$entry}{newSuffix} );
1268 
        next if ( $opt_flat );
1269 
 
1270 
        next unless ($versions{$entry}{newSuffix} );
1271 
#print "--- Project new Suffix $versions{$entry}{vname}\n";
1272 
 
1273 
 
1274 
        my $suffix = $versions{$entry}{suffix};
1275 
        $knownProjects{$suffix}{count}++;
1276 
 
1277 
        my $next = $versions{$entry}{next}[0];
1278 
        my $tip;
1279 
        while ( $next )
1280 
        {
1281 
            last if ( $suffix ne $versions{$next}{suffix} );
1282 
            $tip = $next unless (exists ($versions{$next}{DeadWood}) || $versions{$next}{badSingleton});
1283 
            $next = $versions{$next}{next}[0];
1284 
        }
1285 
 
1286 
        $versions{$tip}{Tip} = 1 if $tip;
1287 
    }
1288 
 
1289 
    unless ( $opt_flat )
1290 
    {
1291 
        my $finalTrees = scalar @startPoints;
1292 
        Warning ("Still have multiple trees: $finalTrees") unless ( $finalTrees == 1 );
1293 
    }
1294 
 
1295 
    #
1296 
    #   Display warnings about multiple
1297 
    #
1298 
    foreach ( sort keys %knownProjects )
1299 
    {
1300 
        my $count = $knownProjects{$_}{count} || 0;
1301 
        Warning ("Multiple Project Roots: $_ ($count)" )
1302 
            if ( $count > 1 );
1303 
    }
1304 
 
1305 
    #
1306 
    #   Display warnings about Bad Essential Packages
1307 
    #
1308 
    $allSvn = 1;
1309 
    foreach my $entry ( keys(%versions) )
1310 
    {
1311 
        $rippleCount++ if ( exists($versions{$entry}{isaRipple}) && $versions{$entry}{isaRipple} );
1312 
        $allSvn = 0 unless ( $versions{$entry}{isSvn} );
1313 
        next unless ( exists $versions{$entry}{Essential}  );
1314 
        next unless ( $versions{$entry}{badVcsTag}  );
1315 
        push @badEssentials, $entry;
1316 
        Warning ("BadVCS Essential: " . GetVname($entry))
1317 
    }
1318 
 
1319 
    #
1320 
    #   All done
1321 
    #
1270 dpurdie 1322 
    $processTotal = scalar keys %versions;
1323 
    Message("Retained entries: $processTotal" );
392 dpurdie 1324 
    Message("Pruned entries: $pruneCount");
1325 
    Message("Deadwood entries: $trimCount");
1326 
    Message("Bad Singletons: $badSingletonCount");
1327 
    Message("Ripples: $rippleCount");
1272 dpurdie 1328 
    Message("Recent entries: $recentCount");
392 dpurdie 1329 
}
1330 
 
1331 
sub calculateWalkOrder
1332 
{
1333 
    my ($entry) = @_;
1334 
    my @next = @{$versions{$entry}{next}};
1335 
    my $count = @next;
1336 
    my @ordered;
1337 
    my $main;
1338 
 
1339 
    if ( $count > 1 )
1340 
    {
1341 
        # Array to hash to simplify removal
1342 
        my %nexts = map { $_ => 1 } @next;
1343 
        foreach my $e ( @next )
1344 
        {
1345 
 
1346 
            #
1347 
            #   Locate branch points that are not a part of a new project
1348 
            #   These will not be preferred paths for walking
1349 
            #
1350 
            if ( !defined($versions{$e}{branchPoint}) && $versions{$entry}{suffix} ne $versions{$e}{suffix} )
1351 
            {
1352 
                unless ( exists $versions{$e}{DeadWood} || $versions{$e}{badSingleton}  )
1353 
                {
1354 
#print "--- Project Branch (1) $versions{$e}{vname}\n";
1355 
                    $versions{$e}{branchPoint} = 1;
1356 
                    $versions{$e}{newSuffix} = 1;
1357 
                }
1358 
            }
1359 
 
1360 
            #
1361 
            #   Remove those that already have a branch,
1362 
            #
1363 
            if ( $versions{$e}{branchPoint} || $versions{$e}{newSuffix} || $versions{$e}{DeadWood}  )
1364 
            {
1365 
                push @ordered, $e;
1366 
                delete $nexts{$e};
1367 
            }
1368 
        }
1369 
        #
1370 
        #   Select longest arm as the non-branching path
1371 
        #   Note: Reverse sort order
1372 
        #         Done so that 'newest' item is given preference
1373 
        #         to the main trunk in cases where all subtrees are
1374 
        #         the same length
1375 
        #
1376 
        my $maxData = '';
1377 
        my $countEntry;
1378 
        foreach my $e ( sort {$b <=> $a} keys %nexts )
1379 
        {
1380 
            if ( $versions{$e}{maxVersion} gt $maxData )
1381 
            {
1382 
                $maxData = $versions{$e}{maxVersion};
1383 
                $countEntry = $e;
1384 
            }
1385 
        }
1386 
        if ($countEntry)
1387 
        {
1388 
            $main = $countEntry;
1389 
            delete $nexts{$countEntry};
1390 
        }
1391 
 
1392 
        #
1393 
        #   Append the remaining
1394 
        #
1395 
        push @ordered, keys %nexts;
1396 
 
1397 
        #
1398 
        #   Re-order 'next' so that the main path is first
1399 
        #   Sort (non main) by number
1400 
        #
1401 
        @ordered = sort {$a <=> $b} @ordered;
1402 
        unshift @ordered, $main if ( $main );
1403 
        @{$versions{$entry}{next}} = @ordered;
1404 
 
1405 
        #
1406 
        #   Ensure all except the first are a branch point
1407 
        #   First may still be a branch point
1408 
        #
1409 
        shift @ordered;
1410 
        foreach my $e ( @ordered )
1411 
        {
1412 
            $versions{$e}{branchPoint} = 1;
1413 
        }
1414 
    }
1415 
}
1416 
 
1417 
#-------------------------------------------------------------------------------
1418 
# Function        : calcRippleGroups
1419 
#
1420 
# Description     : Locate and mark ripple groups
1272 dpurdie 1421 
#                   packages that are ripples of each other
392 dpurdie 1422 
#                       Keep first version of each ripple. Must keep first
1423 
#                       Group ripples together so that they can be
1424 
#                       proccessed at the same time
1425 
#
1426 
# Inputs          :
1427 
#
1428 
# Returns         :
1429 
#
1430 
sub calcRippleGroups
1431 
{
1432 
    my %rippleVersions;
1433 
    foreach my $entry ( keys(%versions) )
1434 
    {
1435 
        my $ep = $versions{$entry};
1436 
        if ( defined $ep->{buildVersion} )
1437 
        {
1438 
            my $suffix = $ep->{suffix};
1439 
            my ($major, $minor, $patch, $build) = @{$ep->{buildVersion}};
1440 
#print "--- $major, $minor, $patch, $build, $suffix\n";
1441 
            $rippleVersions{$suffix}{"$major.$minor.$patch"}{count}++;
1442 
            my $rp = $rippleVersions{$suffix}{"$major.$minor.$patch"};
1443 
            $rp->{list}{$entry} = 1;
1444 
 
1445 
            next if ( $ep->{badVcsTag} );
1446 
            next if ( $ep->{locked} eq 'N');
1447 
            if (!defined ($rp->{min}) || $rp->{min} > $build )
1448 
            {
1449 
                $rp->{pvid} = $entry;
1450 
                $rp->{min} = $build;
1451 
            }
1452 
        }
1453 
    }
1454 
#            DebugDumpData("rippleVersions", \%rippleVersions );
1455 
 
1456 
    while ( my($suffix, $e1) = each %rippleVersions )
1457 
    {
1458 
        while ( my( $mmp, $e2) = each %{$e1} )
1459 
        {
1460 
            next unless ( exists  $e2->{pvid} );
1461 
            my $entry = $e2->{pvid};
1462 
            if ( !exists $versions{$entry} )
1463 
            {
1464 
                Error ("Internal: Expected entry not found: $entry, $mmp");
1465 
            }
1466 
 
1467 
            $versions{$entry}{keepLowestRipple} = 1;
1468 
#print "--- Keep Riple $versions{$entry}{vname}\n";
1469 
 
1470 
            #
1471 
            #   Update entry with list of associated ripples, removing lowest
1472 
            #
1473 
            delete $e2->{list}{$entry};
1474 
            my @rippleList = sort keys %{$e2->{list}};
1475 
            if ( @rippleList)
1476 
            {
1477 
#DebugDumpData("LIST: $entry", $e2->{list}, \@rippleList  );
1478 
                @{$versions{$entry}{rippleList}} = @rippleList;
1479 
            }
1480 
        }
1481 
    }
1482 
}
1483 
 
1484 
#-------------------------------------------------------------------------------
1485 
# Function        : processBranch
1486 
#
1487 
# Description     : Process one complete branch within the tree of versions
1488 
#                   May be called recursivly to walk the tree
1489 
#
1490 
# Inputs          : Array of package-version ID to process
1491 
#
1492 
# Returns         : Nothing
1493 
#
1494 
 
1495 
sub processBranch
1496 
{
1497 
    foreach my $entry ( @_ )
1498 
    {
1499 
        #
1500 
        #   Do we need to create a branch before we can process this package
1501 
        #
1502 
        if ( $versions{$entry}{newSuffix} || $versions{$entry}{branchPoint} )
1503 
        {
1504 
            newProject();
1505 
            $createBranch = 1;
1506 
            $createSuffix = 1 if $versions{$entry}{newSuffix};
1507 
        }
1508 
 
1509 
        newPackageVersion( $entry );
1510 
no warnings "recursion";
1511 
        processBranch (@{$versions{$entry}{next}});
1512 
    }
1513 
}
1514 
 
1515 
#-------------------------------------------------------------------------------
1516 
# Function        : newPackageVersion
1517 
#
1518 
# Description     : Create a package version
1519 
#
1520 
# Inputs          : $entry              - Ref to entry being proccessed
1521 
#
1522 
# Returns         :
1523 
#
1524 
sub newPackageVersion
1525 
{
1526 
    my ($entry) = @_;
1527 
    my %data;
1528 
    my $flags = 'e';
1529 
    my $rv = 1;
1530 
    my $startTime = time();
1531 
    my $timestamp = localtime;
1532 
 
1533 
    $data{rmRef} = 'ERROR';
1534 
    $data{tag} = 'ERROR';
1535 
 
1536 
    #
1537 
    #   If its been processed then fake that its been done
1538 
    #   May have been a ripple that we processed
1539 
    #
1270 dpurdie 1540 
    return if ($versions{$entry}{Processed});
1541 
    $processCount++;
392 dpurdie 1542 
    Message ("------------------------------------------------------------------" );
1270 dpurdie 1543 
    Message ("Package $processCount of $processTotal");
1544 
 
392 dpurdie 1545 
    Message ("New package-version: " . GetVname($entry) . " Tag: " . $versions{$entry}{vcsTag} );
1546 
 
1328 dpurdie 1547 
    #
1548 
    #   Detect user abort
1549 
    #
1550 
    if ( -f $cwd . '/stopfile' )
1551 
    {
1552 
        $globalError = 1;
1553 
        Message ("Stop file located");
1554 
    }
392 dpurdie 1555 
 
1556 
    #
1557 
    #   If we have a global error,then we pretend to process, but we
1558 
    #   report errors for the logging system
1559 
    #
1342 dpurdie 1560 
    if ( $globalError )
392 dpurdie 1561 
    {
1342 dpurdie 1562 
        Message ("Global error prevents futher importation");
1563 
    }
1564 
    else
1565 
    {
392 dpurdie 1566 
        #
1567 
        #   Call worker function
1568 
        #   It will exist on any error so that it can be logged
1569 
        #
1570 
        $rv = newPackageVersionBody( \%data, @_ );
1571 
        $globalError = 1 if ( $rv >= 10 );
1572 
    }
1573 
 
1574 
    #
1575 
    #   Highlight essential packages that failed to transfer
1576 
    #
1577 
    if ( $globalError ) {
1578 
        $flags = 'e';
1579 
    } elsif ( $rv && ( exists $versions{$entry}{Essential} ) ) {
1580 
        $flags = 'X';
1581 
    } elsif ( $rv ) {
1582 
        $flags = 'E';
1583 
    } else {
1584 
        $flags = 'G';
1585 
    }
1586 
 
1587 
    #
1588 
    #   Always log results to a file
1589 
    #   Flags:
1590 
    #       e - Error: Global Fatal causes other versions to be ignored
1591 
    #       X - Essential Package NOT proccessed
1592 
    #       E - Error processing package
1593 
    #       G - Good
1594 
    #
1595 
    my $duration = time() - $startTime;
1596 
    my $line = join(';',
1597 
            $flags,
1598 
            $entry,
1599 
            $packageNames,
1600 
            $versions{$entry}{vname},
1601 
            $data{rmRef},
1602 
            $data{tag},
1603 
            $timestamp,
1604 
            $duration,
1605 
            $data{errStr} || ''
1606 
            );
1607 
    logToFile( $cwd . '/importsummary.txt', ";$line;");
2438 dpurdie 1608 
 
392 dpurdie 1609 
    #
1610 
    #   Sava data
1611 
    #
1270 dpurdie 1612 
    $data{errFlags} = $flags;
1613 
    $data{duration} = $duration;
392 dpurdie 1614 
    $versions{$entry}{rmRef} = $data{rmRef};
1270 dpurdie 1615 
    delete $data{rmRef};
1616 
    delete $data{tag};
1340 dpurdie 1617 
    ##delete $data{ViewRoot};
1270 dpurdie 1618 
    $versions{$entry}{data} = \%data;
1619 
 
392 dpurdie 1620 
    #
1621 
    #   Delete the created view
1622 
    #   Its just a directory, so delete it
1623 
    #
1624 
    if ( $data{ViewRoot} && -d $data{ViewRoot})
1625 
    {
2449 dpurdie 1626 
        if ( !$opt_reuse || ($rv && ($rv != 4 && $rv != 12 && $rv != 5 )) )
1340 dpurdie 1627 
        {
1628 
            Message ("Delete View: $data{ViewRoot}");
1629 
            RmDirTree ($data{ViewRoot} );
1630 
        }
1631 
        else
1632 
        {
1633 
            Message ("Retaining View: $data{ViewRoot}");
1634 
        }
1635 
 
392 dpurdie 1636 
    }
1340 dpurdie 1637 
    else
1638 
    {
1639 
        Message ("No view to delete");
1640 
    }
392 dpurdie 1641 
 
1642 
 
1643 
    #
1644 
    #   If this version has any 'ripples' then process them while we have the
1645 
    #   main view. Note the ripple list may contain entries that do not
1646 
    #   exist - they will have been pruned.
1647 
    #
2354 dpurdie 1648 
if(1) {
392 dpurdie 1649 
    foreach my $rentry ( @{$versions{$entry}{rippleList}} )
1650 
    {
1651 
        next unless( exists $versions{$rentry} );
1652 
 
1653 
        if ($versions{$rentry}{Processed})
1654 
        {
1655 
            Warning ("Ripple Processed before main entry");
1656 
            $versions{$rentry}{rippleProcessed} = 1;
1657 
        }
1658 
 
1659 
        Message ("Proccessing associated Ripple: " . GetVname($rentry));
1660 
        newPackageVersion($rentry);
1661 
    }
1662 
}
2029 dpurdie 1663 
}
392 dpurdie 1664 
 
1665 
#-------------------------------------------------------------------------------
1666 
# Function        : newPackageVersionBody
1667 
#
1668 
# Description     : Perform the bulk of the work in creating a new PackageVersion
1669 
#                   Designed to return on error and have error processing
1670 
#                   performed by caller
1671 
#
1672 
# Inputs          : $data               - Shared data
1673 
#                   $entry              - Package entry to process
1674 
#
1675 
# Returns         : Error Code
1676 
#                         0 - All is well
1272 dpurdie 1677 
#                       <10 - Recoverable error
2449 dpurdie 1678 
#                               1 - Bad VCS Tag
1679 
#                               2 - No Files in the extracted view
1680 
#                                   Label not found
1681 
#                                   Failed to extract files from CC
1682 
#                                   No Files in the extracted view after labeling dirs
1683 
#                               3 - Deadwood
1684 
#                               4 - Bad usage of ProjectBase detected
1685 
#                                   Use of MakeProject detected
1686 
#                               5  - Subversion Import disabled
392 dpurdie 1687 
#                       >10 - Fatal error
1688 
#
1689 
sub newPackageVersionBody
1690 
{
1691 
    my ($data, $entry) = @_;
1692 
    my $rv;
2476 dpurdie 1693 
    my $vcs_type;
392 dpurdie 1694 
    my $cc_label;
1695 
    my $cc_path;
2354 dpurdie 1696 
    my $cc_path_original;
392 dpurdie 1697 
 
1698 
    #
1699 
    #   Init Data
1700 
    #
1701 
    $data->{rmRef} = 'ERROR';
1702 
    $data->{tag} = '';
1703 
    $data->{ViewRoot} = undef;
1704 
    $data->{ViewPath} = undef;
1705 
    $data->{errStr} = '';
1706 
    $versions{$entry}{Processed} = 1;
1707 
 
1708 
 
1709 
    SystemConfig ('ExitOnError' => 0);
1710 
 
1711 
    push @processOrder, $entry;
1712 
    return 0 if ( $opt_test );
1713 
 
1714 
#   Keep DeadWood. May be a WIP
1715 
#    if ( exists $versions{$entry}{DeadWood} && $versions{$entry}{DeadWood} )
1716 
#    {
1717 
#        $data->{errStr} = 'Package is DeadWood';
1718 
#        return 3;
1719 
#    }
1720 
 
1721 
    #
1722 
    #   Determine version information
1723 
    #
1724 
    $data->{tag} = $versions{$entry}{vcsTag} || '';
1725 
    if ( $versions{$entry}{badVcsTag} )
1726 
    {
1727 
        Warning ("Error: Bad VcsTag for: " . GetVname($entry),
1728 
                 "Tag: $data->{tag}" );
1729 
        $data->{errStr} = 'VCS Tag Marked as Bad';
1730 
        return 1;
1731 
    }
1732 
 
1733 
 
1734 
    $data->{tag} =~ m~^(.+?)::(.*?)(::(.+))?$~;
2476 dpurdie 1735 
    $vcs_type = $1;
392 dpurdie 1736 
    $cc_label = $4;
1737 
    $cc_path = $2;
1738 
    $cc_path = '/' . $cc_path;
1739 
    $cc_path =~ tr~\\/~/~s;
2354 dpurdie 1740 
    $cc_path_original = $cc_path;
392 dpurdie 1741 
 
1742 
    #
2476 dpurdie 1743 
    #   Correct well known path mistakes in CC paths
392 dpurdie 1744 
    #
2476 dpurdie 1745 
    if ( $vcs_type eq 'CC' )
1746 
    {
1747 
        $cc_path =~ s~/build.pl$~~i;
1748 
        $cc_path =~ s~/src$~~i;
1749 
        $cc_path =~ s~/cpp$~~i;
1750 
        $cc_path =~ s~/MASS_Dev/Infra/~/MASS_Dev_Infra/~i;
1751 
        $cc_path =~ s~/MASS_Dev/Tools/~/MASS_Dev_Tools/~i;
1752 
        $cc_path =~ s~/MASS_Dev/Bus/~/MASS_Dev_Bus/~i;
1753 
        $cc_path =~ s~/MASS_Dev_Bus/Cbp/~/MASS_Dev_Bus/CBP/~i;
1754 
        $cc_path =~ s~/MREF_Package/ergpostmongui$~/MREF_Package/ergpostmongui~i;
1755 
        $cc_path =~ s~/MREF_../MREF_Package/~/MREF_Package/~i;
1756 
        $cc_path =~ s~/MREF_Package/mass_ergocdp/~/MREF_Package/ergocdp/~i;
1757 
        $cc_path =~ s~/MASS_Dev_Bus/CBP/systemCD.ejb~/MASS_Dev_Bus/CBP/systemCD/ejb~i;
1758 
        $cc_path =~ s~/MASS_Dev_Bus/Financial/cpp/paymentmanager~/MASS_Dev_Bus/Financial/cpp/paymentmanager~i;
1759 
        $cc_path =~ s~/MASS_Dev_Bus/WebServices~/MASS_Dev_Bus/WebServices~i;
1760 
        $cc_path =~ s~/MASS_Dev_Bus/CBP/nullAdapter~//MASS_Dev_Bus/CBP/nullAdaptor~i;
392 dpurdie 1761 
 
2476 dpurdie 1762 
        $cc_path = '/MASS_Dev_Bus' if ( $cc_path =~ m~/MASS_Dev_Bus/ImageCapture(/|$)~i );
1763 
        $cc_path = '/MASS_Dev_Bus/CBP/enquiry' if ( $versions{$entry}{name} eq 'EJBEnqPxyConnector');
1764 
        $cc_path = '/MASS_Dev_Bus/CBP/enquiry' if ( $versions{$entry}{name} eq 'proxyif4j');
1765 
        $cc_path = '/MASS_Dev_Bus' if ( $versions{$entry}{name} eq 'ImageCaptureTomcatDeployment');
1766 
        $cc_path = '/MASS_Dev_Bus/WebServices/MassWS' if ( $versions{$entry}{name} eq 'MassWebServicesImpl');
2489 dpurdie 1767 
        $cc_path = '/DPG_SWCode/projects/seattle/ddu' if ( $versions{$entry}{name} eq 'ddu_dog');
1197 dpurdie 1768 
 
2476 dpurdie 1769 
        if (   $versions{$entry}{name} =~ m/^ERGagency$/i
1770 
            || $versions{$entry}{name} =~ m/^ERGavm$/i
1771 
            || $versions{$entry}{name} =~ m/^ERGboi$/i
1772 
            || $versions{$entry}{name} =~ m/^ERGcallcenter$/i
1773 
            || $versions{$entry}{name} =~ m/^ERGcardholder$/i
1774 
            || $versions{$entry}{name} =~ m/^ERGcdaimports$/i
1775 
            || $versions{$entry}{name} =~ m/^ERGcda$/i
1776 
            || $versions{$entry}{name} =~ m/^ERGcscedit$/i
1777 
            || $versions{$entry}{name} =~ m/^ERGcs$/i
1778 
            || $versions{$entry}{name} =~ m/^ERGofs$/i
1779 
            || $versions{$entry}{name} =~ m/^ERGols$/i
1780 
            || $versions{$entry}{name} =~ m/^ERGtpf$/i
1781 
            || $versions{$entry}{name} =~ m/^ERGorasys$/i
1782 
            || $versions{$entry}{name} =~ m/^ERGoracs$/i
1783 
            || $versions{$entry}{name} =~ m/^ERGpxyif$/i
1784 
            || $versions{$entry}{name} =~ m/^ERGtp5upg$/i
1785 
            || $versions{$entry}{name} =~ m/^ERGinstitutional$/i
1786 
            || $versions{$entry}{name} =~ m/^ERGinfra$/i
1787 
            || $versions{$entry}{name} =~ m/^ERGcrrpts$/i
1788 
            || $versions{$entry}{name} =~ m/^ERGmiddle$/i
1789 
            || $versions{$entry}{name} =~ m/^ERGmiddleapi$/i
1790 
            || $versions{$entry}{name} =~ m/^ERGwebapi$/i
1791 
            || $versions{$entry}{name} =~ m/^ERGwebtestui$/i
1792 
            || $versions{$entry}{name} =~ m/^ERGwebesbui$/i
1793 
            || $versions{$entry}{name} =~ m/^ERGwspiv$/i
1794 
            || $versions{$entry}{name} =~ m/^ERGwscst$/i
1795 
            || $versions{$entry}{name} =~ m/^sposMUG$/i
1796 
            || $versions{$entry}{name} =~ m/^ERGfinman$/i
1797 
            || $versions{$entry}{name} =~ m/^ERGkm$/i
1798 
            || $versions{$entry}{name} =~ m/^ERGxml$/i
1799 
            || $versions{$entry}{name} =~ m/^ERGoradacw$/i
1800 
            || $versions{$entry}{name} =~ m/^ERGtru$/i
1801 
            )
2354 dpurdie 1802 
        {
1803 
            $cc_path = '/MREF_Package';
1804 
        }
1805 
 
2476 dpurdie 1806 
        if (   $versions{$entry}{name} =~ m/^tp5000_MUG$/i )
1807 
        {
1808 
            if ( $versions{$entry}{version} =~ m~vtk$~ )
1809 
            {
1810 
                $cc_path = '/MREF_Package';
1811 
            }
1812 
        }
1813 
 
1814 
        if ( $cc_path_original ne $cc_path )
1815 
        {
1816 
                Message ("Package: $versions{$entry}{name}. Forcing CC path to: $cc_path" );
1817 
        }
2354 dpurdie 1818 
    }
1819 
 
392 dpurdie 1820 
#print "--- Path: $cc_path, Label: $cc_label\n";
1821 
 
2476 dpurdie 1822 
    if ( $vcs_type eq 'SVN' )
1823 
    {
1824 
        $rv = extractFilesFromSubversion( $data, $entry );
1825 
        return $rv if ( $rv );
1826 
    }
1827 
    else
1828 
    {
1829 
        #
1830 
        #   Create CC view
1831 
        #   Import into Subversion View
1832 
        #
1833 
        $rv = extractFilesFromClearCase( $data, $cc_path, $cc_label );
1834 
        return $rv if ( $rv );
1835 
    }
1197 dpurdie 1836 
 
392 dpurdie 1837 
    #
1270 dpurdie 1838 
    #   Developers have been slack
1839 
    #       Sometime the mark the source path as 'GMTPE2005'
1840 
    #       Sometimes as 'GMTPE2005/Package/Fred/Jill/Harry'
1841 
    #
1842 
    #   Attempt to suck up empty directories below the specified
1843 
    #   source path
1844 
    #
2489 dpurdie 1845 
    unless ( $opt_preserveProjectBase || $opt_forceProjectBase )
1270 dpurdie 1846 
    {
1847 
        #
1848 
        #   Look in ViewPath
1849 
        #   If it contains only ONE directory then we can suck it up
1850 
        #
1851 
        my $testDir = findDirWithStuff( $data->{ViewPath} );
1328 dpurdie 1852 
 
1270 dpurdie 1853 
        unless ( $data->{ViewPath} eq $testDir  )
1854 
        {
1855 
            Message ("Adjust Base Dir: $testDir");
1856 
            $data->{adjustedPath} = $data->{ViewPath};
1857 
            $data->{ViewPath} = $testDir;
2476 dpurdie 1858 
            $adjustedPath++;
1270 dpurdie 1859 
        }
1860 
    }
2449 dpurdie 1861 
    Message ("BaseDir: $data->{ViewPath}");
2476 dpurdie 1862 
 
2424 dpurdie 1863 
    #
2476 dpurdie 1864 
    #   Check for bad source paths
1865 
    #
1866 
    if (detectBadMakePaths($data) )
1867 
    {
1868 
        unless ( $opt_ignoreBadPaths )
1869 
        {
1870 
            $data->{BadPath}++;
1871 
            $data->{errStr} = 'Bad Paths in Makefile';
1872 
            return 4;           # Lets see what the others look like too
1873 
#            return 14;
1874 
        }
1875 
    }
1876 
 
1877 
    #
2424 dpurdie 1878 
    #   Some really ugly packages make use of a Jats feature called 'SetProjectBase'
1879 
    #   Detect such packages as we will need to handle them differently
1880 
    #   Can't really handle it on the fly
1881 
    #   All we can do is detect it and report it - at the moment
1882 
    #
2449 dpurdie 1883 
    if (detectProjectBaseUsage($data) )
2424 dpurdie 1884 
    {
1885 
        unless ( $opt_ignoreProjectBaseErrors )
1886 
        {
1887 
            $data->{BadProjectBase}++;
1888 
            $data->{errStr} = 'Bad usage of ProjectBase detected';
1889 
            return 4;           # Lets see what the others look like too
1890 
#            return 14;
1891 
        }
1892 
    }
2393 dpurdie 1893 
 
1894 
    #
2424 dpurdie 1895 
    #   Some really really ugly packgaes make use of the MakeProject directive
1896 
    #   and then use an 'include.txt file to access paths all over the VOB
1897 
    #   The problem is with lines like
1898 
    #           /I ..\..\..\..\..\..\DPG_SWCode\projects\seattle\ddu\component\DTIApp\dsi\inc
1899 
    #   Two problems:
1900 
    #       Vob Name is not a part of the migration
1901 
    #       If we 'SuckUp' empty directories then this may break
1902 
    #       the pathing.
1903 
    #   All we can do is detect it and report it - at the moment
1904 
    #
2476 dpurdie 1905 
    if (detectMakeProjectUsage($data) )
2424 dpurdie 1906 
    {
1907 
        unless ( $opt_ignoreMakeProjectErrors )
1908 
        {
1909 
            $data->{BadMakeProject}++;
1910 
            $data->{errStr} = 'Use of MakeProject detected';
1911 
            return 4;           # Lets see what the others look like too
1912 
#            return 14;
1913 
        }
1914 
    }
1915 
 
1916 
    #
2393 dpurdie 1917 
    #   Some packages have filenames that are need to be converted
1918 
    #
1919 
    if ( $mustConvertFileNames  )
1920 
    {
1921 
        $rv = system ( '/home/dpurdie/svn/tools/convmv-1.15/convmv',
1922 
                 '-fiso-8859-1',
1923 
                 '-tutf8',
1924 
                 '-r',
1925 
                 '--notest',
1926 
                 $data->{ViewPath} );
1927 
 
1928 
        if ( $rv )
1929 
        {
1930 
            $data->{errStr} = 'Failed to convert filenames to UTF8';
1931 
            return 14;
1932 
        }
2412 dpurdie 1933 
 
1934 
        #
1935 
        #   Check to see if our ViewPath has been changed
1936 
        #   If so, then try to fix it
1937 
        #
1938 
        unless ( -d $data->{ViewPath} )
1939 
        {
1940 
            Message ("Correct UTF-8 change to ViewPath");
1941 
            $data->{ViewPath} = encode('UTF-8', $data->{ViewPath}, Encode::FB_DEFAULT);
1942 
            Warning ("Correct UTF-8 change to ViewPath - FAILED") unless ( -d $data->{ViewPath} );
1943 
        }
2393 dpurdie 1944 
    }
1270 dpurdie 1945 
 
1946 
    #
392 dpurdie 1947 
    #   Have a CC view
1948 
    #   Now we can create the SVN package and branching point before we
1949 
    #   import the CC data into SVN
1950 
    #
2449 dpurdie 1951 
    if ( !$opt_useSvn )
1952 
    {
2476 dpurdie 1953 
            $data->{errStr} = 'Subversion Import disabled' unless $data->{errStr};
2449 dpurdie 1954 
            return 5;
1955 
    }
1956 
 
392 dpurdie 1957 
    my @args;
1958 
 
1959 
    #
1960 
    #   Calculate args for functions
1961 
    #
1962 
    my $author = $versions{$entry}{created_id};
1963 
    if ( $author )
1964 
    {
1965 
        push @args, '-author', $author;
1966 
    }
1967 
    my $created = $versions{$entry}{created};
1968 
    if ( $created )
1969 
    {
1970 
        $created =~ s~ ~T~;
1971 
        $created .= '00000Z';
1972 
        push @args, '-date', $created;
1973 
    }
1974 
 
1975 
    my $log = $versions{$entry}{comment};
1976 
    if ( $log )
1977 
    {
1978 
        push @args, '-log', $log;
1979 
    }
1980 
 
1981 
    #
1982 
    #   Create package skeleton if needed
1983 
    #
1984 
    $rv = createPackage( $author, $created);
1985 
    if ( $rv )
1986 
    {
1987 
        $data->{errStr} = 'Failed to create Package';
1988 
        return 10;
1989 
    }
1990 
 
1991 
    #
1992 
    #   Calculate the label for the target package
1993 
    #   Use format <packageName>_<PackageVersion>
1994 
    #   Need to handle WIPs too.
1995 
    #
1996 
    my $import_label = saneLabel($entry);
1997 
 
1998 
    #
1999 
    #   May need to create the branchpoint
2000 
    #   The process is delayed until its needed so avoid creating unneeded
2001 
    #   branch points
2002 
    #
2003 
    if ( $createBranch )
2004 
    {
2005 
        $rv = createBranchPoint ($entry, $author, $created);
2006 
        $createBranch = 0;
2007 
        $createSuffix = 0;
2008 
        if ( $rv )
2009 
        {
2010 
            $data->{errStr} = 'Failed to create Branch Point';
2011 
            return 11;
2012 
        }
2013 
    }
2014 
    push @args, "-branch=$currentBranchName" if ( defined $currentBranchName );
2015 
 
2016 
    my $datafile = "importdata.$import_label.properties";
2017 
    $rv = JatsToolPrint ( 'jats_svn', 'import', '-reuse' ,
2018 
                    "-package=$svnRepo/$packageNames",
2019 
                    "-dir=$data->{ViewPath}",
2020 
                    "-label=$import_label",
2021 
                    "-datafile=$datafile",
2022 
                    @args,
2023 
                     );
2024 
 
2025 
    if ( $rv )
2026 
    {
2027 
        $data->{errStr} = 'Failed to import to SVN';
2028 
        return 12;
2029 
    }
2030 
 
2031 
    $versions{$entry}{TagCreated} = 1;
2032 
    $firstVersionCreated = $entry unless ( $firstVersionCreated );
2033 
 
2034 
    #
2035 
    #   Read in the Rm Reference
2036 
    #   Retain entries in a global file
2037 
    #
2038 
    if ( -f $datafile  )
2039 
    {
2040 
        my $rmData = JatsProperties::New($datafile);
2041 
        $data->{rmRef} = 'SVN::' . $rmData->getProperty('subversion.tag');
2042 
    }
2043 
 
2044 
    unless ( $data->{rmRef}  )
2045 
    {
1272 dpurdie 2046 
        $data->{errStr} = 'Failed to determine Rm Reference';
392 dpurdie 2047 
        return 13;
2048 
    }
2049 
 
1380 dpurdie 2050 
######################## Deleted ###############################################
2051 
#
2052 
#
2053 
#    #
2054 
#    #   Add supplemental tags if this version is in a 'Release'
2055 
#    #   But only for some packages - else looks like a mess
2056 
#    #   Just a solution for the ITSO guys
2057 
#    #
2058 
#    foreach my $rtag_id ( keys %{$versions{$entry}{Releases}}  )
2059 
#    {
2060 
#        next unless ( $svnRepo =~ m~/ITSO_TRACS(/|$)~);
2061 
#
2062 
#        my $prog_id = $versions{$entry}{Releases}{$rtag_id}{proj_id};
2063 
#        Message ("Adding Release Tag:$prog_id:$rtag_id");
2064 
#
2065 
#        my $rtext = 'Release_' . saneString($versions{$entry}{Releases}{$rtag_id}{rname});
2066 
#        my @comment;
2067 
#        push @comment, "Tagged by ClearCase to Subversion import";
2068 
#        push @comment, "Project:$prog_id:$versions{$entry}{Releases}{$rtag_id}{pname}";
2069 
#        push @comment, "Release:$rtag_id:$versions{$entry}{Releases}{$rtag_id}{rname}";
2070 
#
2071 
#        $data->{ReleaseTag}{$prog_id}{$rtag_id}{name} = $rtext;
2072 
#
2073 
#        $rv = JatsToolPrint ( 'jats_svnlabel' ,
2074 
#                    '-comment', encode('UTF-8', join("\n", @comment), Encode::FB_DEFAULT),
2075 
#                    $data->{rmRef},
2076 
#                    '-clone',
2077 
#                    $rtext,
2078 
##                    @args,
2079 
#                    '-author=buildadm',
2080 
#                     );
2081 
#        $data->{ReleaseTag}{$prog_id}{$rtag_id}{eState} = $rv;
2082 
#        $data->{ReleaseTag}{tCount}++;
2083 
#
2084 
#        if ( $rv )
2085 
#        {
2086 
#            $data->{ReleaseTag}{eCount}++;
2087 
#            Warning("Failed to add Release Tag: $rtext");
2088 
#        }
2089 
#    }
2090 
#
2091 
######################## Deleted ###############################################
1341 dpurdie 2092 
 
392 dpurdie 2093 
    Message ("RM Ref: $data->{rmRef}");
2094 
    unlink $datafile;
2095 
 
2096 
    #
2097 
    #   All is good
2098 
    #
2099 
    $data->{errStr} = '';
2100 
    return 0;
2101 
}
2102 
 
2103 
 
2104 
#-------------------------------------------------------------------------------
2105 
# Function        : newProject
2106 
#
2107 
# Description     : Start a new project within a package
2108 
#
2109 
# Inputs          :
2110 
#
2111 
# Returns         :
2112 
#
2113 
sub newProject
2114 
{
2115 
#    Message ("---- New Project");
2116 
    $createSuffix = 0;
2117 
 
2118 
    #
2119 
    #   New project
2120 
    #   Kill the running import directory
2121 
    #
2122 
    RmDirTree ('SvnImportDir');
2123 
}
2124 
 
2125 
#-------------------------------------------------------------------------------
2126 
# Function        : newPackage
2127 
#
2128 
# Description     : Start processing a new package
2129 
#
2130 
# Inputs          :
2131 
#
2132 
# Returns         :
2133 
#
2134 
my $createPackageDone;
2135 
sub newPackage
2136 
{
2137 
#    Message( "---- New Package");
2138 
 
2139 
    #
2140 
    #   Create a package specific log file
2141 
    #
2142 
    $logSummary = $packageNames . ".summary.log";
2143 
    unlink $logSummary;
2144 
    Message( "PackageName: $packageNames");
2145 
    $createPackageDone = 1;
2146 
    $createBranch = 0;
2147 
    $createSuffix = 0;
2148 
 
2149 
    #
2150 
    #   First entry being created
2151 
    #   Prime the work area
2152 
    #
2153 
    RmDirTree ('SvnImportDir');
2154 
}
2155 
 
2156 
#-------------------------------------------------------------------------------
2157 
# Function        : createPackage
2158 
#
2159 
# Description     : Create a new Package in SVN
2160 
#                   Called before any serious SVN operation to ensure that the
2161 
#                   package has been created. Don't create a package until
2162 
#                   we expect to put something into it.
2163 
#
2164 
#                   Will only create a package once
2165 
 
2166 
#
2167 
# Inputs          : $author         - Who done it
2168 
#                   $date           - When
2169 
#
2170 
# Returns         :
2171 
#
2172 
sub createPackage
2173 
{
2174 
    my ($author, $date) = @_;
2175 
    my @opts;
2176 
    push (@opts, '-date', $date) if ( $date );
2177 
    push (@opts, '-author', $author) if ( $author );
2178 
    #
2179 
    #   Only do once
2180 
    #
2181 
    return unless ( $createPackageDone );
2182 
    $createPackageDone = 0;
2183 
 
1197 dpurdie 2184 
    #
2185 
    #   Real import
2186 
    #       Do not Delete package if it exists
2187 
    #       Package must NOT exist
2188 
    #
392 dpurdie 2189 
    Message ("Creating new SVN package: $packageNames");
1270 dpurdie 2190 
    if ( $opt_delete )
2191 
    {
2192 
        Message ("Delete existing version of package: $packageNames");
2193 
        JatsToolPrint ( 'jats_svn', 'delete-package', '-noerror',  "$svnRepo/$packageNames" );
2194 
    }
1197 dpurdie 2195 
    JatsToolPrint ( 'jats_svn', 'create', "$svnRepo/$packageNames", '-new', @opts );
392 dpurdie 2196 
}
2197 
 
2198 
 
2199 
#-------------------------------------------------------------------------------
2200 
# Function        : createBranchPoint
2201 
#
2202 
# Description     : Create a branch point for the current work
2203 
#                   Perform the calculation to determine the details of
2204 
#                   the branch point. The work will only be done when its
2205 
#                   needed. This will avoid the creation of branchpoints
2206 
#                   that are not used.
2207 
#
2208 
# Inputs          : $entry                  Entry being processed
2209 
#                   $author         - Who done it
2210 
#                   $date           - When
2211 
#
2212 
# Returns         :
2213 
#
2214 
sub createBranchPoint
2215 
{
2216 
    my ($entry, $author, $date) = @_;
2217 
    my $forceNewProject;
2218 
 
2219 
#    Message ("---- Create Branch Point");
2220 
 
2221 
    #
2222 
    #   Find previous good tag
2223 
    #   We are walking a tree so something should have been created, but
2224 
    #   the one we want may have had an error
2225 
    #
2226 
    #   Walk backwards looking for one that has been created
2227 
    #
2228 
    my $last = $versions{$entry}{last};
2229 
    while ( $last )
2230 
    {
2231 
        unless ( $versions{$last}{TagCreated} )
2232 
        {
2233 
            $last = $versions{$last}{last};
2234 
        }
2235 
        else
2236 
        {
2237 
            last;
2238 
        }
2239 
    }
2240 
 
2241 
    #
2242 
    #   If we have walked back to the base of the tree
2243 
    #   If we transferred any software at all, then use the first
2244 
    #   version as the base for this disconnected version
2245 
    #
2246 
    #   Otherwise we create a new, and empty, view
2247 
    #
2248 
    unless ( $last )
2249 
    {
2250 
        if ( $firstVersionCreated )
2251 
        {
2252 
            Warning ("Cannot find previous version to branch. Use first version");
2253 
            $last = $firstVersionCreated;
2254 
        }
2255 
        else
2256 
        {
2257 
            Warning ("Forcing First instance of a Project");
2258 
            $forceNewProject = 1;
2259 
        }
2260 
    }
2261 
 
2262 
    #
2263 
    #   Determine source name
2264 
    #   This MUST have been created before we can branch
2265 
    #
2266 
    my $src_label;
2267 
    $src_label = saneLabel($last) if $last;
2268 
 
2269 
    #
2270 
    #   Create target name
2271 
    #
2272 
    my $tgt_label;
2273 
    if ( $forceNewProject || $versions{$entry}{newSuffix} || $createSuffix || !defined $src_label )
2274 
    {
2275 
        #
2276 
        #   Create target name based on project
2277 
        #
2278 
        return if ( $singleProject );
2279 
 
2280 
        my $suffix = $versions{$entry}{suffix};
2281 
        if ( $suffix )
2282 
        {
2283 
            Error ("Unknown Project: $suffix") unless ( defined $Projects{$suffix} );
2284 
 
2285 
            #
2286 
            #   If this project can be considered to be a truck, then 'claim' the
2287 
            #   truck for the first created element.
2288 
            #
2289 
            if ( $Projects{$suffix}{Trunk} )
2290 
            {
2291 
                # This project can use the trunk, if it has not been allocated.
2292 
                $ProjectTrunk = $suffix unless ( defined $ProjectTrunk );
2293 
 
2294 
                #
2295 
                #   If this package has multiple instances of the potential
2296 
                #   trunk, then don't place either of them on the trunk as it
2297 
                #   may cause confusion
2298 
                #
2299 
                if ($knownProjects{$suffix}{count} < 2 )
2300 
                {
2301 
                    if ( $suffix eq $ProjectTrunk )
2302 
                    {
2303 
                        return unless $currentBranchName;
2304 
                    }
2305 
                }
2306 
            }
2307 
 
2308 
            $tgt_label = $Projects{$suffix}{Name};
2309 
            $tgt_label = $versions{$entry}{name} . '_' . $tgt_label if ($multiPackages);
2310 
            if ( !exists $ProjectsBaseCreated{$tgt_label}  )
2311 
            {
2312 
                $ProjectsBaseCreated{$tgt_label} = 1;
2313 
            }
2314 
            else
2315 
            {
2316 
                #   Project Base Already taken
2317 
                #   Have disjoint starting points
2318 
                $tgt_label .= '.' . $ProjectsBaseCreated{$tgt_label} ++;
2319 
            }
2320 
        }
2321 
        else
2322 
        {
2323 
            #
2324 
            #   No suffix in use
2325 
            #
2326 
            #   Currently not handled
2327 
            #   May have to force the use of the trunk
2328 
            #
2329 
            Error ("INTERNAL ERROR: No suffix present");
2330 
        }
2331 
    }
2332 
    else
2333 
    {
2334 
        $tgt_label = saneLabel($entry, $src_label . '_for_');
2335 
    }
2336 
 
2337 
    #
2338 
    #   Save branch name for use when populating sandbox
2339 
    #
2340 
    $currentBranchName = $tgt_label;
2341 
 
2342 
    #
2343 
    #   Perform the branch
2344 
    #
2345 
    if ( defined $src_label )
2346 
    {
1328 dpurdie 2347 
        #
1341 dpurdie 2348 
        #   The 'clone' operation will backtrack the branch point
2349 
        #   to the source of the label. This will make the output version
2350 
        #   tree much prettier
1328 dpurdie 2351 
        #
392 dpurdie 2352 
        my @opts;
2353 
        push (@opts, '-date', $date) if ( $date );
2354 
        push (@opts, '-author', $author) if ( $author );
2355 
 
2356 
        JatsToolPrint ( 'jats_svnlabel',
2357 
                        '-packagebase', "$svnRepo/$packageNames",
1341 dpurdie 2358 
                        'tags/' . $src_label,
392 dpurdie 2359 
                        '-branch',
2360 
                        '-clone', $tgt_label,
2361 
                        @opts
2362 
                      );
2363 
    }
2364 
}
2365 
 
2366 
 
2367 
#-------------------------------------------------------------------------------
2368 
# Function        : endPackage
2369 
#
2370 
# Description     : End of package processing
2371 
#                   Clean up and display problems
2372 
#
2373 
# Inputs          :
2374 
#
2375 
# Returns         :
2376 
#
2377 
sub endPackage
2378 
{
2354 dpurdie 2379 
    Message ("-- Import Summary ------------------------------------------------" );
392 dpurdie 2380 
    RmDirTree ('SvnImportDir');
2476 dpurdie 2381 
    my $processedCount = 0;
2382 
    my $inernalErrorCount = 0;
2383 
    my $notProcessedCount = 0;
2384 
    my $badPathCount = 0;
2385 
    my $badProjectBaseCount = 0;
2386 
    my $badMakeProjectCount = 0;
392 dpurdie 2387 
 
2388 
    #
2389 
    #   Display versions that did get captured
2390 
    #
2391 
    foreach my $entry ( @processOrder )
2392 
    {
2393 
        $versions{$entry}{Scanned} = 1;
2394 
        next unless ( $versions{$entry}{TagCreated} );
2395 
        Warning ("Processed: " . GetVname($entry) . ' :: ' . $versions{$entry}{rmRef} || $versions{$entry}{errStr} || '???' );
2396 
    }
2397 
 
2398 
    #
2399 
    #   Display versions that did not get created
2400 
    #
2401 
    foreach my $entry ( @processOrder )
2402 
    {
2403 
        $versions{$entry}{Scanned} = 1;
2476 dpurdie 2404 
        if ( $versions{$entry}{TagCreated} )
2405 
        {
2406 
            $processedCount++;
2407 
            $badPathCount++ if ($versions{$entry}{data}{BadPath} );
2408 
            $badProjectBaseCount++ if ($versions{$entry}{data}{BadProjectBase} );
2409 
            $badMakeProjectCount++ if ($versions{$entry}{data}{BadMakeProject} );
2410 
            next;
2411 
        }
2412 
 
2354 dpurdie 2413 
        my $reason = $versions{$entry}{data}{errStr} || '';
2414 
        my $tag = $versions{$entry}{vcsTag}|| 'No Tag';
2415 
        Warning ("Not Processed: " . GetVname($entry) . ':' . $tag . ' : ' . $reason );
2476 dpurdie 2416 
        $notProcessedCount++;
392 dpurdie 2417 
    }
2418 
 
2419 
    foreach my $entry ( keys(%versions) )
2420 
    {
2421 
        next if ( $versions{$entry}{Scanned} );
2422 
        Warning ("(E) INTERNAL ERROR. Package Not Processed: " . GetVname($entry) );
2476 dpurdie 2423 
        $inernalErrorCount++;
392 dpurdie 2424 
    }
2425 
 
2476 dpurdie 2426 
    if ( $adjustedPath || 1 )
2427 
    {
2428 
        Information ("Package Paths");
2429 
        foreach my $entry ( @processOrder )
2430 
        {
2431 
            my $viewPath = $versions{$entry}{data}{ViewPath} || '';
2432 
            Information (sprintf "ViewPath: %20s : %s", GetVname($entry), $viewPath);
2433 
        }
2434 
    }
2435 
 
2436 
    Message ("Packages processed: $processedCount");
2437 
    Warning ("Packages not processed: $notProcessedCount") if ( $notProcessedCount );
2438 
    Warning ("Internal Errors: $inernalErrorCount") if ( $inernalErrorCount );
2401 dpurdie 2439 
    Message ("Packages Relabled: $packageReLabelCount") if ( $packageReLabelCount );
2476 dpurdie 2440 
    Warning ("Packages with Bad Paths: $badPathCount") if ( $badPathCount );
2441 
    Warning ("Packages with Bad ProjectBase: $badProjectBaseCount") if ( $badProjectBaseCount );
2442 
    Warning ("Packages with MakeProjects: $badMakeProjectCount") if ( $badMakeProjectCount );
2443 
    Warning ("Global Error Detected") if ( $globalError );
392 dpurdie 2444 
    Message ("All Done");
2445 
}
2446 
 
1197 dpurdie 2447 
#-------------------------------------------------------------------------------
2401 dpurdie 2448 
# Function        : extractFilesFromClearCase
2449 
#
2450 
# Description     : Extract files from ClearCase
2451 
#                   May take a while as we handle nasty errors
2452 
#
2453 
# Inputs          : $data           - Hash of good stuff from newPackageVersionBody
2454 
#                   $cc_path
2455 
#                   $cc_label
2456 
#
2457 
# Returns         : exit code
2458 
#                   Sets up
2459 
#                       $data->{errStr}
2460 
#                       $data->{errCode}
2461 
#                   As per newPackageVersionBody
2462 
#
2463 
sub extractFilesFromClearCase
2464 
{
2465 
    my ($data, $cc_path, $cc_label) = @_;
2466 
    my $tryCount = 0;
2467 
    my $rv = 99;
2468 
 
2469 
    $data->{ViewRoot} = $opt_name ? $opt_name : "$cc_label";
2470 
    $data->{ViewPath} =  $data->{ViewRoot} . $cc_path;
2471 
 
2472 
    if ( $opt_preserveProjectBase )
2473 
    {
2474 
        my $cc_vob = $cc_path;
2475 
        $cc_vob =~ s~^/~~;
2476 
        $cc_vob =~ s~/.*~~;
2477 
        $data->{ViewPath} =  $data->{ViewRoot} . '/' . $cc_vob;
2478 
        Message ("Preserving Project Base");
2479 
    }
2480 
    $data->{ViewPath} =~  tr~/~/~s;
2481 
 
2482 
    if ( $opt_reuse && -d $data->{ViewPath}  )
2483 
    {
2484 
        Message ("Reusing view: $cc_label");
2485 
        return 0;
2486 
    }
2487 
 
2488 
    while ( $rv == 99 ) {
2489 
        my @args;
2490 
        push (@args, '-view', $opt_name ) if ( defined $opt_name );
2491 
        $rv = JatsToolPrint ( 'jats_ccrelease', '-extractfiles', '-root=.' , '-noprefix',
2492 
                    "-label=$cc_label" ,
2493 
                    "-path=$cc_path",
2494 
                    @args
2495 
                    );
2496 
 
2497 
        if ( $rv == 10 ) {
2498 
 
2499 
            #
2500 
            #   No files found
2501 
            #   If this is the first time then try really hard to find them
2502 
            #
2503 
            unless ( $tryCount++ )
2504 
            {
2403 dpurdie 2505 
                if ( $opt_relabel )
2506 
                {
2507 
                    $packageReLabelCount++;
2508 
                    $rv = JatsToolPrint('cc2svn_labeldirs',
2509 
                                            '-vob', $cc_path,
2510 
                                            $cc_label,
2511 
                                            );
2512 
                    $data->{DirsLabled} = 100 + $rv;
2513 
                }
2401 dpurdie 2514 
 
2515 
                #
2516 
                #   Second attempt - massage the users path
2517 
                #   We should have labled up to the VOB root so lets
2518 
                #   just use the VOB and not the path
2519 
                #
2403 dpurdie 2520 
                #   If we are not relabeling then we can still do this
2521 
                #   in an attempt to fix user stupidity
2522 
                #
2401 dpurdie 2523 
                $cc_path =~ s~^/~~;
2524 
                $cc_path =~ s~/.*~~;
2525 
                $cc_path = '/' . $cc_path;
2526 
                $data->{ViewPath} =  $data->{ViewRoot} . $cc_path;
2527 
                redo;
2528 
            }
2529 
 
2530 
            $data->{errStr}  = 'No Files in the extracted view';
2531 
            $data->{errCode} = '0';
2532 
            return 2;
2533 
        }
2534 
        elsif ( $rv == 11 ) {
2535 
            $data->{errStr} = 'Label not found';
2536 
            $data->{errCode} = 'L';
2537 
            return 2;
2538 
        }
2539 
 
2540 
        unless ( -d $data->{ViewPath}  )
2541 
        {
2542 
            $data->{errStr} = 'Failed to extract files from CC';
2543 
            return 2;
2544 
        }
2545 
 
2546 
        #
2547 
        #   Looks good
2548 
        #
2549 
        return 0;
2550 
    };
2551 
 
2552 
    $data->{errStr}  = 'No Files in the extracted view after labeling dirs';
2553 
    $data->{errCode} = '0';
2554 
    return 2;
2555 
 
2556 
}
2557 
 
2558 
#-------------------------------------------------------------------------------
2476 dpurdie 2559 
# Function        : extractFilesFromSubversion
2560 
#
2561 
# Description     : Extract files from Subversion
2562 
#                   May take a while as we handle nasty errors
2563 
#
2564 
# Inputs          : $data           - Hash of good stuff from newPackageVersionBody
2565 
#                   $entry          - All the PV information
2566 
#
2567 
# Returns         : exit code
2568 
#                   Sets up
2569 
#                       $data->{errStr}
2570 
#                       $data->{errCode}
2571 
#                   As per newPackageVersionBody
2572 
#
2573 
sub extractFilesFromSubversion
2574 
{
2575 
    my ($data, $entry ) = @_;
2576 
    my $tryCount = 0;
2577 
    my $rv = 99;
2578 
 
2579 
    #
2580 
    #   Create a nice name for the import
2581 
    #
2582 
    my $import_label = saneLabel($entry);
2583 
 
2584 
 
2585 
    $data->{ViewRoot} = $opt_name ? $opt_name : $import_label;
2586 
    $data->{ViewPath} =  $data->{ViewRoot};
2587 
    $data->{ViewPath} =~  tr~/~/~s;
2588 
 
2589 
    if ( $opt_reuse && -d $data->{ViewPath}  )
2590 
    {
2591 
        Message ("Reusing view: $import_label");
2592 
        return 0;
2593 
    }
2594 
 
2595 
    #
2596 
    #   Only allow import from SVN if asked nicely
2597 
    #   May be used if we are correcting a package - and some have been
2598 
    #   placed in SVN
2599 
    #
2600 
    unless ( $opt_extractFromSvn )
2601 
    {
2602 
        $data->{errStr} = 'Some Packages are in SVN';
2603 
        return 15;
2604 
    }
2605 
 
2606 
 
2607 
#print "--- ViewRoot: $data->{ViewPath}\n";
2608 
    $rv = JatsToolPrint ( 'jats_svnrelease',
2609 
                          '-extractfiles',
2610 
                          '-root=.' ,
2611 
                          '-noprefix',
2612 
                          '-DevMode=escrow',
2613 
                          '-label', $data->{tag},
2614 
                          '-view', $data->{ViewPath},
2615 
                );
2616 
 
2617 
    if ( $rv == 10 ) {
2618 
        $data->{errStr}  = 'No Files in the extracted view';
2619 
        $data->{errCode} = '0';
2620 
        return 2;
2621 
 
2622 
    } elsif ( $rv == 11 ) {
2623 
        $data->{errStr} = 'Label not found';
2624 
        $data->{errCode} = 'L';
2625 
        return 2;
2626 
    } elsif ( $rv ) {
2627 
        $data->{errStr} = 'Subversion reported error';
2628 
        return 2;
2629 
    }
2630 
 
2631 
    unless ( -d $data->{ViewPath}  )
2632 
    {
2633 
        $data->{errStr} = 'Failed to extract files from Subversion';
2634 
        return 2;
2635 
    }
2636 
 
2637 
    #
2638 
    #   Looks good
2639 
    #
2640 
    return 0;
2641 
}
2642 
 
2643 
#-------------------------------------------------------------------------------
2424 dpurdie 2644 
# Function        : detectMakeProjectUsage
2645 
#
2646 
# Description     : etect and report usage of the MakeProject directive
2647 
#
2648 
# Inputs          : $data               - Ref to a hash of bits
2649 
#
2650 
# Returns         : true    - Bad usage (Really good usage not detected)
2651 
#                   false   - Good usage detected
2652 
#
2653 
sub detectMakeProjectUsage
2654 
{
2476 dpurdie 2655 
    my ($data) = @_;
2424 dpurdie 2656 
    my $retval = 0;
2657 
    my $eSuf = $opt_ignoreMakeProjectErrors ? '' : 'Error';
2658 
 
2659 
    #
2660 
    #   Find makefile.pl
2661 
    #
2476 dpurdie 2662 
    Message ("Detect MakeProject Usage");
2424 dpurdie 2663 
    my $usesMakeProject = 0;
2664 
    my $badIncludeFile = 0;
2665 
 
2666 
    my $search = JatsLocateFiles->new("--Recurse=1",
2667 
                                       "--FilterIn=makefile.pl",
2668 
                                       );
2669 
    my @makefiles = $search->search($data->{ViewRoot});
2670 
    foreach my $file ( @makefiles )
2671 
    {
2672 
#print "---Reading: $workDir/$data->{ViewRoot}/$file\n";
2673 
        if ( open( my $fh, '<', "$data->{ViewRoot}/$file" ) )
2674 
        {
2675 
            my $eof = 0;
2676 
            my $line = '';
2677 
            until ( $eof )
2678 
            {
2679 
                my $in = <$fh>;
2680 
                unless ( defined $in )
2681 
                {
2682 
                    $eof = 1;
2683 
                }
2684 
                else
2685 
                {
2686 
                $in =~ s~\s+$~~;
2687 
                $in =~ s~^\s+~~;
2688 
                $in =~ s~^#.*$~~;
2689 
                $in =~ s~\s*[^\$]#.*$~~;
2690 
                $line .= ' ' if ( $line );
2691 
                $line .= $in;
2692 
                $line =~ s~\s+~ ~g;
2693 
#print "====== '$line'\n";
2694 
                redo unless ( $line =~ m~;$~  );
2695 
                }
2696 
#print "---- $line\n";
2697 
                if ( $line =~ m~^MakeProject~ )
2698 
                {
2699 
                    $usesMakeProject++;
2700 
                    $data->{UsesMakeProject}++;
2701 
                    Warning ("Package uses MakeProject:",
2702 
                             "Line: " . $line,
2703 
                             "Root: " . "$data->{ViewRoot}",
2704 
                             "File: " . "$data->{ViewRoot}/$file",
2705 
                            );
2706 
 
2707 
                    #
2708 
                    #   Extract out the project name
2709 
                    #
2710 
                    my @myArgs;
2711 
                    my $myProjectDir;
2712 
                    my $myProject = "$data->{ViewRoot}/$file";
2713 
                    $myProject =~ s~/[^/]+$~~;
2714 
                    $line =~ s~MakeProject~push \@myArgs,~;
2715 
                    eval $line;
2716 
                    Error("Line did not compiler: $line", "Err: $@" ) if ($@);
2717 
                    shift @myArgs;
2718 
                    foreach ( @myArgs )
2719 
                    {
2720 
                        next if ( m~^--~ );
2721 
                        $myProject .= '/' . $_;
2722 
                        $myProjectDir = $myProject;
2723 
                        $myProjectDir =~ s~/[^/]+$~~;
2724 
                        last;
2725 
                    }
2726 
                    Error ("No project Found") unless ( defined $myProjectDir);
2476 dpurdie 2727 
 
2728 
                    #
2729 
                    #   Look for 'include.txt' that may be bwteen the makefile and the project
2730 
                    #
2731 
 
2732 
 
2424 dpurdie 2733 
                    if ( -f "$myProjectDir/include.txt" )
2734 
                    {
2735 
                        Warning ("Co-located 'include.txt' file also found");
2736 
                    }
2737 
 
2738 
                    # The only problem is if the include.txt file
2739 
                    # escapes from the VOB - or even uses the vob root
2740 
                    #
2741 
                    # Examine the include file
2742 
                    # Expect it to look like
2743 
                    #   /I Path
2744 
                    #
2745 
 
2746 
                    #
2747 
                    #   Determine safe level
2748 
                    #   Relative to the include file
2749 
                    #
2750 
                    my $depthPath = $myProjectDir;
2751 
                    my $depth = 0;
2752 
                    Error ("Expect this to work") unless ( $depthPath =~ s~^$data->{ViewRoot}/~~ );
2753 
                    foreach ( split('/', $depthPath) )
2754 
                    {
2755 
                        if ( $_ eq '..' ) {
2756 
                            $depth--;
2757 
                        } else {
2758 
                            $depth++;
2759 
                        }
2760 
                    }
2761 
#print "Depth: $depth, $depthPath\n";
2762 
 
2763 
                    if ( open( my $if, '<', "$myProjectDir/include.txt" ) )
2764 
                    {
2765 
                        while ( <$if> )
2766 
                        {
2767 
                            s~\s+$~~;
2768 
                            s~^\s+~~;
2769 
                            next unless ( $_ );
2770 
                            if ( m~/I\s+(.*)~ )
2771 
                            {
2772 
                                my $path = $1;
2773 
                                $path =~ tr~\\/~/~s;
2774 
                                $path =~ s~\\~/~g;
2775 
#print "Examine: $path\n";
2776 
                                my $minLevel = 0;
2777 
                                my $level = 0;
2778 
                                foreach ( split('/', $path) )
2779 
                                {
2780 
                                    if ( $_ eq '..' )
2781 
                                    {
2782 
                                        $level--;
2783 
                                        $minLevel = $level if ($level < $minLevel);
2784 
                                    }
2785 
                                    else
2786 
                                    {
2787 
                                        $level++;
2788 
                                    }
2789 
                                }
2790 
#print "Min: $minLevel, $level, ($depth + $minLevel)\n";
2791 
                                if ( $depth + $minLevel <= 0)
2792 
                                {
2793 
                                    $badIncludeFile++;
2794 
                                    Warning ("Included path escapes package:",
2795 
                                             "Line: " . $_,
2796 
                                             "File: " . "$myProjectDir/include.txt",
2797 
                                            );
2798 
                                    last;
2799 
                                }
2800 
                            }
2801 
                        }
2802 
                        close $if;
2803 
                    }
2804 
 
2805 
                }
2806 
                $line = '';
2807 
            }
2808 
            close $fh;
2809 
        }
2810 
        else
2811 
        {
2812 
            Warning ("MakeProject$eSuf - Cannot open makefile: $file");
2813 
            $retval = 1;
2814 
        }
2815 
    }
2816 
 
2817 
    #
2818 
    #   Used
2819 
    #   May be improved latter
2820 
    #
2821 
    if ( $usesMakeProject && $badIncludeFile)
2822 
    {
2823 
        Warning ("MakeProject$eSuf - Problem detected");
2824 
        $retval = 1;
2825 
    }
2826 
 
2827 
    #
2828 
    #   Until we have more faith in the detection algorithm
2829 
    #
2830 
    if ( $usesMakeProject )
2831 
    {
2832 
        Warning ("MakeProject$eSuf - Makeproject used. Must check manually");
2833 
        $retval = 1;
2834 
    }
2835 
 
2836 
    return $retval;
2837 
}
2838 
 
2839 
#-------------------------------------------------------------------------------
2476 dpurdie 2840 
# Function        : detectBadMakePaths
2841 
#
2842 
# Description     : Detect and report bad usage of some directives
2843 
#
2844 
# Inputs          : $data               - Ref to a hash of bits
2845 
#
2846 
# Returns         : true    - Bad usage (Really good usage not detected)
2847 
#                   false   - Good usage detected
2848 
#
2849 
sub detectBadMakePaths
2850 
{
2851 
    my ($data) = @_;
2852 
    my $retval = 0;
2853 
    my $eSuf = $opt_ignoreBadPaths ? '' : 'Error';
2854 
 
2855 
    #
2856 
    #   Find makefile.pl
2857 
    #
2858 
    Message ("Detect Bad Source Paths");
2859 
    my $badPath = 0;
2860 
 
2861 
    my $search = JatsLocateFiles->new("--Recurse=1",
2862 
                                       "--FilterIn=makefile.pl",
2863 
                                       );
2864 
    my @makefiles = $search->search($data->{ViewPath});
2865 
    foreach my $file ( @makefiles )
2866 
    {
2867 
        $file =~ tr~/~/~s;
2868 
        my $max_up = ($file =~ tr~/~/~);
2869 
        my $shownPath;
2870 
#print "---Reading: $workDir/$data->{ViewPath}/$file\n";
2871 
        if ( open( my $fh, '<', "$data->{ViewPath}/$file" ) )
2872 
        {
2873 
            my $eof = 0;
2874 
            my $line = '';
2875 
 
2876 
            until ( $eof )
2877 
            {
2878 
                my $in = <$fh>;
2879 
                unless ( defined $in )
2880 
                {
2881 
                    $eof = 1;
2882 
                }
2883 
                else
2884 
                {
2885 
                $in =~ s~\s+$~~;
2886 
                $in =~ s~^\s+~~;
2887 
                $in =~ s~^#.*$~~;
2888 
                $in =~ s~\s*[^\$]#.*$~~;
2889 
                $line .= ' ' if ( $line );
2890 
                $line .= $in;
2891 
                $line =~ s~\s+~ ~g;
2892 
#print "====== '$line'\n";
2893 
                redo unless ( $line =~ m~;$~  );
2894 
                }
2895 
                if ( $line =~ m~^AddDir~ || $line =~ m~^AddSrcDir~ || $line =~ m~^AddIncDir~ || $line =~ m~^Src~ )
2896 
                {
2897 
                    #
2898 
                    #   Extract out the arguments
2899 
                    #
2900 
                    my @myArgs;
2901 
                    my $myProjectDir;
2902 
                    my $myProject = "$data->{ViewRoot}/$file";
2903 
                    $myProject =~ s~/[^/]+$~~;
2904 
                    $line =~ s~.*\(~push \@myArgs, (~;
2905 
                    eval $line;
2906 
                    Error("Line did not compiler: $line", "Err: $@" ) if ($@);
2907 
                    shift @myArgs;
2908 
                    foreach ( @myArgs )
2909 
                    {
2910 
                        next if ( m~^--~ );
2911 
                        next unless ( m~^\.\./~ );
2912 
                        my $tmp = $_;
2913 
                        $tmp =~ s~Z~z~g;
2914 
                        $tmp =~ s~\.\./~Z~g;
2915 
                        my $upCount = ( $tmp =~ tr~Z~Z~ );
2916 
                        if ( $upCount > $max_up )
2917 
                        {
2918 
                            Warning ("Makefile Path: $file ") unless $shownPath;
2919 
                            Warning ("Path escapes view: $max_up, $upCount, $_");
2920 
                            $badPath++;
2921 
                            $shownPath = 1;
2922 
                        }
2923 
#print "---x Path : $max_up, $upCount, $_\n";
2924 
                    }
2925 
                }
2926 
                $line = '';
2927 
            }
2928 
            close $fh;
2929 
        }
2930 
        else
2931 
        {
2932 
            Warning ("detectBadMakePaths$eSuf - Cannot open makefile: $file");
2933 
            $retval = 1;
2934 
        }
2935 
    }
2936 
 
2937 
    #
2938 
    #   Used
2939 
    #   May be improved latter
2940 
    #
2941 
    if ( $badPath )
2942 
    {
2943 
        Warning ("detectBadMakePaths$eSuf - Bad Path seen. Must check manually");
2944 
        $retval = 1;
2945 
    }
2946 
 
2947 
    return $retval;
2948 
}
2949 
 
2950 
 
2951 
#-------------------------------------------------------------------------------
1197 dpurdie 2952 
# Function        : detectProjectBaseUsage
2953 
#
2954 
# Description     : Detect and report usage of the SetProjectBase directive
2955 
#
2956 
# Inputs          : $data               - Ref to a hash of bits
2957 
#
2958 
# Returns         : true    - Bad usage (Really good usage not detected)
2959 
#                   false   - Good usage detected
2960 
#
2961 
sub detectProjectBaseUsage
2962 
{
2449 dpurdie 2963 
    my ($data) = @_;
1197 dpurdie 2964 
    my $retval = 0;
2965 
    my $eSuf = $opt_ignoreProjectBaseErrors ? '' : 'Error';
2966 
 
2967 
    #
2968 
    #   Find makefile.pl
2969 
    #
2476 dpurdie 2970 
    Message ("Detect ProjectBase Usage");
1197 dpurdie 2971 
    my $usesProjectBase = 0;
2972 
    my $definesProjectBase = 0;
2973 
    my $definitionError = 0;
2974 
 
2975 
    my $search = JatsLocateFiles->new("--Recurse=1",
2976 
                                       "--FilterIn=makefile.pl",
2977 
                                       );
2449 dpurdie 2978 
    my @makefiles = $search->search($data->{ViewPath});
1197 dpurdie 2979 
    foreach my $file ( @makefiles )
2980 
    {
2449 dpurdie 2981 
        if ( open( my $fh, '<', "$data->{ViewPath}/$file" ) )
1197 dpurdie 2982 
        {
2983 
            while ( <$fh> )
2984 
            {
2985 
                s~\s+$~~;
2986 
                s~^\s+~~;
2987 
                next if ( m~^#~ );
2988 
 
2989 
                if ( m~\$ProjectBase~ )
2990 
                {
2991 
                    $usesProjectBase++;
2992 
                    Message ("Project Base Use: $_");
2993 
                    $data->{UsesProjectBase}++;
2994 
                }
2995 
 
2996 
                if ( m~^SetProjectBase~ )
2997 
                {
2998 
                    $definesProjectBase++;
2999 
                    $data->{DefinesProjectBase}++;
2312 dpurdie 3000 
                    Warning ("Package initialises SetProjectBase:",
2449 dpurdie 3001 
                             "Line : " . $_,
3002 
                             "Root : " . "$data->{ViewRoot}",
3003 
                             "Path : " . "$data->{ViewPath}",
3004 
                             "File : " . "$data->{ViewPath}/$file",
1197 dpurdie 3005 
                            );
3006 
 
3007 
                    # The only problem is if the user attempts to escape
3008 
                    # from the root of the view.
3009 
                    #
3010 
                    # Examine the depth of the makefile with the directive
3011 
                    # Examine the depth of the view base
3012 
                    #
3013 
                    #
3014 
                    # Locate the build.pl file
3015 
                    # This is the basis for for the directive
3016 
                    #
3017 
                    my $blevel;
3018 
                    my @bpaths = split ('/', $file );
2449 dpurdie 3019 
                    my $buildFile;
1197 dpurdie 3020 
                    while ( @bpaths )
3021 
                    {
3022 
                        $bpaths[-1] = 'build.pl';
3023 
                        my $bfile = join '/', @bpaths ;
2449 dpurdie 3024 
                        $buildFile = "$data->{ViewPath}/$bfile";
3025 
                        if ( -f $buildFile )
1197 dpurdie 3026 
                        {
3027 
                            $blevel = scalar @bpaths;
3028 
                            last;
3029 
                        }
3030 
                        pop @bpaths;
3031 
                    }
3032 
                    unless (defined $blevel)
3033 
                    {
3034 
                        Warning ("SetProjectBase$eSuf calculation failed - can't find build.pl");
2312 dpurdie 3035 
#                        $retval = 1;
3036 
                         $definitionError++;
1197 dpurdie 3037 
                    }
3038 
                    else
3039 
                    {
3040 
                        #
3041 
                        #   Determine the depth of the view root
3042 
                        #
2449 dpurdie 3043 
                        Warning ("Build: $buildFile");
3044 
                        my $countPath = ($data->{ViewPath} =~ tr~/~/~);
3045 
                        my $countBuild = ($buildFile =~ tr~/~/~);
3046 
                        my $max_up = $countBuild - $countPath -1;
1197 dpurdie 3047 
 
3048 
                        m~--Up=(\d+)~i;
3049 
                        my $ulevel = $1;
3050 
                        if ( defined $ulevel )
3051 
                        {
3052 
                            my @paths = split ('/', $file );
3053 
                            my $plevel = scalar @paths;
3054 
 
3055 
#print "--- blevel: $blevel\n";
3056 
#print "--- bpaths: @bpaths\n";
3057 
#print "--- ulevel: $ulevel\n";
3058 
#print "--- paths: @paths\n";
3059 
#print "--- plevel: $plevel\n";
3060 
#print "--- max_up: $max_up\n";
3061 
 
3062 
                            if ( $ulevel > $max_up )
3063 
                            {
3064 
                                Warning ("SetProjectBase escapes view. MaxUp: $max_up, Up: $ulevel");
3065 
                                $definitionError++;
3066 
                            }
3067 
                        }
3068 
                        else
3069 
                        {
3070 
                            $retval = 1;
3071 
                            Warning ("SetProjectBase$eSuf MAY escape view - can't detect level")
3072 
                        }
3073 
                    }
3074 
                }
3075 
            }
3076 
            close $fh;
3077 
        }
3078 
        else
3079 
        {
3080 
            Warning ("SetProjectBase$eSuf - Cannot open makefile: $file");
3081 
            $retval = 1;
3082 
        }
3083 
    }
3084 
 
3085 
    #
3086 
    #   Detect defined, but not used
3087 
    #
3088 
    if ( $usesProjectBase && ! $definesProjectBase )
3089 
    {
3090 
        Warning ("SetProjectBase - Uses ProjectBase without defining it");
3091 
    }
3092 
 
3093 
    if ( ! $usesProjectBase && $definesProjectBase )
3094 
    {
3095 
        Warning ("SetProjectBase - Defines ProjectBase without using it");
3096 
    }
3097 
 
3098 
    if ( $usesProjectBase && $definesProjectBase && $definitionError )
3099 
    {
3100 
        Warning ("SetProjectBase$eSuf - Problem detected");
3101 
        $retval = 1;
3102 
    }
3103 
    return $retval;
3104 
}
3105 
 
1270 dpurdie 3106 
#-------------------------------------------------------------------------------
3107 
# Function        : findDirWithStuff
3108 
#
3109 
# Description     : Find a directory that contains more than just another subdir
2354 dpurdie 3110 
#                   Note: don't use 'glob' it doesn't work if the name has a space in it.
1270 dpurdie 3111 
#
3112 
# Inputs          : $base               - Start of the scan
3113 
#
3114 
# Returns         : Path to dir with more than just a single dir in it
3115 
#
3116 
sub findDirWithStuff
3117 
{
3118 
    my ($base) = @_;
1197 dpurdie 3119 
 
1270 dpurdie 3120 
    while ( $base )
3121 
    {
3122 
    my $fileCount = 0;
3123 
    my $dirCount = 0;
1272 dpurdie 3124 
    my $firstDir;
1270 dpurdie 3125 
 
2354 dpurdie 3126 
    opendir (my $dh, $base ) || Error ("Cannot opendir $base. $!");
3127 
    my @list =readdir $dh;
3128 
    closedir $dh;
1270 dpurdie 3129 
    foreach ( @list )
3130 
    {
3131 
        next if ( $_ eq '.' );
3132 
        next if ( $_ eq '..' );
2354 dpurdie 3133 
 
3134 
        $_ = $base . '/' . $_;
1270 dpurdie 3135 
        if ( -d $_ )
3136 
        {
3137 
            $dirCount++;
1272 dpurdie 3138 
            $firstDir = $_ unless ( defined $firstDir );
2354 dpurdie 3139 
            return $base
3140 
                if ( $dirCount > 1  )
1270 dpurdie 3141 
        }
1272 dpurdie 3142 
        elsif ( -e $_ )
1270 dpurdie 3143 
        {
3144 
            return $base;
3145 
        }
1272 dpurdie 3146 
 
3147 
        # else its probably a dead symlink
1270 dpurdie 3148 
    }
2354 dpurdie 3149 
 
3150 
    return $base
3151 
        unless ( $dirCount == 1  );
1272 dpurdie 3152 
    $base = $firstDir;
1270 dpurdie 3153 
    }
3154 
}
3155 
 
1197 dpurdie 3156 
#-------------------------------------------------------------------------------
3157 
# Function        : JatsToolPrint
3158 
#
3159 
# Description     : Print and Execuate a JatsTool command
3160 
#
3161 
# Inputs          :
3162 
#
3163 
# Returns         :
3164 
#
3165 
 
392 dpurdie 3166 
sub JatsToolPrint
3167 
{
3168 
    Information ("Command: @_");
3169 
    JatsTool @_;
3170 
}
3171 
 
3172 
sub GetVname
3173 
{
3174 
    my ($entry) = @_;
3175 
    my $me = 'NONE';
3176 
    if ( $entry )
3177 
        {
3178 
        $me = $versions{$entry}{vname};
3179 
        unless ( $me )
3180 
        {
3181 
            $me = 'Unknown-' . $entry;
3182 
        }
3183 
    }
3184 
    return $me;
3185 
}
3186 
 
2412 dpurdie 3187 
#-------------------------------------------------------------------------------
3188 
# Function        : saneLabel
3189 
#
3190 
# Description     : Generate a sane version label
3191 
#                   Handle suplicates (due to character squishing)
3192 
#                   Cache results for repeatability
3193 
#
3194 
# Inputs          : $entry          - Version info
3195 
#                   $pkgname        - Alternate pkgname (branching)
3196 
#
3197 
# Returns         : Sane string
3198 
#
392 dpurdie 3199 
sub saneLabel
3200 
{
3201 
    my ($entry, $pkgname) = @_;
1272 dpurdie 3202 
    my $me;
3203 
    $me = $versions{$entry}{vname};
392 dpurdie 3204 
    $pkgname = $versions{$entry}{name} unless ( defined $pkgname );
3205 
 
2412 dpurdie 3206 
    #
3207 
    #   If we have calculated it, then reuse it.
3208 
    #
3209 
    if ( exists $versions{$entry}{saneLabel}{$pkgname} )
3210 
    {
3211 
        return $versions{$entry}{saneLabel}{$pkgname};
3212 
    }
3213 
 
3214 
 
392 dpurdie 3215 
    Error ("Package does have a version string: pvid: $entry")
3216 
        unless ( defined $me );
3217 
 
3218 
    #
3219 
    #   Convert Wip format (xxxx) into a string that can be used for a label
3220 
    #
3221 
    if ( $me =~ m~^(.*)\((.*)\)(.*)$~ )
3222 
    {
3223 
        $me = $1 . '_' . $2 . '_' . $3 . '.WIP';
3224 
        $me =~ s~_\.~.~;
3225 
        $me =~ s~^_~~;
3226 
    }
3227 
 
3228 
    #
3229 
    #   Allow for WIPS
3230 
    #   Get rid of multiple '_'
3231 
    #   Replace space with -
3232 
    #
3233 
    $me = $pkgname . '_' . $me;
3234 
    $me =~ tr~ ~-~s;
3235 
    $me =~ tr~-~-~s;
3236 
    $me =~ tr~_~_~s;
3237 
 
2412 dpurdie 3238 
    #
3239 
    #   Due to some sillyness ( package version starting with _ )
3240 
    #   we may get duplicates. Detect and allocate different numbers
3241 
    #
3242 
    if ( exists $saneLabels{$me} )
3243 
    {
3244 
        $saneLabels{$me}++;
3245 
        $me = $me . '.' . $saneLabels{$me};
3246 
        Message ("Duplicate SaneLabel resolved as: $me");
3247 
    }
3248 
    else
3249 
    {
3250 
        $saneLabels{$me} = 0;
3251 
    }
3252 
 
3253 
    #
3254 
    #   Cache value
3255 
    #
3256 
    $versions{$entry}{saneLabel}{$pkgname} = $me;
392 dpurdie 3257 
    return $me;
3258 
}
3259 
 
1341 dpurdie 3260 
sub saneString
3261 
{
3262 
    my ($string) = @_;
3263 
    #
3264 
    #   Get rid of multiple '_'
3265 
    #   Replace space with -
3266 
    #
3267 
    $string =~ s~\W~_~g;
3268 
    $string =~ tr~ ~_~s;
3269 
    $string =~ tr~_-~-~s;
3270 
    $string =~ tr~-_~-~s;
3271 
    $string =~ tr~-~-~s;
3272 
    $string =~ tr~_~_~s;
3273 
    $string =~ s~-$~~;
3274 
    $string =~ s~_$~~;
392 dpurdie 3275 
 
1341 dpurdie 3276 
    return $string;
3277 
}
3278 
 
3279 
 
392 dpurdie 3280 
exit 0;
3281 
 
3282 
 
3283 
#-------------------------------------------------------------------------------
3284 
# Function        : GetPkgIdByName
3285 
#
3286 
# Description     :
3287 
#
3288 
# Inputs          : pkg_name
3289 
#
3290 
# Returns         : pkg_id
3291 
#
3292 
sub GetPkgIdByName
3293 
{
3294 
    my ( $pkg_name ) = @_;
3295 
    my (@row);
3296 
    my $pv_id;
3297 
    my $pkg_id;
3298 
 
3299 
    #
3300 
    #   Establish a connection to Release Manager
3301 
    #
3302 
    connectRM(\$RM_DB) unless ( $RM_DB );
3303 
 
3304 
    #
3305 
    #   Extract data from Release Manager
3306 
    #
3307 
    my $m_sqlstr = "SELECT pkg.PKG_NAME, pkg.PKG_ID" .
3308 
                   " FROM RELEASE_MANAGER.PACKAGES pkg" .
3309 
                   " WHERE pkg.PKG_NAME = \'$pkg_name\'";
3310 
 
3311 
    my $sth = $RM_DB->prepare($m_sqlstr);
3312 
    if ( defined($sth) )
3313 
    {
3314 
        if ( $sth->execute( ) )
3315 
        {
3316 
            if ( $sth->rows )
3317 
            {
3318 
                while ( @row = $sth->fetchrow_array )
3319 
                {
3320 
                    Verbose( "DATA: " . join(',', @row) );
3321 
                    $pkg_id = $row[1] || 0;
3322 
                    last;
3323 
                }
3324 
            }
3325 
            else
3326 
            {
3327 
                Error ("GetPkgIdByName:No Data for package: $pkg_name");
3328 
            }
3329 
            $sth->finish();
3330 
        }
3331 
    }
3332 
    else
3333 
    {
3334 
        Error("GetPkgIdByName:Prepare failure" );
3335 
    }
3336 
 
3337 
    return $pkg_id;
3338 
}
3339 
 
3340 
#-------------------------------------------------------------------------------
3341 
# Function        : GetData_by_pkg_id
3342 
#
3343 
# Description     :
3344 
#
3345 
# Inputs          : pv_id
3346 
#
3347 
# Returns         :
3348 
#
3349 
sub GetData_by_pkg_id
3350 
{
3351 
    my ( $pkg_id, $packageName ) = @_;
3352 
    my (@row);
3353 
 
3354 
    #
3355 
    #   Establish a connection to Release Manager
3356 
    #
3357 
    Message ("Extract package versions from Release Manager: $packageName");
3358 
    connectRM(\$RM_DB) unless ( $RM_DB );
3359 
 
3360 
    #
3361 
    #   Extract data from Release Manager
3362 
    #
2393 dpurdie 3363 
    my $m_sqlstr = "SELECT " .
3364 
                       "pkg.PKG_NAME, " .                                       # row[0]
3365 
                       "pv.PKG_VERSION, " .                                     # row[1]
3366 
                       "pkg.PKG_ID, " .                                         # row[2]
3367 
                       "pv.PV_ID, " .                                           # row[3]
3368 
                       "pv.LAST_PV_ID, " .                                      # row[4]
3369 
                       "pv.MODIFIED_STAMP, " .                                  # row[5]
3370 
                       "release_manager.PK_RMAPI.return_vcs_tag(pv.PV_ID), " .  # row[6]
3371 
                       "amu.USER_NAME, " .                                      # row[7]
3372 
                       "pv.COMMENTS, " .                                        # row[8]
3373 
                       "pv.DLOCKED, " .                                         # row[9]
3374 
                       "pv.CREATOR_ID, ".                                       # row[10]
3375 
                       "pv.BUILD_TYPE ".                                        # row[11]
3376 
                   " FROM " .
3377 
                        "RELEASE_MANAGER.PACKAGES pkg, " .
3378 
                        "RELEASE_MANAGER.PACKAGE_VERSIONS pv, " .
3379 
                        "ACCESS_MANAGER.USERS amu" .
3380 
                   " WHERE " .
3381 
                        "pv.PKG_ID = \'$pkg_id\' " .
3382 
                        "AND pkg.PKG_ID = pv.PKG_ID " .
3383 
                        "AND amu.USER_ID (+) = pv.CREATOR_ID";
3384 
 
392 dpurdie 3385 
    my $sth = $RM_DB->prepare($m_sqlstr);
3386 
    if ( defined($sth) )
3387 
    {
3388 
        if ( $sth->execute( ) )
3389 
        {
3390 
            if ( $sth->rows )
3391 
            {
3392 
                while ( @row = $sth->fetchrow_array )
3393 
                {
3394 
                    Verbose( "DATA: " . join(',', @row) );
3395 
                    my $pkg_name = $row[0] || 'Unknown';
3396 
                    my $pkg_ver = $row[1] || 'Unknown';
3397 
                       $pkg_ver =~ s~\s+$~~;
3398 
                       $pkg_ver =~ s~^\s+~~;
3399 
                    my $pv_id = $row[3] || 'Unknown';
3400 
                    my $last_pv_id = $row[4];
3401 
                    my $created =  $row[5] || 'Unknown';
3402 
                    my $vcstag =  $row[6] || 'Unknown';
395 dpurdie 3403 
 
392 dpurdie 3404 
                    my $created_id =  $row[7] || ($row[10] ? "Userid_$row[10]" :'Unknown');
3405 
                    my $comment =  $row[8] || '';
3406 
                    my $locked =  $row[9] || 'N';
2393 dpurdie 3407 
                    my $manual = $row[11] || 'M';
392 dpurdie 3408 
 
3409 
                    #
3410 
                    #   Some developers have a 'special' package version
3411 
                    #   We really need to ignore them
3412 
                    #
3413 
                    next if ( $pkg_ver eq '23.23.23.ssw' );
3414 
 
3415 
                    #
3416 
                    #   Add data to the hash
3417 
                    #       Remove entries that address themselves
3418 
                    #
3419 
                    push (@{$versions{$last_pv_id}{next}}, $pv_id) unless ($pv_id == $last_pv_id || $last_pv_id == 0) ;
3420 
                    $versions{$pv_id}{name} = $pkg_name;
3421 
                    $versions{$pv_id}{pvid} = $pv_id;
3422 
                    $versions{$pv_id}{vname} = $pkg_ver;
3423 
                    $versions{$pv_id}{vcsTag} = $vcstag;
3424 
                    $versions{$pv_id}{created} = $created;
3425 
                    $versions{$pv_id}{created_id} = $created_id;
3426 
                    $versions{$pv_id}{comment} = $comment;
3427 
                    $versions{$pv_id}{locked} = $locked;
3428 
                    $versions{$pv_id}{TimeStamp} = str2time( $created );
3429 
                    $versions{$pv_id}{Age} = ($now - $versions{$pv_id}{TimeStamp}) / (60 * 60 * 24);
3430 
                    $versions{$pv_id}{TooOld} = 1 if ( $opt_age && $opt_age <= $versions{$pv_id}{Age} );
2393 dpurdie 3431 
                    $versions{$pv_id}{BuildType} = $manual;
392 dpurdie 3432 
                    examineVcsTag($pv_id);
3433 
 
3434 
                    #
3435 
                    #   Process version number
3436 
                    #
3437 
                    my ($suffix, $version, $isaR, $isaWip, $buildVersion ) = massageVersion($pkg_ver, $pkg_name);
3438 
 
3439 
                    $versions{$pv_id}{version} = $version;
3440 
                    $versions{$pv_id}{buildVersion} = $buildVersion;
3441 
                    $versions{$pv_id}{isaWip} = 1 if ( $isaWip );
3442 
 
3443 
                    #
2393 dpurdie 3444 
                    #   New methof for detecting a ripple
3445 
                    #       Don't look at the version number
3446 
                    #       Use RM data
3447 
                    #       Inlude the comment - there are some cases where the comment
3448 
                    #       appears to have been user modified.
3449 
                    #
3450 
#                    $versions{$pv_id}{isaRipple} = 1 if ( $isaR );
3451 
#                    $versions{$pv_id}{isaRipple} = 1 if ( uc($manual) eq 'Y' );
3452 
                    $versions{$pv_id}{isaRipple} = ( $comment =~ m~^Rippled Build~i && ( uc($manual) eq 'Y' ));
3453 
 
3454 
                    #
392 dpurdie 3455 
                    #   Process suffix
3456 
                    #
3457 
                    $suffix = 'Unknown' unless ( $suffix );
3458 
                    $suffix = lc ($suffix);
3459 
                    $versions{$pv_id}{suffix} = $suffix;
3460 
                    push @{$suffixes{$suffix}}, $pv_id;
3461 
 
3462 
#                    print "$pkg_name, $pkg_ver, $pv_id, $last_pv_id, $locked, $created, $created_id, $suffix\n";
3463 
                }
3464 
            }
3465 
            else
3466 
            {
3467 
                Error ("GetData_by_pkg_id: No Data: $m_sqlstr");
3468 
            }
3469 
            $sth->finish();
3470 
        }
3471 
        else
3472 
        {
3473 
                Error ("GetData_by_pkg_id: Execute: $m_sqlstr");
3474 
        }
3475 
    }
3476 
    else
3477 
    {
3478 
        Error("GetData_by_pkg_id:Prepare failure" );
3479 
    }
3480 
}
3481 
 
3482 
#-------------------------------------------------------------------------------
3483 
# Function        : massageVersion
3484 
#
3485 
# Description     : Process a version number and return usful bits
3486 
#
3487 
# Inputs          : Version Number
3488 
#                   Package Name - debug only
3489 
#
3490 
# Returns         : An array
3491 
#                       suffix
3492 
#                       multipart version string useful for text comparisons
3493 
#
3494 
sub massageVersion
3495 
{
3496 
    my ($version, $name) = @_;
3497 
    my ($major, $minor, $patch, $build, $suffix);
3498 
    my $result;
3499 
    my $buildVersion;
3500 
    my $isaRipple;
3501 
    my $isaWIP;
3502 
    $build = 0;
3503 
 
3504 
#print "--- $name, $version\n";
3505 
    $version =~ s~^_~~;
3506 
    $version =~ s~^${name}_~~;
3507 
 
3508 
    #
3509 
    #   xxxxxxxxx.nnnn.cots
3510 
    #
3511 
    if ( $version =~ m~(.*)\.cots$~ ) {
3512 
        my $cots_base = $1;
3513 
        $suffix = '.cots';
3514 
        if ( $version =~ m~(.*?)\.([0-9]{4})\.cots$~ )
3515 
        {
3516 
            $result = $1 . sprintf (".%4.4d", $2) . $suffix;
3517 
        }
3518 
        else
3519 
        {
3520 
            $result = $cots_base . '.0000.cots';
3521 
        }
3522 
    }
3523 
    #
3524 
    #   Convert version into full form for comparisions
3525 
    #       nnn.nnn.nnn.[p]nnn.xxx
3526 
    #       nnn.nnn.nnn.[p]nnn-xxx
3527 
    #       nnn.nnn.nnn-[p]nnn.xxx
3528 
    #       nnn.nnn.nnn-[p]nnn-xxx
3529 
    #       nnn.nnn.nnn[p]nnn-xxx
3530 
    #   Don't flag as ripples - they are patches
3531 
    #
3532 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-.p][p]?(\d+)([-.](.*))?$~ ) {
3533 
        $major = $1;
3534 
        $minor = $2;
3535 
        $patch = $3;
3536 
        $build = $4;
3537 
        $suffix = defined $6 ? ".$6" : '';
3538 
        $isaRipple = 0;
3539 
    }
3540 
    #
3541 
    #       nn.nnn.nnnnn.xxx
3542 
    #       nn.nnn.nnnnn-xxx
3543 
    #       nnn.nnn.nnnx.xxx
3544 
    #   Don't flag as ripples - they are patches
3545 
    #
3546 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)\w?([-.](.*))?$~ ) {
3547 
        $major = $1;
3548 
        $minor = $2;
3549 
        $patch = $3;
3550 
        if ( length( $patch) >= 4 )
3551 
        {
3552 
            $build = substr( $patch, -3 ,3);
3553 
            $patch = substr( $patch,  0 ,length($patch)-3);
3554 
        }
3555 
        $suffix = defined $5 ? ".$5" : '';
3556 
    }
3557 
 
3558 
    #
3559 
    #       nnn.nnn.nnn
3560 
    #       nnn.nnn-nnn
3561 
    #       nnn.nnn_nnn
3562 
    #
3563 
    elsif ( $version =~ m~^(\d+)\.(\d+)[-._](\d+)$~ ) {
3564 
        $major = $1;
3565 
        $minor = $2;
3566 
        $patch = $3;
3567 
        $suffix = '';
3568 
    }
3569 
 
3570 
    #
3571 
    #       nnn.nnn.nnn.nnn
3572 
    #       nnn.nnn.nnn-nnn
3573 
    #       nnn.nnn.nnn_nnn
3574 
    #
3575 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-._](\d+)$~ ) {
3576 
        $major = $1;
3577 
        $minor = $2;
3578 
        $patch = $3;
3579 
        $build = $4;
3580 
        $suffix = '';
3581 
        $isaRipple = 0;
3582 
    }
3583 
 
3584 
 
3585 
    #
3586 
    #       nnn.nnn
3587 
    #
3588 
    elsif ( $version =~ m~^(\d+)\.(\d+)$~ ) {
3589 
        $major = $1;
3590 
        $minor = $2;
3591 
        $patch = 0;
3592 
        $suffix = '';
3593 
    }
3594 
    #
3595 
    #       nnn.nnn.xxx
3596 
    #
3597 
    elsif ( $version =~ m~^(\d+)\.(\d+)(\.\w+)$~ ) {
3598 
        $major = $1;
3599 
        $minor = $2;
3600 
        $patch = 0;
3601 
        $suffix = $3;
3602 
    }
3603 
 
3604 
    #
3605 
    #       nnn.nnn.nnnz
3606 
    #
3607 
    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)([a-z])$~ ) {
3608 
        $major = $1;
3609 
        $minor = $2;
3610 
        $patch = $3;
3611 
        $build = ord($4) - ord('a');
3612 
        $suffix = '.cots';
3613 
        $isaRipple = 0;
3614 
    }
3615 
    #
3616 
    #       ???REV=???
3617 
    #
3618 
    elsif ( $version =~ m~REV=~ ) {
3619 
        $suffix = '.cots';
3620 
        $result = $version . '.0000.cots';
3621 
    }
3622 
 
3623 
    #
3624 
    #   Wip Packages
3625 
    #   (nnnnnn).xxx
3626 
    #   Should be essential, but want to sort very low
3627 
    #
3628 
    elsif ($version =~ m~\((.*)\)(\..*)?~) {
3629 
        $suffix = $2 || '';
3630 
        $result = "000.000.000.000$suffix";
3631 
        $isaWIP = 1;
3632 
    }
3633 
 
3634 
    #
3635 
    #   !current
3636 
    #
3637 
    elsif ($version eq '!current' || $version eq 'current_$USER' || $version eq 'current' || $version eq 'beta' || $version eq 'latest' || $version eq 'beta.cr' || $version eq 'CREATE') {
3638 
        $suffix = '';
3639 
        $result = "000.000.000.000$suffix";
3640 
        $isaWIP = 1;
3641 
    }
3642 
 
3643 
    #
3644 
    #   Also WIP: FINRUN.103649.BEI.WIP
3645 
    elsif ($version =~ m~(\.[a-zA-Z]+)\.WIP$~) {
3646 
        $suffix = lc($1);
3647 
        $result = "000.000.000.000$suffix";
3648 
        $isaWIP = 1;
3649 
    }
3650 
 
3651 
    #
3652 
    #   Also ERGOFSSLS190100_015
3653 
    #   Don't flag as a ripple
3654 
    elsif ($version =~ m~^ERG[A-Z]+(\d\d)(\d\d)(\d\d)[-_](\d+)(\.\w+)?$~) {
3655 
        $major = $1;
3656 
        $minor = $2;
3657 
        $patch = $3;
3658 
        $build = $4;
3659 
        $suffix = $5 || '.sls';
3660 
        $isaRipple = 0;
3661 
    }
3662 
 
3663 
    #
3664 
    #   Stuff we don't yet handle
3665 
    #
3666 
    else  {
3667 
        Warning ("Unknown version number: $name,$version");
3668 
        $version =~ m~(\.\w+)$~;
3669 
        $suffix = $1 || '';
3670 
        $result = $version;
3671 
    }
3672 
 
3673 
    $isaRipple = ($build > 0) unless defined $isaRipple;
3674 
    unless ( $result )
3675 
    {
3676 
        # Major and minor of 99.99 are normally funy versions
3677 
        # Don't make important desicions on them
3678 
        #
3679 
        if ( $major == 99 && $minor == 99 )
3680 
        {
3681 
            $major = 0;
3682 
            $minor = 0;
3683 
            $patch = 0;
3684 
        }
3685 
 
3686 
        $result = sprintf("%3.3d.%3.3d.%3.3d.%3.3d%s", $major,$minor,$patch,$build,$suffix || '.0000');
3687 
        $buildVersion = [ $major, $minor, $patch, $build ];
3688 
    }
3689 
 
3690 
    $suffix = lc( $suffix );
3691 
    if ( exists $suffixFixup{$suffix} )
3692 
    {
3693 
        $suffix = $suffixFixup{$suffix} ;
3694 
    }
3695 
 
3696 
    return ($suffix, $result, $isaRipple, $isaWIP, $buildVersion );
3697 
}
3698 
 
3699 
#-------------------------------------------------------------------------------
395 dpurdie 3700 
# Function        : vcsCleanup
3701 
#
3702 
# Description     : Cleanup and rewrite a vcstag
3703 
#
3704 
#                   DUPLICATED IN:
3705 
#                       - cc2svn_procdata
3706 
#                       - cc2svn_importpackage
3707 
#
3708 
# Inputs          : vcstag
3709 
#
3710 
# Returns         : Cleaned up vcs tag
3711 
#
3712 
sub vcsCleanup
3713 
{
3714 
    my ($tag) = @_;
3715 
    $tag =~ tr~\\/~/~;
3716 
    if ( $tag =~ m~^CC::~ )
3717 
    {
2354 dpurdie 3718 
        $tag =~ s~CC::load\s+~CC::~;                # Load rule
3719 
        $tag =~ s~CC::\s+~CC::~;                    # Leading white space
3720 
        $tag =~ s~CC::[A-Za-z]\:/~CC::/~;           # Leading driver letter
3721 
        $tag =~ s~CC::/+~CC::/~;                    # Multiple initial /'s
2319 dpurdie 3722 
        $tag =~ s~/build.pl::~::~i;
3723 
        $tag =~ s~/src::~::~i;
395 dpurdie 3724 
        $tag =~ s~MASS_Dev_Bus/Cbp/~MASS_Dev_Bus/CBP/~i;
3725 
        $tag =~ s~MASS_Dev_Bus~MASS_Dev_Bus~i;
3726 
        $tag =~ s~/MASS_Dev/Infra~MASS_Dev_Infra~i;
3727 
        $tag =~ s~/MASS_Dev/Bus/web~/MASS_Dev_Bus/web~i;
3728 
 
3729 
        $tag =~ s~/Vastraffik/~/Vasttrafik/~;
3730 
        $tag =~ s~/MREF_Package/ergpostmongui$~/MREF_Package/ergpostmongui~i;
3731 
        $tag =~ s~DPC_SWCode/~DPG_SWCode/~i;
3732 
    }
3733 
    return $tag;
3734 
}
3735 
 
3736 
#-------------------------------------------------------------------------------
392 dpurdie 3737 
# Function        : examineVcsTag
3738 
#
3739 
# Description     : Examine a VCS Tag and determine if it looks like rubbish
395 dpurdie 3740 
#                   Give it a clean
392 dpurdie 3741 
#
3742 
# Inputs          : $entry
3743 
#
3744 
# Returns         : Will add Data to the $entry
3745 
#
3746 
sub examineVcsTag
3747 
{
3748 
    my ($entry) = @_;
3749 
    my $bad = 0;
395 dpurdie 3750 
 
3751 
    $versions{$entry}{vcsTag} = vcsCleanup($versions{$entry}{vcsTag});
392 dpurdie 3752 
    my $vcstag = $versions{$entry}{vcsTag};
395 dpurdie 3753 
 
392 dpurdie 3754 
    if ( $vcstag =~ m~^SVN::~ ) {
3755 
        $versions{$entry}{isSvn} = 1;
3756 
 
3757 
    } elsif ( $vcstag =~ m~^CC::(.*?)(::(.+))?$~ ) {
3758 
        my $path = $1  || '';
3759 
        my $label = $2 || '';
3760 
        $bad = 1 unless ( $label );
3761 
        $bad = 1 if ( $label =~ m~^N/A$~i || $label  =~ m~^na$~i );
3762 
 
3763 
        $bad = 1 unless ( $path );
3764 
        $bad = 1 if ( $path =~ m~^N/A$~i || $path  =~ m~^na$~i );
3765 
        $bad = 1 if ( $path =~ m~^/dpkg_archive~ || $path  =~ m~^dpkg_archive~ );
3766 
        $bad = 1 if ( $path =~ m~^/devl/~ || $path  =~ m~^devl/~ );
395 dpurdie 3767 
        $bad = 1 if ( $path =~ m~^CVS~ );
392 dpurdie 3768 
        $bad = 1 if ( $path =~ m~^http:~i );
3769 
        $bad = 1 if ( $path =~ m~^[A-Za-z]\:~ );
3770 
        $bad = 1 if ( $path =~ m~^//~ );
395 dpurdie 3771 
        $bad = 1 if ( $path =~ m~^/*none~i );
3772 
        $bad = 1 if ( $path =~ m~^/*NoWhere~i );
3773 
        $bad = 1 if ( $path =~ m~^-$~i );
392 dpurdie 3774 
        $bad = 1 if ( $path =~ m~^cvsserver:~ );
3775 
        $bad = 1 if ( $path =~ m~,\s*module:~ );
3776 
#        $bad = 1 unless ( $path =~ m~^/~ );
3777 
    }
3778 
    else
3779 
    {
3780 
        $bad = 1;
3781 
    }
3782 
    $versions{$entry}{badVcsTag} = 1 if ( $bad );
3783 
}
3784 
 
3785 
#-------------------------------------------------------------------------------
3786 
# Function        : logToFile
3787 
#
3788 
# Description     : Log some data to a named file
3789 
#                   Use file locking to allow multiple process to log
3790 
#
3791 
# Inputs          : $filename           - Name of file to log
3792 
#                   ...                 - Data to log
3793 
#
3794 
# Returns         : Nothing
3795 
#
3796 
sub logToFile
3797 
{
3798 
    my ($file, @data) = @_;
3799 
 
3800 
    open  (LOGFILE, '>>', $file);
3801 
    flock (LOGFILE, LOCK_EX);
3802 
    print  LOGFILE "@data\n";
3803 
    flock (LOGFILE, LOCK_UN);
3804 
    close (LOGFILE);
3805 
}
3806 
 
3807 
#-------------------------------------------------------------------------------
3808 
# Function        : createImages
3809 
#
3810 
# Description     : Create nice images of the RM version tree
3811 
#
3812 
# Inputs          :
3813 
#
3814 
# Returns         :
3815 
#
3816 
sub createImages
3817 
{
3818 
 
3819 
    my $filebase = "${packageNames}";
2438 dpurdie 3820 
    open (FH, '>', $cwd . "/$filebase.dot" ) or die "Cannot open output";
392 dpurdie 3821 
    print FH "digraph \"${packageNames}\" {\n";
3822 
    #print FH "rankdir=LR;\n";
3823 
    print FH "node[fontsize=16];\n";
3824 
    print FH "node[target=_graphviz];\n";
3825 
#    print FH "subgraph cluster_A {\n";
3826 
#    print FH "node[fontsize=12];\n";
3827 
 
3828 
    {
3829 
        my @text;
3830 
        push @text, $packageNames;
3831 
        push @text, 'HyperLinked to Release Manager';
3832 
        push @text, 'Created:' . localtime();
3833 
        push @text, '|';
3834 
 
3835 
        push @text, 'Total RM versions: ' . $totalVersions;
3836 
        push @text, 'Essential Entries: ' . scalar @EssentialPackages;
3837 
        push @text, 'Initial trees: ' . $initialTrees;
3838 
 
1270 dpurdie 3839 
        push @text, 'Number of Entries: ' . $processTotal;
392 dpurdie 3840 
        push @text, 'Type : ' . $packageType;
3841 
        push @text, 'All versions in Subversion' if ( $allSvn );
3842 
 
3843 
        push @text, '|';
3844 
        push @text, 'Total Project Branches: ' . $ProjectCount;
3845 
        foreach ( sort keys %knownProjects )
3846 
        {
3847 
            my $count = $knownProjects{$_}{count} || 0;
3848 
            if ( $count )
3849 
            {
3850 
                my $text = 'Project Branch: ' . $_;
3851 
                $text .= " (" . $count . ")" if ( $count > 1 );
3852 
                push @text, $text;
3853 
            }
3854 
        }
3855 
 
3856 
        push @text, '|';
3857 
        push @text, 'Bad VCS : ' . $badVcsCount;
3858 
        push @text, 'Bad Singletions : ' . $badSingletonCount;
3859 
        push @text, 'Deadwood entries : ' . $trimCount;
3860 
        push @text, 'Walking Mode : Flat' if ($opt_flat);
3861 
        push @text, 'Pruned Mode : ' . $pruneModeString;
3862 
        push @text, 'Pruned entries : ' . $pruneCount;
1272 dpurdie 3863 
        push @text, 'Recent entries : ' . $recentCount;
392 dpurdie 3864 
 
3865 
        if ( @unknownProjects )
3866 
        {
3867 
            push @text, '|';
3868 
            push @text, 'Unknown Projects';
3869 
            push @text, 'Unknown Project: ' . $_ foreach (sort @unknownProjects );
3870 
        }
3871 
 
3872 
        #
3873 
        #   Multiple Paths
3874 
        #
3875 
        if ( scalar @multiplePaths > 1 )
3876 
        {
3877 
            push @text, '|';
3878 
            push @text, 'Multiple Paths';
3879 
            push @text, @multiplePaths;
3880 
        }
3881 
 
3882 
        #
3883 
        #   Bad essentials
3884 
        #
3885 
        if ( @badEssentials  )
3886 
        {
3887 
            push @text, '|';
3888 
            push @text, 'Bad Essential Versions';
3889 
            push @text, GetVname($_) foreach ( @badEssentials );
3890 
        }
3891 
 
3892 
        #
3893 
        #   Subversion Data
3894 
        #
3895 
        if ( %svnData )
3896 
        {
3897 
            push @text, '|';
3898 
            push @text, 'Subversion';
3899 
            push @text, 'Trunk used' if exists $svnData{branches}{trunk} ;
3900 
            push @text, 'Labels: ' . scalar keys %{$svnData{tags}} ;
3901 
            push @text, 'Branches: ' . scalar keys %{$svnData{branches}} ;
2401 dpurdie 3902 
            push @text, 'Relabled Packages : ' . $packageReLabelCount;
392 dpurdie 3903 
        }
3904 
 
3905 
        push @text, '';
3906 
        my $text = join '\l', @text;
3907 
        $text =~ s~\|\\l~|~g;
3908 
 
3909 
        my @attributes;
3910 
        push @attributes, "shape=record";
3911 
        push @attributes, "label=\"{$text}\"";
3912 
        push @attributes, "tooltip=\"$packageNames\"";
1272 dpurdie 3913 
        push (@attributes, "URL=\"" . $GBE_RM_URL . "/view_by_version.asp?pkg_id=$first_pkg_id" . "\"" )if $first_pkg_id;
392 dpurdie 3914 
        push @attributes, "color=red";
3915 
        my $attr = join( ' ', @attributes);
3916 
 
3917 
        my $tld_done = 'TitleBlock';
3918 
        print FH "$tld_done [$attr]\n";
3919 
    }
3920 
 
3921 
    #
3922 
    #   Generate Legend
3923 
    #
3924 
    {
3925 
        my @text;
3926 
        push @text, 'Legend';
3927 
        push @text, '|';
3928 
        push @text, 'Node Content';
3929 
        push @text, 'Package Version';
3930 
#        push @text, 'Release Manager Ref (pvid)';
3931 
        push @text, 'Creation Date: yyyy-mm-dd';
3932 
        push @text, '(Coded information)';
3933 
        push @text, '|{Code';
3934 
        push @text, '|{N: Not Locked';
3935 
        push @text, 'b: Bad Singleton';
3936 
        push @text, 'B: Bad VCS Tag';
3937 
        push @text, 'D: DeadWood';
1272 dpurdie 3938 
        push @text, 'E: Essential Release Version';
2401 dpurdie 3939 
        push @text, 'F: Package directories labled';
392 dpurdie 3940 
        push @text, 'G: Glued into Version Tree';
2354 dpurdie 3941 
        push @text, 'L: Label not in VOB';
1272 dpurdie 3942 
        push @text, 'r: Recent version';
1328 dpurdie 3943 
        push @text, 'R: Ripple';
392 dpurdie 3944 
        push @text, 'S: Splitpoint';
3945 
        push @text, 't: Glued into Project Tree';
3946 
        push @text, 'T: Tip version';
3947 
        push @text, 'V: In SVN';
3948 
        push @text, '+: In Subversion';
2354 dpurdie 3949 
        push @text, '0: Zero files extracted';
392 dpurdie 3950 
        push @text, '}}';
3951 
 
3952 
        push @text, '|';
3953 
        push @text, 'Outline';
3954 
        push @text, 'Red: Dead or Bad VCS Tag';
3955 
        push @text, 'Orange: Project Branch Root';
3956 
        push @text, 'Green: Ripple Build Version';
3957 
        push @text, 'Blue: Essential Version';
3958 
        push @text, 'Darkmagenta: Entry Glued into tree';
3959 
        push @text, 'Magenta: Entry added to project tree';
2354 dpurdie 3960 
        push @text, 'DeepPink: Label not in VOB';
3961 
        push @text, 'DarkViolet: Zero files extracted';
392 dpurdie 3962 
 
3963 
 
3964 
        push @text, '|';
3965 
        push @text, 'Fill';
3966 
        push @text, 'PowderBlue: Essential Version';
3967 
        push @text, 'Red: Bad Essential Version';
3968 
        push @text, 'Light Green: Migrated to SVN';
3969 
#        push @text, 'Red: Entry Glued into tree';
3970 
#        push @text, 'Green: Entry added to project tree';
3971 
 
3972 
        push @text, '|';
3973 
        push @text, 'Shape';
3974 
        push @text, 'Oval: Normal Package Version';
3975 
        push @text, 'Invhouse: Project Branch Root';
3976 
        push @text, 'Octagon: Branch Point';
3977 
        push @text, 'Box: Bad Single version with no history';
3978 
        push @text, 'Doublecircle: Tip of a Project Branch';
3979 
 
3980 
        push @text, '';
3981 
        my $text = join '\l', @text;
3982 
        $text =~ s~\|\\l~|~g;
3983 
        $text =~ s~\}\\l~}~g;
3984 
 
3985 
        my @attributes;
3986 
        push @attributes, "shape=record";
3987 
        push @attributes, "label=\"{$text}\"";
3988 
        push @attributes, "color=red";
3989 
        my $attr = join( ' ', @attributes);
3990 
 
3991 
        my $tld_done = 'LegendBlock';
3992 
        print FH "$tld_done [$attr]\n";
3993 
    }
3994 
 
3995 
#    print FH "\n}\n";
3996 
    print FH "TitleBlock -> LegendBlock [style=invis]\n";
3997 
 
3998 
    sub genLabelText
3999 
    {
4000 
        my ($entry) = @_;
4001 
        my @label;
4002 
        push @label, $versions{$entry}{name} if ( $multiPackages );
4003 
        push @label, $versions{$entry}{vname};
4004 
#        push @label, $entry;       # Add PVID
4005 
        push @label, substr( $versions{$entry}{created}, 0, 10); #  2008-02-19
4006 
#        push @label, 'V=' . $versions{$entry}{maxVersion};
4007 
#        push @label, 'B=' . $versions{$entry}{svnBranchTip} if ( exists $versions{$entry}{svnBranchTip} );
4008 
 
4009 
 
4010 
        my $stateText = '';
4011 
        $stateText .= 'N' if ($versions{$entry}{locked} eq 'N');
4012 
        $stateText .= 'b' if (exists $versions{$entry}{badSingleton});
4013 
        $stateText .= 'B' if (exists $versions{$entry}{badVcsTag});
4014 
        $stateText .= 'G' if (exists $versions{$entry}{GluedIn});
4015 
        $stateText .= 't' if (exists $versions{$entry}{MakeTree});
4016 
        $stateText .= 'E' if (exists $versions{$entry}{Essential});
4017 
        $stateText .= 'D' if (exists $versions{$entry}{DeadWood});
1328 dpurdie 4018 
        $stateText .= 'R' if ( $versions{$entry}{isaRipple} );
1272 dpurdie 4019 
        $stateText .= 'r' if (exists $versions{$entry}{keepRecent} && $versions{$entry}{keepRecent} );
392 dpurdie 4020 
        $stateText .= 'S' if (exists $versions{$entry}{EssentialSplitPoint} && $versions{$entry}{EssentialSplitPoint} > 1 );
4021 
        $stateText .= 'T' if (exists $versions{$entry}{Tip} );
4022 
        $stateText .= 'V' if (exists $versions{$entry}{isSvn} );
4023 
        $stateText .= '+' if (exists $versions{$entry}{svnVersion} );
2354 dpurdie 4024 
        $stateText .= '0' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq '0');
4025 
        $stateText .= 'L' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq 'L');
2401 dpurdie 4026 
        $stateText .= 'F' if ($versions{$entry}{data}{DirsLabled});
2354 dpurdie 4027 
 
4028 
 
392 dpurdie 4029 
#        $stateText .= 's' if (exists $versions{$entry}{branchPoint} );
4030 
#        $stateText .= ' T='. $versions{$entry}{threadId} if (exists $versions{$entry}{threadId});
4031 
#        $stateText .= ' EssentalPath' if (exists $versions{$entry}{EssentialPath});
4032 
#        $stateText .= ' Count='. $versions{$entry}{EssentialSplitPoint} if (exists $versions{$entry}{EssentialSplitPoint});
4033 
#        $stateText .= ' M='. $versions{$entry}{maxVersion} if (exists $versions{$entry}{maxVersion});
4034 
 
2354 dpurdie 4035 
        push @label, "(${stateText})" if ( length($stateText) );
392 dpurdie 4036 
 
1341 dpurdie 4037 
##       Insert Release Names
1451 dpurdie 4038 
        foreach my $rtag_id ( keys %{$versions{$entry}{Releases}}  ) {
4039 
            next unless ( exists $ukHopsReleases{$rtag_id} );
4040 
            push @label, "Release: $versions{$entry}{Releases}{$rtag_id}{rname}";
4041 
        }
1341 dpurdie 4042 
 
392 dpurdie 4043 
        return join ('\n', @label );
4044 
    }
4045 
 
4046 
    sub genAttributes
4047 
    {
4048 
        my ($entry) = @_;
4049 
        my @attributes;
4050 
        push @attributes, 'label="' . genLabelText($entry) . '"';
4051 
        push @attributes, 'URL="' . dotUrl($entry) . '"';
4052 
        push @attributes, 'tooltip="' . "Goto: $versions{$entry}{vname}, PVID=$entry" ,'"';
4053 
        my $shape;
4054 
            $shape = 'box' if ($versions{$entry}{badSingleton});
4055 
            $shape = 'octagon'  if ($versions{$entry}{branchPoint});
4056 
            $shape = 'invhouse' if ($versions{$entry}{newSuffix});
4057 
            $shape = 'doublecircle' if ($versions{$entry}{Tip});
4058 
 
4059 
 
4060 
        push @attributes, 'shape=' . $shape if ( $shape );
4061 
 
4062 
        my $color;
4063 
        my $fill;
4064 
           $color = 'color=green style=bold' if ( $versions{$entry}{isaRipple} );
4065 
           $color = 'color=orange style=bold' if ( $versions{$entry}{newSuffix} );
4066 
           $color = 'color=red style=bold' if ( $versions{$entry}{DeadWood} || $versions{$entry}{badVcsTag} );
4067 
           $color = 'color=blue style=bold' if ( $versions{$entry}{Essential} );
4068 
           $color = 'color=darkmagenta style=bold' if ( $versions{$entry}{GluedIn} );
4069 
           $color = 'color=magenta style=bold' if ( $versions{$entry}{MakeTree} );
2354 dpurdie 4070 
           $color = 'color=DeepPink style=bold' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq 'L');
4071 
           $color = 'color=DarkViolet style=bold' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq '0');
392 dpurdie 4072 
 
4073 
           $fill = 'style=filled fillcolor=powderblue' if ( $versions{$entry}{Essential} );
4074 
           $fill = 'style=filled fillcolor=red' if ( $versions{$entry}{Essential} && $versions{$entry}{badVcsTag} );
4075 
           $fill = 'style=filled fillcolor="#99FF99"' if ( exists $versions{$entry}{svnVersion} );
4076 
 
4077 
 
4078 
        push @attributes, $color if ( $color );
4079 
        push @attributes, $fill if ( $fill );
4080 
 
4081 
        return '[' . join( ' ', @attributes) . ']';
4082 
    }
4083 
 
4084 
    sub genArrowAttributes
4085 
    {
4086 
        my ($not_first, $entry) = @_;
4087 
        my @attributes;
4088 
 
4089 
        push @attributes, 'arrowhead=empty' if ( $not_first );
4090 
        push ( @attributes, 'label="' . $versions{$entry}{svnBranchTip} .'"' ) if ( exists $versions{$entry}{svnBranchTip} );
4091 
 
4092 
        return ('[' . join( ' ', @attributes) . ']') if ( @attributes ) ;
4093 
        return '';
4094 
    }
4095 
 
4096 
    #
4097 
    #   Flat
4098 
    #
4099 
    if ( $opt_flat )
4100 
    {
4101 
        my $last = 0;
4102 
        foreach my $entry (@flatOrder )
4103 
        {
4104 
            if ( $last )
4105 
            {
4106 
                my $me = dotTag($last);
4107 
 
4108 
                print FH pentry($me)  ,' -> ', pentry(dotTag($entry)), genArrowAttributes(0, $entry) ,";\n";
4109 
                print FH pentry($me)  ,genAttributes($last) . ";\n";
4110 
            }
4111 
            $last = $entry;
4112 
        }
4113 
        print FH pentry(dotTag($last))  ,genAttributes($last) . ";\n";
4114 
 
4115 
    }
4116 
    else
4117 
    {
4118 
        foreach my $entry ( sort {$a <=> $b} keys(%versions) )
4119 
        {
4120 
            my $me = dotTag($entry);
4121 
            my @versions = @{ $versions{$entry}{next}};
4122 
            my $ii = 0;
4123 
            foreach ( @versions )
4124 
            {
4125 
                print FH pentry($me)  ," -> ",pentry(dotTag($_)), genArrowAttributes($ii++, $_), ";\n";
4126 
            }
4127 
 
4128 
            print FH pentry($me)  ,genAttributes($entry) . ";\n";
4129 
        }
4130 
    }
4131 
 
4132 
    print FH "\n};\n";
4133 
    close FH;
4134 
 
4135 
    #
4136 
    #   Convert DOT to a SVG
4137 
    #
4138 
    unless ( $UNIX )
4139 
    {
4140 
    print "Generating graphical images\n";
4141 
#    system( "dot $filebase.dot -Tjpg -o$filebase.jpg" );  # -v
4142 
    system( "dot $filebase.dot -Tsvg -o$filebase.svg" );  # -v
4143 
#    unlink("$filebase.dot");
4144 
 
4145 
    #
4146 
    #   Display a list of terminal packages
4147 
    #   These are packages that are not used by any other package
4148 
    #
4149 
    print "\n";
4150 
#    print "Generated: $filebase.dot\n";
4151 
#    print "Generated: $filebase.jpg\n";
4152 
    print "Generated: $filebase.svg\n";
4153 
    }
4154 
    else
4155 
    {
4156 
        print "Generated: $filebase.dot\n";
4157 
    }
4158 
}
4159 
 
4160 
sub dotTag
4161 
{
4162 
    my ($entry) = @_;
4163 
 
4164 
    my $label = '';
4165 
    $label .= $versions{$entry}{name} if $multiPackages;
4166 
    $label .= $versions{$entry}{vname};
4167 
    $label =~ s~[-() ]~_~g;
4168 
    return $label;
4169 
}
4170 
 
4171 
sub dotUrl
4172 
{
4173 
    my ($entry) = @_;
4174 
 
4175 
    my $pv_base = $GBE_RM_URL . "/fixed_issues.asp?pv_id=$entry";
4176 
}
4177 
 
4178 
#-------------------------------------------------------------------------------
4179 
# Function        : pentry
4180 
#
4181 
# Description     : Generate an entry list as text
4182 
#                   Replace "." with "_" since DOT doesn't like .'s
4183 
#                   Seperate the arguments
4184 
#
4185 
# Inputs          : @_          - An array of entries to process
4186 
#
4187 
# Returns         : A string
4188 
#
4189 
sub pentry
4190 
{
4191 
    my ($data) = @_;
4192 
    $data =~ s~\.~_~g;
4193 
    $result = '"' . $data . '"' ;
4194 
    return $result;
4195 
}
4196 
 
4197 
#-------------------------------------------------------------------------------
4198 
# Function        : getVobMapping
4199 
#
4200 
# Description     : Read in Package to Repository Mapping
4201 
#
4202 
# Inputs          :
4203 
#
4204 
# Returns         : Populates %VobMapping
4205 
#                             Mapping of PackageName to RepoName[/Subdir]
4206 
#
4207 
our %ScmRepoMap;
4208 
sub getVobMapping
4209 
{
4210 
    Message ("Read in Vob Mapping");
4211 
 
4212 
    my $fname = 'cc2svn.repo.dat';
4213 
    Error "Cannot locate $fname" unless ( -f $fname );
4214 
    require $fname;
4215 
 
4216 
    Error "Data in $fname is not valid\n"
4217 
        unless ( keys(%ScmRepoMap) >= 0 );
4218 
 
4219 
    $opt_vobMap = $ScmRepoMap{$packageNames}{repo}
4220 
        if (exists $ScmRepoMap{$packageNames});
4221 
 
2449 dpurdie 4222 
    $opt_protected = $ScmRepoMap{$packageNames}{protected}
4223 
        if (exists $ScmRepoMap{$packageNames}{protected});
4224 
 
392 dpurdie 4225 
    #
4226 
    #   Free the memory
4227 
    #
4228 
    %ScmRepoMap = ();
4229 
 
4230 
    #
4231 
    #   Calculate Target Repo
4232 
    #
4233 
    Warning ("No VOB Mapping found")
4234 
        unless ($opt_vobMap);
4235 
    Error("No repository specified. ie -repo=DevTools or -repo=COTS")
4236 
        unless ( $opt_repo || $opt_vobMap );
4237 
 
4238 
    my $r1 = ($opt_repo || '') . '/' . ($opt_vobMap || '');
4239 
    $r1 =~ s~^/~~;
4240 
    $r1 =~ s~/$~~;
4241 
    $svnRepo = $opt_repo_base . $r1;
4242 
 
4243 
    Verbose( "Repo URL: $svnRepo");
4244 
}
4245 
 
4246 
 
4247 
#-------------------------------------------------------------------------------
4248 
# Function        : getEssenialPackageVersions
4249 
#
4250 
# Description     : Determine the 'Essental' Package Versions
4251 
#                   Read the data in from an external file
4252 
#
4253 
# Inputs          :
4254 
#
4255 
# Returns         : Populates @EssentialPackages
4256 
#
4257 
 
4258 
our %ScmReleases;
4259 
our %ScmPackages;
4260 
our %ScmSuffixes;
4261 
sub getEssenialPackageVersions
4262 
{
4263 
    Message ("Read in Essential Package Versions");
4264 
 
4265 
    my $fname = 'cc2svn.raw.txt';
4266 
    Error "Cannot locate $fname" unless ( -f $fname );
4267 
    require $fname;
4268 
 
4269 
    Error "Data in $fname is not valid\n"
4270 
        unless ( keys(%ScmReleases) >= 0 );
4271 
 
4272 
#    DebugDumpData("ScmReleases", \%ScmReleases );
4273 
#    DebugDumpData("ScmPackages", \%ScmPackages );
4274 
#    DebugDumpData("ScmSuffixes", \%ScmSuffixes );
4275 
 
4276 
    #
4277 
    #   Create a list of essential packages
4278 
    #   Retain packages-versions used in this program
4279 
    #
4280 
    foreach ( keys %ScmPackages )
4281 
    {
4282 
        next unless ( exists  $pkg_ids{ $ScmPackages{$_}{pkgid} } );
4283 
        push @EssentialPackages, $_;
4284 
        Error ("Essential Package Version not in extracted Release Manager Data: $_")
4285 
            unless ( exists $versions{$_} );
4286 
        $versions{$_}{Essential} = 1;
1341 dpurdie 4287 
 
4288 
        # Retain which RM Release this package-version is the tip
4289 
        # Release of
1342 dpurdie 4290 
        foreach my $rtag_id ( @{$ScmPackages{$_}{'release'}} )
1341 dpurdie 4291 
        {
1342 dpurdie 4292 
            $versions{$_}{Releases}{$rtag_id}{rname}   = $ScmReleases{$rtag_id}{name};
4293 
            $versions{$_}{Releases}{$rtag_id}{pname}   = $ScmReleases{$rtag_id}{pName};
4294 
            $versions{$_}{Releases}{$rtag_id}{proj_id} = $ScmReleases{$rtag_id}{proj_id};
1341 dpurdie 4295 
        }
4296 
 
392 dpurdie 4297 
        #print "ESSENTIAL: $versions{$_}{name} $versions{$_}{vname}\n";
4298 
    }
4299 
 
4300 
    #
4301 
    #   Free memory
4302 
    #
4303 
    %ScmReleases = ();
4304 
    %ScmPackages = ();
4305 
    %ScmSuffixes = ();
4306 
 
4307 
#    DebugDumpData("Essential", \@EssentialPackages );
4308 
    Message ("Essential Versions: " . scalar @EssentialPackages );
4309 
}
4310 
 
4311 
#-------------------------------------------------------------------------------
4312 
# Function        : ReportPathVariance
4313 
#
4314 
# Description     : Report variance in paths used by the versions
4315 
#
4316 
# Inputs          :
4317 
#
4318 
# Returns         :
4319 
#
4320 
my %VobPaths;
4321 
sub ReportPathVariance
4322 
{
4323 
    Message ("Detect Multiple Paths");
4324 
    foreach my $entry ( keys(%versions) )
4325 
    {
4326 
        my $e = $versions{$entry};
4327 
        next if ( isSet ($e, 'DeadWood' ) );
4328 
        next if ( isSet ($e, 'badVcsTag') );
4329 
        next if ( isSet ($e, 'isSvn') );
4330 
        my $tag = $e->{vcsTag};
4331 
        next unless ( $tag );
4332 
 
4333 
        $tag =~ m~^(.+?)::(.*?)(::(.+))?$~;
4334 
        my $vcsType = $1;
4335 
        my $cc_label = $4;
4336 
        my $cc_path = $2;
4337 
        $cc_path = '/' . $cc_path;
4338 
        $cc_path =~ tr~\\/~/~s;
4339 
 
4340 
        $VobPaths{$cc_path}++;
4341 
    }
4342 
 
4343 
    @multiplePaths = sort keys %VobPaths;
4344 
    if ( scalar @multiplePaths > 1 )
4345 
    {
4346 
        Warning ("Multiple Paths:" . $_ ) foreach (@multiplePaths);
4347 
    }
4348 
}
4349 
 
4350 
sub isSet
4351 
{
4352 
    my ($base, $element) = @_;
4353 
    return 0 unless ( exists $base->{$element} );
4354 
    return $base->{$element};
4355 
}
4356 
 
4357 
 
4358 
#-------------------------------------------------------------------------------
4359 
# Function        : recurseList
4360 
#
4361 
# Description     : Return a list of all element below a given head element
4362 
#
4363 
# Inputs          : $head               - Head element
4364 
#
4365 
# Returns         : A list, not in any particular order
4366 
#
4367 
 
4368 
our @recurseList;
4369 
sub recurseList
4370 
{
4371 
    @recurseList = ();
4372 
    recurseListBody (@_);
4373 
    return @recurseList;
4374 
}
4375 
sub recurseListBody
4376 
{
4377 
    foreach my $entry ( @_ )
4378 
    {
4379 
        push @recurseList, $entry;
4380 
no warnings "recursion";
4381 
        recurseListBody (@{$versions{$entry}{next}});
4382 
    }
4383 
}
4384 
 
4385 
#-------------------------------------------------------------------------------
4386 
# Function        : getSvnData
4387 
#
4388 
# Description     : Read the SVN tree and see what we have
4389 
#
4390 
# Inputs          :
4391 
#
4392 
# Returns         :
4393 
#
4394 
my @svnDataItems;
4395 
sub getSvnData
4396 
{
4397 
    Message ("Examine Subversion Tree");
4398 
 
4399 
    #
4400 
    #   Re-init data
4401 
    #
4402 
    @svnDataItems = ();
4403 
    %svnData = ();
4404 
 
4405 
    #
4406 
    #   Create an SVN session
4407 
    #
4408 
    return unless ( $svnRepo );
4409 
    my $svn = NewSessionByUrl ( "$svnRepo/$packageNames" );
4410 
    return unless ( $svn );
4411 
 
4412 
    #
4413 
    #   extract data
4414 
    #
4415 
#    DebugDumpData("SVN", $svn );
4416 
    $svn->SvnCmd ( 'log', '-v', '--xml', '--stop-on-copy', $svn->Full()
4417 
                    , { 'credentials' => 1,
4418 
                        'process' => \&ProcessSvnLog,
4419 
                         }
4420 
                        );
4421 
 
4422 
    #
4423 
    #   Process data
4424 
    foreach my $entry ( @svnDataItems )
4425 
    {
4426 
        my $name;
4427 
        my $isaBranch;
4428 
        my $target = $entry->{target};
4429 
        if ( $target =~ m~/tags/(.*)~ ) {
4430 
            $name = $1;
4431 
            $svnData{tags}{$name} = 1;
4432 
        } elsif ( $target =~ m~/branches/(.*)~ )  {
4433 
            $name = $1;
4434 
    #        $branches{$1} = 1;
4435 
        } else {
4436 
            $svnData{nonTag}{$target} = 1;
4437 
        }
4438 
 
4439 
        my $fromBranch;
4440 
        if ( $entry->{fromPath} =~ m~/trunk$~  ) {
4441 
            $fromBranch = 'trunk';
4442 
        } elsif ( $entry->{fromPath} =~ m~/branches/(.*)~ ) {
4443 
            $fromBranch = $1;
4444 
        }
4445 
 
1341 dpurdie 4446 
        # largest Rev number on branch
4447 
        if ( exists $svnData{max}{$fromBranch} )
392 dpurdie 4448 
        {
1341 dpurdie 4449 
            if ( $svnData{max}{$fromBranch}{rev} <  $entry->{fromRev} )
392 dpurdie 4450 
            {
1341 dpurdie 4451 
                $svnData{max}{$fromBranch}{rev} =  $entry->{fromRev};
4452 
                $svnData{max}{$fromBranch}{name} = $name;
392 dpurdie 4453 
            }
4454 
        }
1341 dpurdie 4455 
        else
4456 
        {
4457 
            $svnData{max}{$fromBranch}{rev} =  $entry->{fromRev};
4458 
            $svnData{max}{$fromBranch}{name} = $name;
4459 
        }
392 dpurdie 4460 
    }
1341 dpurdie 4461 
 
4462 
    foreach my $branch ( keys %{$svnData{max}} )
4463 
    {
4464 
        $svnData{tips}{$svnData{max}{$branch}{name}} = $branch;
4465 
    }
4466 
#    DebugDumpData("svnDataItems", \@svnDataItems);
392 dpurdie 4467 
#    DebugDumpData("SvnData", \%svnData);
4468 
 
1341 dpurdie 4469 
 
392 dpurdie 4470 
    foreach my $entry ( keys(%versions) )
4471 
    {
4472 
        my $import_label = saneLabel($entry);
4473 
        delete $versions{$entry}{svnVersion};
4474 
        delete $versions{$entry}{svnBranchTip};
4475 
 
4476 
        if ( exists $svnData{tags}{$import_label} )
4477 
        {
4478 
            $versions{$entry}{svnVersion} = 1;
4479 
        }
4480 
 
4481 
        if ( exists $svnData{tips}{$import_label} )
4482 
        {
4483 
            $versions{$entry}{svnBranchTip} = $svnData{tips}{$import_label};
4484 
        }
4485 
    }
4486 
 
1341 dpurdie 4487 
    Message ( 'Trunk used: ' . (exists $svnData{'max'}{trunk} ? 'Yes' : 'No') );
392 dpurdie 4488 
    Message ( 'Labels    : ' . scalar keys %{$svnData{tags}} );
1341 dpurdie 4489 
    Message ( 'Branches  : ' . scalar keys %{$svnData{'max'}} );
392 dpurdie 4490 
}
4491 
 
4492 
#-------------------------------------------------------------------------------
4493 
# Function        : ProcessSvnLog
4494 
#
4495 
# Description     :
4496 
#                   Parse
4497 
#                       <logentry
4498 
#                          revision="24272">
4499 
#                       <author>bivey</author>
4500 
#                       <date>2005-07-25T15:45:35.000000Z</date>
4501 
#                       <paths>
4502 
#                       <path
4503 
#                          prop-mods="false"
4504 
#                          text-mods="false"
4505 
#                          kind="dir"
4506 
#                          copyfrom-path="/enqdef/branches/Stockholm"
4507 
#                          copyfrom-rev="24271"
4508 
#                          action="A">/enqdef/tags/enqdef_24.0.1.sls</path>
4509 
#                       </paths>
4510 
#                       <msg>COTS/enqdef: Tagged by Jats Svn Import</msg>
4511 
#                       </logentry>
4512 
#
4513 
# Inputs          :
4514 
#
4515 
# Returns         :
4516 
#
4517 
my $entryData;
4518 
sub  ProcessSvnLog
4519 
{
4520 
    my ($self, $line ) = @_;
4521 
#print "----- $line\n";
4522 
    if ( $line =~ m~^<logentry~ ) {
4523 
        $entryData = ();
4524 
 
4525 
    } elsif ( $line =~ m~^\s+revision="(\d+)"~ ) {
4526 
        $entryData->{Rev} = $1;
4527 
 
4528 
    } elsif ( $line =~ m~^\s+copyfrom-path="(.*)"~ ) {
4529 
        $entryData->{fromPath} = $1;
4530 
 
4531 
    } elsif ( $line =~ m~^\s+copyfrom-rev="(\d+)"~ ) {
4532 
        $entryData->{fromRev} = $1;
4533 
 
4534 
    } elsif ( $line =~ m~\s+action=.*?>(.*)</path~ ) {
4535 
        $entryData->{target} = $1;
4536 
 
4537 
    } elsif ( $line =~ m~</logentry~ ) {
4538 
        if ( exists $entryData->{fromPath} )
4539 
        {
4540 
#            DebugDumpData("Data", $entryData);
4541 
            push @svnDataItems, $entryData;
4542 
        }
4543 
    }
4544 
 
4545 
    #
4546 
    #   Return 0 to keep on going
4547 
    return 0;
4548 
}
4549 
 
1328 dpurdie 4550 
#-------------------------------------------------------------------------------
392 dpurdie 4551 
# Function        : saveData
4552 
#
4553 
# Description     : Save essential data
4554 
#
4555 
# Inputs          :
4556 
#
4557 
# Returns         :
4558 
#
4559 
sub saveData
4560 
{
4561 
    my $file = $cwd . "/${packageNames}.data";
4562 
 
4563 
    Message ("Create: $file");
4564 
    my $fh = ConfigurationFile::New( $file );
4565 
 
4566 
    $fh->DumpData(
4567 
        "\n# ScmVersions.\n#\n",
4568 
        "ScmVersions", \%versions );
4569 
 
4570 
    #
4571 
    #   Close out the file
4572 
    #
4573 
    $fh->Close();
4574 
}
4575 
 
4576 
 
4577 
#-------------------------------------------------------------------------------
4578 
#   Documentation
4579 
#
4580 
 
4581 
=pod
4582 
 
4583 
=for htmltoc    SYSUTIL::cc2svn::
4584 
 
4585 
=head1 NAME
4586 
 
4587 
cc2svn_gendata - CC2SVN tool to import an entire package into SVN
4588 
 
4589 
=head1 SYNOPSIS
4590 
 
4591 
  jats cc2svn_importpackage [options] package_name
4592 
 
4593 
 Options:
4594 
    -help              - brief help message
4595 
    -help -help        - Detailed help message
4596 
    -man               - Full documentation
4597 
    -repository=name   - Specify target repository
4598 
    -[no]flat          - Do not create project tree. Def: -noflat
4599 
    -prunemode=mode    - Mode: none, ripple, retain, severe, Def=ripple
4600 
    -retain=N          - Specify retain count for pruning. Def=2
4601 
    -[no]test          - Do not create packages. Def:-notest
4602 
    -[no]reuse         - Keep and reuse ClearCase views
4603 
    -age=nnDays        - Only keep recent package
4604 
    -dump[=n]          - Dump raw data. N=0,1,2
4605 
    -images[=n]        - Create SVG of version tree. N=0,1,2
4606 
    -name=aaa          - Alternate output package name. Test Only
4607 
    -[no]log           - Write output to log file. Def: -nolog
4608 
    -[no]postimage     - Create image after transger: Def: -post
4609 
    -workdir=path      - Use for temp storage (def:/work)
1270 dpurdie 4610 
    -delete            - Delete SVN package before test
2403 dpurdie 4611 
    -[no]relabel       - Attempt to relabel dirs in packages that don't extract
2449 dpurdie 4612 
    -testRmDatabase    - Use test database
2476 dpurdie 4613 
    -[no]fromSvn       - Also extract packages from SVN
392 dpurdie 4614 
 
4615 
=head1 OPTIONS
4616 
 
4617 
=over 8
4618 
 
4619 
=item B<-help>
4620 
 
4621 
Print a brief help message and exits.
4622 
 
4623 
=item B<-help -help>
4624 
 
4625 
Print a detailed help message with an explanation for each option.
4626 
 
4627 
=item B<-man>
4628 
 
4629 
Prints the manual page and exits.
4630 
 
4631 
=item B<-prunemode=mode>
4632 
 
4633 
This option control the manner in which excess versions will be pruned. Valid
4634 
modes are:
4635 
 
4636 
=over 8
4637 
 
4638 
=item   none
4639 
 
4640 
No pruning will be performed
4641 
 
4642 
=item   ripple
4643 
 
4644 
Non-Essential packages that are ripple builds will be removed.
4645 
 
4646 
=item   retain
4647 
 
4648 
Versions that preceed an Essential version will be retained.
4649 
 
4650 
=item   severe
4651 
 
4652 
Only Essential Versions, and Branching points will be retained.
4653 
 
4654 
=back
4655 
 
4656 
=back
4657 
 
4658 
=head1 DESCRIPTION
4659 
 
4660 
This program is a tool used in the conversion of ClearCase VOBS to subversion.
4661 
It will take a complete package and all relevent versions from ClearCase and
4662 
insert them into subversion in a sessible manner. It will attempt to retain
4663 
file change order and history.
4664 
 
4665 
It will:
4666 
 
4667 
=over 8
4668 
 
4669 
=item *
4670 
 
4671 
Read in the Essential Package Version list.
4672 
 
4673 
=item *
4674 
 
4675 
Extract, from Release Manager, all known versions of the specified package.
4676 
 
4677 
=item *
4678 
 
4679 
It will attempt to determine the type of package: COTS, TOOL, CORE, PROJECT
4680 
and alter the processing accordingly.
4681 
 
4682 
=item *
4683 
 
4684 
It will create a version dependency tree and determine 'new' project branch
4685 
points. It will remove (prune) versions that are excess to requirements.
4686 
 
4687 
=item *
4688 
 
4689 
It will extract source from ClearCase and insert it into SVN, creating
4690 
branches and tags as it goes.
4691 
 
4692 
=back
4693 
 
4694 
The program can also be used to create a SVG image of the version dependency
4695 
tree. This does not work on Linux; only Windows with 'dot' installed.
4696 
 
4697 
=cut
4698