WebSVN – DevTools – Diff – /core_devl/trunk/TOOLS/jats_sandbox.pl

+#
 #   Options
+#
 my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
 my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
-my $opt_help = 0;
+my $opt_help = 0;                           # Help level
+my $opt_exact = 0;                          # Exact (escrow) build
+#
 #   Globals - Provided by the JATS environment
+#
 my $USER         = $ENV{'USER'};
+#
 ErrorConfig( 'name'    => 'SANDBOX',
              'verbose' => $opt_verbose );
+#
-#   Validate user options
+#   Reconfigure the options parser to allow subcommands to parse options
+#
+Getopt::Long::Configure('permute');
+#
+#   Determine Sandbox type. Exact or local
+#
+$opt_exact = (-f  $GBE_SANDBOX . '/sandbox_dpkg_archive/.exact' )
+    if ( $GBE_SANDBOX );
+#
 #   Parse the user command and decide what to do
+#
+#   Remove user command from the command line. This will leave command options
+#   in @ARGV so that they can be parsed by the subcommand.
+#
 my $cmd = shift @ARGV || "";
 help(1)                                 if ( $cmd =~ m/^help$/ || $cmd eq "" );
-delete_sandbox()                        if ( $cmd =~ m/^delete$/ );
-create_sandbox()                        if ( $cmd =~ m/^create$/ );
-info(@ARGV)                             if ( $cmd =~ m/^info$/ );
-cmd(@ARGV)                              if ( $cmd =~ m/^cmd$/ );
 buildcmd($cmd, @ARGV )                  if ( $cmd =~ m/(^all$)|(^build$)/  );
-cmd($cmd, @ARGV )                       if ( $cmd =~ m/(^make$)/  );
-clean($cmd, @ARGV)                      if ( $cmd =~ m/(^clobber$)|(^clean$)/  );
 cache(@ARGV)                            if ( $cmd =~ m/^cache$/  );
+clean($cmd, @ARGV)                      if ( $cmd =~ m/(^clobber$)|(^clean$)/  );
+cmd('make', $cmd, @ARGV )               if ( $cmd =~ m/(^make$)/  );
+cmd('cmd', @ARGV)                       if ( $cmd =~ m/^cmd$/ );
+create_sandbox()                        if ( $cmd =~ m/^create$/ );
+delete_sandbox()                        if ( $cmd =~ m/^delete$/ );
+info(@ARGV)                             if ( $cmd =~ m/^info$/ );
+populate(@ARGV)                         if ( $cmd =~ m/^populate$/  );
 Error ("Unknown sandbox command: $cmd");
 exit 1;
 # Inputs          : None
+#
+#
 sub create_sandbox
+{
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
+                "exact"         => \$opt_exact,
+                ) || Error ("Invalid command line" );
-    Error ("Unexpected arguments: @ARGV") if ( @ARGV );
+    SubCommandHelp( $opt_help, "Create Sandbox") if ($opt_help || $#ARGV >= 0 );
     Error ("Cannot create a sandbox within a sandbox",
            "Sandbox base is: $GBE_SANDBOX" ) if ( $GBE_SANDBOX );
     mkdir ('sandbox_dpkg_archive') || Error ("Cannot create the directory: sandbox_dpkg_archive") ;
+    TouchFile( 'sandbox_dpkg_archive/.exact', 'Sandbox marker file')
-    Message ('Sandbox created');
+        if ($opt_exact);
+    Message ('Sandbox created' . ($opt_exact ? ' - With exact version number processing' : ''));
     exit  0;
+}
 #-------------------------------------------------------------------------------
 # Function        : delete_sandbox
+#
 # Returns         :
+#
 sub delete_sandbox
