Subversion Repositories DevTools

Rev

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

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