Subversion Repositories DevTools

Rev

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

Rev Author Line No. Line
392 dpurdie 1 
########################################################################
5710 dpurdie 2 
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
392 dpurdie 3 
#
4 
# Module name   : jats.sh
5 
# Module type   : Makefile system
6 
# Compiler(s)   : n/a
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 
#
15 
#                 Pump it into SVN
16 
#
17 
#                 Project Based Pumping
18 
#
19 
#......................................................................#
20 
 
21 
require 5.006_001;
22 
use strict;
23 
use warnings;
24 
use JatsError;
25 
use JatsRmApi;
26 
use FileUtils;
27 
use JatsSystem;
28 
use HTTP::Date;
29 
 
30 
 
31 
#use Data::Dumper;
32 
use Cwd;
33 
use DBI;
34 
use Getopt::Long;
35 
use Pod::Usage;                             # required for help support
36 
 
37 
#
38 
#   Options
39 
#
40 
my $opt_help = 0;
41 
my $opt_manual = 0;
42 
my $opt_verbose = 0;
43 
my $opt_repo_base = 'https://auperasvn01.aupera.erggroup.com/svn/';
44 
my $opt_repo;
45 
my $opt_package;
46 
my $opt_resume;
47 
my $opt_flat;
48 
my $opt_test;
49 
my $opt_reuse;
50 
my $opt_age;
51 
my $opt_dump = 0;
52 
my $opt_images = 0;
53 
my $opt_tailcount;
54 
 
55 
################################################################################
56 
#   List of Projects Suffixes and Branch Names to be used within SVN
57 
#
58 
my %ProjectsBaseCreated;
59 
my %Projects = (
60 
    '.sea' => 'Seattle',
61 
    '.coct' => 'CapeTown',
62 
    '.sls'  => 'Stockholm',
63 
    '.syd'  => 'Sydney',
64 
    '.vtk'  => 'Vasttrafik',
65 
    '.bei'  => 'Beijing',
66 
    '.bkk'  => 'Bangkok',
67 
    '.mas'  => 'Mass',
68 
    '.ndl'  => 'NewDelhi',
69 
    '.nzs'  => 'NewZealandStageCoach',
70 
    '.was'  => 'Washington',
71 
    '.wdc'  => 'Washington',
72 
    '.oso'  => 'Oslo',
73 
    '.lvs'  => 'LasVegas',
74 
    '.mlc'  => 'BeijingMlc',
75 
    '.sfo'   => 'SanFrancisco',
76 
    '.sf'   => 'SanFrancisco',
77 
    'unknown' => 'UnknownProject',
78 
);
79 
 
80 
################################################################################
81 
#   Global data
82 
#
83 
my $VERSION = "1.0.0";
84 
my $RM_DB;
85 
my $currentBranchName;
86 
my $last_pv_id;
87 
my $pkg_id;
88 
my %versions;
89 
my %suffixes;
90 
my @processOrder;
91 
my @startPoints;
92 
my @endPoints;
93 
my @BranchPoints;
94 
my $now = time();
95 
my $logSummary;
96 
 
97 
 
98 
my $result = GetOptions (
99 
                "help+"         => \$opt_help,          # Help
100 
                "manual"        => \$opt_manual,        # Help
101 
                "verbose+"      => \$opt_verbose,       # Versose
102 
                "repository:s"  => \$opt_repo,          # Name of repository
103 
                "resume:s"      => \$opt_resume,        # Resume at given version
104 
                "flat!"         => \$opt_flat,          # Flat structure
105 
                "test!"         => \$opt_test,          # Test operations
106 
                "reuse!"        => \$opt_reuse,         # Reuse ClearCase views
107 
                "age:i"         => \$opt_age,           # Only recent versions
108 
                "dump:1"        => \$opt_dump,          # Dump Data
109 
                "images:1"      => \$opt_images,        # Create DOT images
110 
                "last:i"        => \$opt_tailcount,     # Retain last N versions of each project
111 
                );
112 
 
113 
#
114 
#   Process help and manual options
115 
#
116 
pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);
117 
pod2usage(-verbose => 1)  if ($opt_help == 2 );
118 
pod2usage(-verbose => 2)  if ($opt_manual || ($opt_help > 2));
119 
 
120 
#
121 
#   Configure the error reporting process now that we have the user options
122 
#
123 
ErrorConfig( 'name'    =>'PLAY9d',
124 
             'verbose' => $opt_verbose,
125 
             'log'     => \&logErrors,
126 
              );
127 
 
128 
Error("No repository specified. ie -repo=DevTools, COTS") unless ( defined $opt_repo );
129 
Error("Specify a package as 'name'" ) unless ( defined $ARGV[0] );
130 
 
131 
$opt_package = $ARGV[0];
132 
$opt_repo = $opt_repo_base . $opt_repo;
133 
 
134 
Verbose( "Base Package: $opt_package");
135 
Verbose( "Repo URL: $opt_repo");
136 
 
137 
#
138 
#   Body of the process
139 
#
140 
GetPkgIdByName ( $opt_package );
141 
GetData_by_pkg_id ( $pkg_id );
142 
MassageData();
143 
 
144 
if ( $opt_dump )
145 
{
146 
    DebugDumpData ("Versions", \%versions );
147 
    DebugDumpData ("Starts", \@startPoints );
148 
    DebugDumpData ("Ends", \@endPoints );
149 
    DebugDumpData ("Suffixes", \%suffixes );
150 
}
151 
 
