Subversion Repositories DevTools

Rev

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