Subversion Repositories DevTools

Rev

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