Subversion Repositories DevTools

########################################################################
# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.
#
# Module name   : jats.sh
# Module type   : Makefile system
# Compiler(s)   : n/a
# Environment(s): jats
#
# Description   : Get package information for a package name specified on the
#                 command line.
#
#                 Determine the package id
#                 Locate all packages that have the same package name
#
#                 Pump it into SVN
#
#                 Project Based Pumping
#
#......................................................................#

require 5.006_001;
use strict;
use warnings;
use JatsError;
use JatsRmApi;
use FileUtils;
use JatsSystem;
use HTTP::Date;


#use Data::Dumper;
use Cwd;
use DBI;
use Getopt::Long;
use Pod::Usage;                             # required for help support

#
#   Options
#
my $opt_help = 0;
my $opt_manual = 0;
my $opt_verbose = 0;
my $opt_repo_base = 'https://auawsasvn001.vix.local/svn/';
my $opt_repo;
my $opt_package;
my $opt_resume;
my $opt_flat;
my $opt_test;
my $opt_reuse;
my $opt_age;
my $opt_dump = 0;
my $opt_images = 0;
my $opt_tailcount;

################################################################################
#   List of Projects Suffixes and Branch Names to be used within SVN
#
my %ProjectsBaseCreated;
my %Projects = (
    '.sea' => 'Seattle',
    '.coct' => 'CapeTown',
    '.sls'  => 'Stockholm',
    '.syd'  => 'Sydney',
    '.vtk'  => 'Vasttrafik',
    '.bei'  => 'Beijing',
    '.bkk'  => 'Bangkok',
    '.mas'  => 'Mass',
    '.ndl'  => 'NewDelhi',
    '.nzs'  => 'NewZealandStageCoach',
    '.was'  => 'Washington',
    '.wdc'  => 'Washington',
    '.oso'  => 'Oslo',
    '.lvs'  => 'LasVegas',
    '.mlc'  => 'BeijingMlc',
    '.sfo'   => 'SanFrancisco',
    '.sf'   => 'SanFrancisco',
    'unknown' => 'UnknownProject',
);

################################################################################
#   Global data
#
my $VERSION = "1.0.0";
my $RM_DB;
my $currentBranchName;
my $last_pv_id;
my $pkg_id;
my %versions;
my %suffixes;
my @processOrder;
my @startPoints;
my @endPoints;
my @BranchPoints;
my $now = time();
my $logSummary;


my $result = GetOptions (
                "help+"         => \$opt_help,          # Help
                "manual"        => \$opt_manual,        # Help
                "verbose+"      => \$opt_verbose,       # Versose
                "repository:s"  => \$opt_repo,          # Name of repository
                "resume:s"      => \$opt_resume,        # Resume at given version
                "flat!"         => \$opt_flat,          # Flat structure
                "test!"         => \$opt_test,          # Test operations
                "reuse!"        => \$opt_reuse,         # Reuse ClearCase views
                "age:i"         => \$opt_age,           # Only recent versions
                "dump:1"        => \$opt_dump,          # Dump Data
                "images:1"      => \$opt_images,        # Create DOT images
                "last:i"        => \$opt_tailcount,     # Retain last N versions of each project
                );

#
#   Process help and manual options
#
pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);
pod2usage(-verbose => 1)  if ($opt_help == 2 );
pod2usage(-verbose => 2)  if ($opt_manual || ($opt_help > 2));

#
#   Configure the error reporting process now that we have the user options
#
ErrorConfig( 'name'    =>'PLAY9d',
             'verbose' => $opt_verbose,
             'log'     => \&logErrors,
              );

Error("No repository specified. ie -repo=DevTools, COTS") unless ( defined $opt_repo );
Error("Specify a package as 'name'" ) unless ( defined $ARGV[0] );

$opt_package = $ARGV[0];
$opt_repo = $opt_repo_base . $opt_repo;

Verbose( "Base Package: $opt_package");
Verbose( "Repo URL: $opt_repo");

#
#   Body of the process
#
GetPkgIdByName ( $opt_package );
GetData_by_pkg_id ( $pkg_id );
MassageData();

