Subversion Repositories DevTools

Rev

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

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