Subversion Repositories DevTools

Rev

Go to most recent revision | Details | Last modification | View Log | RSS feed

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