Subversion Repositories DevTools

Rev

Rev 2489 | Rev 2553 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

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