152 
if ( $opt_images )
153 
{
154 
    createImages();
155 
}
156 
 
157 
exit if ( ($opt_dump > 1) || ($opt_images > 1) );
158 
 
159 
 
160 
#
161 
#   Process all packages
162 
#       Going to create versions based on RM structure
163 
#       May have several starting points: Process each
164 
#
165 
newPackage();
166 
 
167 
if ( $opt_flat )
168 
{
169 
    newProject();
170 
    foreach my $entry (sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions) )
171 
    {
172 
        processPackage( $entry, $versions{$entry}{suffix} );
173 
    }
174 
}
175 
else
176 
{
177 
    processBranch(@startPoints);
178 
}
179 
endPackage();
180 
exit 0;
181 
 
182 
#-------------------------------------------------------------------------------
183 
# Function        : MassageData
184 
#
185 
# Description     :
186 
#
187 
# Inputs          :
188 
#
189 
# Returns         :
190 
#
191 
my %seenSuffixes;
192 
sub calcLinks
193 
{
194 
    #
195 
    #   Process the 'versions' hash and:
196 
    #   Add back references
197 
    #   Find starts and ends
198 
    #       Entry with no previous
199 
    #       Entry with no next
200 
    #
201 
    foreach my $entry ( keys(%versions) )
202 
    {
203 
        foreach ( @{ $versions{$entry}{next}} )
204 
        {
205 
            $versions{$_}{last} = $entry;
206 
        }
207 
    }
208 
    @startPoints = ();
209 
    @endPoints = ();
210 
    foreach my $entry ( keys(%versions) )
211 
    {
212 
        push @startPoints, $entry
213 
            unless ( exists $versions{$entry}{last} );
214 
 
215 
        push @endPoints, $entry
216 
            unless ( @{$versions{$entry}{next}} > 0  )
217 
    }
218 
}
219 
 