if ( $opt_dump )
{
    DebugDumpData ("Versions", \%versions );
    DebugDumpData ("Starts", \@startPoints );
    DebugDumpData ("Ends", \@endPoints );
    DebugDumpData ("Suffixes", \%suffixes );
}

if ( $opt_images )
{
    createImages();
}

exit if ( ($opt_dump > 1) || ($opt_images > 1) );


#
#   Process all packages
#       Going to create versions based on RM structure
#       May have several starting points: Process each
#
newPackage();

if ( $opt_flat )
{
    newProject();
    foreach my $entry (sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions) )
    {
        processPackage( $entry, $versions{$entry}{suffix} );
    }
}
else
{
    processBranch(@startPoints);
}
endPackage();
exit 0;

#-------------------------------------------------------------------------------
# Function        : MassageData
#
# Description     : 
#
# Inputs          : 
#
# Returns         : 
#
my %seenSuffixes;
sub calcLinks
{
    #
    #   Process the 'versions' hash and:
    #   Add back references
    #   Find starts and ends
    #       Entry with no previous
    #       Entry with no next
    #
    foreach my $entry ( keys(%versions) )
    {
        foreach ( @{ $versions{$entry}{next}} )
        {
            $versions{$_}{last} = $entry;
        }
    }
    @startPoints = ();
    @endPoints = ();
    foreach my $entry ( keys(%versions) )
    {
        push @startPoints, $entry
            unless ( exists $versions{$entry}{last} );

        push @endPoints, $entry
            unless ( @{$versions{$entry}{next}} > 0  )
    }
}

