Rev 2040 | Rev 2439 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### Copyright (C) 1998-2012 Vix Technology, All rights reserved## Module name : cc2svn_importpackage.pl# Module type : Makefile system# Compiler(s) : Perl# 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# Determine essential packages# Prune uneeded packages## Pump it into SVN## Project Based Pumping, creating branches as needed##......................................................................#require 5.006_001;use strict;use warnings;use JatsError;use JatsRmApi;use FileUtils;use JatsSystem;use HTTP::Date;use JatsProperties;use JatsEnv;use ConfigurationFile;use JatsSvn qw(:All);use JatsLocateFiles;use Encode;#use Data::Dumper;use Fcntl ':flock'; # import LOCK_* constantsuse Cwd;use DBI;use Getopt::Long;use Pod::Usage; # required for help supportuse Encode;## Options#my $opt_help = 0;my $opt_manual = 0;my $opt_verbose = 0;my $opt_repo_base = 'AUPERASVN01/';my $opt_repo = '';my $opt_flat;my $opt_test;my $opt_reuse;my $opt_age;my $opt_dump = 0;my $opt_images = 0;my $opt_retaincount = 2;my $opt_pruneModeString;my $opt_listTags;my $opt_name;my $opt_log = 0;my @opt_tip;my $opt_postimage = 1;my $opt_workDir = '/work';my $opt_vobMap;my $opt_preserveProjectBase;my $opt_ignoreProjectBaseErrors;my $opt_ignoreMakeProjectErrors;my $opt_delete;my $opt_recentAge = 14; # Daysmy $opt_relabel = 0;################################################################################# List of Projects Suffixes and Branch Names to be used within SVN## Name - Name of branch for the project# Trunk - Can be a trunk project# First one seen will be placed on the trunk# Others will create project branches#my $ProjectTrunk;my %ProjectsBaseCreated;my %Projects = ('.sea' => { Name => 'Seattle' },'.coct' => { Name => 'CapeTown' },'.sls' => { Name => 'Stockholm' },'.syd' => { Name => 'Sydney' },'.vtk' => { Name => 'Vasttrafik' },'.bei' => { Name => 'Beijing' },'.bkk' => { Name => 'Bangkok' },'.ndl' => { Name => 'NewDelhi' },'.nzs' => { Name => 'NewZealandStageCoach' },'.wdc' => { Name => 'Washington' },'.oso' => { Name => 'Oslo' },'.lvs' => { Name => 'LasVegas' },'.mlc' => { Name => 'BeijingMlc' },'.sfo' => { Name => 'SanFrancisco' },'.sg' => { Name => 'Singapore' },'.gmp' => { Name => 'GmpteProject' },'.ssw' => { Name => 'UkStageCoach' },'.uk' => { Name => 'UkProject' },'.pmb' => { Name => 'Pietermaritzburg' },'.vps' => { Name => 'VixPayments' },'.ncc' => { Name => 'NSWClubCard' },'.rm' => { Name => 'Rome' },'.vss' => { Name => 'SmartSite' },'unknown' => { Name => 'UnknownProject' },'.ebr' => { Name => 'eBrio' , Trunk => 1 },'.mas' => { Name => 'Mass' , Trunk => 1 },'.cr' => { Name => 'Core' , Trunk => 1 },'.cots' => { Name => 'Cots' , Trunk => 1 },'.tool' => { Name => 'Tools' , Trunk => 1 },);my %suffixFixup = ('.sf' => '.sfo','.vt' => '.vtk','.lv' => '.lvs','.was' => '.wdc','.uk.1' => '.uk','.ssts.demo' => '.ssts','.u244.syd' => '.syd','.pxxx.sea' => '.sea','.pxxx.syd' => '.syd','.pxxx.sydddd' => '.syd','.oslo' => '.oso','.osl' => '.oso',);my @excludeFromImport = (# 22-Oct-12: Excluded on request from Kasun Sirikumara# Pending VSS work'agency_website','alx','alx-api','cardholder_website','loginmodule-ad','ols-enquiry','ols-enquiry-api','olsrpc4j','orca-middleware','orca-middleware-api','orca-salesEngine','orca-web-api','orca-web-utils','TestPaymentGateway','tgen4j','web-cd-client',# 05-Nov-12: Pending fixup for include.txt files that escape the VOB## 'ddu_app_manager',# 'ddu_dog',# 'ddu_dog_lib',# 'ddu_fim',# 'ddu_logging_lib',# 'ddu_management',# 'ddu_mccain',# 'ddu_mon',# 'ddu_rcu',# 'ddu_status_logging',);my %specialPackages = ('core_devl' => ',all,protected,','daf_utils_mos' => ',flat,','mos_packager' => ',all,','cfmgr-cfmgr' => ',flat,','daf_utils_button_st' => ',flat,','ReleaseName' => ',flat,','reports' => ',utf8,','cda_imports' => ',utf8,','cdxforms' => ',utf8,','db_cda' => ',utf8,','CommandServer' => ',IgnoreMakeProject,',# Need to be handled in a special manner# Not done by this utility#'linux_drivers_eb5600' => ',protected,','linux_drivers_viper' => ',protected,','linux_drivers_cobra' => ',protected,','linux_drivers_bcp4600' => ',protected,','linux_drivers_etx86' => ',protected,','linux_drivers_tp5600' => ',protected,',# Not in the ukHops migration at the moment'cs' => ',protected,','DBA-Common' => ',protected,','DBA-DatabaseInstall' => ',protected,','DBA-ExternalPerlModules' => ',protected,','DBA-OraUserBuild' => ',protected,','DBA-OST' => ',protected,',# 'orahops-install' => ',protected,',# 'orahops-patch' => ',protected,',# 'orahops-ssw-install' => ',protected,',# 'orahops-ssw-patch' => ',protected,',# End of ukHops migration exclussion'ftp' => 'SetProjectBase,','ddu_app_manager' => 'SetProjectBase,','icl' => 'IgnoreProjectBase,','itso' => 'IgnoreProjectBase,','daf_osa_mos' => 'IgnoreProjectBase,','daf_utils_mos' => 'IgnoreProjectBase,','itso_ud' => 'IgnoreProjectBase,',# 'mos_api' => 'IgnoreProjectBase,',# 'mos_fonts' => 'IgnoreProjectBase,',# 'sntp' => 'IgnoreProjectBase,',# 'time_it' => 'IgnoreProjectBase,',);my %notCots = ('isl' => 1,);my $ukHopsMode = 0;my %ukHopsReleases = ('6222' => { name => 'MainLine', 'trunk' => 1 },'14503' => { name => 'Hops3' },'21864' => { name => 'Hops3.6' },'22303' => { name => 'Hops3.7' },'17223' => { name => 'Hops4' },);# The following packages will have the version in the specified release forced to be on the trunk# A trunk will be forced and the version will be on it.# May only work if the version in the release is also a TIPmy %ukHopsTip = ('ItsoMessaging' => '6222','MessageProcessor' => '6222','StrongNameKey' => '6222',);################################################################################# Global data#my $VERSION = "1.0.0";my $RM_DB;my $last_pv_id;my %pkg_ids;my $first_pkg_id;my %versions;my %suffixes;my @processOrder;my @startPoints;my @allStartPoints;my @endPoints;my $now = time();my $logSummary;my $firstVersionCreated;my @EssentialPackages;my $createBranch;my $createSuffix;my $currentBranchName;my $singleProject;my $pruneCount = 0;my $trimCount = 0;my $badVcsCount = 0;my $ProjectCount = 0;my $totalVersions = 0;my $initialTrees = 0;my $globalError;my @unknownProjects;my %knownProjects;my $badSingletonCount = 0;my @flatOrder;my $pruneMode;my $pruneModeString;my $threadId = 0;my $threadCount;my %tipVersions;my $allSvn;my @multiplePaths;my @badEssentials;my %svnData;my $cwd;my $mustConvertFileNames;my $workDir;my $packageNames;my @packageNames;my $multiPackages = -1;my $visitId = 0;my $noTransfer;my $rippleCount = 0;my $svnRepo;my $processCount = 0;my $processTotal = 0;my $recentCount = 0;my $packageReLabelCount = 0;my %saneLabels;our $GBE_RM_URL;my $UNIX = $ENV{'GBE_UNIX'};my $result = GetOptions ("help+" => \$opt_help, # flag, multiple use allowed"manual:3" => \$opt_help,"verbose:+" => \$opt_verbose, # Versose"repository:s" => \$opt_repo, # Name of repository'rbase:s' => \$opt_repo_base, # Base of the repo"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"retain:i" => \$opt_retaincount, # Retain N packages"pruneMode:s" => \$opt_pruneModeString,"listtags:i" => \$opt_listTags,"name:s" => \$opt_name, # Alternate output"tip:s" => \@opt_tip, # Force tip version(s)"log!" => \$opt_log,"delete!" => \$opt_delete,"postimage!" => \$opt_postimage,'workdir:s' => \$opt_workDir,'relabel!' => \$opt_relabel,);## 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#SystemConfig ('ExitOnError' => 1);ErrorConfig( 'name' =>'CC2SVN_IMPORT','verbose' => $opt_verbose,);Error("Workdir does not exist" ) unless ( -d $opt_workDir );Error("Specify a package as 'name'" ) unless ( defined $ARGV[0] );EnvImport('GBE_RM_URL');$cwd = Getcwd();## Init the pruning mode#setPruneMode( $opt_pruneModeString || 'ripple');## Get data for all packages#foreach my $packageName ( @ARGV ){next unless ( $packageName );Verbose( "Base Package: $packageName");my $pkg_id = GetPkgIdByName ( $packageName );GetData_by_pkg_id ( $pkg_id, $packageName );$pkg_ids{$pkg_id} = 1;$first_pkg_id = $pkg_id unless ( $first_pkg_id );push @packageNames, $packageName;$multiPackages++;}{## Delete entries that have been created as we read in# data, but don't exist in RM. They will not have a pvid.#foreach my $entry ( keys(%versions) ){delete $versions{$entry}unless ( exists $versions{$entry}{pvid} );}}$totalVersions = scalar keys %versions;Error ("No packages specified") unless ( $multiPackages >= 0 );Warning ("Multiple Packages being processed") if ( $multiPackages > 1 );$packageNames = join ('_', @packageNames );$packageNames = $opt_name if ( defined $opt_name );Message ("PackageName: $packageNames" );## Save logging data#if ( $opt_log ){my $opt_logfile = $packageNames . '.import';Message ("Logging outout: $opt_logfile" );open STDOUT, '>', $opt_logfile or die "Can't redirect STDOUT: $!";open STDERR, ">&STDOUT" or die "Can't dup STDOUT: $!";}## Prepare tip version hash#$tipVersions{$_} = 1 foreach ( @opt_tip );## Read in external data and massage it all#getEssenialPackageVersions();getVobMapping();smartPackageType(); # Determine special prune modeReportPathVariance();massageData();getSvnData();smartPackageType(); # Have another gomy @missedTips = keys %tipVersions;Error ("Specified tip version not found: @missedTips") if ( @missedTips );if ( $opt_flat ){# @flatOrder = sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions);# @flatOrder = sort {$versions{$a}{created} cmp $versions{$b}{created}} keys(%versions);@flatOrder = sort {$a <=> $b} keys(%versions);my $tip = $flatOrder[-1];$versions{$tip}{Tip} = 1 if $tip;}## Generate dumps and images#if ( $opt_images ){createImages();}if ( $opt_dump ){DebugDumpData ("Versions", \%versions );DebugDumpData ("Starts", \@startPoints );DebugDumpData ("Ends", \@endPoints );DebugDumpData ("Suffixes", \%suffixes );}# Display VCS tags#if ( $opt_listTags ){foreach my $entry (sort {$versions{$a}{version} cmp $versions{$b}{version}} keys(%versions) ){print $versions{$entry}{vcsTag} || '-' ,"\n";}}exit if ( ($opt_dump > 1) || ($opt_images > 1) );transferPackageToSvn();if ( $opt_postimage ){getSvnData();createImages();}exit 0;#-------------------------------------------------------------------------------# Function : transferPackageToSvn## Description : Transfer the package to SVN## Inputs :## Returns :#sub transferPackageToSvn{Error ("Repository Path not setup")unless ( $svnRepo );## Going to do serious work# Need to ensure we have more arguments#if ( $noTransfer ){Warning("Protected Package not transferred: $packageNames[0]");exit 0;}## Perform all the work in a package specific subdirectory#$workDir = $opt_workDir . '/' . $packageNames;mkdir $workDir unless ( -d $workDir );chdir $workDir || Error ("Cannot cd to $workDir");## 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 (@flatOrder ){newPackageVersion( $entry, $versions{$entry}{suffix} );}}else{processBranch(@allStartPoints);}endPackage();chdir $cwd || Error ("Cannot cd back to $cwd");rmdir $workDir;Warning ("Work Directory still exists: $workDir");saveData();}#-------------------------------------------------------------------------------# Function : setPruneMode## Description : Set the pruning mode## Inputs : mode - Text mode value## Returns : Nothing#sub setPruneMode{my ($mode) = @_;my $value;if ( $mode ){if ( $mode =~ m/none/i) {$value = 0;} elsif ( $mode =~ m/ripple/i) {$value = 1;} elsif ( $mode =~ m/retain/i) {$value = 2;} elsif ( $mode =~ m/severe/i) {$value = 3;} else {Error ("Unknown pruning mode", "Use: none, ripple, retain or severe");}$pruneModeString = $mode;$pruneMode = $value;}}#-------------------------------------------------------------------------------# Function : smartPackageType## Description : Have a look at the projects in the package set and# attempt to determine what sort of mechanism to use## Inputs : Uses %suffixes data## Returns :#my $packageType = 'UNKNOWN';sub smartPackageType{## Rebuild suffixes hash based on post massaged versions#my %suffixes;my @unknown;foreach my $entry ( keys %versions ){my $suffix = $versions{$entry}{suffix} || '';push (@unknown, $entry) if ($suffix eq 'unknown');next if ( exists $suffixes{$suffix} );next if ( $versions{$entry}{badSingleton} );next if ( $versions{$entry}{locked} eq 'N' || $versions{$entry}{isaWip} );$suffixes{$suffix} = 1;$knownProjects{$suffix}{seen} = 1;}## The 'unknown' suffix is really an 'empty' suffix# Try to be clever# Map unknown to 'cr' or 'mas' if present##if ( exists $suffixes{'unknown'} ){my $new_suffix;if ( exists $suffixes{'.cr'} ) {$new_suffix = '.cr';} elsif ( exists $suffixes{'.mas'} ) {$new_suffix = '.mas';}if ( $new_suffix ){foreach my $entry ( @unknown ){$versions{$entry}{suffix} = $new_suffix;}delete $suffixes{'unknown'};delete $knownProjects{'unknown'}{seen};}}if ( exists $suffixes{'.cots'} && !exists ($notCots{$packageNames}) ) {$packageType = 'COTS';$Projects{'.cots'}{Trunk} = 1;$singleProject = 1;$opt_flat = 1 unless defined $opt_flat;setPruneMode('none') unless (defined $opt_pruneModeString);} elsif ( exists $suffixes{'.tool'} ) {$packageType = 'TOOL';$Projects{'.tool'}{Trunk} = 1;$singleProject = 1;setPruneMode('none') unless (defined $opt_pruneModeString);# $opt_flat = 1;} elsif ( scalar (keys %suffixes ) == 1 ) {$packageType = 'SINGLE_PROJECT';$singleProject = 1;} else {$packageType = 'MULTIPLE_PROJECT';}## Some packages are special#if ( $svnRepo =~ m~/Manufacturing(/|$)~ ){Message ("Set Manufacturing Repo style");$opt_flat = 1;setPruneMode('none') unless (defined $opt_pruneModeString);}if ( $packageNames[0] =~ m'^br_applet_' ){$opt_flat = 1 unless defined $opt_flat;}foreach ( @excludeFromImport ){$specialPackages{$_} .= 'protected,';}if ( exists $specialPackages{$packageNames[0]} ){my $data = $specialPackages{$packageNames[0]};if ( index( $data, ',all' ) >= 0) {setPruneMode('none') unless (defined $opt_pruneModeString);}if ( index( $data, 'protected,' ) >= 0) {$noTransfer = 1;}if ( index( $data, 'flat,' ) >= 0) {$opt_flat = 1;}if ( index( $data, 'SetProjectBase,' ) >= 0) {$opt_preserveProjectBase = 1;$opt_ignoreProjectBaseErrors = 1;Message ("Preserving ProjectBase");}if ( index( $data, 'IgnoreProjectBase,' ) >= 0) {$opt_ignoreProjectBaseErrors = 1;Message ("Ignore ProjectBase Errors");}if ( index( $data, 'IgnoreMakeProject,' ) >= 0) {$opt_ignoreMakeProjectErrors = 1;Message ("Ignore MakeProject Usage");}if ( index( $data, 'utf8,' ) >= 0) {$mustConvertFileNames = 1;Message ("Convert filenames to UTF8");}}Message("Package Type: $packageType, $pruneModeString");}#-------------------------------------------------------------------------------# Function : massageData## Description : Massage all the data to create a tree of package versions# that can be used to create images as well as an import order## Inputs :## Returns :#my $reprocess=0;sub calcLinks{## Process the 'versions' hash and:# Add back references# Find starts and ends# Entry with no previous# Entry with no next#$reprocess = 0;foreach my $entry ( keys(%versions) ){foreach ( @{ $versions{$entry}{next}} ){$versions{$_}{last} = $entry;}}@allStartPoints = ();@startPoints = ();@endPoints = ();foreach my $entry ( keys(%versions) ){push @startPoints, $entryunless ( exists $versions{$entry}{last} || $versions{$entry}{badSingleton} );push @allStartPoints, $entryunless ( exists $versions{$entry}{last} );push @endPoints, $entryunless ( @{$versions{$entry}{next}} > 0 )}}sub massageData{## Report unknown suffixes# Handle bad, or little known project suffixes by creating them#foreach my $suffix ( keys %suffixes ){if ( exists $Projects{$suffix} ){next;}Message ("Unknown project suffix: '$suffix'");push @unknownProjects, $suffix;my $cleanSuffix = ucfirst(lc(substr( $suffix, 1)));$Projects{$suffix}{Name} = 'Project_' . $cleanSuffix;}calcLinks();$initialTrees = scalar @allStartPoints;Message ('Total RM versions: ' . $totalVersions );Message ('Initial trees: ' . $initialTrees );## Attempt to glue all the start points into one chain.# This should allow us to track projects that branch from each other# in cases where the RM data is incorrect/incomplete# Strays are those that have no next or last## Glue based on Name, then PVID (Creation Order)#{## Examine threads. If it is a single entry thats bad then drop it# This is simple to do. Should examine all entries, but thats a# bit harder. Perhaps later.#if (1) {Message ("Dropping Bad Singletons");my $badSingletons;foreach my $entry ( sort {$a <=> $b} @startPoints ){my $ep = $versions{$entry};unless ( $ep->{last} || $ep->{next}[0] ){# if ( $ep->{isaWip} )if ( (exists $ep->{badVcsTag} && $ep->{badVcsTag}) || $ep->{isaWip} ){$ep->{badSingleton} = 1;$reprocess = 1;$badSingletonCount++;# Add to a list of its own.if ( $badSingletons ){push @{$versions{$badSingletons}{next}}, $entry;}$badSingletons = $entry;}}}calcLinks()if ( $reprocess );}## Create simple trees out of the chains# Tree is based on suffix (project) and version#{my %trees;Message ("Entries into trees");foreach my $single ( @startPoints ){my $suffix = $versions{$single}{suffix} || '';push @{$trees{$suffix}}, $single;}foreach ( keys %trees ){my $last;foreach my $entry ( sort { $versions{$a}{version} cmp $versions{$b}{version} } @{$trees{$_}} ){if ( $last ){$versions{$last}{MakeTree} = 1;push @{$versions{$last}{next}}, $entry;$reprocess = 1;}$last = $entry;}}calcLinks()if ( $reprocess );}## Have a number of trees that are project related# Attempt to create a single tree by inserting# Secondary trees into the main line at suitable points#my @AllVersions = sort { $a <=> $b } @startPoints;my $lastEntry = shift @AllVersions;Error ("Oldest entry has a previous version") if ( $versions{$lastEntry}{last} );#print "Oldest: $lastEntry\n";## Insert remaining entries into out list, which is now sorted#my @completeList;foreach my $base ( @AllVersions ){push @completeList, recurseList($lastEntry);@completeList = sort {$a <=> $b} @completeList;# Message("Complete List: ", @completeList);# Message("Complete List($completeList[0]) Length: " . scalar @completeList);$lastEntry = $base;my $last;foreach my $entry ( @completeList ){if ( $entry > $base ){Error ("Not expecting last to be empty. $base, $entry") unless ( $last );last;}$last = $entry;}## Insert at end if point not yet found##print "Inserting $base at $last\n";push @{$versions{$last}{next}}, $base;$versions{$base}{GluedIn} = 1;$reprocess = 1;}## Recalc basic links if any processing done#calcLinks()if ( $reprocess );}## Remove Dead Ends# Packages that were never released# Not locked, unless essential or a branchpoint# Won't consider these to be mainline path.#{Message ("Remove Dead Ends");foreach my $entry ( @endPoints ){my $deadWood;while ( $entry ){last if ( $versions{$entry}{Essential} );my @next = @{$versions{$entry}{next}};my $count = @next;last if ( $count > 1 );last unless ( $versions{$entry}{locked} eq 'N' || $versions{$entry}{isaWip} );$versions{$entry}{DeadWood} = 1;$trimCount++;} continue {$entry = $versions{$entry}{last};}}}## Walk each starting point list and determine new Projects# branchpoints.#Message ("Locate Projects branch points");foreach my $bentry ( keys(%versions) ){my $baseSuffix = $versions{$bentry}{suffix};foreach my $entry ( @{$versions{$bentry}{next}} ){if ( $baseSuffix ne $versions{$entry}{suffix}){unless ( exists $versions{$entry}{DeadWood} || $versions{$entry}{badSingleton} ){#print "--- Project Branch $versions{$entry}{vname}\n";$versions{$entry}{branchPoint} = 1;$versions{$entry}{newSuffix} = 1;}}}}## Mark UkHops special points#foreach my $entry ( keys(%versions) ) {foreach my $rtag_id ( keys %{$versions{$entry}{Releases}} ) {next unless ( exists $ukHopsReleases{$rtag_id} );next unless ( $svnRepo =~ m~/ITSO_TRACS$~ );## This package is current in a special ukHops release# Need to handle the differently#my $ukData = $ukHopsReleases{$rtag_id};# Mark version we want on the trunk# Will calculate tip laterif ( $ukData->{trunk} ){## Can only place on trunk IFF its a tip# May have a WIP.# Solution. Walk to the tip, but only if there is one# path.#my $end = $entry;my $last;while ( $end ){$last = $end;if ( @{$versions{$end}{next}} > 1){Warning ("Uk Release. Preferred trunk is not a tip: $versions{$entry}{vname}");last;}$end = @{$versions{$end}{next}}[0];}$versions{$last}{ukTrunk} = 1 ;}## What to do if the version is in more than one release#$versions{$entry}{ukBranch}++;if ( $versions{$entry}{ukBranch} > 1 ){Warning ("Version found in multiple Uk Releases - don't know what to do");}## What to do if the package has multiple version in a release#$ukData->{count}++;if ( $ukData->{count} > 1 ){Warning ("Package has multiple versions in the one Uk Release: $versions{$entry}{Releases}{$rtag_id}{rname}");}}}## Prune# Marks paths to root for all essential packages# Marks the last-N from all essential packages#if ( $pruneMode ){Message ("Prune Tree: $pruneModeString");foreach ( @EssentialPackages ){#next unless ( exists $versions{$_} ); # Aleady deleted# Mark previous-N to be retained as wellmy $entry = $_;my $count = 0;while ( $entry ){last if ( $versions{$entry}{KeepMe} );# unless ( $versions{$entry}{isaRipple} ){my $keepFlag = ($count++ < $opt_retaincount);last unless ( $keepFlag );$versions{$entry}{KeepMe} = $keepFlag;}$entry = $versions{$entry}{last}}}## Keep recent versions# Keep versions created in the last N days# Will keep recent ripples too#if ( $pruneMode == 1 ){foreach my $entry ( keys(%versions) ){next unless ( $versions{$entry}{Age} <= $opt_recentAge );$versions{$entry}{keepRecent} = 1;$recentCount++;#print "--- Recent version $versions{$entry}{vname}, $versions{$entry}{Age} <= $opt_recentAge\n";}# ## # Keep the tip of each branch# ## foreach my $entry ( @endPoints )# {# next if exists $versions{$entry}{keepRecent};# $versions{$entry}{keepRecent} = 1;##print "--- Tip version $versions{$entry}{vname}\n";# }}## Keep versions that are common parents to Essential Versions# Mark paths through the tree to essential versions# Mark nodes with the number of essential versions that they sprout# Don't do it if we are ripple pruning#Message ("Prune Tree keep common parents");if ( $pruneMode != 1 ){foreach my $entry ( @endPoints ){my $hasEssential = 0;$visitId++;while ( $entry ){$hasEssential = 1 if ( exists ($versions{$entry}{Essential}) && $versions{$entry}{Essential} );if ( $hasEssential ){if ( @{$versions{$entry}{next}} > 1 ){$versions{$entry}{EssentialSplitPoint}++;}last if ( exists $versions{$entry}{EssentialPath} );$versions{$entry}{EssentialPath} = 1;}if ( ($versions{$entry}{visitId} || 0) == $visitId ){DebugDumpData ("Versions", \%versions );Warning ("Circular dependency");last;}$versions{$entry}{visitId} = $visitId;$entry = $versions{$entry}{last};}}}## Keep first version of each ripple. Must keep first# Group ripples together so that they can be proccessed at the same time#calcRippleGroups()if ( $pruneMode == 1);## Delete all nodes that are not marked for retention# This is rough on the tree#Message ("Prune Tree Deleting");# 0 - Keep me# 1 - Prune mesub pruneMe{my ($entry) = @_;return 0 unless ( exists $versions{$entry} );return 0 unless ( $versions{$entry}{last} );# return 0 if ( ($pruneMode == 2) && exists $versions{$entry}{KeepMe} );return 0 if ( exists $versions{$entry}{KeepMe} );return 0 if ( exists $versions{$entry}{Essential} );return 0 if ( $versions{$entry}{newSuffix} );return 0 if ( $versions{$entry}{newSuffix} && (exists $versions{$entry}{EssentialPath}) );# return 1 if ( exists $versions{$entry}{DeadWood} );return 0 if ( exists $versions{$entry}{EssentialSplitPoint} && $versions{$entry}{EssentialSplitPoint} > 1 );return 0 if ( exists $versions{$entry}{keepLowestRipple} && $versions{$entry}{keepLowestRipple} );return 0 if ( ($pruneMode == 1) && ! $versions{$entry}{isaRipple} );return 0 if ( exists $versions{$entry}{keepRecent} && $versions{$entry}{keepRecent} );return 1;}foreach my $entry ( keys(%versions) ){#last;next unless ( pruneMe($entry) );#print "--- Prune: $versions{$entry}{vname}\n";# Delete the current node#my @newNext;$pruneCount++;my $last = $versions{$entry}{last};foreach ( @{$versions{$last}{next}} ){next if ( $_ == $entry );push @newNext, $_;}foreach ( @{$versions{$entry}{next}} ){push @newNext, $_;$versions{$_}{last} = $last;}@{$versions{$last}{next}} = @newNext;delete $versions{$entry};}# Recalculate endpointscalcLinks();}else{# No rippling happening# Some process still need to happen#calcRippleGroups();}## Want some versions to be forced to tip trunk#foreach my $name ( keys %ukHopsTip ){foreach my $entry ( keys(%versions) ){next unless ( $versions{$entry}{name} eq $name );next unless ( exists $versions{$entry}{Releases}{$ukHopsTip{$name}} );## Force this suffix to be the trunk# Remove all others#foreach my $suffix ( keys %Projects ){delete $Projects{$suffix}{Trunk};}my $suffix = $versions{$entry}{suffix};$Projects{$suffix}{Trunk} = 1;}}## Calculate best through-path for branches in the tree# Attempt to keep that 'max' version on the mainline# May be modified by -tip=nnnn## For each leaf (end point), walk backwards and mark each node with the# max version see. If we get to a node which already has been marked then# stop if our version is greater. We want the value to be the max version# to a leaf## Account for 'suffix'. When suffix changes, then the 'max' version must# be recalculated#Message ("Calculate Max Version");my $maxVersion;foreach my $entry ( @endPoints ){my $lastSuffix;my $forceTip;while ( $entry ){if (!defined($lastSuffix) || ($versions{$entry}{suffix} ne $lastSuffix) ){$maxVersion = '0';$visitId++;$forceTip = ( exists $tipVersions{$versions{$entry}{vname}} );$forceTip = 1 if $versions{$entry}{ukTrunk};delete $tipVersions{$versions{$entry}{vname}};$maxVersion = '999.999.999.999.zzz' if ( $forceTip );$lastSuffix = $versions{$entry}{suffix};#print "---Tip Found\n" if $forceTip;}# Detect circular dependenciesif ( ($versions{$entry}{visitId} || 0) == $visitId ){DebugDumpData ("Circular dependency: Versions", \%versions );Warning ("Circular dependency");last;}$versions{$entry}{visitId} = $visitId;my $thisVersion = $versions{$entry}{version} || '';if ( $thisVersion gt $maxVersion ){$maxVersion = $thisVersion;}if ( exists $versions{$entry}{maxVersion} ){if ( $versions{$entry}{maxVersion} gt $maxVersion ){last;}}$versions{$entry}{maxVersion} = $maxVersion;$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.#Message ("Calculate package version branches");foreach my $entry ( sort {$a <=> $b} keys(%versions) ){calculateWalkOrder($entry);}## Mark Project Branch Tips as they will be in the Repository# Find each project head and walk primary entry to the end.#foreach my $entry ( keys(%versions) ){## Root of each tree is 'new'#unless ( defined $versions{$entry}{last}){unless ( $versions{$entry}{badSingleton} ){$versions{$entry}{newSuffix} = 1;}}## Update stats#$badVcsCount++ if ( $versions{$entry}{badVcsTag} );$ProjectCount++ if ( $versions{$entry}{newSuffix} );next if ( $opt_flat );next unless ($versions{$entry}{newSuffix} );#print "--- Project new Suffix $versions{$entry}{vname}\n";my $suffix = $versions{$entry}{suffix};$knownProjects{$suffix}{count}++;my $next = $versions{$entry}{next}[0];my $tip;while ( $next ){last if ( $suffix ne $versions{$next}{suffix} );$tip = $next unless (exists ($versions{$next}{DeadWood}) || $versions{$next}{badSingleton});$next = $versions{$next}{next}[0];}$versions{$tip}{Tip} = 1 if $tip;}unless ( $opt_flat ){my $finalTrees = scalar @startPoints;Warning ("Still have multiple trees: $finalTrees") unless ( $finalTrees == 1 );}## Display warnings about multiple#foreach ( sort keys %knownProjects ){my $count = $knownProjects{$_}{count} || 0;Warning ("Multiple Project Roots: $_ ($count)" )if ( $count > 1 );}## Display warnings about Bad Essential Packages#$allSvn = 1;foreach my $entry ( keys(%versions) ){$rippleCount++ if ( exists($versions{$entry}{isaRipple}) && $versions{$entry}{isaRipple} );$allSvn = 0 unless ( $versions{$entry}{isSvn} );next unless ( exists $versions{$entry}{Essential} );next unless ( $versions{$entry}{badVcsTag} );push @badEssentials, $entry;Warning ("BadVCS Essential: " . GetVname($entry))}## All done#$processTotal = scalar keys %versions;Message("Retained entries: $processTotal" );Message("Pruned entries: $pruneCount");Message("Deadwood entries: $trimCount");Message("Bad Singletons: $badSingletonCount");Message("Ripples: $rippleCount");Message("Recent entries: $recentCount");}sub calculateWalkOrder{my ($entry) = @_;my @next = @{$versions{$entry}{next}};my $count = @next;my @ordered;my $main;if ( $count > 1 ){# Array to hash to simplify removalmy %nexts = map { $_ => 1 } @next;foreach my $e ( @next ){## Locate branch points that are not a part of a new project# These will not be preferred paths for walking#if ( !defined($versions{$e}{branchPoint}) && $versions{$entry}{suffix} ne $versions{$e}{suffix} ){unless ( exists $versions{$e}{DeadWood} || $versions{$e}{badSingleton} ){#print "--- Project Branch (1) $versions{$e}{vname}\n";$versions{$e}{branchPoint} = 1;$versions{$e}{newSuffix} = 1;}}## Remove those that already have a branch,#if ( $versions{$e}{branchPoint} || $versions{$e}{newSuffix} || $versions{$e}{DeadWood} ){push @ordered, $e;delete $nexts{$e};}}## Select longest arm as the non-branching path# Note: Reverse sort order# Done so that 'newest' item is given preference# to the main trunk in cases where all subtrees are# the same length#my $maxData = '';my $countEntry;foreach my $e ( sort {$b <=> $a} keys %nexts ){if ( $versions{$e}{maxVersion} gt $maxData ){$maxData = $versions{$e}{maxVersion};$countEntry = $e;}}if ($countEntry){$main = $countEntry;delete $nexts{$countEntry};}## Append the remaining#push @ordered, keys %nexts;## Re-order 'next' so that the main path is first# Sort (non main) by number#@ordered = sort {$a <=> $b} @ordered;unshift @ordered, $main if ( $main );@{$versions{$entry}{next}} = @ordered;## Ensure all except the first are a branch point# First may still be a branch point#shift @ordered;foreach my $e ( @ordered ){$versions{$e}{branchPoint} = 1;}}}#-------------------------------------------------------------------------------# Function : calcRippleGroups## Description : Locate and mark ripple groups# packages that are ripples of each other# Keep first version of each ripple. Must keep first# Group ripples together so that they can be# proccessed at the same time## Inputs :## Returns :#sub calcRippleGroups{my %rippleVersions;foreach my $entry ( keys(%versions) ){my $ep = $versions{$entry};if ( defined $ep->{buildVersion} ){my $suffix = $ep->{suffix};my ($major, $minor, $patch, $build) = @{$ep->{buildVersion}};#print "--- $major, $minor, $patch, $build, $suffix\n";$rippleVersions{$suffix}{"$major.$minor.$patch"}{count}++;my $rp = $rippleVersions{$suffix}{"$major.$minor.$patch"};$rp->{list}{$entry} = 1;next if ( $ep->{badVcsTag} );next if ( $ep->{locked} eq 'N');if (!defined ($rp->{min}) || $rp->{min} > $build ){$rp->{pvid} = $entry;$rp->{min} = $build;}}}# DebugDumpData("rippleVersions", \%rippleVersions );while ( my($suffix, $e1) = each %rippleVersions ){while ( my( $mmp, $e2) = each %{$e1} ){next unless ( exists $e2->{pvid} );my $entry = $e2->{pvid};if ( !exists $versions{$entry} ){Error ("Internal: Expected entry not found: $entry, $mmp");}$versions{$entry}{keepLowestRipple} = 1;#print "--- Keep Riple $versions{$entry}{vname}\n";## Update entry with list of associated ripples, removing lowest#delete $e2->{list}{$entry};my @rippleList = sort keys %{$e2->{list}};if ( @rippleList){#DebugDumpData("LIST: $entry", $e2->{list}, \@rippleList );@{$versions{$entry}{rippleList}} = @rippleList;}}}}#-------------------------------------------------------------------------------# 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();$createBranch = 1;$createSuffix = 1 if $versions{$entry}{newSuffix};}newPackageVersion( $entry );no warnings "recursion";processBranch (@{$versions{$entry}{next}});}}#-------------------------------------------------------------------------------# Function : newPackageVersion## Description : Create a package version## Inputs : $entry - Ref to entry being proccessed## Returns :#sub newPackageVersion{my ($entry) = @_;my %data;my $flags = 'e';my $rv = 1;my $startTime = time();my $timestamp = localtime;$data{rmRef} = 'ERROR';$data{tag} = 'ERROR';## If its been processed then fake that its been done# May have been a ripple that we processed#return if ($versions{$entry}{Processed});$processCount++;Message ("------------------------------------------------------------------" );Message ("Package $processCount of $processTotal");Message ("New package-version: " . GetVname($entry) . " Tag: " . $versions{$entry}{vcsTag} );## Detect user abort#if ( -f $cwd . '/stopfile' ){$globalError = 1;Message ("Stop file located");}## If we have a global error,then we pretend to process, but we# report errors for the logging system#if ( $globalError ){Message ("Global error prevents futher importation");}else{## Call worker function# It will exist on any error so that it can be logged#$rv = newPackageVersionBody( \%data, @_ );$globalError = 1 if ( $rv >= 10 );}## Highlight essential packages that failed to transfer#if ( $globalError ) {$flags = 'e';} elsif ( $rv && ( exists $versions{$entry}{Essential} ) ) {$flags = 'X';} elsif ( $rv ) {$flags = 'E';} else {$flags = 'G';}## Always log results to a file# Flags:# e - Error: Global Fatal causes other versions to be ignored# X - Essential Package NOT proccessed# E - Error processing package# G - Good#my $duration = time() - $startTime;my $line = join(';',$flags,$entry,$packageNames,$versions{$entry}{vname},$data{rmRef},$data{tag},$timestamp,$duration,$data{errStr} || '');logToFile( $cwd . '/importsummary.txt', ";$line;");## Sava data#$data{errFlags} = $flags;$data{duration} = $duration;$versions{$entry}{rmRef} = $data{rmRef};delete $data{rmRef};delete $data{tag};##delete $data{ViewRoot};$versions{$entry}{data} = \%data;## Delete the created view# Its just a directory, so delete it#if ( $data{ViewRoot} && -d $data{ViewRoot}){if ( !$opt_reuse || ($rv && ($rv != 4 && $rv != 12 )) ){Message ("Delete View: $data{ViewRoot}");RmDirTree ($data{ViewRoot} );}else{Message ("Retaining View: $data{ViewRoot}");}}else{Message ("No view to delete");}## If this version has any 'ripples' then process them while we have the# main view. Note the ripple list may contain entries that do not# exist - they will have been pruned.#if(1) {foreach my $rentry ( @{$versions{$entry}{rippleList}} ){next unless( exists $versions{$rentry} );if ($versions{$rentry}{Processed}){Warning ("Ripple Processed before main entry");$versions{$rentry}{rippleProcessed} = 1;}Message ("Proccessing associated Ripple: " . GetVname($rentry));newPackageVersion($rentry);}}}#-------------------------------------------------------------------------------# Function : newPackageVersionBody## Description : Perform the bulk of the work in creating a new PackageVersion# Designed to return on error and have error processing# performed by caller## Inputs : $data - Shared data# $entry - Package entry to process## Returns : Error Code# 0 - All is well# <10 - Recoverable error# >10 - Fatal error#sub newPackageVersionBody{my ($data, $entry) = @_;my $rv;my $cc_label;my $cc_path;my $cc_path_original;## Init Data#$data->{rmRef} = 'ERROR';$data->{tag} = '';$data->{ViewRoot} = undef;$data->{ViewPath} = undef;$data->{errStr} = '';$versions{$entry}{Processed} = 1;SystemConfig ('ExitOnError' => 0);push @processOrder, $entry;return 0 if ( $opt_test );# Keep DeadWood. May be a WIP# if ( exists $versions{$entry}{DeadWood} && $versions{$entry}{DeadWood} )# {# $data->{errStr} = 'Package is DeadWood';# return 3;# }## Determine version information#$data->{tag} = $versions{$entry}{vcsTag} || '';if ( $versions{$entry}{badVcsTag} ){Warning ("Error: Bad VcsTag for: " . GetVname($entry),"Tag: $data->{tag}" );$data->{errStr} = 'VCS Tag Marked as Bad';return 1;}$data->{tag} =~ m~^(.+?)::(.*?)(::(.+))?$~;$cc_label = $4;$cc_path = $2;$cc_path = '/' . $cc_path;$cc_path =~ tr~\\/~/~s;$cc_path_original = $cc_path;## Correct well known path mistakes#$cc_path =~ s~/build.pl$~~i;$cc_path =~ s~/src$~~i;$cc_path =~ s~/cpp$~~i;$cc_path =~ s~/MASS_Dev/Infra/~/MASS_Dev_Infra/~i;$cc_path =~ s~/MASS_Dev/Tools/~/MASS_Dev_Tools/~i;$cc_path =~ s~/MASS_Dev/Bus/~/MASS_Dev_Bus/~i;$cc_path =~ s~/MASS_Dev_Bus/Cbp/~/MASS_Dev_Bus/CBP/~i;$cc_path =~ s~/MREF_Package/ergpostmongui$~/MREF_Package/ergpostmongui~i;$cc_path =~ s~/MREF_../MREF_Package/~/MREF_Package/~i;$cc_path =~ s~/MREF_Package/mass_ergocdp/~/MREF_Package/ergocdp/~i;$cc_path =~ s~/MASS_Dev_Bus/CBP/systemCD.ejb~/MASS_Dev_Bus/CBP/systemCD/ejb~i;$cc_path =~ s~/MASS_Dev_Bus/Financial/cpp/paymentmanager~/MASS_Dev_Bus/Financial/cpp/paymentmanager~i;$cc_path =~ s~/MASS_Dev_Bus/WebServices~/MASS_Dev_Bus/WebServices~i;$cc_path =~ s~/MASS_Dev_Bus/CBP/nullAdapter~//MASS_Dev_Bus/CBP/nullAdaptor~i;$cc_path = '/MASS_Dev_Bus' if ( $cc_path =~ m~/MASS_Dev_Bus/ImageCapture(/|$)~i );$cc_path = '/MASS_Dev_Bus/CBP/enquiry' if ( $versions{$entry}{name} eq 'EJBEnqPxyConnector');$cc_path = '/MASS_Dev_Bus/CBP/enquiry' if ( $versions{$entry}{name} eq 'proxyif4j');$cc_path = '/MASS_Dev_Bus' if ( $versions{$entry}{name} eq 'ImageCaptureTomcatDeployment');$cc_path = '/MASS_Dev_Bus/WebServices/MassWS' if ( $versions{$entry}{name} eq 'MassWebServicesImpl');if ( $versions{$entry}{name} =~ m/^ERGagency$/i|| $versions{$entry}{name} =~ m/^ERGavm$/i|| $versions{$entry}{name} =~ m/^ERGboi$/i|| $versions{$entry}{name} =~ m/^ERGcallcenter$/i|| $versions{$entry}{name} =~ m/^ERGcardholder$/i|| $versions{$entry}{name} =~ m/^ERGcdaimports$/i|| $versions{$entry}{name} =~ m/^ERGcda$/i|| $versions{$entry}{name} =~ m/^ERGcscedit$/i|| $versions{$entry}{name} =~ m/^ERGcs$/i|| $versions{$entry}{name} =~ m/^ERGofs$/i|| $versions{$entry}{name} =~ m/^ERGols$/i|| $versions{$entry}{name} =~ m/^ERGtpf$/i|| $versions{$entry}{name} =~ m/^ERGorasys$/i|| $versions{$entry}{name} =~ m/^ERGoracs$/i|| $versions{$entry}{name} =~ m/^ERGpxyif$/i|| $versions{$entry}{name} =~ m/^ERGtp5upg$/i|| $versions{$entry}{name} =~ m/^ERGinstitutional$/i|| $versions{$entry}{name} =~ m/^ERGinfra$/i|| $versions{$entry}{name} =~ m/^ERGcrrpts$/i|| $versions{$entry}{name} =~ m/^ERGmiddle$/i|| $versions{$entry}{name} =~ m/^ERGmiddleapi$/i|| $versions{$entry}{name} =~ m/^ERGwebapi$/i|| $versions{$entry}{name} =~ m/^ERGwebtestui$/i|| $versions{$entry}{name} =~ m/^ERGwebesbui$/i|| $versions{$entry}{name} =~ m/^ERGwspiv$/i|| $versions{$entry}{name} =~ m/^ERGwscst$/i|| $versions{$entry}{name} =~ m/^sposMUG$/i|| $versions{$entry}{name} =~ m/^ERGfinman$/i|| $versions{$entry}{name} =~ m/^ERGkm$/i|| $versions{$entry}{name} =~ m/^ERGxml$/i|| $versions{$entry}{name} =~ m/^ERGoradacw$/i|| $versions{$entry}{name} =~ m/^ERGtru$/i){$cc_path = '/MREF_Package';}if ( $versions{$entry}{name} =~ m/^tp5000_MUG$/i ){if ( $versions{$entry}{version} =~ m~vtk$~ ){$cc_path = '/MREF_Package';}}if ( $cc_path_original ne $cc_path ){Message ("Package: $versions{$entry}{name}. Forcing CC path to: $cc_path" );}#print "--- Path: $cc_path, Label: $cc_label\n";## Create CC view# Import into Subversion View#$rv = extractFilesFromClearCase( $data, $cc_path, $cc_label );return $rv if ( $rv );## Developers have been slack# Sometime the mark the source path as 'GMTPE2005'# Sometimes as 'GMTPE2005/Package/Fred/Jill/Harry'## Attempt to suck up empty directories below the specified# source path#unless ( $opt_preserveProjectBase ){## Look in ViewPath# If it contains only ONE directory then we can suck it up#my $testDir = findDirWithStuff( $data->{ViewPath} );unless ( $data->{ViewPath} eq $testDir ){Message ("Adjust Base Dir: $testDir");$data->{adjustedPath} = $data->{ViewPath};$data->{ViewPath} = $testDir;}}## Some really ugly packages make use of a Jats feature called 'SetProjectBase'# Detect such packages as we will need to handle them differently# Can't really handle it on the fly# All we can do is detect it and report it - at the moment#if (detectProjectBaseUsage($data, $cc_path) ){unless ( $opt_ignoreProjectBaseErrors ){$data->{BadProjectBase}++;$data->{errStr} = 'Bad usage of ProjectBase detected';return 4; # Lets see what the others look like too# return 14;}}## Some really really ugly packgaes make use of the MakeProject directive# and then use an 'include.txt file to access paths all over the VOB# The problem is with lines like# /I ..\..\..\..\..\..\DPG_SWCode\projects\seattle\ddu\component\DTIApp\dsi\inc# Two problems:# Vob Name is not a part of the migration# If we 'SuckUp' empty directories then this may break# the pathing.# All we can do is detect it and report it - at the moment#if (detectMakeProjectUsage($data, $cc_path) ){unless ( $opt_ignoreMakeProjectErrors ){$data->{BadMakeProject}++;$data->{errStr} = 'Use of MakeProject detected';return 4; # Lets see what the others look like too# return 14;}}## Some packages have filenames that are need to be converted#if ( $mustConvertFileNames ){$rv = system ( '/home/dpurdie/svn/tools/convmv-1.15/convmv','-fiso-8859-1','-tutf8','-r','--notest',$data->{ViewPath} );if ( $rv ){$data->{errStr} = 'Failed to convert filenames to UTF8';return 14;}## Check to see if our ViewPath has been changed# If so, then try to fix it#unless ( -d $data->{ViewPath} ){Message ("Correct UTF-8 change to ViewPath");$data->{ViewPath} = encode('UTF-8', $data->{ViewPath}, Encode::FB_DEFAULT);Warning ("Correct UTF-8 change to ViewPath - FAILED") unless ( -d $data->{ViewPath} );}}## Have a CC view# Now we can create the SVN package and branching point before we# import the CC data into SVN#my @args;## Calculate args for functions#my $author = $versions{$entry}{created_id};if ( $author ){push @args, '-author', $author;}my $created = $versions{$entry}{created};if ( $created ){$created =~ s~ ~T~;$created .= '00000Z';push @args, '-date', $created;}my $log = $versions{$entry}{comment};if ( $log ){push @args, '-log', $log;}## Create package skeleton if needed#$rv = createPackage( $author, $created);if ( $rv ){$data->{errStr} = 'Failed to create Package';return 10;}## Calculate the label for the target package# Use format <packageName>_<PackageVersion># Need to handle WIPs too.#my $import_label = saneLabel($entry);## May need to create the branchpoint# The process is delayed until its needed so avoid creating unneeded# branch points#if ( $createBranch ){$rv = createBranchPoint ($entry, $author, $created);$createBranch = 0;$createSuffix = 0;if ( $rv ){$data->{errStr} = 'Failed to create Branch Point';return 11;}}push @args, "-branch=$currentBranchName" if ( defined $currentBranchName );my $datafile = "importdata.$import_label.properties";$rv = JatsToolPrint ( 'jats_svn', 'import', '-reuse' ,"-package=$svnRepo/$packageNames","-dir=$data->{ViewPath}","-label=$import_label","-datafile=$datafile",@args,);if ( $rv ){$data->{errStr} = 'Failed to import to SVN';return 12;}$versions{$entry}{TagCreated} = 1;$firstVersionCreated = $entry unless ( $firstVersionCreated );## Read in the Rm Reference# Retain entries in a global file#if ( -f $datafile ){my $rmData = JatsProperties::New($datafile);$data->{rmRef} = 'SVN::' . $rmData->getProperty('subversion.tag');}unless ( $data->{rmRef} ){$data->{errStr} = 'Failed to determine Rm Reference';return 13;}######################## Deleted ################################################## ## # Add supplemental tags if this version is in a 'Release'# # But only for some packages - else looks like a mess# # Just a solution for the ITSO guys# ## foreach my $rtag_id ( keys %{$versions{$entry}{Releases}} )# {# next unless ( $svnRepo =~ m~/ITSO_TRACS(/|$)~);## my $prog_id = $versions{$entry}{Releases}{$rtag_id}{proj_id};# Message ("Adding Release Tag:$prog_id:$rtag_id");## my $rtext = 'Release_' . saneString($versions{$entry}{Releases}{$rtag_id}{rname});# my @comment;# push @comment, "Tagged by ClearCase to Subversion import";# push @comment, "Project:$prog_id:$versions{$entry}{Releases}{$rtag_id}{pname}";# push @comment, "Release:$rtag_id:$versions{$entry}{Releases}{$rtag_id}{rname}";## $data->{ReleaseTag}{$prog_id}{$rtag_id}{name} = $rtext;## $rv = JatsToolPrint ( 'jats_svnlabel' ,# '-comment', encode('UTF-8', join("\n", @comment), Encode::FB_DEFAULT),# $data->{rmRef},# '-clone',# $rtext,## @args,# '-author=buildadm',# );# $data->{ReleaseTag}{$prog_id}{$rtag_id}{eState} = $rv;# $data->{ReleaseTag}{tCount}++;## if ( $rv )# {# $data->{ReleaseTag}{eCount}++;# Warning("Failed to add Release Tag: $rtext");# }# }######################### Deleted ###############################################Message ("RM Ref: $data->{rmRef}");unlink $datafile;## All is good#$data->{errStr} = '';return 0;}#-------------------------------------------------------------------------------# Function : newProject## Description : Start a new project within a package## Inputs :## Returns :#sub newProject{# Message ("---- New Project");$createSuffix = 0;## New project# Kill the running import directory#RmDirTree ('SvnImportDir');}#-------------------------------------------------------------------------------# Function : newPackage## Description : Start processing a new package## Inputs :## Returns :#my $createPackageDone;sub newPackage{# Message( "---- New Package");## Create a package specific log file#$logSummary = $packageNames . ".summary.log";unlink $logSummary;Message( "PackageName: $packageNames");$createPackageDone = 1;$createBranch = 0;$createSuffix = 0;## First entry being created# Prime the work area#RmDirTree ('SvnImportDir');}#-------------------------------------------------------------------------------# Function : createPackage## Description : Create a new Package in SVN# Called before any serious SVN operation to ensure that the# package has been created. Don't create a package until# we expect to put something into it.## Will only create a package once## Inputs : $author - Who done it# $date - When## Returns :#sub createPackage{my ($author, $date) = @_;my @opts;push (@opts, '-date', $date) if ( $date );push (@opts, '-author', $author) if ( $author );## Only do once#return unless ( $createPackageDone );$createPackageDone = 0;## Real import# Do not Delete package if it exists# Package must NOT exist#Message ("Creating new SVN package: $packageNames");if ( $opt_delete ){Message ("Delete existing version of package: $packageNames");JatsToolPrint ( 'jats_svn', 'delete-package', '-noerror', "$svnRepo/$packageNames" );}JatsToolPrint ( 'jats_svn', 'create', "$svnRepo/$packageNames", '-new', @opts );}#-------------------------------------------------------------------------------# Function : createBranchPoint## Description : Create a branch point for the current work# Perform the calculation to determine the details of# the branch point. The work will only be done when its# needed. This will avoid the creation of branchpoints# that are not used.## Inputs : $entry Entry being processed# $author - Who done it# $date - When## Returns :#sub createBranchPoint{my ($entry, $author, $date) = @_;my $forceNewProject;# Message ("---- Create Branch Point");## 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# If we transferred any software at all, then use the first# version as the base for this disconnected version## Otherwise we create a new, and empty, view#unless ( $last ){if ( $firstVersionCreated ){Warning ("Cannot find previous version to branch. Use first version");$last = $firstVersionCreated;}else{Warning ("Forcing First instance of a Project");$forceNewProject = 1;}}## Determine source name# This MUST have been created before we can branch#my $src_label;$src_label = saneLabel($last) if $last;## Create target name#my $tgt_label;if ( $forceNewProject || $versions{$entry}{newSuffix} || $createSuffix || !defined $src_label ){## Create target name based on project#return if ( $singleProject );my $suffix = $versions{$entry}{suffix};if ( $suffix ){Error ("Unknown Project: $suffix") unless ( defined $Projects{$suffix} );## If this project can be considered to be a truck, then 'claim' the# truck for the first created element.#if ( $Projects{$suffix}{Trunk} ){# This project can use the trunk, if it has not been allocated.$ProjectTrunk = $suffix unless ( defined $ProjectTrunk );## If this package has multiple instances of the potential# trunk, then don't place either of them on the trunk as it# may cause confusion#if ($knownProjects{$suffix}{count} < 2 ){if ( $suffix eq $ProjectTrunk ){return unless $currentBranchName;}}}$tgt_label = $Projects{$suffix}{Name};$tgt_label = $versions{$entry}{name} . '_' . $tgt_label if ($multiPackages);if ( !exists $ProjectsBaseCreated{$tgt_label} ){$ProjectsBaseCreated{$tgt_label} = 1;}else{# Project Base Already taken# Have disjoint starting points$tgt_label .= '.' . $ProjectsBaseCreated{$tgt_label} ++;}}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 = saneLabel($entry, $src_label . '_for_');}## Save branch name for use when populating sandbox#$currentBranchName = $tgt_label;## Perform the branch#if ( defined $src_label ){## The 'clone' operation will backtrack the branch point# to the source of the label. This will make the output version# tree much prettier#my @opts;push (@opts, '-date', $date) if ( $date );push (@opts, '-author', $author) if ( $author );JatsToolPrint ( 'jats_svnlabel','-packagebase', "$svnRepo/$packageNames",'tags/' . $src_label,'-branch','-clone', $tgt_label,@opts);}}#-------------------------------------------------------------------------------# Function : endPackage## Description : End of package processing# Clean up and display problems## Inputs :## Returns :#sub endPackage{Message ("-- Import Summary ------------------------------------------------" );RmDirTree ('SvnImportDir');## Display versions that did get captured#foreach my $entry ( @processOrder ){$versions{$entry}{Scanned} = 1;next unless ( $versions{$entry}{TagCreated} );Warning ("Processed: " . GetVname($entry) . ' :: ' . $versions{$entry}{rmRef} || $versions{$entry}{errStr} || '???' );}## Display versions that did not get created#foreach my $entry ( @processOrder ){$versions{$entry}{Scanned} = 1;next if ( $versions{$entry}{TagCreated} );my $reason = $versions{$entry}{data}{errStr} || '';my $tag = $versions{$entry}{vcsTag}|| 'No Tag';Warning ("Not Processed: " . GetVname($entry) . ':' . $tag . ' : ' . $reason );}foreach my $entry ( keys(%versions) ){next if ( $versions{$entry}{Scanned} );Warning ("(E) INTERNAL ERROR. Package Not Processed: " . GetVname($entry) );}Message ("Packages Relabled: $packageReLabelCount") if ( $packageReLabelCount );Message ("All Done");}#-------------------------------------------------------------------------------# Function : extractFilesFromClearCase## Description : Extract files from ClearCase# May take a while as we handle nasty errors## Inputs : $data - Hash of good stuff from newPackageVersionBody# $cc_path# $cc_label## Returns : exit code# Sets up# $data->{errStr}# $data->{errCode}# As per newPackageVersionBody#sub extractFilesFromClearCase{my ($data, $cc_path, $cc_label) = @_;my $tryCount = 0;my $rv = 99;$data->{ViewRoot} = $opt_name ? $opt_name : "$cc_label";$data->{ViewPath} = $data->{ViewRoot} . $cc_path;if ( $opt_preserveProjectBase ){my $cc_vob = $cc_path;$cc_vob =~ s~^/~~;$cc_vob =~ s~/.*~~;$data->{ViewPath} = $data->{ViewRoot} . '/' . $cc_vob;Message ("Preserving Project Base");}$data->{ViewPath} =~ tr~/~/~s;if ( $opt_reuse && -d $data->{ViewPath} ){Message ("Reusing view: $cc_label");return 0;}while ( $rv == 99 ) {my @args;push (@args, '-view', $opt_name ) if ( defined $opt_name );$rv = JatsToolPrint ( 'jats_ccrelease', '-extractfiles', '-root=.' , '-noprefix',"-label=$cc_label" ,"-path=$cc_path",@args);if ( $rv == 10 ) {## No files found# If this is the first time then try really hard to find them#unless ( $tryCount++ ){if ( $opt_relabel ){$packageReLabelCount++;$rv = JatsToolPrint('cc2svn_labeldirs','-vob', $cc_path,$cc_label,);$data->{DirsLabled} = 100 + $rv;}## Second attempt - massage the users path# We should have labled up to the VOB root so lets# just use the VOB and not the path## If we are not relabeling then we can still do this# in an attempt to fix user stupidity#$cc_path =~ s~^/~~;$cc_path =~ s~/.*~~;$cc_path = '/' . $cc_path;$data->{ViewPath} = $data->{ViewRoot} . $cc_path;redo;}$data->{errStr} = 'No Files in the extracted view';$data->{errCode} = '0';return 2;}elsif ( $rv == 11 ) {$data->{errStr} = 'Label not found';$data->{errCode} = 'L';return 2;}unless ( -d $data->{ViewPath} ){$data->{errStr} = 'Failed to extract files from CC';return 2;}## Looks good#return 0;};$data->{errStr} = 'No Files in the extracted view after labeling dirs';$data->{errCode} = '0';return 2;}#-------------------------------------------------------------------------------# Function : detectMakeProjectUsage## Description : etect and report usage of the MakeProject directive## Inputs : $data - Ref to a hash of bits# $cc_path - Packages cc_path## Returns : true - Bad usage (Really good usage not detected)# false - Good usage detected#sub detectMakeProjectUsage{my ($data, $cc_path) = @_;my $retval = 0;my $eSuf = $opt_ignoreMakeProjectErrors ? '' : 'Error';## Find makefile.pl#Message ("Locate JATS makefiles");my $usesMakeProject = 0;my $badIncludeFile = 0;my $search = JatsLocateFiles->new("--Recurse=1","--FilterIn=makefile.pl",);my @makefiles = $search->search($data->{ViewRoot});foreach my $file ( @makefiles ){#print "---Reading: $workDir/$data->{ViewRoot}/$file\n";if ( open( my $fh, '<', "$data->{ViewRoot}/$file" ) ){my $eof = 0;my $line = '';until ( $eof ){my $in = <$fh>;unless ( defined $in ){$eof = 1;}else{$in =~ s~\s+$~~;$in =~ s~^\s+~~;$in =~ s~^#.*$~~;$in =~ s~\s*[^\$]#.*$~~;$line .= ' ' if ( $line );$line .= $in;$line =~ s~\s+~ ~g;#print "====== '$line'\n";redo unless ( $line =~ m~;$~ );}#print "---- $line\n";if ( $line =~ m~^MakeProject~ ){$usesMakeProject++;$data->{UsesMakeProject}++;Warning ("Package uses MakeProject:","Line: " . $line,"Root: " . "$data->{ViewRoot}","File: " . "$data->{ViewRoot}/$file",);## Extract out the project name#my @myArgs;my $myProjectDir;my $myProject = "$data->{ViewRoot}/$file";$myProject =~ s~/[^/]+$~~;$line =~ s~MakeProject~push \@myArgs,~;eval $line;Error("Line did not compiler: $line", "Err: $@" ) if ($@);shift @myArgs;foreach ( @myArgs ){next if ( m~^--~ );$myProject .= '/' . $_;$myProjectDir = $myProject;$myProjectDir =~ s~/[^/]+$~~;last;}Error ("No project Found") unless ( defined $myProjectDir);if ( -f "$myProjectDir/include.txt" ){Warning ("Co-located 'include.txt' file also found");}# The only problem is if the include.txt file# escapes from the VOB - or even uses the vob root## Examine the include file# Expect it to look like# /I Path### Determine safe level# Relative to the include file#my $depthPath = $myProjectDir;my $depth = 0;Error ("Expect this to work") unless ( $depthPath =~ s~^$data->{ViewRoot}/~~ );foreach ( split('/', $depthPath) ){if ( $_ eq '..' ) {$depth--;} else {$depth++;}}#print "Depth: $depth, $depthPath\n";if ( open( my $if, '<', "$myProjectDir/include.txt" ) ){while ( <$if> ){s~\s+$~~;s~^\s+~~;next unless ( $_ );if ( m~/I\s+(.*)~ ){my $path = $1;$path =~ tr~\\/~/~s;$path =~ s~\\~/~g;#print "Examine: $path\n";my $minLevel = 0;my $level = 0;foreach ( split('/', $path) ){if ( $_ eq '..' ){$level--;$minLevel = $level if ($level < $minLevel);}else{$level++;}}#print "Min: $minLevel, $level, ($depth + $minLevel)\n";if ( $depth + $minLevel <= 0){$badIncludeFile++;Warning ("Included path escapes package:","Line: " . $_,"File: " . "$myProjectDir/include.txt",);last;}}}close $if;}}$line = '';}close $fh;}else{Warning ("MakeProject$eSuf - Cannot open makefile: $file");$retval = 1;}}## Used# May be improved latter#if ( $usesMakeProject && $badIncludeFile){Warning ("MakeProject$eSuf - Problem detected");$retval = 1;}## Until we have more faith in the detection algorithm#if ( $usesMakeProject ){Warning ("MakeProject$eSuf - Makeproject used. Must check manually");$retval = 1;}return $retval;}#-------------------------------------------------------------------------------# Function : detectProjectBaseUsage## Description : Detect and report usage of the SetProjectBase directive## Inputs : $data - Ref to a hash of bits# $cc_path - Packages cc_path## Returns : true - Bad usage (Really good usage not detected)# false - Good usage detected#sub detectProjectBaseUsage{my ($data, $cc_path) = @_;my $retval = 0;my $eSuf = $opt_ignoreProjectBaseErrors ? '' : 'Error';## Find makefile.pl#Message ("Locate JATS makefiles");my $usesProjectBase = 0;my $definesProjectBase = 0;my $definitionError = 0;my $search = JatsLocateFiles->new("--Recurse=1","--FilterIn=makefile.pl",);my @makefiles = $search->search($data->{ViewRoot});foreach my $file ( @makefiles ){if ( open( my $fh, '<', "$data->{ViewRoot}/$file" ) ){while ( <$fh> ){s~\s+$~~;s~^\s+~~;next if ( m~^#~ );if ( m~\$ProjectBase~ ){$usesProjectBase++;Message ("Project Base Use: $_");$data->{UsesProjectBase}++;}if ( m~^SetProjectBase~ ){$definesProjectBase++;$data->{DefinesProjectBase}++;Warning ("Package initialises SetProjectBase:","Line: " . $_,"Root: " . "$data->{ViewRoot}","File: " . "$data->{ViewRoot}/$file",);# The only problem is if the user attempts to escape# from the root of the view.## Examine the depth of the makefile with the directive# Examine the depth of the view base### Locate the build.pl file# This is the basis for for the directive#my $blevel;my @bpaths = split ('/', $file );while ( @bpaths ){$bpaths[-1] = 'build.pl';my $bfile = join '/', @bpaths ;if ( -f "$data->{ViewRoot}/$bfile" ){$blevel = scalar @bpaths;last;}pop @bpaths;}unless (defined $blevel){Warning ("SetProjectBase$eSuf calculation failed - can't find build.pl");# $retval = 1;$definitionError++;}else{## Determine the depth of the view root# This is given by cc_path, but cc_path has a leading /#my @cpaths = split ('/', $cc_path );my $clevel = (scalar @cpaths) - 1;my $max_up = $blevel - $clevel - 1;m~--Up=(\d+)~i;my $ulevel = $1;if ( defined $ulevel ){my @paths = split ('/', $file );my $plevel = scalar @paths;#print "--- blevel: $blevel\n";#print "--- bpaths: @bpaths\n";#print "--- ulevel: $ulevel\n";#print "--- paths: @paths\n";#print "--- plevel: $plevel\n";#print "--- cpaths: @cpaths\n";#print "--- clevel: $clevel\n";#print "--- max_up: $max_up\n";if ( $ulevel > $max_up ){Warning ("SetProjectBase escapes view. MaxUp: $max_up, Up: $ulevel");$definitionError++;}}else{$retval = 1;Warning ("SetProjectBase$eSuf MAY escape view - can't detect level")}}}}close $fh;}else{Warning ("SetProjectBase$eSuf - Cannot open makefile: $file");$retval = 1;}}## Detect defined, but not used#if ( $usesProjectBase && ! $definesProjectBase ){Warning ("SetProjectBase - Uses ProjectBase without defining it");}if ( ! $usesProjectBase && $definesProjectBase ){Warning ("SetProjectBase - Defines ProjectBase without using it");}if ( $usesProjectBase && $definesProjectBase && $definitionError ){Warning ("SetProjectBase$eSuf - Problem detected");$retval = 1;}return $retval;}#-------------------------------------------------------------------------------# Function : findDirWithStuff## Description : Find a directory that contains more than just another subdir# Note: don't use 'glob' it doesn't work if the name has a space in it.## Inputs : $base - Start of the scan## Returns : Path to dir with more than just a single dir in it#sub findDirWithStuff{my ($base) = @_;while ( $base ){my $fileCount = 0;my $dirCount = 0;my $firstDir;opendir (my $dh, $base ) || Error ("Cannot opendir $base. $!");my @list =readdir $dh;closedir $dh;foreach ( @list ){next if ( $_ eq '.' );next if ( $_ eq '..' );$_ = $base . '/' . $_;if ( -d $_ ){$dirCount++;$firstDir = $_ unless ( defined $firstDir );return $baseif ( $dirCount > 1 )}elsif ( -e $_ ){return $base;}# else its probably a dead symlink}return $baseunless ( $dirCount == 1 );$base = $firstDir;}}#-------------------------------------------------------------------------------# Function : JatsToolPrint## Description : Print and Execuate a JatsTool command## Inputs :## Returns :#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;}#-------------------------------------------------------------------------------# Function : saneLabel## Description : Generate a sane version label# Handle suplicates (due to character squishing)# Cache results for repeatability## Inputs : $entry - Version info# $pkgname - Alternate pkgname (branching)## Returns : Sane string#sub saneLabel{my ($entry, $pkgname) = @_;my $me;$me = $versions{$entry}{vname};$pkgname = $versions{$entry}{name} unless ( defined $pkgname );## If we have calculated it, then reuse it.#if ( exists $versions{$entry}{saneLabel}{$pkgname} ){return $versions{$entry}{saneLabel}{$pkgname};}Error ("Package does have a version string: pvid: $entry")unless ( defined $me );## Convert Wip format (xxxx) into a string that can be used for a label#if ( $me =~ m~^(.*)\((.*)\)(.*)$~ ){$me = $1 . '_' . $2 . '_' . $3 . '.WIP';$me =~ s~_\.~.~;$me =~ s~^_~~;}## Allow for WIPS# Get rid of multiple '_'# Replace space with -#$me = $pkgname . '_' . $me;$me =~ tr~ ~-~s;$me =~ tr~-~-~s;$me =~ tr~_~_~s;## Due to some sillyness ( package version starting with _ )# we may get duplicates. Detect and allocate different numbers#if ( exists $saneLabels{$me} ){$saneLabels{$me}++;$me = $me . '.' . $saneLabels{$me};Message ("Duplicate SaneLabel resolved as: $me");}else{$saneLabels{$me} = 0;}## Cache value#$versions{$entry}{saneLabel}{$pkgname} = $me;return $me;}sub saneString{my ($string) = @_;## Get rid of multiple '_'# Replace space with -#$string =~ s~\W~_~g;$string =~ tr~ ~_~s;$string =~ tr~_-~-~s;$string =~ tr~-_~-~s;$string =~ tr~-~-~s;$string =~ tr~_~_~s;$string =~ s~-$~~;$string =~ s~_$~~;return $string;}exit 0;#-------------------------------------------------------------------------------# Function : GetPkgIdByName## Description :## Inputs : pkg_name## Returns : pkg_id#sub GetPkgIdByName{my ( $pkg_name ) = @_;my (@row);my $pv_id;my $pkg_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" );}return $pkg_id;}#-------------------------------------------------------------------------------# Function : GetData_by_pkg_id## Description :## Inputs : pv_id## Returns :#sub GetData_by_pkg_id{my ( $pkg_id, $packageName ) = @_;my (@row);## Establish a connection to Release Manager#Message ("Extract package versions from Release Manager: $packageName");connectRM(\$RM_DB) unless ( $RM_DB );## Extract data from Release Manager#my $m_sqlstr = "SELECT " ."pkg.PKG_NAME, " . # row[0]"pv.PKG_VERSION, " . # row[1]"pkg.PKG_ID, " . # row[2]"pv.PV_ID, " . # row[3]"pv.LAST_PV_ID, " . # row[4]"pv.MODIFIED_STAMP, " . # row[5]"release_manager.PK_RMAPI.return_vcs_tag(pv.PV_ID), " . # row[6]"amu.USER_NAME, " . # row[7]"pv.COMMENTS, " . # row[8]"pv.DLOCKED, " . # row[9]"pv.CREATOR_ID, ". # row[10]"pv.BUILD_TYPE ". # row[11]" 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 amu.USER_ID (+) = pv.CREATOR_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';$pkg_ver =~ s~\s+$~~;$pkg_ver =~ s~^\s+~~;my $pv_id = $row[3] || 'Unknown';my $last_pv_id = $row[4];my $created = $row[5] || 'Unknown';my $vcstag = $row[6] || 'Unknown';my $created_id = $row[7] || ($row[10] ? "Userid_$row[10]" :'Unknown');my $comment = $row[8] || '';my $locked = $row[9] || 'N';my $manual = $row[11] || 'M';## Some developers have a 'special' package version# We really need to ignore them#next if ( $pkg_ver eq '23.23.23.ssw' );## Add data to the hash# Remove entries that address themselves#push (@{$versions{$last_pv_id}{next}}, $pv_id) unless ($pv_id == $last_pv_id || $last_pv_id == 0) ;$versions{$pv_id}{name} = $pkg_name;$versions{$pv_id}{pvid} = $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} );$versions{$pv_id}{BuildType} = $manual;examineVcsTag($pv_id);## Process version number#my ($suffix, $version, $isaR, $isaWip, $buildVersion ) = massageVersion($pkg_ver, $pkg_name);$versions{$pv_id}{version} = $version;$versions{$pv_id}{buildVersion} = $buildVersion;$versions{$pv_id}{isaWip} = 1 if ( $isaWip );## New methof for detecting a ripple# Don't look at the version number# Use RM data# Inlude the comment - there are some cases where the comment# appears to have been user modified.## $versions{$pv_id}{isaRipple} = 1 if ( $isaR );# $versions{$pv_id}{isaRipple} = 1 if ( uc($manual) eq 'Y' );$versions{$pv_id}{isaRipple} = ( $comment =~ m~^Rippled Build~i && ( uc($manual) eq 'Y' ));## 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, $locked, $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 : massageVersion## Description : Process a version number and return usful bits## Inputs : Version Number# Package Name - debug only## Returns : An array# suffix# multipart version string useful for text comparisons#sub massageVersion{my ($version, $name) = @_;my ($major, $minor, $patch, $build, $suffix);my $result;my $buildVersion;my $isaRipple;my $isaWIP;$build = 0;#print "--- $name, $version\n";$version =~ s~^_~~;$version =~ s~^${name}_~~;## xxxxxxxxx.nnnn.cots#if ( $version =~ m~(.*)\.cots$~ ) {my $cots_base = $1;$suffix = '.cots';if ( $version =~ m~(.*?)\.([0-9]{4})\.cots$~ ){$result = $1 . sprintf (".%4.4d", $2) . $suffix;}else{$result = $cots_base . '.0000.cots';}}## Convert version into full form for comparisions# nnn.nnn.nnn.[p]nnn.xxx# nnn.nnn.nnn.[p]nnn-xxx# nnn.nnn.nnn-[p]nnn.xxx# nnn.nnn.nnn-[p]nnn-xxx# nnn.nnn.nnn[p]nnn-xxx# Don't flag as ripples - they are patches#elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-.p][p]?(\d+)([-.](.*))?$~ ) {$major = $1;$minor = $2;$patch = $3;$build = $4;$suffix = defined $6 ? ".$6" : '';$isaRipple = 0;}## nn.nnn.nnnnn.xxx# nn.nnn.nnnnn-xxx# nnn.nnn.nnnx.xxx# Don't flag as ripples - they are patches#elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)\w?([-.](.*))?$~ ) {$major = $1;$minor = $2;$patch = $3;if ( length( $patch) >= 4 ){$build = substr( $patch, -3 ,3);$patch = substr( $patch, 0 ,length($patch)-3);}$suffix = defined $5 ? ".$5" : '';}## nnn.nnn.nnn# nnn.nnn-nnn# nnn.nnn_nnn#elsif ( $version =~ m~^(\d+)\.(\d+)[-._](\d+)$~ ) {$major = $1;$minor = $2;$patch = $3;$suffix = '';}## nnn.nnn.nnn.nnn# nnn.nnn.nnn-nnn# nnn.nnn.nnn_nnn#elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)[-._](\d+)$~ ) {$major = $1;$minor = $2;$patch = $3;$build = $4;$suffix = '';$isaRipple = 0;}## nnn.nnn#elsif ( $version =~ m~^(\d+)\.(\d+)$~ ) {$major = $1;$minor = $2;$patch = 0;$suffix = '';}## nnn.nnn.xxx#elsif ( $version =~ m~^(\d+)\.(\d+)(\.\w+)$~ ) {$major = $1;$minor = $2;$patch = 0;$suffix = $3;}## nnn.nnn.nnnz#elsif ( $version =~ m~^(\d+)\.(\d+)\.(\d+)([a-z])$~ ) {$major = $1;$minor = $2;$patch = $3;$build = ord($4) - ord('a');$suffix = '.cots';$isaRipple = 0;}## ???REV=???#elsif ( $version =~ m~REV=~ ) {$suffix = '.cots';$result = $version . '.0000.cots';}## Wip Packages# (nnnnnn).xxx# Should be essential, but want to sort very low#elsif ($version =~ m~\((.*)\)(\..*)?~) {$suffix = $2 || '';$result = "000.000.000.000$suffix";$isaWIP = 1;}## !current#elsif ($version eq '!current' || $version eq 'current_$USER' || $version eq 'current' || $version eq 'beta' || $version eq 'latest' || $version eq 'beta.cr' || $version eq 'CREATE') {$suffix = '';$result = "000.000.000.000$suffix";$isaWIP = 1;}## Also WIP: FINRUN.103649.BEI.WIPelsif ($version =~ m~(\.[a-zA-Z]+)\.WIP$~) {$suffix = lc($1);$result = "000.000.000.000$suffix";$isaWIP = 1;}## Also ERGOFSSLS190100_015# Don't flag as a rippleelsif ($version =~ m~^ERG[A-Z]+(\d\d)(\d\d)(\d\d)[-_](\d+)(\.\w+)?$~) {$major = $1;$minor = $2;$patch = $3;$build = $4;$suffix = $5 || '.sls';$isaRipple = 0;}## Stuff we don't yet handle#else {Warning ("Unknown version number: $name,$version");$version =~ m~(\.\w+)$~;$suffix = $1 || '';$result = $version;}$isaRipple = ($build > 0) unless defined $isaRipple;unless ( $result ){# Major and minor of 99.99 are normally funy versions# Don't make important desicions on them#if ( $major == 99 && $minor == 99 ){$major = 0;$minor = 0;$patch = 0;}$result = sprintf("%3.3d.%3.3d.%3.3d.%3.3d%s", $major,$minor,$patch,$build,$suffix || '.0000');$buildVersion = [ $major, $minor, $patch, $build ];}$suffix = lc( $suffix );if ( exists $suffixFixup{$suffix} ){$suffix = $suffixFixup{$suffix} ;}return ($suffix, $result, $isaRipple, $isaWIP, $buildVersion );}#-------------------------------------------------------------------------------# Function : vcsCleanup## Description : Cleanup and rewrite a vcstag## DUPLICATED IN:# - cc2svn_procdata# - cc2svn_importpackage## Inputs : vcstag## Returns : Cleaned up vcs tag#sub vcsCleanup{my ($tag) = @_;$tag =~ tr~\\/~/~;if ( $tag =~ m~^CC::~ ){$tag =~ s~CC::load\s+~CC::~; # Load rule$tag =~ s~CC::\s+~CC::~; # Leading white space$tag =~ s~CC::[A-Za-z]\:/~CC::/~; # Leading driver letter$tag =~ s~CC::/+~CC::/~; # Multiple initial /'s$tag =~ s~/build.pl::~::~i;$tag =~ s~/src::~::~i;$tag =~ s~MASS_Dev_Bus/Cbp/~MASS_Dev_Bus/CBP/~i;$tag =~ s~MASS_Dev_Bus~MASS_Dev_Bus~i;$tag =~ s~/MASS_Dev/Infra~MASS_Dev_Infra~i;$tag =~ s~/MASS_Dev/Bus/web~/MASS_Dev_Bus/web~i;$tag =~ s~/Vastraffik/~/Vasttrafik/~;$tag =~ s~/MREF_Package/ergpostmongui$~/MREF_Package/ergpostmongui~i;$tag =~ s~DPC_SWCode/~DPG_SWCode/~i;}return $tag;}#-------------------------------------------------------------------------------# Function : examineVcsTag## Description : Examine a VCS Tag and determine if it looks like rubbish# Give it a clean## Inputs : $entry## Returns : Will add Data to the $entry#sub examineVcsTag{my ($entry) = @_;my $bad = 0;$versions{$entry}{vcsTag} = vcsCleanup($versions{$entry}{vcsTag});my $vcstag = $versions{$entry}{vcsTag};if ( $vcstag =~ m~^SVN::~ ) {$versions{$entry}{isSvn} = 1;} elsif ( $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~^/devl/~ || $path =~ m~^devl/~ );$bad = 1 if ( $path =~ m~^CVS~ );$bad = 1 if ( $path =~ m~^http:~i );$bad = 1 if ( $path =~ m~^[A-Za-z]\:~ );$bad = 1 if ( $path =~ m~^//~ );$bad = 1 if ( $path =~ m~^/*none~i );$bad = 1 if ( $path =~ m~^/*NoWhere~i );$bad = 1 if ( $path =~ m~^-$~i );$bad = 1 if ( $path =~ m~^cvsserver:~ );$bad = 1 if ( $path =~ m~,\s*module:~ );# $bad = 1 unless ( $path =~ m~^/~ );}else{$bad = 1;}$versions{$entry}{badVcsTag} = 1 if ( $bad );}#-------------------------------------------------------------------------------# Function : logToFile## Description : Log some data to a named file# Use file locking to allow multiple process to log## Inputs : $filename - Name of file to log# ... - Data to log## Returns : Nothing#sub logToFile{my ($file, @data) = @_;open (LOGFILE, '>>', $file);flock (LOGFILE, LOCK_EX);print LOGFILE "@data\n";flock (LOGFILE, LOCK_UN);close (LOGFILE);}#-------------------------------------------------------------------------------# Function : createImages## Description : Create nice images of the RM version tree## Inputs :## Returns :#sub createImages{my $filebase = "${packageNames}";open (FH, '>', "$filebase.dot" ) or die "Cannot open output";print FH "digraph \"${packageNames}\" {\n";#print FH "rankdir=LR;\n";print FH "node[fontsize=16];\n";print FH "node[target=_graphviz];\n";# print FH "subgraph cluster_A {\n";# print FH "node[fontsize=12];\n";{my @text;push @text, $packageNames;push @text, 'HyperLinked to Release Manager';push @text, 'Created:' . localtime();push @text, '|';push @text, 'Total RM versions: ' . $totalVersions;push @text, 'Essential Entries: ' . scalar @EssentialPackages;push @text, 'Initial trees: ' . $initialTrees;push @text, 'Number of Entries: ' . $processTotal;push @text, 'Type : ' . $packageType;push @text, 'All versions in Subversion' if ( $allSvn );push @text, '|';push @text, 'Total Project Branches: ' . $ProjectCount;foreach ( sort keys %knownProjects ){my $count = $knownProjects{$_}{count} || 0;if ( $count ){my $text = 'Project Branch: ' . $_;$text .= " (" . $count . ")" if ( $count > 1 );push @text, $text;}}push @text, '|';push @text, 'Bad VCS : ' . $badVcsCount;push @text, 'Bad Singletions : ' . $badSingletonCount;push @text, 'Deadwood entries : ' . $trimCount;push @text, 'Walking Mode : Flat' if ($opt_flat);push @text, 'Pruned Mode : ' . $pruneModeString;push @text, 'Pruned entries : ' . $pruneCount;push @text, 'Recent entries : ' . $recentCount;if ( @unknownProjects ){push @text, '|';push @text, 'Unknown Projects';push @text, 'Unknown Project: ' . $_ foreach (sort @unknownProjects );}## Multiple Paths#if ( scalar @multiplePaths > 1 ){push @text, '|';push @text, 'Multiple Paths';push @text, @multiplePaths;}## Bad essentials#if ( @badEssentials ){push @text, '|';push @text, 'Bad Essential Versions';push @text, GetVname($_) foreach ( @badEssentials );}## Subversion Data#if ( %svnData ){push @text, '|';push @text, 'Subversion';push @text, 'Trunk used' if exists $svnData{branches}{trunk} ;push @text, 'Labels: ' . scalar keys %{$svnData{tags}} ;push @text, 'Branches: ' . scalar keys %{$svnData{branches}} ;push @text, 'Relabled Packages : ' . $packageReLabelCount;}push @text, '';my $text = join '\l', @text;$text =~ s~\|\\l~|~g;my @attributes;push @attributes, "shape=record";push @attributes, "label=\"{$text}\"";push @attributes, "tooltip=\"$packageNames\"";push (@attributes, "URL=\"" . $GBE_RM_URL . "/view_by_version.asp?pkg_id=$first_pkg_id" . "\"" )if $first_pkg_id;push @attributes, "color=red";my $attr = join( ' ', @attributes);my $tld_done = 'TitleBlock';print FH "$tld_done [$attr]\n";}## Generate Legend#{my @text;push @text, 'Legend';push @text, '|';push @text, 'Node Content';push @text, 'Package Version';# push @text, 'Release Manager Ref (pvid)';push @text, 'Creation Date: yyyy-mm-dd';push @text, '(Coded information)';push @text, '|{Code';push @text, '|{N: Not Locked';push @text, 'b: Bad Singleton';push @text, 'B: Bad VCS Tag';push @text, 'D: DeadWood';push @text, 'E: Essential Release Version';push @text, 'F: Package directories labled';push @text, 'G: Glued into Version Tree';push @text, 'L: Label not in VOB';push @text, 'r: Recent version';push @text, 'R: Ripple';push @text, 'S: Splitpoint';push @text, 't: Glued into Project Tree';push @text, 'T: Tip version';push @text, 'V: In SVN';push @text, '+: In Subversion';push @text, '0: Zero files extracted';push @text, '}}';push @text, '|';push @text, 'Outline';push @text, 'Red: Dead or Bad VCS Tag';push @text, 'Orange: Project Branch Root';push @text, 'Green: Ripple Build Version';push @text, 'Blue: Essential Version';push @text, 'Darkmagenta: Entry Glued into tree';push @text, 'Magenta: Entry added to project tree';push @text, 'DeepPink: Label not in VOB';push @text, 'DarkViolet: Zero files extracted';push @text, '|';push @text, 'Fill';push @text, 'PowderBlue: Essential Version';push @text, 'Red: Bad Essential Version';push @text, 'Light Green: Migrated to SVN';# push @text, 'Red: Entry Glued into tree';# push @text, 'Green: Entry added to project tree';push @text, '|';push @text, 'Shape';push @text, 'Oval: Normal Package Version';push @text, 'Invhouse: Project Branch Root';push @text, 'Octagon: Branch Point';push @text, 'Box: Bad Single version with no history';push @text, 'Doublecircle: Tip of a Project Branch';push @text, '';my $text = join '\l', @text;$text =~ s~\|\\l~|~g;$text =~ s~\}\\l~}~g;my @attributes;push @attributes, "shape=record";push @attributes, "label=\"{$text}\"";push @attributes, "color=red";my $attr = join( ' ', @attributes);my $tld_done = 'LegendBlock';print FH "$tld_done [$attr]\n";}# print FH "\n}\n";print FH "TitleBlock -> LegendBlock [style=invis]\n";sub genLabelText{my ($entry) = @_;my @label;push @label, $versions{$entry}{name} if ( $multiPackages );push @label, $versions{$entry}{vname};# push @label, $entry; # Add PVIDpush @label, substr( $versions{$entry}{created}, 0, 10); # 2008-02-19# push @label, 'V=' . $versions{$entry}{maxVersion};# push @label, 'B=' . $versions{$entry}{svnBranchTip} if ( exists $versions{$entry}{svnBranchTip} );my $stateText = '';$stateText .= 'N' if ($versions{$entry}{locked} eq 'N');$stateText .= 'b' if (exists $versions{$entry}{badSingleton});$stateText .= 'B' if (exists $versions{$entry}{badVcsTag});$stateText .= 'G' if (exists $versions{$entry}{GluedIn});$stateText .= 't' if (exists $versions{$entry}{MakeTree});$stateText .= 'E' if (exists $versions{$entry}{Essential});$stateText .= 'D' if (exists $versions{$entry}{DeadWood});$stateText .= 'R' if ( $versions{$entry}{isaRipple} );$stateText .= 'r' if (exists $versions{$entry}{keepRecent} && $versions{$entry}{keepRecent} );$stateText .= 'S' if (exists $versions{$entry}{EssentialSplitPoint} && $versions{$entry}{EssentialSplitPoint} > 1 );$stateText .= 'T' if (exists $versions{$entry}{Tip} );$stateText .= 'V' if (exists $versions{$entry}{isSvn} );$stateText .= '+' if (exists $versions{$entry}{svnVersion} );$stateText .= '0' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq '0');$stateText .= 'L' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq 'L');$stateText .= 'F' if ($versions{$entry}{data}{DirsLabled});# $stateText .= 's' if (exists $versions{$entry}{branchPoint} );# $stateText .= ' T='. $versions{$entry}{threadId} if (exists $versions{$entry}{threadId});# $stateText .= ' EssentalPath' if (exists $versions{$entry}{EssentialPath});# $stateText .= ' Count='. $versions{$entry}{EssentialSplitPoint} if (exists $versions{$entry}{EssentialSplitPoint});# $stateText .= ' M='. $versions{$entry}{maxVersion} if (exists $versions{$entry}{maxVersion});push @label, "(${stateText})" if ( length($stateText) );## Insert Release Namesforeach my $rtag_id ( keys %{$versions{$entry}{Releases}} ) {next unless ( exists $ukHopsReleases{$rtag_id} );push @label, "Release: $versions{$entry}{Releases}{$rtag_id}{rname}";}return join ('\n', @label );}sub genAttributes{my ($entry) = @_;my @attributes;push @attributes, 'label="' . genLabelText($entry) . '"';push @attributes, 'URL="' . dotUrl($entry) . '"';push @attributes, 'tooltip="' . "Goto: $versions{$entry}{vname}, PVID=$entry" ,'"';my $shape;$shape = 'box' if ($versions{$entry}{badSingleton});$shape = 'octagon' if ($versions{$entry}{branchPoint});$shape = 'invhouse' if ($versions{$entry}{newSuffix});$shape = 'doublecircle' if ($versions{$entry}{Tip});push @attributes, 'shape=' . $shape if ( $shape );my $color;my $fill;$color = 'color=green style=bold' if ( $versions{$entry}{isaRipple} );$color = 'color=orange style=bold' if ( $versions{$entry}{newSuffix} );$color = 'color=red style=bold' if ( $versions{$entry}{DeadWood} || $versions{$entry}{badVcsTag} );$color = 'color=blue style=bold' if ( $versions{$entry}{Essential} );$color = 'color=darkmagenta style=bold' if ( $versions{$entry}{GluedIn} );$color = 'color=magenta style=bold' if ( $versions{$entry}{MakeTree} );$color = 'color=DeepPink style=bold' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq 'L');$color = 'color=DarkViolet style=bold' if (exists $versions{$entry}{data}{errCode} && $versions{$entry}{data}{errCode} eq '0');$fill = 'style=filled fillcolor=powderblue' if ( $versions{$entry}{Essential} );$fill = 'style=filled fillcolor=red' if ( $versions{$entry}{Essential} && $versions{$entry}{badVcsTag} );$fill = 'style=filled fillcolor="#99FF99"' if ( exists $versions{$entry}{svnVersion} );push @attributes, $color if ( $color );push @attributes, $fill if ( $fill );return '[' . join( ' ', @attributes) . ']';}sub genArrowAttributes{my ($not_first, $entry) = @_;my @attributes;push @attributes, 'arrowhead=empty' if ( $not_first );push ( @attributes, 'label="' . $versions{$entry}{svnBranchTip} .'"' ) if ( exists $versions{$entry}{svnBranchTip} );return ('[' . join( ' ', @attributes) . ']') if ( @attributes ) ;return '';}## Flat#if ( $opt_flat ){my $last = 0;foreach my $entry (@flatOrder ){if ( $last ){my $me = dotTag($last);print FH pentry($me) ,' -> ', pentry(dotTag($entry)), genArrowAttributes(0, $entry) ,";\n";print FH pentry($me) ,genAttributes($last) . ";\n";}$last = $entry;}print FH pentry(dotTag($last)) ,genAttributes($last) . ";\n";}else{foreach my $entry ( sort {$a <=> $b} keys(%versions) ){my $me = dotTag($entry);my @versions = @{ $versions{$entry}{next}};my $ii = 0;foreach ( @versions ){print FH pentry($me) ," -> ",pentry(dotTag($_)), genArrowAttributes($ii++, $_), ";\n";}print FH pentry($me) ,genAttributes($entry) . ";\n";}}print FH "\n};\n";close FH;## Convert DOT to a SVG#unless ( $UNIX ){print "Generating graphical images\n";# system( "dot $filebase.dot -Tjpg -o$filebase.jpg" ); # -vsystem( "dot $filebase.dot -Tsvg -o$filebase.svg" ); # -v# unlink("$filebase.dot");## 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";}else{print "Generated: $filebase.dot\n";}}sub dotTag{my ($entry) = @_;my $label = '';$label .= $versions{$entry}{name} if $multiPackages;$label .= $versions{$entry}{vname};$label =~ s~[-() ]~_~g;return $label;}sub dotUrl{my ($entry) = @_;my $pv_base = $GBE_RM_URL . "/fixed_issues.asp?pv_id=$entry";}#-------------------------------------------------------------------------------# Function : pentry## Description : Generate an entry list as text# Replace "." with "_" since DOT doesn't like .'s# Seperate the arguments## Inputs : @_ - An array of entries to process## Returns : A string#sub pentry{my ($data) = @_;$data =~ s~\.~_~g;$result = '"' . $data . '"' ;return $result;}#-------------------------------------------------------------------------------# Function : getVobMapping## Description : Read in Package to Repository Mapping## Inputs :## Returns : Populates %VobMapping# Mapping of PackageName to RepoName[/Subdir]#our %ScmRepoMap;sub getVobMapping{Message ("Read in Vob Mapping");my $fname = 'cc2svn.repo.dat';Error "Cannot locate $fname" unless ( -f $fname );require $fname;Error "Data in $fname is not valid\n"unless ( keys(%ScmRepoMap) >= 0 );$opt_vobMap = $ScmRepoMap{$packageNames}{repo}if (exists $ScmRepoMap{$packageNames});## Free the memory#%ScmRepoMap = ();## Calculate Target Repo#Warning ("No VOB Mapping found")unless ($opt_vobMap);Error("No repository specified. ie -repo=DevTools or -repo=COTS")unless ( $opt_repo || $opt_vobMap );my $r1 = ($opt_repo || '') . '/' . ($opt_vobMap || '');$r1 =~ s~^/~~;$r1 =~ s~/$~~;$svnRepo = $opt_repo_base . $r1;Verbose( "Repo URL: $svnRepo");}#-------------------------------------------------------------------------------# Function : getEssenialPackageVersions## Description : Determine the 'Essental' Package Versions# Read the data in from an external file## Inputs :## Returns : Populates @EssentialPackages#our %ScmReleases;our %ScmPackages;our %ScmSuffixes;sub getEssenialPackageVersions{Message ("Read in Essential Package Versions");my $fname = 'cc2svn.raw.txt';Error "Cannot locate $fname" unless ( -f $fname );require $fname;Error "Data in $fname is not valid\n"unless ( keys(%ScmReleases) >= 0 );# DebugDumpData("ScmReleases", \%ScmReleases );# DebugDumpData("ScmPackages", \%ScmPackages );# DebugDumpData("ScmSuffixes", \%ScmSuffixes );## Create a list of essential packages# Retain packages-versions used in this program#foreach ( keys %ScmPackages ){next unless ( exists $pkg_ids{ $ScmPackages{$_}{pkgid} } );push @EssentialPackages, $_;Error ("Essential Package Version not in extracted Release Manager Data: $_")unless ( exists $versions{$_} );$versions{$_}{Essential} = 1;# Retain which RM Release this package-version is the tip# Release offoreach my $rtag_id ( @{$ScmPackages{$_}{'release'}} ){$versions{$_}{Releases}{$rtag_id}{rname} = $ScmReleases{$rtag_id}{name};$versions{$_}{Releases}{$rtag_id}{pname} = $ScmReleases{$rtag_id}{pName};$versions{$_}{Releases}{$rtag_id}{proj_id} = $ScmReleases{$rtag_id}{proj_id};}#print "ESSENTIAL: $versions{$_}{name} $versions{$_}{vname}\n";}## Free memory#%ScmReleases = ();%ScmPackages = ();%ScmSuffixes = ();# DebugDumpData("Essential", \@EssentialPackages );Message ("Essential Versions: " . scalar @EssentialPackages );}#-------------------------------------------------------------------------------# Function : ReportPathVariance## Description : Report variance in paths used by the versions## Inputs :## Returns :#my %VobPaths;sub ReportPathVariance{Message ("Detect Multiple Paths");foreach my $entry ( keys(%versions) ){my $e = $versions{$entry};next if ( isSet ($e, 'DeadWood' ) );next if ( isSet ($e, 'badVcsTag') );next if ( isSet ($e, 'isSvn') );my $tag = $e->{vcsTag};next unless ( $tag );$tag =~ m~^(.+?)::(.*?)(::(.+))?$~;my $vcsType = $1;my $cc_label = $4;my $cc_path = $2;$cc_path = '/' . $cc_path;$cc_path =~ tr~\\/~/~s;$VobPaths{$cc_path}++;}@multiplePaths = sort keys %VobPaths;if ( scalar @multiplePaths > 1 ){Warning ("Multiple Paths:" . $_ ) foreach (@multiplePaths);}}sub isSet{my ($base, $element) = @_;return 0 unless ( exists $base->{$element} );return $base->{$element};}#-------------------------------------------------------------------------------# Function : recurseList## Description : Return a list of all element below a given head element## Inputs : $head - Head element## Returns : A list, not in any particular order#our @recurseList;sub recurseList{@recurseList = ();recurseListBody (@_);return @recurseList;}sub recurseListBody{foreach my $entry ( @_ ){push @recurseList, $entry;no warnings "recursion";recurseListBody (@{$versions{$entry}{next}});}}#-------------------------------------------------------------------------------# Function : getSvnData## Description : Read the SVN tree and see what we have## Inputs :## Returns :#my @svnDataItems;sub getSvnData{Message ("Examine Subversion Tree");## Re-init data#@svnDataItems = ();%svnData = ();## Create an SVN session#return unless ( $svnRepo );my $svn = NewSessionByUrl ( "$svnRepo/$packageNames" );return unless ( $svn );## extract data## DebugDumpData("SVN", $svn );$svn->SvnCmd ( 'log', '-v', '--xml', '--stop-on-copy', $svn->Full(), { 'credentials' => 1,'process' => \&ProcessSvnLog,});## Process dataforeach my $entry ( @svnDataItems ){my $name;my $isaBranch;my $target = $entry->{target};if ( $target =~ m~/tags/(.*)~ ) {$name = $1;$svnData{tags}{$name} = 1;} elsif ( $target =~ m~/branches/(.*)~ ) {$name = $1;# $branches{$1} = 1;} else {$svnData{nonTag}{$target} = 1;}my $fromBranch;if ( $entry->{fromPath} =~ m~/trunk$~ ) {$fromBranch = 'trunk';} elsif ( $entry->{fromPath} =~ m~/branches/(.*)~ ) {$fromBranch = $1;}# largest Rev number on branchif ( exists $svnData{max}{$fromBranch} ){if ( $svnData{max}{$fromBranch}{rev} < $entry->{fromRev} ){$svnData{max}{$fromBranch}{rev} = $entry->{fromRev};$svnData{max}{$fromBranch}{name} = $name;}}else{$svnData{max}{$fromBranch}{rev} = $entry->{fromRev};$svnData{max}{$fromBranch}{name} = $name;}}foreach my $branch ( keys %{$svnData{max}} ){$svnData{tips}{$svnData{max}{$branch}{name}} = $branch;}# DebugDumpData("svnDataItems", \@svnDataItems);# DebugDumpData("SvnData", \%svnData);foreach my $entry ( keys(%versions) ){my $import_label = saneLabel($entry);delete $versions{$entry}{svnVersion};delete $versions{$entry}{svnBranchTip};if ( exists $svnData{tags}{$import_label} ){$versions{$entry}{svnVersion} = 1;}if ( exists $svnData{tips}{$import_label} ){$versions{$entry}{svnBranchTip} = $svnData{tips}{$import_label};}}Message ( 'Trunk used: ' . (exists $svnData{'max'}{trunk} ? 'Yes' : 'No') );Message ( 'Labels : ' . scalar keys %{$svnData{tags}} );Message ( 'Branches : ' . scalar keys %{$svnData{'max'}} );}#-------------------------------------------------------------------------------# Function : ProcessSvnLog## Description :# Parse# <logentry# revision="24272"># <author>bivey</author># <date>2005-07-25T15:45:35.000000Z</date># <paths># <path# prop-mods="false"# text-mods="false"# kind="dir"# copyfrom-path="/enqdef/branches/Stockholm"# copyfrom-rev="24271"# action="A">/enqdef/tags/enqdef_24.0.1.sls</path># </paths># <msg>COTS/enqdef: Tagged by Jats Svn Import</msg># </logentry>## Inputs :## Returns :#my $entryData;sub ProcessSvnLog{my ($self, $line ) = @_;#print "----- $line\n";if ( $line =~ m~^<logentry~ ) {$entryData = ();} elsif ( $line =~ m~^\s+revision="(\d+)"~ ) {$entryData->{Rev} = $1;} elsif ( $line =~ m~^\s+copyfrom-path="(.*)"~ ) {$entryData->{fromPath} = $1;} elsif ( $line =~ m~^\s+copyfrom-rev="(\d+)"~ ) {$entryData->{fromRev} = $1;} elsif ( $line =~ m~\s+action=.*?>(.*)</path~ ) {$entryData->{target} = $1;} elsif ( $line =~ m~</logentry~ ) {if ( exists $entryData->{fromPath} ){# DebugDumpData("Data", $entryData);push @svnDataItems, $entryData;}}## Return 0 to keep on goingreturn 0;}#-------------------------------------------------------------------------------# Function : saveData## Description : Save essential data## Inputs :## Returns :#sub saveData{my $file = $cwd . "/${packageNames}.data";Message ("Create: $file");my $fh = ConfigurationFile::New( $file );$fh->DumpData("\n# ScmVersions.\n#\n","ScmVersions", \%versions );## Close out the file#$fh->Close();}#-------------------------------------------------------------------------------# Documentation#=pod=for htmltoc SYSUTIL::cc2svn::=head1 NAMEcc2svn_gendata - CC2SVN tool to import an entire package into SVN=head1 SYNOPSISjats cc2svn_importpackage [options] package_nameOptions:-help - brief help message-help -help - Detailed help message-man - Full documentation-repository=name - Specify target repository-[no]flat - Do not create project tree. Def: -noflat-prunemode=mode - Mode: none, ripple, retain, severe, Def=ripple-retain=N - Specify retain count for pruning. Def=2-[no]test - Do not create packages. Def:-notest-[no]reuse - Keep and reuse ClearCase views-age=nnDays - Only keep recent package-dump[=n] - Dump raw data. N=0,1,2-images[=n] - Create SVG of version tree. N=0,1,2-name=aaa - Alternate output package name. Test Only-[no]log - Write output to log file. Def: -nolog-[no]postimage - Create image after transger: Def: -post-workdir=path - Use for temp storage (def:/work)-delete - Delete SVN package before test-[no]relabel - Attempt to relabel dirs in packages that don't extract=head1 OPTIONS=over 8=item B<-help>Print a brief help message and exits.=item B<-help -help>Print a detailed help message with an explanation for each option.=item B<-man>Prints the manual page and exits.=item B<-prunemode=mode>This option control the manner in which excess versions will be pruned. Validmodes are:=over 8=item noneNo pruning will be performed=item rippleNon-Essential packages that are ripple builds will be removed.=item retainVersions that preceed an Essential version will be retained.=item severeOnly Essential Versions, and Branching points will be retained.=back=back=head1 DESCRIPTIONThis program is a tool used in the conversion of ClearCase VOBS to subversion.It will take a complete package and all relevent versions from ClearCase andinsert them into subversion in a sessible manner. It will attempt to retainfile change order and history.It will:=over 8=item *Read in the Essential Package Version list.=item *Extract, from Release Manager, all known versions of the specified package.=item *It will attempt to determine the type of package: COTS, TOOL, CORE, PROJECTand alter the processing accordingly.=item *It will create a version dependency tree and determine 'new' project branchpoints. It will remove (prune) versions that are excess to requirements.=item *It will extract source from ClearCase and insert it into SVN, creatingbranches and tags as it goes.=backThe program can also be used to create a SVG image of the version dependencytree. This does not work on Linux; only Windows with 'dot' installed.=cut