220 
sub MassageData
221 
{
222 
    calcLinks();
223 
    #
224 
    #   Attempt to glue 'stray' versions into a project
225 
    #   Strays are those that have no next or last
226 
    #
227 
    {
228 
    my %Strays;
229 
    my %ProjectRoots;
230 
    my @Remainders;
231 
    my $reprocess=0;
232 
        foreach my $entry ( @startPoints )
233 
        {
234 
            unless ( exists $versions{$entry}{next}[0]  )
235 
            {
236 
                push @{$Strays{$versions{$entry}{suffix}}}, $entry;
237 
            }
238 
            else
239 
            {
240 
                $ProjectRoots{$versions{$entry}{suffix}} = $entry;
241 
            }
242 
        }
243 
 
244 
        foreach ( keys %Strays )
245 
        {
246 
            if ( exists $ProjectRoots{$_} )
247 
            {
248 
                my @list = reverse sort @{$Strays{$_}};
249 
                my $last = $ProjectRoots{$_} ;
250 
                $reprocess = 1;
251 
                foreach my $entry ( @list )
252 
                {
253 
                    push @{$versions{$entry}{next}}, $last;
254 
                    $last = $entry;
255 
                }
256 
            }
257 
            else
258 
            {
259 
                push @Remainders, @{$Strays{$_}};
260 
            }
261 
        }
262 
 
263 
        #
264 
        #   Put strays that cannot be assigned to a project into a group
265 
        #   of there own.
266 
        #
267 
        my $last = pop @Remainders;
268 
        foreach my $entry ( @Remainders )
269 
        {
270 
            push @{$versions{$entry}{next}}, $last;
271 
            $last = $entry;
272 
        }
273 
 
274 
        #
275 
        #   Recalc basic links if any processing done
276 
        #
277 
        calcLinks()
278 
            if ( $reprocess );
279 
    }
280 
 
281 
 
282 
    #
283 
    #   Walk each starting point list and determine new Projects
284 
    #
285 
    foreach my $entry ( @startPoints )
286 
    {
287 
        processBranchLists($entry);
288 
 
289 
        sub processBranchLists
290 
        {
291 
            foreach my $entry ( @_ )
292 
            {
293 
                my $s = $versions{$entry}{suffix};
294 
                unless ( exists $seenSuffixes{$s} )
295 
                {
296 
                    $seenSuffixes{$s} = 1;
297 
                    push @BranchPoints, $entry;
298 
                    $versions{$entry}{branchPoint} = 1;
299 
                    $versions{$entry}{newSuffix} = 1;
300 
                }
301 
                processBranchLists (@{$versions{$entry}{next}});
302 
            }
303 
        }
304 
    }
305 
 
306 
    #
307 
    #   For each leaf ( end point ), walk backwards and mark each node with the
308 
    #   distance from the end. If we get to a node which already has been marked then
309 
    #   stop if our length is less. We want the value to be the longest distance to
310 
    #   a leaf
311 
    #
312 
    my $distanceCount;
313 
    foreach my $entryPoint ( @endPoints )
314 
    {
315 
        $distanceCount = 0;
316 
        my $entry = $entryPoint;
317 
        while ( $entry )
318 
        {
319 
            if ( defined $versions{$entry}{distance} )
320 
            {
321 
                if ( $versions{$entry}{distance} > $distanceCount )
322 
                {
323 
                    last;
324 
                }
325 
            }
326 
            $versions{$entry}{distance} = $distanceCount++;
327 
            $entry = $versions{$entry}{last};
328 
        }
329 
    }
330 
 
331 
    #
332 
    #   Mark entries that exceed the configured distance from the end
333 
    #   of each leaf
334 
    #
335 
    if ( $opt_tailcount )
336 
    {
337 
        foreach my $entryPoint ( @endPoints )
338 
        {
339 
            $distanceCount = 0;
340 
            my $entry = $entryPoint;
341 
            while ( $entry )
342 
            {
343 
                if ( $distanceCount > $opt_tailcount )
344 
                {
345 
                    $versions{$entry}{TooFar} |= 2;
346 
                }
347 
                else
348 
                {
349 
                    $versions{$entry}{TooFar} |= 1;
350 
                }
351 
                $distanceCount++;
352 
                $entry = $versions{$entry}{last};
353 
            }
354 
        }
355 
    }
356 
 
357 
    #
358 
    #   Locate all instances where a package-version branches
359 
    #   Determine the version that should be on the non-branching path
360 
    #
361 
    #   Reorder the 'next' list so that the first item is the non-branching
362 
    #   path. This will be used in the data-insertion phase to simplify the
363 
    #   processing.
364 
    #
365 
    foreach my $entry ( sort keys(%versions) )
366 
    {
367 
        my @next = @{$versions{$entry}{next}};
368 
        my $count = @next;
369 
        my @ordered;
370 
        my $main;
371 
 
372 
        #
373 
        #   Recalculate general version exclusion data
374 
        #
375 
        delete $versions{$entry}{TooFar} if ( defined($versions{$entry}{TooFar}) && $versions{$entry}{TooFar} & 1);
376 
        if ( $versions{$entry}{TooFar} || $versions{$entry}{TooOld} || ($versions{$entry}{locked} eq 'N') )
377 
        {
378 
            $versions{$entry}{Exclude} = 1;
379 
        }
380 
 
381 
        if ( $count > 0 )
382 
        {
383 
            my %nexts = map { $_ => 1 } @next;
384 
            foreach my $e ( @next )
385 
            {
386 
                #
387 
                #   Remove those that already have a branch,
388 
                #   or where the branch is tool old
389 
                #
390 
                if ( $versions{$e}{branchPoint} || $versions{$e}{newSuffix} || $versions{$entry}{Exclude} )
391 
                {
392 
                    push @ordered, $e;
393 
                    delete $nexts{$e};
394 
                }
395 
            }
396 
 
397 
            #
398 
            #   Select longest arm as the non-branching path
399 
            #
400 
            my $count = -1;
401 
            my $countEntry;
402 
            foreach my $e ( sort keys %nexts )
403 
            {
404 
                if ( $versions{$e}{distance} > $count )
405 
                {
406 
                    $count = $versions{$e}{distance};
407 
                    $countEntry = $e;
408 
                }
409 
            }
410 
            if ($countEntry)
411 
            {
412 
                $main = $countEntry;
413 
                delete $nexts{$countEntry};
414 
            }
415 
 
416 
            #
417 
            #   Mark remaining as non-main
418 
            #
419 
            foreach my $e ( keys %nexts )
420 
            {
421 
                push @ordered, $e;
422 
                $versions{$e}{branchPoint} = 1;
423 
            }
424 
 
425 
            #
426 
            #   Re-order 'next' so that the main path is first
427 
            #
428 
            @ordered = sort @ordered;
429 
            unshift @ordered, $main if ( $main );
430 
            @{$versions{$entry}{next}} = @ordered;
431 
        }
432 
    }
433 
 
434 
    #
435 
    #   Walk the newSuffix start points and move the newSuffix tag down
436 
    #   to a non-excluded node
437 
    #
438 
    foreach ( @BranchPoints )
439 
    {
440 
        my $entry = $_;
441 
        while ( $versions{$entry}{Exclude} )
442 
        {
443 
            $versions{$entry}{newSuffix} = 0;
444 
            $entry = $versions{$entry}{next}[0];
445 
        }
446 
        $versions{$entry}{newSuffix} = 1;
447 
    }
448 
}
449 
 
450 
#-------------------------------------------------------------------------------
451 
# Function        : processBranch
452 
#
453 
# Description     : Process one complete branch within the tree of versions
454 
#                   May be called recursivly to walk the tree
455 
#
456 
# Inputs          : Array of package-version ID to process
457 
#
458 
# Returns         : Nothing
459 
#
460 
 
461 
sub processBranch
462 
{
463 
    foreach my $entry ( @_ )
464 
    {
465 
        #
466 
        #   Do we need to create a branch before we can process this package
467 
        #
468 
        if ( $versions{$entry}{newSuffix} || $versions{$entry}{branchPoint} )
469 
        {
470 
            newProject();
471 
            createBranchPoint ($entry);
472 
        }
473 
 
474 
        processPackage( $entry );
475 
        processBranch (@{$versions{$entry}{next}});
476 
    }
477 
}
478 
 