sub MassageData
{
    calcLinks();
    #
    #   Attempt to glue 'stray' versions into a project
    #   Strays are those that have no next or last
    #
    {
    my %Strays;
    my %ProjectRoots;
    my @Remainders;
    my $reprocess=0;
        foreach my $entry ( @startPoints )
        {
            unless ( exists $versions{$entry}{next}[0]  )
            {
                push @{$Strays{$versions{$entry}{suffix}}}, $entry;
            }
            else
            {
                $ProjectRoots{$versions{$entry}{suffix}} = $entry;
            }
        }

        foreach ( keys %Strays )
        {
            if ( exists $ProjectRoots{$_} )
            {
                my @list = reverse sort @{$Strays{$_}};
                my $last = $ProjectRoots{$_} ;
                $reprocess = 1;
                foreach my $entry ( @list )
                {
                    push @{$versions{$entry}{next}}, $last;
                    $last = $entry;
                }
            }
            else
            {
                push @Remainders, @{$Strays{$_}};
            }
        }

        #
        #   Put strays that cannot be assigned to a project into a group
        #   of there own.
        #
        my $last = pop @Remainders;
        foreach my $entry ( @Remainders )
        {
            push @{$versions{$entry}{next}}, $last;
            $last = $entry;
        }

        #
        #   Recalc basic links if any processing done
        #
        calcLinks()
            if ( $reprocess );
    }


    #
    #   Walk each starting point list and determine new Projects
    #
    foreach my $entry ( @startPoints )
    {
        processBranchLists($entry);

        sub processBranchLists
        {
            foreach my $entry ( @_ )
            {
                my $s = $versions{$entry}{suffix};
                unless ( exists $seenSuffixes{$s} )
                {
                    $seenSuffixes{$s} = 1;
                    push @BranchPoints, $entry;
                    $versions{$entry}{branchPoint} = 1;
                    $versions{$entry}{newSuffix} = 1;
                }
                processBranchLists (@{$versions{$entry}{next}});
            }
        }
    }

    #
    #   For each leaf ( end point ), walk backwards and mark each node with the
    #   distance from the end. If we get to a node which already has been marked then
    #   stop if our length is less. We want the value to be the longest distance to
    #   a leaf
    #
    my $distanceCount;
    foreach my $entryPoint ( @endPoints )
    {
        $distanceCount = 0;
        my $entry = $entryPoint;
        while ( $entry )
        {
            if ( defined $versions{$entry}{distance} )
            {
                if ( $versions{$entry}{distance} > $distanceCount )
                {
                    last;
                }
            }
            $versions{$entry}{distance} = $distanceCount++;
            $entry = $versions{$entry}{last};
        }
    }

    #
    #   Mark entries that exceed the configured distance from the end
    #   of each leaf
    #
    if ( $opt_tailcount )
    {
        foreach my $entryPoint ( @endPoints )
        {
            $distanceCount = 0;
            my $entry = $entryPoint;
            while ( $entry )
            {
                if ( $distanceCount > $opt_tailcount )
                {
                    $versions{$entry}{TooFar} |= 2;
                }
                else
                {
                    $versions{$entry}{TooFar} |= 1;
                }
                $distanceCount++;
                $entry = $versions{$entry}{last};
            }
        }
    }

    #
    #   Locate all instances where a package-version branches
    #   Determine the version that should be on the non-branching path
    #
    #   Reorder the 'next' list so that the first item is the non-branching
    #   path. This will be used in the data-insertion phase to simplify the
    #   processing.
    #
    foreach my $entry ( sort keys(%versions) )
    {
        my @next = @{$versions{$entry}{next}};
        my $count = @next;
        my @ordered;
        my $main;

        #
        #   Recalculate general version exclusion data
        #
        delete $versions{$entry}{TooFar} if ( defined($versions{$entry}{TooFar}) && $versions{$entry}{TooFar} & 1);
        if ( $versions{$entry}{TooFar} || $versions{$entry}{TooOld} || ($versions{$entry}{locked} eq 'N') )
        {
            $versions{$entry}{Exclude} = 1;
        }

        if ( $count > 0 )
        {
            my %nexts = map { $_ => 1 } @next;
            foreach my $e ( @next )
            {
                #
                #   Remove those that already have a branch,
                #   or where the branch is tool old
                #
                if ( $versions{$e}{branchPoint} || $versions{$e}{newSuffix} || $versions{$entry}{Exclude} )
                {
                    push @ordered, $e;
                    delete $nexts{$e};
                }
            }

            #
            #   Select longest arm as the non-branching path
            #
            my $count = -1;
            my $countEntry;
            foreach my $e ( sort keys %nexts )
            {
                if ( $versions{$e}{distance} > $count )
                {
                    $count = $versions{$e}{distance};
                    $countEntry = $e;
                }
            }
            if ($countEntry)
            {
                $main = $countEntry;
                delete $nexts{$countEntry};
            }

            #
            #   Mark remaining as non-main
            #
            foreach my $e ( keys %nexts )
            {
                push @ordered, $e;
                $versions{$e}{branchPoint} = 1;
            }

            #
            #   Re-order 'next' so that the main path is first
            #
            @ordered = sort @ordered;
            unshift @ordered, $main if ( $main );
            @{$versions{$entry}{next}} = @ordered;
        }
    }

    #
    #   Walk the newSuffix start points and move the newSuffix tag down
    #   to a non-excluded node
    #
    foreach ( @BranchPoints )
    {
        my $entry = $_;
        while ( $versions{$entry}{Exclude} )
        {
            $versions{$entry}{newSuffix} = 0;
            $entry = $versions{$entry}{next}[0];
        }
        $versions{$entry}{newSuffix} = 1;
    }
}

#-------------------------------------------------------------------------------
# Function        : processBranch
#
# Description     : Process one complete branch within the tree of versions
#                   May be called recursivly to walk the tree
#
# Inputs          : Array of package-version ID to process
#
# Returns         : Nothing
#

sub processBranch
{
    foreach my $entry ( @_ )
    {
        #
        #   Do we need to create a branch before we can process this package
        #
        if ( $versions{$entry}{newSuffix} || $versions{$entry}{branchPoint} )
        {
            newProject();
            createBranchPoint ($entry);
        }

        processPackage( $entry );
        processBranch (@{$versions{$entry}{next}});
    }
}

