Subversion Repositories DevTools

Rev

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

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