+{
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
-    Error ("Unexpected arguments: @ARGV") if ( @ARGV );
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, "Delete Sandbox") if ($opt_help || $#ARGV >= 0 );
     unless ( $GBE_SANDBOX )
+    {
         Warning("No sandbox found to delete");
+    }
     else
+#
 # Returns         : Will exit
+#
 sub info
+{
-    #
-    #   Allow user to specify verboseness as an argument
-    #
-    my @unknown;
+    GetOptions (
-    foreach  ( @_ )
+                "help:+"        => \$opt_help,
-    {
-        $opt_verbose++, next if ( m/^-v/ );
+                "manual:3"      => \$opt_help,
-        push @unknown, $_;
+                "verbose:+"     => \$opt_verbose,
-    }
-    Error ("sandbox info: Unknown options: @unknown") if @unknown;
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, "Sandbox Information") if ($opt_help || $#ARGV >=0 );
+    #
     #   Determine Sandbox information
     #   Populate global variables
+    #
     calc_sandbox_info();
+    #
     #   Display information
+    #
+    Message ("Type   : " . ($opt_exact ? 'Exact' : 'Development') );
-    Message ("Base: $GBE_SANDBOX");
+    Message ("Base   : $GBE_SANDBOX");
     Message ("Archive: $GBE_DPKG_SBOX");
     Message ("Build Order");
     foreach my $fe ( @build_order )
+    {
-        Message( "    Level:" . $fe->{level} . " Name: " . $fe->{mname} );
+        Message( "    Level:" . $fe->{level} . " Name: " . $fe->{dname} );
         Message( DisplayPath ("        Path: $fe->{dir}" )) if $opt_verbose;
         if ( $opt_verbose )
+        {
-            foreach my $idep ( sort keys %{$fe->{ideps}} )
+            foreach my $idep ( sort values %{$fe->{'ideps'}} )
+            {
-                my ($ppn,$pps) = split( $; , $idep);
-                Message ("        I:$ppn.$pps");
+                Message ("        I:$idep");
+            }
-            foreach my $edep ( sort keys %{$fe->{edeps}} )
+            foreach my $edep ( sort keys %{$fe->{'edeps'}} )
+            {
-                my ($ppn,$pps) = split( $; , $edep);
+                my ($ppn,$ppv) = split( $; , $edep);
-                my $pv = $fe->{edeps}{$edep};
-                Message ("        E:$ppn $pv.$pps");
+                Message ("        E:$ppn $ppv");
+            }
+        }
+    }
+    #
+    #   External dependencies flags
+    #       * - Package does not exist in dpkg_archive
+    #       + - Multiple versions of this package are used
     Message("External Dependencies");
     foreach my $de ( sort keys %extern_deps )
+    {
-        my ($pn,$ps) = split( $; , $de);
         my @vlist = keys %{$extern_deps{$de}};
         my $flag = $#vlist ? '+' : '';
-        foreach my $pv ( @vlist )
+        foreach my $pve ( @vlist )
+        {
+            my ($pn,$pv) = split( $; , $pve );
-            my $exists = check_package_existance( $pn, "$pv.$ps") ? '' : '*';
+            my $exists = check_package_existance($pn,$pv  ) ? '' : '*';
             my $flags = sprintf ("%4.4s", $flag . $exists);
-            Message ("${flags}${pn} ${pv}.${ps}");
+            Message ("${flags}${pn} ${pv}");
             if ( $opt_verbose )
+            {
-                foreach my $pkg ( @{$extern_deps{$de}{$pv}} )
+                foreach my $pkg ( @{$extern_deps{$de}{$pve}} )
+                {
-                    my ($ppn,$pps) = split( $; , $pkg);
+                    my $ppn = join ('.', split( $; , $pkg));
-                    Message ("        U:$ppn.$pps");
+                    Message ("        U:$ppn");
+                }
+            }
+        }
+    }
     if ( $opt_verbose > 2 )
+    {
+        #
         #   Locate the build files in each package
         #   Scan the build files and extract dependancy information
+        #
-        my $bscanner = BuildFileScanner( $pname, 'build.pl', '--LocateAll', '--ScanDependencies' );
+        my $bscanner = BuildFileScanner( $pname, 'build.pl',
+                                                 '--LocateAll',
+                                                 $opt_exact ? '--ScanExactDependencies' : '--ScanDependencies' );
         $bscanner->scan();
         my @blist = $bscanner->getInfo();
         Warning ("Package does not have build files: $pname") unless ( @blist );
         Warning ("Package has multiple build files: $pname") if ( $#blist > 0 );
         push @build_list, @blist;
     my %depends;
     my %multi;
     foreach my $be ( @build_list )
+    {
         Verbose( DisplayPath ("Build file: " . $be->{dir} . " Name: " . $be->{file} ));
+        #
+        #   Sandbox vs Exact processing
+        #       Set a suitable display name
+        #       Set a suitable tag
+        #
+        $be->{dname} = $opt_exact ? $be->{full}    : $be->{mname};
+        $be->{tag}   = $opt_exact ? $be->{fullTag} : $be->{package};
 #        DebugDumpData ("be", $be );
+        #
         #   Catch multiple builds for the same package
         #   Report later - when we have all
+        #
-        next unless ( $be->{mname} );
+        next unless ( $be->{dname} );
-        push @{$multi{$be->{mname}}},$be->{dir};
+        push @{$multi{$be->{dname}}},$be->{dir};
+        #
         #   Add into dependency struct
+        #
-        $depends{$be->{package}}{depends} = $be->{depends};
+        $depends{$be->{tag}}{entry} = $be;
-        $depends{$be->{package}}{entry} = $be;
+        $depends{$be->{tag}}{depends} = $be->{depends};
+    }
-    foreach my $mname ( sort keys %multi )
+    foreach my $dname ( sort keys %multi )
+    {
-        ReportError ("Mutiple builders for : $mname", @{$multi{$mname}} )
+        ReportError ("Mutiple builders for : $dname", @{$multi{$dname}} )
-            if ( scalar @{$multi{$mname}} > 1 );
+            if ( scalar @{$multi{$dname}} > 1 );
+    }
     ErrorDoExit();
 #DebugDumpData ("depends", \%depends );
+    {
         foreach my $build ( keys( %{$depends{$key}{depends}} ))
+        {
             unless (exists $depends{$build})
+            {
-                push @{$extern_deps{$build}{$depends{$key}{depends}{$build}}}, $key;
+                push @{$extern_deps{$build} {$depends{$key}{depends}{$build}} }, $key;
-                $depends{$key}{entry}{edeps}{$build} = $depends{$key}{depends}{$build};
+                $depends{$key}{entry}{'edeps'}{$depends{$key}{depends}{$build}} = 1;
                 delete ($depends{$key}{depends}{$build}) ;
                 Verbose2( "Not in set: $build");
+            }
             else
+            {
-                $depends{$key}{entry}{ideps}{$build} = 1;
+                $depends{$key}{entry}{'ideps'}{$build} = $depends{$build}{entry}{dname};
+            }
+        }
+    }
+#DebugDumpData ("depends", \%depends );
+#DebugDumpData ("External Depends", \%extern_deps );
+    #
+    #   Determine package build order
+    #       Scan the list of packages in the build set and determine
+    #       those with no dependencies. These can be built.
+    #       Remove those packages as dependents from all packages
+    #       Repeat.
+    #
     while ( $more )
+    {
         $more = 0;
         $level++;
         my @build;
         #DebugDumpData ("depends", \%depends );
         Error( "Internal algorithm error: Bad dependancy walk",
                "Possible circular dependency");
+    }
-#    DebugDumpData ("Order", \@build_order);
+#   DebugDumpData ("Order", \@build_order);
+#   DebugDumpData("External Depends", \%extern_deps );
+}
 #-------------------------------------------------------------------------------
 # Function        : cmd
+#
+#
 # Returns         : Will exit
+#
 sub cmd
+{
-    my @cmds = @_;
+    my ($hcmd, @cmds ) = @_;
+    Getopt::Long::Configure('pass_through');
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, $hcmd) if ($opt_help  );
+    #
     #   Determine Sandbox information
     #   Populate global variables
+    #
     calc_sandbox_info();
     foreach my $fe ( @build_order )
+    {
         my $dir = $fe->{dir};
-        Message( "Level:" . $fe->{level} . " Name: " . $fe->{mname} ,
+        Message( "Level:" . $fe->{level} . " Name: " . $fe->{dname} ,
                   DisplayPath ("        Path: $fe->{dir}" ));
         my $result = JatsCmd( "-cd=$dir", @cmds);
         Error ("Cmd failure") if ( $result );
+    }
     my ($cmd, @cmd_opts) = @_;
     my @build_opts;
     my @make_opts;
+    #
+    #   Extract and options
+    #
+    Getopt::Long::Configure('pass_through');
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, "Command $cmd") if ($opt_help );
+    #
     #   Insert default options
+    #
     push @build_opts, '-noforce' if ( $cmd eq 'all' );
     push @build_opts, '-force' if ( $cmd ne 'all' );
+    #
     calc_sandbox_info();
     foreach my $fe ( @build_order )
+    {
         my $dir = $fe->{dir};
-        Message( "Level:" . $fe->{level} . " Name: " . $fe->{mname} ,
+        Message( "Level:" . $fe->{level} . " Name: " . $fe->{dname} ,
                   DisplayPath ("        Path: $fe->{dir}" ));
         JatsCmd( "-cd=$dir", 'build', @build_opts) && Error ("Build Cmd failure") if ( $result );
         JatsCmd( "-cd=$dir", 'make',  @make_opts)  && Error ("Make Cmd failure")  if ( $result );
+    }
 # Returns         : Will exit
+#
 sub clean
+{
     my ($mode, @cmds ) = @_;
+    #
+    #   Extract and options
+    #
+    Getopt::Long::Configure('pass_through');
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, "Clean") if ($opt_help );
+    #
     #   Determine Sandbox information
     #   Populate global variables
+    #
     calc_sandbox_info();
     #   Clobber and clean need to be done in the reverse order
+    #
     foreach my $fe ( reverse @build_order )
+    {
         my $dir = $fe->{dir};
-        Message( "Level:" . $fe->{level} . " Name: " . $fe->{mname} ,
+        Message( "Level:" . $fe->{level} . " Name: " . $fe->{dname} ,
                   DisplayPath ("        Path: $fe->{dir}" ));
         my $result = JatsCmd( "-cd=$dir", @cmd, @cmds);
         Error ("Cmd failure") if ( $result );
+    }
 # Returns         : Nothing
+#
 sub cache
+{
     my (@opts) = @_;
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
-    Warning("Unknown options: @opts") if ( @opts );
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, "Cache") if ($opt_help || $#ARGV >= 0 );
+    #
     #   Determine Sandbox information
     #   Populate global variables
+    #
+    #
     #   Walk the list of external depenedencies and cache each one
+    #
     foreach my $de ( sort keys %extern_deps )
+    {
-        my ($pn,$ps) = split( $; , $de);
         my @vlist = keys %{$extern_deps{$de}};
-        foreach my $pv ( @vlist )
+        foreach my $pve ( @vlist )
+        {
+            my ($pn,$pv) = split( $; , $pve );
-            Message ("Cache ${pn} ${pv}.${ps}");
+            Message ("Cache ${pn} ${pv}");
-            JatsTool ('cache_dpkg', "${pn}/${pv}.${ps}" );
+            JatsTool ('cache_dpkg', "${pn}/${pv}" );
+        }
+    }
     exit 0;
+}
+#-------------------------------------------------------------------------------
+# Function        : populate
+#
+# Description     : Populate the sandbox with package versions
+#
+#
+# Inputs          : commands            - Array of command line arguments
+#                   Mode-0:
+#
+#                       pkg_name pkg_version        - Import files for named package
+#                       options:
+#                           -recurse                - Import dependent packages too
+#                           -missing                - Import dependencies not in dpkg_archive
+#                           -test                   - Show what would be done
+#                           -extractfiles           - Extract file, no view
+#
+#
+#
+#
+# Returns         : Does not return
+#
+use JatsRmApi;
+use DBI;
+#
+#   Data Base Interface
+#
+my $RM_DB;
+my $PopLevel = 0;
+my %PopPackage;
+my @StrayPackages;
+my @PopBase;
+sub populate
+{
+    my $opt_missing = 0;
+    my $opt_recurse = 0;
+    my $opt_test = 0;
+    my $opt_extractfiles;
+    my @opt_extract = qw(-extract);
+    my @opt_fnames;
+    Getopt::Long::Configure('pass_through');
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
+                "missing"       => \$opt_missing,
+                "test"          => \$opt_test,
+                "recurse:100"   => \$opt_recurse,
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, "Populate Sandbox") if ($opt_help );
+    #
+    #   Extract options for the jats extract utility
+    #
+    foreach ( @ARGV )
+    {
+        if ( m~^-~ ) {
+            push ( @opt_extract, $_);
+        } else {
+            push ( @opt_fnames, $_);
+        }
+    }
+    #
+    #   Allow exactly zero or two 'bare' arguments
+    #   Create an array of package-versions to be processed.
+    #
+    if ( $#opt_fnames >= 0 )
+    {
+        Error ("Populate: Must speicfy both a package name and version")
+            if ( $#opt_fnames != 1 );
+        push @PopBase, join( $;, @opt_fnames );
+    }
+    elsif ( $opt_missing )
+    {
+        #
+        #   User has not provided a package name to extract
+        #   Assume that the user will want missing dependencies
+        #
+        #   Determine packages that are not present
+        #
+        calc_sandbox_info();
+        #
+        # Scan for missing dependencies
+        #
+        foreach my $de ( sort keys %extern_deps )
+        {
+            my @vlist = keys %{$extern_deps{$de}};
+            foreach my $pve ( @vlist )
+            {
+                my ($pn,$pv) = split( $; , $pve );
+                unless (check_package_existance( $pn, $pv ))
+                {
+                    push @PopBase, join( $;, $pn , $pv );
+                }
+            }
+        }
+    }
+    else
+    {
+        Error ("No command or option specified. See help for command usage");
+    }
+    #
+    #   Process the list of package-versions
+    #   These are top level packages. Get details from Release Manager
+    #
+    #DebugDumpData("Data", \@PopBase );
+    $PopLevel = 0;
+    foreach my $entry ( @PopBase )
+    {
+        my ($pname, $pver ) = split( $; , $entry);
+        my $pv_id = getPkgDetailsByName($pname, $pver);
+        Error ("populate: $pname, $pver not found in Release Manager" )
+            unless ( $pv_id );
+        getPkgDetailsByPV_ID($pv_id);
+    }
+    #
+    #   If recursing then process packages that have yet to
+    #   be processed. At the start there will be the initial user specified
+    #   packages on the list. Place a marker at the end so that we can
+    #   determine how far we are recursing down the dependency tree.
+    #
+    if ( $opt_recurse )
+    {
+        my $marker = join($; , '_NEXT_LEVEL_', 0, 0 );
+        push @StrayPackages, $marker;
+        $PopLevel++;
+        while ( $#StrayPackages >= 0 )
+        {
+            my ($name, $ver, $pv_id) = split($;, shift @StrayPackages);
+            #
+            #   Marker.
+            #   Increment the level of recursion
+            #   Detect end conditions
+            #
+            if ( $name eq '_NEXT_LEVEL_' )
+            {
+                last unless ($#StrayPackages >= 0 );
+                $PopLevel++;
+                last if ( $PopLevel > $opt_recurse );
+                push @StrayPackages, $marker;
+                next;
+            }
+            next if ( exists $PopPackage{$name}{$ver}{done} );
+            getPkgDetailsByPV_ID ( $pv_id );
+            #print "Stray: $pv_id, $name, $ver\n";
+        }
+    }
+    #DebugDumpData("Data", \%PopPackage );
+    #
+    #   Determine packages that need to be extracted
+    #   Not ordered in any way. Could order by level if we wanted
+    #
+    foreach my $pname ( sort keys %PopPackage )
+    {
+        foreach my $pver ( sort keys %{$PopPackage{$pname}} )
+        {
+            #
+            #   Create a nice view name for the extraction
+            #   Will also be used to test for package existance
+            #
+            my $vname = "$pname $pver";
+            $vname =~ s~ ~_~g;
+            $vname =~ s~__~~g;
+            if ( -d "$GBE_SANDBOX/$vname" )
+            {
+                Warning("Package already in sandbox: $pname, $pver");
+                next;
+            }
+            #
+            #   If scanning for missing packages, then examine archives
+            #   for the packages existence. Don't do this on level-0 packages
+            #   These have been user specified.
+            #
+            if ( $opt_missing && $PopPackage{$pname}{$pver}{level}  )
+            {
+                my $found = check_package_existance( $pname, $pver );
+                if ( $found )
+                {
+                    Verbose ("Package found in archive - skipped: $pname, $pver");
+                    next;
+                }
+            }
+            #
+            #   Generate commands to extract the package
+            #
+            my $vcstag = $PopPackage{$pname}{$pver}{vcstag};
+            my @cmd = qw(jats_vcsrelease);
+            push @cmd, "-view=$vname", "-label=$vcstag", @opt_extract;
+            if ( $opt_test )
+            {
+                Message "jats " . QuoteCommand (@cmd );
+            }
+            else
+            {
+                Message "Extracting: $pname $pver";
+                my $rv = JatsCmd (@cmd);
+                Error ("Package version not extracted")
+                    if ( $rv );
+            }
+        }
+    }
+    #
+    # This command does not return
+    #
+    exit (0);
+}
+#-------------------------------------------------------------------------------
+# Function        : getPkgDetailsByName
+#
+# Description     : Determine the PVID for a given package name and version
+#
+# Inputs          : $pname          - Package name
+#                   $pver           - Package Version
+#
+# Returns         :
+#
+sub getPkgDetailsByName
+{
+    my ($pname, $pver) = @_;
+    my $pv_id;
+    my (@row);
+    connectRM(\$RM_DB) unless ($RM_DB);
+    # First get details for a given package version
+    my $m_sqlstr = "SELECT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION" .
+                    " FROM RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
+                    " WHERE pkg.PKG_NAME = \'$pname\' AND pv.PKG_VERSION = \'$pver\' AND pv.PKG_ID = pkg.PKG_ID";
+    my $sth = $RM_DB->prepare($m_sqlstr);
+    if ( defined($sth) )
+    {
+        if ( $sth->execute( ) )
+        {
+            if ( $sth->rows )
+            {
+                while ( @row = $sth->fetchrow_array )
+                {
+                    $pv_id = $row[0];
+                    my $name = $row[1];
+                    my $ver = $row[2];
+                    Verbose( "getPkgDetailsByName :PV_ID= $pv_id");
+                }
+            }
+            $sth->finish();
+        }
+    }
+    else
+    {
+        Error("Prepare failure" );
+    }
+    return $pv_id;
+}
+#-------------------------------------------------------------------------------
+# Function        : getPkgDetailsByPV_ID
+#
+# Description     : Populate the Packages structure given a PV_ID
+#                   Called for each package in the SBOM
+#
+# Inputs          : PV_ID           - Package Unique Identifier
+#
+# Returns         : Populates Package
+#
+sub getPkgDetailsByPV_ID
+{
+    my ($PV_ID) = @_;
+    my $foundDetails = 0;
+    my (@row);
+    connectRM(\$RM_DB) unless ($RM_DB);
+    # First get details from pv_id
+    my $m_sqlstr = "SELECT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION, release_manager.PK_RMAPI.return_vcs_tag($PV_ID)" .
+                    " FROM RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg " .
+                    " WHERE pv.PV_ID = \'$PV_ID\' AND pv.PKG_ID = pkg.PKG_ID";
+    my $sth = $RM_DB->prepare($m_sqlstr);
+    if ( defined($sth) )
+    {
+        if ( $sth->execute( ) )
+        {
+            if ( $sth->rows )
+            {
+                while ( @row = $sth->fetchrow_array )
+                {
+                    my $pv_id       = $row[0];
+                    my $name        = $row[1];
+                    my $ver         = $row[2];
+                    my $vcstag      = $row[3] || '';
+                    $vcstag =~ tr~\\/~/~;
+                    Verbose ("getPkgDetailsByPV_ID: $PV_ID, $name, $ver, $vcstag");
+                    $PopPackage{$name}{$ver}{pvid} = $PV_ID;
+                    $PopPackage{$name}{$ver}{done} = 1;
+                    $PopPackage{$name}{$ver}{vcstag} = $vcstag;
+                    $PopPackage{$name}{$ver}{level} = $PopLevel;
+                    getDependsByPV_ID( $pv_id, $name, $ver );
+                }
+            }
+            else
+            {
+                Warning ("No Package details for: PVID: $PV_ID");
+            }
+            $sth->finish();
+        }
+        else
+        {
+            Error("getPkgDetailsByPV_ID: Execute failure", $m_sqlstr );
+        }
+    }
+    else
+    {
+        Error("Prepare failure" );
+    }
+}
+#-------------------------------------------------------------------------------
+# Function        : getDependsByPV_ID
+#
+# Description     : Extract the dependancies for a given package version
+#
+# Inputs          : $pvid
+#
+# Returns         :
+#
+sub getDependsByPV_ID
+{
+    my ($pv_id, $pname, $pver) = @_;
+    connectRM(\$RM_DB) unless ($RM_DB);
+    #
+    #   Now extract the package dependacies
+    #
+    my $m_sqlstr = "SELECT pkg.PKG_NAME, pv.PKG_VERSION, pd.DPV_ID" .
+                   " FROM RELEASE_MANAGER.PACKAGE_DEPENDENCIES pd, RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
+                   " WHERE pd.PV_ID = \'$pv_id\' AND pd.DPV_ID = pv.PV_ID AND pv.PKG_ID = pkg.PKG_ID";
+    my $sth = $RM_DB->prepare($m_sqlstr);
+    if ( defined($sth) )
+    {
+        if ( $sth->execute( ) )
+        {
+            if ( $sth->rows )
+            {
+                while ( my @row = $sth->fetchrow_array )
+                {
+                    my $name = $row[0];
+                    my $ver = $row[1];
+                    Verbose2( "       Depends: $name, $ver");
+                    unless ( exists $PopPackage{$name} && exists $PopPackage{$name}{$ver} && exists $PopPackage{$name}{$ver}{done} )
+                    {
+                        push @StrayPackages, join($;, $name, $ver, $row[2] );
+                    }
+                }
+            }
+            $sth->finish();
+        }
+    }
+    else
+    {
+        Error("GetDepends:Prepare failure" );
+    }
+}
+#-------------------------------------------------------------------------------
+# Function        : SubCommandHelp
+#
+# Description     : Provide help on a subcommand
+#
+# Inputs          : $help_level             - Help Level 1,2,3
+#                   $topic                  - Topic Name
+#
+# Returns         : This function does not return
+#
+sub SubCommandHelp
+{
+    my ($help_level, $topic) = @_;
+    my @sections;
+    #
+    #   Spell out the section we want to display
+    #
+    #   Note:
+    #   Due to bug in pod2usage can't use 'head1' by itself
+    #   Each one needs a subsection.
+    #
+    push @sections, qw( NAME SYNOPSIS ) ;
+    push @sections, qw( ARGUMENTS OPTIONS )     if ( $help_level > 1 );
+    push @sections, qw( DESCRIPTION EXAMPLES )  if ( $help_level > 2 );
+    #
+    #   Extract section from the POD
+    #
+    pod2usage({-verbose => 99,
+               -noperldoc => 1,
+               -sections => $topic . '/' . join('|', @sections) } );
+}
 #-------------------------------------------------------------------------------
 #   Documentation
+#   NOTE
+#
+#   Each subcommand MUST have
+#   head1 section as used by the subcommand
+#       This should be empty, as the contents will NOT be displayed
+#   head2 sections called
+#       NAME SYNOPSIS ARGUMENTS OPTIONS DESCRIPTION EXAMPLES
+#
+#=head1 xxxxxx
+#=head2 NAME
+#=head2 SYNOPSIS
+#=head2 ARGUMENTS
+#=head2 OPTIONS
+#=head2 DESCRIPTION
+#=head2 EXAMPLES
+#
 =pod
 =head1 NAME
 jats_sandbox - Build in a Development Sandbox
 =head1 SYNOPSIS
-  jats sandbox [options] [commands]
+  jats sandbox [options] {command} [command options]
  Options:
     -help[=n]          - Display help with specified detail
     -help -help        - Detailed help message
     -man               - Full documentation
  Commands:
     help                - Same as -help
     create              - Create a sandbox in the current directory
+    populate            - Populate the sandbox with packages
     delete              - Delete the sandbox
     info [[-v]-v]       - Sandbox information. -v: Be more verbose
     cmd                 - Do commands in all sandbox components
     all                 - Do 'build', if required, then a make in all sandbox components
     build               - Force 'build and make' in all sandbox components
     make                - Do 'make' in all sandbox components
     clean               - Do 'make clean' in all sandbox components
     clobber             - Do 'build clobber' is all sandbox components
     cache               - Cache external dependent packages
+ Use the command
+    jats sandbox 'command' -h
+ for command specific help
 =head1 OPTIONS
 =over 8
 =item B<-help[=n]>
 Several JATS commands operate differently within a sandbox. The 'extract' and
 'release' commands will create static viwes within the sandbox and not the
 normal directory. The 'sandbox' sub commands can only be used within a sandbox.
 The sandbox directory contains sub directories, each should contain a single
-package. Sub directories may be created with the 'jats extract' command.
+package. Sub directories may be created with the 'jats extract' command or with the
+'jats sandbox populate' command.
 Note: Symbolic links are not supported. They cannot work as he sandbox mechanism
 requires that all the packages be conatined within a sub directory tree so
 that the root of the sandbox can be located by a simple scan of the directory
 tree.
 <GBE_MACHTYPE>', then that package will not be considered as a part of the
 build-set. A 'stop' file will prevent consideration all build platforms. The 'stop.
 <GBE_MACHTYPE>' will only prevent consideration if being built on a GBE_MACHTYPE
 type of computer.
-=head2 COMMAND SUMMARY
+=head1 Create Sandbox
+=head2 NAME
+Create Sandbox
+=head2 SYNOPSIS
+jats sandbox [options] create [command options]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+    -verbose[=n]            - Verbose operation
+    -exact                  - Create sandbox to reproduce exact versions
+=head2 OPTIONS
+The 'create' command takes the following options:
+=over 8
+=item -exact
+When this option is specified the sandbox is marked for exact processing of
+package versions. In this mode the version numbers of the packages in the
+sandbox are significant. This is ideal for recreating a package-version.
+The default is for in-exact processing, in which the version numbers of packages
+within the sandbox are not significant. The is ideal for development.
+=back
-=head3 create
+=head2 DESCRIPTION
 The 'create' command will create a sandbox in the users current directory. It is
 not possible to create a sandbox within a sandbox.
 A sandbox can be created in a directory that contains files and subdirectories.
 The create command simply places a known directory in the current directory.
-This dorectory is used by the sandboxing process. It may be manually deleted, or
+This directory is used by the sandboxing process. It may be manually deleted, or
 deleted with the 'delete' command.
+=head1 Populate Sandbox
+=head2 NAME
+Populate a Sandbox
+=head2 SYNOPSIS
+jats sandbox [options] populate [command options] [packageName packageVersion]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+    -recurse[=n]            - Locate dependencies within packages
+    -missing                - Locate missing packages
+    -test                   - Do not extract packages
+    -<Other>                - Pass options to jats extract
+=head2 ARGUMENTS
+The 'populate' command can take a package name and version as arguments. It will
+then populate the sandbox with this package. See 'DESCRIPTION' for details.
+=head2 OPTIONS
+The 'populate' command takes the following options:
+=over 4
+=over 4
+=item -recurse[=N]
+This option will modify the operation of the command such that dependencies
+of named packages can also be extracted into the sandbox.
+The default operation is to only extract named packages. If the option is
+specified then all dependent packages are processed. An optional numeric argument
+can be specified to limit the depth of the recursion.
+=item -missing
+This option will modify the operation of the dependency recursion scanning such
+that dependent packages that exist in a package archive will not be extracted.
+Use of this option allows a sandbox to be populated with packages that are
+required by packages in the sandbox, but are not available in a package archive.
+=item -test
+This option will prevent the command from performing the extraction. It will
+simply display the JATS commands that can be used to perform the extraction.
+=item -<Other>
+Options not understood by the 'populate' sub command will be passed through
+the package extraction program. Useful options include:
+=over 8
+=item   -extractfiles
+=item   -branch=<branch name>
+=back
+=back
+=back
+=head2 DESCRIPTION
+The 'populate' command can be used to assist in populating the sandbox. It has
+two modes of operation.
+=over 8
+=item Named Package
+If the user specifies both a package name and a package version then he command
+will populate the sandbox with that package and optionally its dependencies.
+=item Determine missing dependencies
+If the user does not specify a package name and version, but does specify
+the '-missing' option,  then the command will examine the current sandbox and
+determine missing dependent packages. It will then populate the sandbox with
+these packages and optionally there dependencies.
+=back
+=head2 EXAMPLES
+=over 4
+=item jats sandbox populate package1 version1
+This command will populate the sandbox with version1 of package1, if it does not
+already exist in the sandbox.
+=item jats sandbox populate package1 version1 -recurse -missing
+This command will populate the sandbox with version1 of package1, if it does not
+already exist in the sandbox, together will all the packages dependencies that
+are not available in a package archive.
+=item jats sandbox populate -recurse -missing
+This command will examine the current sandbox and populate the sandbox with
+packages that are required to build the packages in the sandbox and the
+dependencies of these packages, provide the dependent package is not in a
+package archive.
+=item jats sandbox populate
+This command will examine the current sandbox and populate the sandbox with
+packages that are required to build the packages in the sandbox. It will not
+examine the dependents of these packages.
+=back
+=head1 Delete Sandbox
-=head3 delete
+=head2 NAME
+Deleta a sandbox
+=head2 SYNOPSIS
+jats sandbox [options] delete
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+=head2 DESCRIPTION
 The 'delete' command will delete the sandbox's marker directory. The command may
 be executed anywhere within the sandbox.
-Once the sanbox has been deleted, the user must remove the components within the
+Once the sandbox has been deleted, the user must remove the components within the
 sandbox.
+=head1 Sandbox Information
-=head3 info
+=head2 NAME
+Display Sandbox Information
+=head2 SYNOPSIS
+jats sandbox [options] info [command options]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+    -verbose[=n]            - Display more information
+=head2 OPTIONS
+=over
+=item B<-verbose[=n]>
+This options will increase the verbosity of the information being displayed.
+Values 1 and 2 are described in the detailed 'DESCRIPTION'. Other values are
+reserved for diagnostic use.
+=back
+=head2 DESCRIPTION
 The 'info' command will display information about the build order and the
-depenedencies of packages that it finds within the sandbox.
+dependencies of packages that it finds within the sandbox.
-The command will accept one option '-v' to increase the verbosity of the
+The command works within various levels of verbosity:
-information being displayed.
 =over 8
 =item * No Verbosity
 =back
 =item Verbosity of 1
-This level of verbosoity will display the build order and detailed information
+This level of verbosity will display the build order and detailed information
 on the dependencies. The dependencies will be prefixed with:
 =over 8
 =item   E   Dependent Package is external to the sandbox
 no-verbosity. Additionally the internal consumer of the external package is also
 shown. These are prefixed with a 'U'.
 =item Verbosity of 2
-Reserved forfuture use
+Reserved for future use
 =item Verbosity over 2
-This should be considered a debug option. Undocument internal information will
+This should be considered a debug option. Undocumented internal information will
 be displayed.
 =back
+=head1 Command all
-=head3 all
+=head2 NAME
+Build packages in the sandbox
+=head2 SYNOPSIS
+jats sandbox [options] all [command options] [arguments]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+=head2 ARGUMENTS
+Arguments are passed to the 'make' phase of the process.
+=head2 OPTIONS
+The are command specific options.
+=head2 DESCRIPTION
 The 'all' command will perform build, if the build files are out of date,
 followed by a make in each of the packages within the sandbox, in the correct
 build order.
 =item * Resume a failed build.
 =back
+=head1 Command build
-=head3 build
+=head2 NAME
+Build packages in the sandbox
+=head2 SYNOPSIS
+jats sandbox [options] build [command options] [arguments]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+=head2 ARGUMENTS
+Arguments are passed to the 'make' phase of the process.
+=head2 OPTIONS
+The are no command specific options.
+=head2 DESCRIPTION
 The 'build' command will force a build followed by a make in each of the packages
 within the sandbox, in the correct build order.
 Any arguments are passed to the 'make' phase of the process.
 In practice, the 'sandbox all' command is quicker.
+=head1 Clean
+=head2 NAME
+Clean all sandbox components
+=head2 SYNOPSIS
+jats sandbox [options] clean|clobber [command options]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+=head2 ARGUMENTS
+None
+=head2 OPTIONS
+No command specific options
+=head2 DESCRIPTION
+The 'clean' command will perform a 'jats make clean' in all components in the
+sandbox.
+The 'clobber' command will perform a 'jats clobber' in all components in the
+sandbox.
-=head3 make
+=head1 make
+=head2 NAME
+Make packages in the sandbox
+=head2 SYNOPSIS
+jats sandbox [options] make [command options] [arguments]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+=head2 ARGUMENTS
+Arguments are passed to the 'make' phase of the process.
+=head2 OPTIONS
+The are no command specific options.
+=head2 DESCRIPTION
 The 'make' command will perform a 'make' operation in each of the packages
 within the sandbox, in the correct build order.
 Any arguments are passed to the 'make'.
-=head3 cmd
+=head1 cmd
+=head2 NAME
+Process each package with a specified command.
+=head2 SYNOPSIS
+jats sandbox [options] cmd [command options] [arguments]
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+=head2 ARGUMENTS
+Arguments are passed to a JATS command.
+=head2 OPTIONS
+The are no command specific options.
+=head2 DESCRIPTION
 The 'cmd' command will pass all of its arguments to JATS in the build directory
 of each of the packages within the sandbox, in the package build order.
-=head3 clean
+=head1 Cache
-The 'clean' command will perform a 'jats make clean' in all components in the
-sandbox.
+=head2 NAME
-=head3 clobber
+Cache dependent packages
-The 'clobber' command will perform a 'jats clobber' in all components in the
+jats sandbox [options] cache [command options]
-sandbox.
-=head3 cache
+ Options:
+    -help[=n]               - Help message, [n=1,2,3]
+    -man                    - Full documentation [-help=3]
+    -verbose[=n]            - Verbose command operation
+ Command Options
-The 'cache' command will cache all external dependent packages into the sandbox.
+    -help[=n]               - Command specific help, [n=1,2,3]
-This allows the simple creation of a small development environment that is
-not tied to the larger Development Environment. It may then be used in a
-disconnected mode to perform development.
+=head2 ARGUMENTS
+The are no command specific arguments.
-=cut
+=head2 OPTIONS
+The are no command specific options.
+=head2 DESCRIPTION
+The 'cache' command will cache all external dependent packages into the users
+dpkg_archive_cache as defined through the EnvVar GBE_DPKG_CACHE. The result is
+similar to the command 'jats sandbox build -cache', without the overhead of
+building the sandbox components.
+This command allows the simple creation of a small development environment that
+is not tied to the larger Development Environment. It may then be used in a
+disconnected mode to perform development.
+=cut

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/jats_sandbox.pl – Rev 341 → 359