#-------------------------------------------------------------------------------
# Function        : processPackage
#
# Description     : Process a package version
#
# Inputs          : $entry              - Ref to entry being proccessed
#
# Returns         :
#
sub processPackage
{
    my ($entry) = @_;
    my $rv;

    print "--- Entry:",GetVname($entry)," Tag: ",$versions{$entry}{vcsTag},"\n";
    push @processOrder, $entry;
    return if ( $opt_test );
    return if ( $versions{$entry}{Exclude} );

    #
    #   Allow resumption
    #   Assumes a great deal ...
    #   Designed to allow manual recovery
    #
    if ( $opt_resume )
    {
        return if ( $opt_resume ne GetVname($entry) );
        $opt_resume = undef;
    }

    #
    #   Determine version information
    #
    my $opt_label = $opt_package . '_' . GetVname($entry);

    my $tag = $versions{$entry}{vcsTag} || '';
    $tag =~ s~\\~/~g;
    $tag =~ m~^(.+?)::(.*?)(::(.+))?$~;

    my $cc_label = $4;
    my $opt_path = $2;
    if ( !defined $opt_path || ! defined $cc_label )
    {
        print "--- (E) Error: Bad Config Spec for:",GetVname($entry),"\n";
        return;
    }

    $opt_path = '/' . $opt_path;
    $opt_path =~ s~\\~/~g;
    $opt_path =~ s~//~/~g;

print "--- Path: $opt_path, Label: $cc_label\n";

    my @author;
    my $author = $versions{$entry}{created_id};
    if ( $author )
    {
        push @author, '-author', $author;
    }
    my $created = $versions{$entry}{created};
    if ( $created )
    {
        $created =~ s~ ~T~;
        $created .= '00000Z';
        push @author, '-date', $created;
    }

    my $log = $versions{$entry}{comment};
    if ( $log )
    {
        push @author, '-log', $log;
    }

    #
    #   Create CC view
    #   Import into Subversion View
    #
    SystemConfig ('ExitOnError' => 0);
    if ( $opt_reuse && -d ("$cc_label/$opt_path") )
    {
        Message ("Reusing view: $cc_label");
        $rv = 0;
    }
    else
    {
        $rv = JatsToolPrint ( 'jats_ccrelease', '-extractfiles', '-root=.' , '-noprefix',
                    "-label=$cc_label" ,
                    "-path=$opt_path");

        unless ( -d ("$cc_label/$opt_path") )
        {
            $rv = 1;
        }
    }

    unless ( $rv )
    {
        SystemConfig ('ExitOnError' => 1);
        my $import_label = $opt_label;
        $import_label = $cc_label if ( $cc_label =~ m~WIP$~ );
        my @args;
        push @args, "-branch=$currentBranchName" if ( defined $currentBranchName );

        JatsToolPrint ( 'jats_svn', 'import', '-reuse' ,
                        "-package=$opt_repo/$opt_package",
                        "-dir=$cc_label/$opt_path",
                        "-label=$import_label",
                        @args,
                        @author
                         );
        $versions{$entry}{TagCreated} = 1;
    }

    #
    #   Delete the created view
    #   Its just a directory, so delete it
    #
    RmDirTree ($cc_label) if -d ($cc_label && (! $opt_reuse) || ($rv));
}

#-------------------------------------------------------------------------------
# Function        : newProject
#
# Description     : Start a new project within a package
#
# Inputs          : 
#
# Returns         : 
#
sub newProject
{
    print "---- New Project\n";
    return if ( $opt_resume  );
    
    #
    #   New project
    #   Kill the running import directory
    #
    RmDirTree ('SvnImportDir');
}

#-------------------------------------------------------------------------------
# Function        : newPackage
#
# Description     : Start processing a new package
#
# Inputs          : 
#
# Returns         : 
#
sub newPackage
{
    print "---- New Package\n";
    return if ( $opt_resume  );

    $logSummary = $opt_package . ".summary.log";
    unlink $logSummary;
    logToFile( $logSummary, "PackageName: $opt_package");

    #
    #   First entry being created
    #   Prime the work area
    #
    SystemConfig ('ExitOnError' => 1);
    JatsToolPrint ( 'jats_svn', 'delete-package', '-noerror',  "$opt_repo/$opt_package" );
    JatsToolPrint ( 'jats_svn', 'create', "$opt_repo/$opt_package" );
    RmDirTree ('SvnImportDir');
}

