Subversion Repositories DevTools

Rev

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