Subversion Repositories DevTools

Rev

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