#-------------------------------------------------------------------------------
# Function        : createBranchPoint
#
# Description     : Create a branch point for the current work
#
# Inputs          : $entry                  Entry being processed
#
# Returns         : 
#
sub createBranchPoint
{
    my ($entry) = @_;
    my $forceNewProject;
    print "---- Create Branch Point\n";

    return if ( $versions{$entry}{Exclude} );

    #
    #   Find previous good tag
    #   We are walking a tree so something should have been created, but
    #   the one we want may have had an error
    #
    #   Walk backwards looking for one that has been created
    #
    my $last = $versions{$entry}{last};
    while ( $last )
    {
        unless ( $versions{$last}{TagCreated} )
        {
            $last = $versions{$last}{last};
        }
        else
        {
            last;
        }
    }

    #
    #   If we have walked back to the base of the tree then we will create
    #   an empty view
    #
    unless ( $last )
    {
    print "---- Create Branch Point: New Root Branch\n";
        $forceNewProject = 1;
    }

    #
    #   Determine source name
    #   This MUST have been created before we can branch
    #
    my $src_label;
    $src_label = ($opt_package . '_' . GetVname($last)) if $last;

    #
    #   Create target name
    #
    my $tgt_label;
    if ( $forceNewProject || $versions{$entry}{newSuffix} || !defined $src_label )
    {
        #
        #   Create target name based on project
        #
        my $suffix = $versions{$entry}{suffix};
        if ( $suffix )
        {
            Error ("Unknown Project: $suffix") unless ( defined $Projects{$suffix} );
            if ( ! exists $ProjectsBaseCreated{$suffix} )
            {
                $tgt_label = $Projects{$suffix};
                $ProjectsBaseCreated{$suffix} = 1;
            }
            else
            {
                #
                #   Project Base Already taken
                #   Have disjoint starting points
                #
                $tgt_label = $Projects{$suffix} . '.' . $ProjectsBaseCreated{$suffix};
                $ProjectsBaseCreated{$suffix}++;
            }
        }
        else
        {
            #
            #   No suffix in use
            #
            #   Currently not handled
            #   May have to force the use of the trunk
            #
            Error ("INTERNAL ERROR: No suffix present");
        }
    }
    else
    {
        $tgt_label = $src_label . '_for_' . $opt_package . '_' . GetVname($entry);
    }

    #
    #   Save branch name for use when populating sandbox
    #
    $currentBranchName = $tgt_label;

    #
    #   Perform the branch
    #
    if ( $src_label )
    {
        SystemConfig ('ExitOnError' => 1);
        JatsToolPrint ( 'jats_svnlabel',
                        '-packagebase', "$opt_repo/$opt_package",
                        'tags/' . $src_label,
                        '-branch',
                        '-clone', $tgt_label,
                      );
    }
}


#-------------------------------------------------------------------------------
# Function        : endPackage
#
# Description     : End of package processing
#                   Clean up and display problems
#
# Inputs          : 
#
# Returns         : 
#
sub endPackage
{
    RmDirTree ('SvnImportDir');

    #
    #   Display versions that did not get created
    #
    foreach my $entry ( @processOrder )
    {
        $versions{$entry}{Scanned} = 1;
        next if ( $versions{$entry}{TagCreated} );
        Warning ("Not Processed: " . GetVname($entry) );
    }

    foreach my $entry ( keys(%versions) )
    {
        next if ( $versions{$entry}{Scanned} );
        Warning ("(E) INTERNAL ERROR. Package Not Processed: " . GetVname($entry) );
    }

    Message ("All Done");
}

sub JatsToolPrint
{
    Information ("Command: @_");
    JatsTool @_;
}