479 
#-------------------------------------------------------------------------------
480 
# Function        : processPackage
481 
#
482 
# Description     : Process a package version
483 
#
484 
# Inputs          : $entry              - Ref to entry being proccessed
485 
#
486 
# Returns         :
487 
#
488 
sub processPackage
489 
{
490 
    my ($entry) = @_;
491 
    my $rv;
492 
 
493 
    print "--- Entry:",GetVname($entry)," Tag: ",$versions{$entry}{vcsTag},"\n";
494 
    push @processOrder, $entry;
495 
    return if ( $opt_test );
496 
    return if ( $versions{$entry}{Exclude} );
497 
 
498 
    #
499 
    #   Allow resumption
500 
    #   Assumes a great deal ...
501 
    #   Designed to allow manual recovery
502 
    #
503 
    if ( $opt_resume )
504 
    {
505 
        return if ( $opt_resume ne GetVname($entry) );
506 
        $opt_resume = undef;
507 
    }
508 
 
509 
    #
510 
    #   Determine version information
511 
    #
512 
    my $opt_label = $opt_package . '_' . GetVname($entry);
513 
 
514 
    my $tag = $versions{$entry}{vcsTag} || '';
515 
    $tag =~ s~\\~/~g;
516 
    $tag =~ m~^(.+?)::(.*?)(::(.+))?$~;
517 
 
518 
    my $cc_label = $4;
519 
    my $opt_path = $2;
520 
    if ( !defined $opt_path || ! defined $cc_label )
521 
    {
522 
        print "--- (E) Error: Bad Config Spec for:",GetVname($entry),"\n";
523 
        return;
524 
    }
525 
 
526 
    $opt_path = '/' . $opt_path;
527 
    $opt_path =~ s~\\~/~g;
528 
    $opt_path =~ s~//~/~g;
529 
 
530 
print "--- Path: $opt_path, Label: $cc_label\n";
531 
 
532 
    my @author;
533 
    my $author = $versions{$entry}{created_id};
534 
    if ( $author )
535 
    {
536 
        push @author, '-author', $author;
537 
    }
538 
    my $created = $versions{$entry}{created};
539 
    if ( $created )
540 
    {
541 
        $created =~ s~ ~T~;
542 
        $created .= '00000Z';
543 
        push @author, '-date', $created;
544 
    }
545 
 
546 
    my $log = $versions{$entry}{comment};
547 
    if ( $log )
548 
    {
549 
        push @author, '-log', $log;
550 
    }
551 
 
552 
    #
553 
    #   Create CC view
554 
    #   Import into Subversion View
555 
    #
556 
    SystemConfig ('ExitOnError' => 0);
557 
    if ( $opt_reuse && -d ("$cc_label/$opt_path") )
558 
    {
559 
        Message ("Reusing view: $cc_label");
560 
        $rv = 0;
561 
    }
562 
    else
563 
    {
564 
        $rv = JatsToolPrint ( 'jats_ccrelease', '-extractfiles', '-root=.' , '-noprefix',
565 
                    "-label=$cc_label" ,
566 
                    "-path=$opt_path");
567 
 
568 
        unless ( -d ("$cc_label/$opt_path") )
569 
        {
570 
            $rv = 1;
571 
        }
572 
    }
573 
 
574 
    unless ( $rv )
575 
    {
576 
        SystemConfig ('ExitOnError' => 1);
577 
        my $import_label = $opt_label;
578 
        $import_label = $cc_label if ( $cc_label =~ m~WIP$~ );
579 
        my @args;
580 
        push @args, "-branch=$currentBranchName" if ( defined $currentBranchName );
581 
 
582 
        JatsToolPrint ( 'jats_svn', 'import', '-reuse' ,
583 
                        "-package=$opt_repo/$opt_package",
584 
                        "-dir=$cc_label/$opt_path",
585 
                        "-label=$import_label",
586 
                        @args,
587 
                        @author
588 
                         );
589 
        $versions{$entry}{TagCreated} = 1;
590 
    }
591 
 
592 
    #
593 
    #   Delete the created view
594 
    #   Its just a directory, so delete it
595 
    #
596 
    RmDirTree ($cc_label) if -d ($cc_label && (! $opt_reuse) || ($rv));
597 
}
598 
 
599 
#-------------------------------------------------------------------------------
600 
# Function        : newProject
601 
#
602 
# Description     : Start a new project within a package
603 
#
604 
# Inputs          :
605 
#
606 
# Returns         :
607 
#
608 
sub newProject
609 
{
610 
    print "---- New Project\n";
611 
    return if ( $opt_resume  );
612 
 
613 
    #
614 
    #   New project
615 
    #   Kill the running import directory
616 
    #
617 
    RmDirTree ('SvnImportDir');
618 
}
619 
 
620 
#-------------------------------------------------------------------------------
621 
# Function        : newPackage
622 
#
623 
# Description     : Start processing a new package
624 
#
625 
# Inputs          :
626 
#
627 
# Returns         :
628 
#
629 
sub newPackage
630 
{
631 
    print "---- New Package\n";
632 
    return if ( $opt_resume  );
633 
 
634 
    $logSummary = $opt_package . ".summary.log";
635 
    unlink $logSummary;
636 
    logToFile( $logSummary, "PackageName: $opt_package");
637 
 
638 
    #
639 
    #   First entry being created
640 
    #   Prime the work area
641 
    #
642 
    SystemConfig ('ExitOnError' => 1);
643 
    JatsToolPrint ( 'jats_svn', 'delete-package', '-noerror',  "$opt_repo/$opt_package" );
644 
    JatsToolPrint ( 'jats_svn', 'create', "$opt_repo/$opt_package" );
645 
    RmDirTree ('SvnImportDir');
646 
}
647 
 