sub GetVname
{
    my ($entry) = @_;
    my $me = 'NONE';
    if ( $entry )
        {
        $me = $versions{$entry}{vname};
        unless ( $me )
        {
            $me = 'Unknown-' . $entry;
        }
    }
    return $me;
}

exit 0;


#-------------------------------------------------------------------------------
# Function        : GetPkgIdByName
#
# Description     :
#
# Inputs          : pkg_name
#
# Returns         :
#
sub GetPkgIdByName
{
    my ( $pkg_name ) = @_;
    my (@row);
    my $pv_id;

    #
    #   Establish a connection to Release Manager
    #
    connectRM(\$RM_DB) unless ( $RM_DB );

    #
    #   Extract data from Release Manager
    #
    my $m_sqlstr = "SELECT pkg.PKG_NAME, pkg.PKG_ID" .
                   " FROM RELEASE_MANAGER.PACKAGES pkg" .
                   " WHERE pkg.PKG_NAME = \'$pkg_name\'";
                   
    my $sth = $RM_DB->prepare($m_sqlstr);
    if ( defined($sth) )
    {
        if ( $sth->execute( ) )
        {
            if ( $sth->rows )
            {
                while ( @row = $sth->fetchrow_array )
                {
                    Verbose( "DATA: " . join(',', @row) );
                    $pkg_id = $row[1] || 0;
                    last;
                }
            }
            else
            {
                Error ("GetPkgIdByName:No Data for package: $pkg_name");
            }
            $sth->finish();
        }
    }
    else
    {
        Error("GetPkgIdByName:Prepare failure" );
    }
}

#-------------------------------------------------------------------------------
# Function        : GetData_by_pkg_id
#
# Description     :
#
# Inputs          : pv_id
#
# Returns         :
#
sub GetData_by_pkg_id
{
    my ( $pkg_id ) = @_;
    my (@row);

    #
    #   Establish a connection to Release Manager
    #
    connectRM(\$RM_DB) unless ( $RM_DB );

    #
    #   Extract data from Release Manager
    #
    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 ".
                   " FROM RELEASE_MANAGER.PACKAGES pkg, RELEASE_MANAGER.PACKAGE_VERSIONS pv, ACCESS_MANAGER.USERS amu" .
                   " WHERE pv.PKG_ID = \'$pkg_id\' AND pkg.PKG_ID = pv.PKG_ID AND pv.CREATOR_ID = amu.USER_ID";
                   
                   
    my $sth = $RM_DB->prepare($m_sqlstr);
    if ( defined($sth) )
    {
        if ( $sth->execute( ) )
        {
            if ( $sth->rows )
            {
                while ( @row = $sth->fetchrow_array )
                {
                    Verbose( "DATA: " . join(',', @row) );
                    my $pkg_name = $row[0] || 'Unknown';
                    my $pkg_ver = $row[1] || 'Unknown';
                    my $pv_id = $row[3] || 'Unknown';
                    my $last_pv_id = $row[4] || 'Unknown';
                    my $created =  $row[5] || 'Unknown';
                    my $vcstag =  $row[6] || 'Unknown';
                    my $created_id =  $row[7] || 0;
                    my $comment =  $row[8] || '';
                    my $locked =  $row[9] || 'N';

                    #
                    #   Add data to the hash
                    #       Remove entries that address themselves
                    #
                    push (@{$versions{$last_pv_id}{next}}, $pv_id) unless ($pv_id == $last_pv_id) ;
                    $versions{$pv_id}{vname} = $pkg_ver;
                    $versions{$pv_id}{vcsTag} = $vcstag;
                    $versions{$pv_id}{created} = $created;
                    $versions{$pv_id}{created_id} = $created_id;
                    $versions{$pv_id}{comment} = $comment;
                    $versions{$pv_id}{locked} = $locked;
                    $versions{$pv_id}{TimeStamp} = str2time( $created );
                    $versions{$pv_id}{Age} = ($now - $versions{$pv_id}{TimeStamp}) / (60 * 60 * 24);
                    $versions{$pv_id}{TooOld} = 1 if ( $opt_age && $opt_age <= $versions{$pv_id}{Age} );
                    examineVcsTag($pv_id);
                    #
                    #   Convert version into full form for comparisions
                    #
                    my $version = $pkg_ver;
                    my $suffix;
                    if ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-.][p]?(\d+)([-.](.*))?$~ ) {
                        $suffix = defined $6 ? ".$6" : '';
                        $version = sprintf("%3.3d.%3.3d.%3.3d.%3.3d%s", $1,$2,$3,$4,$suffix || '.0000');
                    }
                    elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)([-.](.*))?$~ ) {
                        my $patch = $3;
                        my $build = '000';
                        if ( length( $patch) >= 4 )
                        {
                            $build = substr( $patch, -3 ,3);
                            $patch = substr( $patch,  0 ,length($patch)-3);
                        }

                        $suffix = defined $5 ? ".$5" : '';
                        $version = sprintf("%3.3d.%3.3d.%3.3d.%3.3d%s", $1,$2,$patch,$build,$suffix || '.0000');
                    }
                    elsif ( $version =~ m~(.*)\.cots$~ ) {
                        my $cots_base = $1;
                        $suffix = '.cots';
                        unless ( $version =~ m~(.*)(\.[0-9]4)\.cots~ )
                        {
                            $version = $cots_base . '.0000.cots';
                        }
                    }
                    else  {
                        $pkg_ver =~ m~(\.\w+)$~;
                        $suffix = $1 || '';
                    }
                    $versions{$pv_id}{version} = $version;

                    #
                    #   Process suffix
                    #
                    $suffix = 'Unknown' unless ( $suffix );
                    $suffix = lc ($suffix);
                    $versions{$pv_id}{suffix} = $suffix;
                    push @{$suffixes{$suffix}}, $pv_id;


                    print "$pkg_name, $pkg_ver, $pv_id, $last_pv_id, $created, $created_id, $suffix\n";
                }
            }
            else
            {
                Error ("GetData_by_pkg_id: No Data: $m_sqlstr");
            }
            $sth->finish();
        }
        else
        {
                Error ("GetData_by_pkg_id: Execute: $m_sqlstr");
        }
    }
    else
    {
        Error("GetData_by_pkg_id:Prepare failure" );
    }
}