648 
#-------------------------------------------------------------------------------
649 
# Function        : createBranchPoint
650 
#
651 
# Description     : Create a branch point for the current work
652 
#
653 
# Inputs          : $entry                  Entry being processed
654 
#
655 
# Returns         :
656 
#
657 
sub createBranchPoint
658 
{
659 
    my ($entry) = @_;
660 
    my $forceNewProject;
661 
    print "---- Create Branch Point\n";
662 
 
663 
    return if ( $versions{$entry}{Exclude} );
664 
 
665 
    #
666 
    #   Find previous good tag
667 
    #   We are walking a tree so something should have been created, but
668 
    #   the one we want may have had an error
669 
    #
670 
    #   Walk backwards looking for one that has been created
671 
    #
672 
    my $last = $versions{$entry}{last};
673 
    while ( $last )
674 
    {
675 
        unless ( $versions{$last}{TagCreated} )
676 
        {
677 
            $last = $versions{$last}{last};
678 
        }
679 
        else
680 
        {
681 
            last;
682 
        }
683 
    }
684 
 
685 
    #
686 
    #   If we have walked back to the base of the tree then we will create
687 
    #   an empty view
688 
    #
689 
    unless ( $last )
690 
    {
691 
    print "---- Create Branch Point: New Root Branch\n";
692 
        $forceNewProject = 1;
693 
    }
694 
 
695 
    #
696 
    #   Determine source name
697 
    #   This MUST have been created before we can branch
698 
    #
699 
    my $src_label;
700 
    $src_label = ($opt_package . '_' . GetVname($last)) if $last;
701 
 
702 
    #
703 
    #   Create target name
704 
    #
705 
    my $tgt_label;
706 
    if ( $forceNewProject || $versions{$entry}{newSuffix} || !defined $src_label )
707 
    {
708 
        #
709 
        #   Create target name based on project
710 
        #
711 
        my $suffix = $versions{$entry}{suffix};
712 
        if ( $suffix )
713 
        {
714 
            Error ("Unknown Project: $suffix") unless ( defined $Projects{$suffix} );
715 
            if ( ! exists $ProjectsBaseCreated{$suffix} )
716 
            {
717 
                $tgt_label = $Projects{$suffix};
718 
                $ProjectsBaseCreated{$suffix} = 1;
719 
            }
720 
            else
721 
            {
722 
                #
723 
                #   Project Base Already taken
724 
                #   Have disjoint starting points
725 
                #
726 
                $tgt_label = $Projects{$suffix} . '.' . $ProjectsBaseCreated{$suffix};
727 
                $ProjectsBaseCreated{$suffix}++;
728 
            }
729 
        }
730 
        else
731 
        {
732 
            #
733 
            #   No suffix in use
734 
            #
735 
            #   Currently not handled
736 
            #   May have to force the use of the trunk
737 
            #
738 
            Error ("INTERNAL ERROR: No suffix present");
739 
        }
740 
    }
741 
    else
742 
    {
743 
        $tgt_label = $src_label . '_for_' . $opt_package . '_' . GetVname($entry);
744 
    }
745 
 
746 
    #
747 
    #   Save branch name for use when populating sandbox
748 
    #
749 
    $currentBranchName = $tgt_label;
750 
 
751 
    #
752 
    #   Perform the branch
753 
    #
754 
    if ( $src_label )
755 
    {
756 
        SystemConfig ('ExitOnError' => 1);
757 
        JatsToolPrint ( 'jats_svnlabel',
758 
                        '-packagebase', "$opt_repo/$opt_package",
759 
                        'tags/' . $src_label,
760 
                        '-branch',
761 
                        '-clone', $tgt_label,
762 
                      );
763 
    }
764 
}
765 
 
766 
 
767 
#-------------------------------------------------------------------------------
768 
# Function        : endPackage
769 
#
770 
# Description     : End of package processing
771 
#                   Clean up and display problems
772 
#
773 
# Inputs          :
774 
#
775 
# Returns         :
776 
#
777 
sub endPackage
778 
{
779 
    RmDirTree ('SvnImportDir');
780 
 
781 
    #
782 
    #   Display versions that did not get created
783 
    #
784 
    foreach my $entry ( @processOrder )
785 
    {
786 
        $versions{$entry}{Scanned} = 1;
787 
        next if ( $versions{$entry}{TagCreated} );
788 
        Warning ("Not Processed: " . GetVname($entry) );
789 
    }
790 
 
791 
    foreach my $entry ( keys(%versions) )
792 
    {
793 
        next if ( $versions{$entry}{Scanned} );
794 
        Warning ("(E) INTERNAL ERROR. Package Not Processed: " . GetVname($entry) );
795 
    }
796 
 
797 
    Message ("All Done");
798 
}
799 
 
800 
sub JatsToolPrint
801 
{
802 
    Information ("Command: @_");
803 
    JatsTool @_;
804 
}
805 
 
806 
sub GetVname
807 
{
808 
    my ($entry) = @_;
809 
    my $me = 'NONE';
810 
    if ( $entry )
811 
        {
812 
        $me = $versions{$entry}{vname};
813 
        unless ( $me )
814 
        {
815 
            $me = 'Unknown-' . $entry;
816 
        }
817 
    }
818 
    return $me;
819 
}
820 
 