#-------------------------------------------------------------------------------
# Function        : examineVcsTag
#
# Description     : Examine a VCS Tag and determine if it looks like rubbish
#
# Inputs          : $entry
#
# Returns         : Will add Data to the $entry
#
sub examineVcsTag
{
    my ($entry) = @_;
    my $bad = 0;
    my $vcstag = $versions{$entry}{vcsTag};
    if ( $vcstag =~ m~^CC::(.*?)(::(.+))?$~ )
    {
        my $path = $1  || '';
        my $label = $2 || '';
        $bad = 1 unless ( $label );
        $bad = 1 if ( $label =~ m~^N/A$~i || $label  =~ m~^na$~i );

        $bad = 1 unless ( $path );
        $bad = 1 if ( $path =~ m~^N/A$~i || $path  =~ m~^na$~i );
        $bad = 1 if ( $path =~ m~^/dpkg_archive~ || $path  =~ m~^dpkg_archive~ );
        $bad = 1 if ( $path =~ m~^http:~i );
        $bad = 1 if ( $path =~ m~^[A-Za-z]\:~ );
        $bad = 1 if ( $path =~ m~^//~ );
#        $bad = 1 unless ( $path =~ m~^/~ );
    }
    else
    {
        $bad = 1;
    }

    $versions{$entry}{badVcsTag} = 1 if ( $bad );
}

#-------------------------------------------------------------------------------
# Function        : logErrors
#
# Description     : This function is registered with the Jats Error processing
#                   It will be called on Errors and Messages
#
# Inputs          : Message to log
#
# Returns         : Does not return
#
sub logErrors
{
    my ($tag,@message) = @_;
    logToFile( $logSummary, $tag, @message ) if ( $logSummary );
}


#-------------------------------------------------------------------------------
# Function        : logToFile
#
# Description     : Log some data to a named file
#
# Inputs          : $filename           - Name of file to log
#                   ...                 - Data to log
#
# Returns         : Nothing
#
sub logToFile
{
    my ($file, @data) = @_;

    open  (LOGFILE, '>>', $file);
    print  LOGFILE "@data\n";
    close (LOGFILE);
}

#-------------------------------------------------------------------------------
# Function        : createImages
#
# Description     : Create nice images of the RM version tree
#
# Inputs          : 
#
# Returns         : 
#
sub createImages
{

    my $filebase = "${opt_package}_versions";
    open (FH, ">$filebase.dot" ) or die "Cannot open output";
    print FH "digraph world {\n";
    #print FH "\trankdir=LR;\n";
    print FH "\tnode[fontsize=24];\n";

    if ( $opt_flat )
    {
        my $last = 0;
        foreach my $entry (sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions) )
        {
    print "-- $entry, $versions{$entry}{version}, $versions{$entry}{vname}\n";
            if ( $last )
            {
                my $me = GetVname($last);
                print FH "\t", pentry($me)  ," -> { ", plist ( ' ; ', GetVname( $entry) ), " }\n";
                print FH "\t", pentry($me)  ,"[label=\"$me\\n$last\"];\n";
            }
            $last = $entry;
        }
    }
    else
    {
        foreach my $entry ( sort keys(%versions) )
        {
            my @versions;
            my $me = GetVname($entry);
            my $distanceCount = $versions{$entry}{distance};
            foreach ( @{ $versions{$entry}{next}} )
            {
                push @versions, GetVname( $_);
            }

            my @label = $versions{$entry}{vname};
            my $excludeText;
            $excludeText = 'Excluded' if ( $versions{$entry}{Exclude}  );
            $excludeText .= ' (N)' if ($versions{$entry}{locked} eq 'N');
            $excludeText .= ' (B)' if (exists $versions{$entry}{badVcsTag});
            push @label, $excludeText if ( $excludeText );

            my $labelText = join ('\n', @label );

            print FH "\t", pentry($me)  ," -> { ", plist ( ' ; ', @versions ), " }\n";
            print FH "\t", pentry($me)  ,"[label=\"$labelText\"];\n";
     #       print FH "\t", pentry($me)  ,"[label=\"$me\\n$distanceCount\\n$entry\"];\n";
            print FH "\t", pentry($me)  ,"[shape=rectangle];\n" if ($versions{$entry}{main});
        #    print FH "\t", pentry($me)  ,"[shape=circle];\n" if ($versions{$entry}{main});
            print FH "\t", pentry($me)  ,"[shape=octagon];\n" if ($versions{$entry}{branchPoint});
            print FH "\t", pentry($me)  ,"[shape=invhouse];\n" if ($versions{$entry}{newSuffix});

        }
    }


    print FH "\n};\n";
    close FH;

    #
    #   Convert DOT to a SVG
    #
    print "Generating graphical images\n";
    system( "dot $filebase.dot -Tjpg -o$filebase.jpg" );  # -v
    system( "dot $filebase.dot -Tsvg -o$filebase.svg" );  # -v

    #
    #   Display a list of terminal packages
    #   These are packages that are not used by any other package
    #
    print "\n";
    print "Generated: $filebase.dot\n";
    print "Generated: $filebase.jpg\n";
    print "Generated: $filebase.svg\n";

}

#-------------------------------------------------------------------------------
# Function        : plist
#
# Description     : Generate an entry list as text
#                   Replace "." with "_" since DOT doesn't like .'s
#                   Seperate the arguments
#
# Inputs          : $pref       - Prefix string
#                   @_          - An array of entries to process
#
# Returns         : A string
#
sub plist
{
    my $pref = shift;
    my $result = "";
    foreach  ( @_ )
    {
        $_ =~ s~\.~_~g;
        $result .= '"' . $_ . '"' . $pref;
    }
    return $result;
}

sub pentry
{

    my $result = "";
    foreach  ( @_ )
    {
        next unless ( $_ );
        $_ =~ s~\.~_~g;
        $result .= '"' . $_ . '"'
    }
    return $result;
}