821 
exit 0;
822 
 
823 
 
824 
#-------------------------------------------------------------------------------
825 
# Function        : GetPkgIdByName
826 
#
827 
# Description     :
828 
#
829 
# Inputs          : pkg_name
830 
#
831 
# Returns         :
832 
#
833 
sub GetPkgIdByName
834 
{
835 
    my ( $pkg_name ) = @_;
836 
    my (@row);
837 
    my $pv_id;
838 
 
839 
    #
840 
    #   Establish a connection to Release Manager
841 
    #
842 
    connectRM(\$RM_DB) unless ( $RM_DB );
843 
 
844 
    #
845 
    #   Extract data from Release Manager
846 
    #
847 
    my $m_sqlstr = "SELECT pkg.PKG_NAME, pkg.PKG_ID" .
848 
                   " FROM RELEASE_MANAGER.PACKAGES pkg" .
849 
                   " WHERE pkg.PKG_NAME = \'$pkg_name\'";
850 
 
851 
    my $sth = $RM_DB->prepare($m_sqlstr);
852 
    if ( defined($sth) )
853 
    {
854 
        if ( $sth->execute( ) )
855 
        {
856 
            if ( $sth->rows )
857 
            {
858 
                while ( @row = $sth->fetchrow_array )
859 
                {
860 
                    Verbose( "DATA: " . join(',', @row) );
861 
                    $pkg_id = $row[1] || 0;
862 
                    last;
863 
                }
864 
            }
865 
            else
866 
            {
867 
                Error ("GetPkgIdByName:No Data for package: $pkg_name");
868 
            }
869 
            $sth->finish();
870 
        }
871 
    }
872 
    else
873 
    {
874 
        Error("GetPkgIdByName:Prepare failure" );
875 
    }
876 
}
877 
 
878 
#-------------------------------------------------------------------------------
879 
# Function        : GetData_by_pkg_id
880 
#
881 
# Description     :
882 
#
883 
# Inputs          : pv_id
884 
#
885 
# Returns         :
886 
#
887 
sub GetData_by_pkg_id
888 
{
889 
    my ( $pkg_id ) = @_;
890 
    my (@row);
891 
 
892 
    #
893 
    #   Establish a connection to Release Manager
894 
    #
895 
    connectRM(\$RM_DB) unless ( $RM_DB );
896 
 
897 
    #
898 
    #   Extract data from Release Manager
899 
    #
900 
    my $m_sqlstr = "SELECT pkg.PKG_NAME, pv.PKG_VERSION, pkg.PKG_ID, pv.PV_ID, pv.LAST_PV_ID, pv.MODIFIED_STAMP, release_manager.PK_RMAPI.return_vcs_tag(pv.PV_ID), amu.USER_NAME, pv.COMMENTS, pv.DLOCKED ".
901 
                   " FROM RELEASE_MANAGER.PACKAGES pkg, RELEASE_MANAGER.PACKAGE_VERSIONS pv, ACCESS_MANAGER.USERS amu" .
902 
                   " WHERE pv.PKG_ID = \'$pkg_id\' AND pkg.PKG_ID = pv.PKG_ID AND pv.CREATOR_ID = amu.USER_ID";
903 
 
904 
 
905 
    my $sth = $RM_DB->prepare($m_sqlstr);
906 
    if ( defined($sth) )
907 
    {
908 
        if ( $sth->execute( ) )
909 
        {
910 
            if ( $sth->rows )
911 
            {
912 
                while ( @row = $sth->fetchrow_array )
913 
                {
914 
                    Verbose( "DATA: " . join(',', @row) );
915 
                    my $pkg_name = $row[0] || 'Unknown';
916 
                    my $pkg_ver = $row[1] || 'Unknown';
917 
                    my $pv_id = $row[3] || 'Unknown';
918 
                    my $last_pv_id = $row[4] || 'Unknown';
919 
                    my $created =  $row[5] || 'Unknown';
920 
                    my $vcstag =  $row[6] || 'Unknown';
921 
                    my $created_id =  $row[7] || 0;
922 
                    my $comment =  $row[8] || '';
923 
                    my $locked =  $row[9] || 'N';
924 
 
925 
                    #
926 
                    #   Add data to the hash
927 
                    #       Remove entries that address themselves
928 
                    #
929 
                    push (@{$versions{$last_pv_id}{next}}, $pv_id) unless ($pv_id == $last_pv_id) ;
930 
                    $versions{$pv_id}{vname} = $pkg_ver;
931 
                    $versions{$pv_id}{vcsTag} = $vcstag;
932 
                    $versions{$pv_id}{created} = $created;
933 
                    $versions{$pv_id}{created_id} = $created_id;
934 
                    $versions{$pv_id}{comment} = $comment;
935 
                    $versions{$pv_id}{locked} = $locked;
936 
                    $versions{$pv_id}{TimeStamp} = str2time( $created );
937 
                    $versions{$pv_id}{Age} = ($now - $versions{$pv_id}{TimeStamp}) / (60 * 60 * 24);
938 
                    $versions{$pv_id}{TooOld} = 1 if ( $opt_age && $opt_age <= $versions{$pv_id}{Age} );
939 
                    examineVcsTag($pv_id);
940 
                    #
941 
                    #   Convert version into full form for comparisions
942 
                    #
943 
                    my $version = $pkg_ver;
944 
                    my $suffix;
945 
                    if ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-.][p]?(\d+)([-.](.*))?$~ ) {
946 
                        $suffix = defined $6 ? ".$6" : '';
947 
                        $version = sprintf("%3.3d.%3.3d.%3.3d.%3.3d%s", $1,$2,$3,$4,$suffix || '.0000');
948 
                    }
949 
                    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)([-.](.*))?$~ ) {
950 
                        my $patch = $3;
951 
                        my $build = '000';
952 
                        if ( length( $patch) >= 4 )
953 
                        {
954 
                            $build = substr( $patch, -3 ,3);
955 
                            $patch = substr( $patch,  0 ,length($patch)-3);
956 
                        }
957 
 
958 
                        $suffix = defined $5 ? ".$5" : '';
959 
                        $version = sprintf("%3.3d.%3.3d.%3.3d.%3.3d%s", $1,$2,$patch,$build,$suffix || '.0000');
960 
                    }
961 
                    elsif ( $version =~ m~(.*)\.cots$~ ) {
962 
                        my $cots_base = $1;
963 
                        $suffix = '.cots';
964 
                        unless ( $version =~ m~(.*)(\.[0-9]4)\.cots~ )
965 
                        {
966 
                            $version = $cots_base . '.0000.cots';
967 
                        }
968 
                    }
969 
                    else  {
970 
                        $pkg_ver =~ m~(\.\w+)$~;
971 
                        $suffix = $1 || '';
972 
                    }
973 
                    $versions{$pv_id}{version} = $version;
974 
 
975 
                    #
976 
                    #   Process suffix
977 
                    #
978 
                    $suffix = 'Unknown' unless ( $suffix );
979 
                    $suffix = lc ($suffix);
980 
                    $versions{$pv_id}{suffix} = $suffix;
981 
                    push @{$suffixes{$suffix}}, $pv_id;
982 
 
983 
 
984 
                    print "$pkg_name, $pkg_ver, $pv_id, $last_pv_id, $created, $created_id, $suffix\n";
985 
                }
986 
            }
987 
            else
988 
            {
989 
                Error ("GetData_by_pkg_id: No Data: $m_sqlstr");
990 
            }
991 
            $sth->finish();
992 
        }
993 
        else
994 
        {
995 
                Error ("GetData_by_pkg_id: Execute: $m_sqlstr");
996 
        }
997 
    }
998 
    else
999 
    {
1000 
        Error("GetData_by_pkg_id:Prepare failure" );
1001 
    }
1002 
}
1003 
 
1004 
#-------------------------------------------------------------------------------
1005 
# Function        : examineVcsTag
1006 
#
1007 
# Description     : Examine a VCS Tag and determine if it looks like rubbish
1008 
#
1009 
# Inputs          : $entry
1010 
#
1011 
# Returns         : Will add Data to the $entry
1012 
#
1013 
sub examineVcsTag
1014 
{
1015 
    my ($entry) = @_;
1016 
    my $bad = 0;
1017 
    my $vcstag = $versions{$entry}{vcsTag};
1018 
    if ( $vcstag =~ m~^CC::(.*?)(::(.+))?$~ )
1019 
    {
1020 
        my $path = $1  || '';
1021 
        my $label = $2 || '';
1022 
        $bad = 1 unless ( $label );
1023 
        $bad = 1 if ( $label =~ m~^N/A$~i || $label  =~ m~^na$~i );
1024 
 
1025 
        $bad = 1 unless ( $path );
1026 
        $bad = 1 if ( $path =~ m~^N/A$~i || $path  =~ m~^na$~i );
1027 
        $bad = 1 if ( $path =~ m~^/dpkg_archive~ || $path  =~ m~^dpkg_archive~ );
1028 
        $bad = 1 if ( $path =~ m~^http:~i );
1029 
        $bad = 1 if ( $path =~ m~^[A-Za-z]\:~ );
1030 
        $bad = 1 if ( $path =~ m~^//~ );
1031 
#        $bad = 1 unless ( $path =~ m~^/~ );
1032 
    }
1033 
    else
1034 
    {
1035 
        $bad = 1;
1036 
    }
1037 
 
1038 
    $versions{$entry}{badVcsTag} = 1 if ( $bad );
1039 
}
1040 
 
1041 
#-------------------------------------------------------------------------------
1042 
# Function        : logErrors
1043 
#
1044 
# Description     : This function is registered with the Jats Error processing
1045 
#                   It will be called on Errors and Messages
1046 
#
1047 
# Inputs          : Message to log
1048 
#
1049 
# Returns         : Does not return
1050 
#
1051 
sub logErrors
1052 
{
1053 
    my ($tag,@message) = @_;
1054 
    logToFile( $logSummary, $tag, @message ) if ( $logSummary );
1055 
}
1056 
 
1057 
 
1058 
#-------------------------------------------------------------------------------
1059 
# Function        : logToFile
1060 
#
1061 
# Description     : Log some data to a named file
1062 
#
1063 
# Inputs          : $filename           - Name of file to log
1064 
#                   ...                 - Data to log
1065 
#
1066 
# Returns         : Nothing
1067 
#
1068 
sub logToFile
1069 
{
1070 
    my ($file, @data) = @_;
1071 
 
1072 
    open  (LOGFILE, '>>', $file);
1073 
    print  LOGFILE "@data\n";
1074 
    close (LOGFILE);
1075 
}
1076 
 
1077 
#-------------------------------------------------------------------------------
1078 
# Function        : createImages
1079 
#
1080 
# Description     : Create nice images of the RM version tree
1081 
#
1082 
# Inputs          :
1083 
#
1084 
# Returns         :
1085 
#
1086 
sub createImages
1087 
{
1088 
 
1089 
    my $filebase = "${opt_package}_versions";
1090 
    open (FH, ">$filebase.dot" ) or die "Cannot open output";
1091 
    print FH "digraph world {\n";
1092 
    #print FH "\trankdir=LR;\n";
1093 
    print FH "\tnode[fontsize=24];\n";
1094 
 
1095 
    if ( $opt_flat )
1096 
    {
1097 
        my $last = 0;
1098 
        foreach my $entry (sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions) )
1099 
        {
1100 
    print "-- $entry, $versions{$entry}{version}, $versions{$entry}{vname}\n";
1101 
            if ( $last )
1102 
            {
1103 
                my $me = GetVname($last);
1104 
                print FH "\t", pentry($me)  ," -> { ", plist ( ' ; ', GetVname( $entry) ), " }\n";
1105 
                print FH "\t", pentry($me)  ,"[label=\"$me\\n$last\"];\n";
1106 
            }
1107 
            $last = $entry;
1108 
        }
1109 
    }
1110 
    else
1111 
    {
1112 
        foreach my $entry ( sort keys(%versions) )
1113 
        {
1114 
            my @versions;
1115 
            my $me = GetVname($entry);
1116 
            my $distanceCount = $versions{$entry}{distance};
1117 
            foreach ( @{ $versions{$entry}{next}} )
1118 
            {
1119 
                push @versions, GetVname( $_);
1120 
            }
1121 
 
1122 
            my @label = $versions{$entry}{vname};
1123 
            my $excludeText;
1124 
            $excludeText = 'Excluded' if ( $versions{$entry}{Exclude}  );
1125 
            $excludeText .= ' (N)' if ($versions{$entry}{locked} eq 'N');
1126 
            $excludeText .= ' (B)' if (exists $versions{$entry}{badVcsTag});
1127 
            push @label, $excludeText if ( $excludeText );
1128 
 
1129 
            my $labelText = join ('\n', @label );
1130 
 
1131 
            print FH "\t", pentry($me)  ," -> { ", plist ( ' ; ', @versions ), " }\n";
1132 
            print FH "\t", pentry($me)  ,"[label=\"$labelText\"];\n";
1133 
     #       print FH "\t", pentry($me)  ,"[label=\"$me\\n$distanceCount\\n$entry\"];\n";
1134 
            print FH "\t", pentry($me)  ,"[shape=rectangle];\n" if ($versions{$entry}{main});
1135 
        #    print FH "\t", pentry($me)  ,"[shape=circle];\n" if ($versions{$entry}{main});
1136 
            print FH "\t", pentry($me)  ,"[shape=octagon];\n" if ($versions{$entry}{branchPoint});
1137 
            print FH "\t", pentry($me)  ,"[shape=invhouse];\n" if ($versions{$entry}{newSuffix});
1138 
 
1139 
        }
1140 
    }
1141 
 
1142 
 
1143 
    print FH "\n};\n";
1144 
    close FH;
1145 
 
1146 
    #
1147 
    #   Convert DOT to a SVG
1148 
    #
1149 
    print "Generating graphical images\n";
1150 
    system( "dot $filebase.dot -Tjpg -o$filebase.jpg" );  # -v
1151 
    system( "dot $filebase.dot -Tsvg -o$filebase.svg" );  # -v
1152 
 
1153 
    #
1154 
    #   Display a list of terminal packages
1155 
    #   These are packages that are not used by any other package
1156 
    #
1157 
    print "\n";
1158 
    print "Generated: $filebase.dot\n";
1159 
    print "Generated: $filebase.jpg\n";
1160 
    print "Generated: $filebase.svg\n";
1161 
 
1162 
}
1163 
 
1164 
#-------------------------------------------------------------------------------
1165 
# Function        : plist
1166 
#
1167 
# Description     : Generate an entry list as text
1168 
#                   Replace "." with "_" since DOT doesn't like .'s
1169 
#                   Seperate the arguments
1170 
#
1171 
# Inputs          : $pref       - Prefix string
1172 
#                   @_          - An array of entries to process
1173 
#
1174 
# Returns         : A string
1175 
#
1176 
sub plist
1177 
{
1178 
    my $pref = shift;
1179 
    my $result = "";
1180 
    foreach  ( @_ )
1181 
    {
1182 
        $_ =~ s~\.~_~g;
1183 
        $result .= '"' . $_ . '"' . $pref;
1184 
    }
1185 
    return $result;
1186 
}
1187 
 
1188 
sub pentry
1189 
{
1190 
 
1191 
    my $result = "";
1192 
    foreach  ( @_ )
1193 
    {
1194 
        next unless ( $_ );
1195 
        $_ =~ s~\.~_~g;
1196 
        $result .= '"' . $_ . '"'
1197 
    }
1198 
    return $result;
1199 
}
1200 
 
1201