WebSVN – DevTools – Diff – /core_devl/branches/dpurdie_devl/TOOLS/jats_sandbox.pl

+#
 my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
 my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
 my $opt_help = 0;                           # Help level
 my $opt_exact = 0;                          # Exact (escrow) build
+my $opt_toPackage;                          # Control recursion
+my $opt_fromPackage;                        # Control recursion
+my @opt_exactPackage;                       # Control recursion
+my @opt_ignorePackage;                      # Control recursion
+#
 #   Globals - Provided by the JATS environment
+#
 my $USER         = $ENV{'USER'};
 my $GBE_DPKG_STORE = $ENV{'GBE_DPKG_STORE'};
+#
 #   Globals
+#
+my @stopped = ();                         # Stopped entries
 my @build_order = ();                     # Build Ordered list of entries
 my %extern_deps;                          # Hash of external dependencies
 my %packages;                             # Hash of packages
+{
     GetOptions (
                 "help:+"        => \$opt_help,
                 "manual:3"      => \$opt_help,
                 "verbose:+"     => \$opt_verbose,
+                'topackage:s'   => \$opt_toPackage,
+                'frompackage:s' => \$opt_fromPackage,
+                'justpackage:s' => \@opt_exactPackage,
+                'ignorepackage:s' => \@opt_ignorePackage,
                 ) || Error ("Invalid command line" );
     SubCommandHelp( $opt_help, "Sandbox Information") if ($opt_help || $#ARGV >=0 );
+    #
     #   Determine Sandbox information
     #   Populate global variables
+    #
-    calc_sandbox_info();
+    calc_sandbox_info(1);
+    #
     #   Display information
+    #
     Message ("Type   : " . ($opt_exact ? 'Exact' : 'Development') );
     Message ("Base   : $GBE_SANDBOX");
     Message ("Archive: $GBE_DPKG_SBOX");
     Message ("Build Order");
+    foreach my $pname ( @stopped )
+    {
+        Message( "    Level:" . "-"  . " Name: " . $pname . ' (Stopped)');
+    }
     foreach my $fe ( @build_order )
+    {
-        Message( "    Level:" . $fe->{level} . " Name: " . $fe->{dname} );
+        Message( "    Level:" . $fe->{level} . " Name: " . $fe->{dname} . ($fe->{buildActive} ? '' : ' (Build Suppressed)'));
         Message( DisplayPath ("        Path: $fe->{dir}" )) if $opt_verbose;
         if ( $opt_verbose )
+        {
             foreach my $idep ( sort values %{$fe->{'ideps'}} )
 # Function        : calc_sandbox_info
+#
 # Description     : Examine the sandbox and determine all the important
 #                   information
+#
+#                   Operation will be modified by
-# Inputs          : None
+#                       $opt_toPackage
+#                       $opt_fromPackage
+#                       @opt_exactPackage
+#                       @opt_ignorePackage
+#
+# Inputs          : info                - True: Just for info
+#                                               Keep supressed packages
+#
 # Returns         : Will exit if not in a sandbox
 #                   Populates global variables
 #                       @build_order - build ordered array of build entries
+#
 sub calc_sandbox_info
+{
+    my ($info) = @_;
+    #
     #   Start from the root of the sandbox
+    #
     Error ("Command must be executed from within a Sandbox") unless ( $GBE_SANDBOX );
     chdir ($GBE_SANDBOX) || Error ("Cannot chdir to $GBE_SANDBOX");
         next unless ( -d $pname );
         Verbose ("Package discovered: $pname");
         if ( -f "$pname/stop" || -f "$pname/stop.$GBE_MACHTYPE" )
+        {
+            push @stopped, $pname;
             Warning("Package contains stop file: $pname");
             next;
+        }
         push @dirlist, $pname;
     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
+        #
         push @{$multi{$be->{dname}}},$be->{dir};
+        #
         #   Add into dependency struct
+        #
-        $depends{$be->{tag}}{entry} = $be;
+        $depends{$be->{tag}} = $be;
-        $depends{$be->{tag}}{depends} = $be->{depends};
+    }
     foreach my $dname ( sort keys %multi )
+    {
         ReportError ("Multiple builders for : $dname", @{$multi{$dname}} )
+    #
     #   Remove any dependencies to 'external' packages
     #   These will not be met internally and can be regarded as constant
+    #
+    #   Split 'depends' into internal (ideps) and external (edeps)
+    #       edeps : External Dependencies
+    #               Key:        Name;Version
+    #               Value:      'tag' - index into packages
+    #       ideps : Internal Dependencies
+    #               Key:        'tag'   - Index into packages
+    #               Value:      'dname' - Display Name
+    #
     foreach my $key ( keys %depends )
+    {
         foreach my $build ( keys( %{$depends{$key}{depends}} ))
+        {
             unless (exists $depends{$build})
+            {
-                push @{$extern_deps{$build} {$depends{$key}{depends}{$build}} }, $key;
-                $depends{$key}{entry}{'edeps'}{$depends{$key}{depends}{$build}} = 1;
+                $depends{$key}{'edeps'}{$depends{$key}{depends}{$build}} = $build;
                 delete ($depends{$key}{depends}{$build}) ;
                 Verbose2( "Not in set: $build");
+            }
             else
+            {
-                $depends{$key}{entry}{'ideps'}{$build} = $depends{$build}{entry}{dname};
+                $depends{$key}{'ideps'}{$build} = $depends{$build}{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.
+    #
+    my $scan_active = $opt_fromPackage ? 0 : 1;
+    my $scan_start = 0;
+    my $scan_stop = 0;
+    my %notFound;
+    my %found;
+    #   Elements in @opt_exactPackage may be comma seperated names
+    #   Split them out
+    if ( @opt_exactPackage )
+    {
+        foreach ( @opt_exactPackage )
+        {
+            $notFound{$_} = 1 foreach ( split(/\s*,\s*/,$_) );
+        }
+        @opt_exactPackage = keys %notFound;
+    }
+    if ( @opt_ignorePackage )
+    {
+        foreach ( @opt_ignorePackage )
+        {
+            $found{$_} = 1 foreach ( split(/\s*,\s*/,$_) );
+        }
+        @opt_ignorePackage = keys %found;
+    }
     while ( $more )
+    {
         $more = 0;
         $level++;
         my @build;
+        }
         foreach my $build ( @build )
+        {
             $more = 1;
-            my $fe = $depends{$build}{entry};
+            my $fe = $depends{$build};
+            my $scan_add = $scan_active ? 1 : 0;
+            if ( @opt_exactPackage )
+            {
+                $scan_add = 0;
+                foreach my $pname ( @opt_exactPackage )
+                {
+                    if ( (($fe->{mname} eq $pname) || ($fe->{name} eq $pname)))
+                    {
+                        $scan_add = 1;
+                        delete $notFound{$pname};
+                    }
+                }
+            }
+            if ( @opt_ignorePackage )
+            {
+                foreach my $pname ( @opt_ignorePackage )
+                {
+                    if ( (($fe->{mname} eq $pname) || ($fe->{name} eq $pname)))
+                    {
+                        $scan_add = 0;
+                        delete $found{$pname};
+                    }
+                }
+            }
+            if ( $opt_toPackage && (($fe->{mname} eq $opt_toPackage) || ($fe->{name} eq $opt_toPackage)))
+            {
+                $scan_add = 0;
+                $scan_active = 0;
+                $scan_stop = 1;
+            }
+            if ( $opt_fromPackage && (($fe->{mname} eq $opt_fromPackage) || ($fe->{name} eq $opt_fromPackage)))
+            {
+                $scan_add = 1;
+                $scan_active = 1;
+                $scan_start = 1;
+            }
             $fe->{level} = $level;
+            $fe->{buildActive} = $scan_add;
             $packages{$build} = $fe;
-            push @build_order, $fe;
+            push (@build_order, $fe) if ( $scan_add || $info );
             delete $depends{$build};
             delete $fe->{depends};                          # remove now its not needed
+        }
         foreach my $key ( keys %depends )
+            }
+        }
+    }
+    #
+    #   Detect bad user specifications
+    #
+    ReportError ("Specified FromPackage not found: $opt_fromPackage") if ( $opt_fromPackage && !$scan_start );
+    ReportError ("Specified ToPackage not found: $opt_toPackage") if ( $opt_toPackage && !$scan_stop );
+    ReportError ("Specified ExactPackages not found: ", keys( %notFound) ) if ( %notFound );
+    ReportError ("Specified IgnorePackages not found: ", keys( %found) ) if ( %found );
+    ErrorDoExit();
+    #
+    #   Calculate the external dependencies
+    #       Only process packages that are a part of the build
+    #
+    #   extern_deps structure
+    #       Hash key: 'tag'   - Index into packages
+    #          Value: Hash of:
+    #                 Key  : Name;Version
+    #                 Value: Array of: 'tags' (Index into packages)
+    #                                   of packages that use the external
+    #                                   component.
+    {
+        Verbose ("Calculate external dependencies");
+        %extern_deps = ();
+        foreach my $key ( keys %packages )
+        {
+                next unless ( $packages{$key}{buildActive} );
+                next unless ( $packages{$key}{'edeps'} );
+                foreach ( keys %{$packages{$key}{'edeps'}} )
+                {
+                    push @{$extern_deps{$packages{$key}{'edeps'}{$_}} {$_} }, $key;
+                }
+        }
+    }
+    #
     #   Just to be sure to be sure
+    #
     if ( keys %depends )
+    {
         #DebugDumpData ("depends", \%depends );
         Error( "Internal algorithm error: Bad dependancy walk",
                "Possible circular dependency");
+    }
+#   DebugDumpData("Packages", \%packages);
 #   DebugDumpData ("Order", \@build_order);
 #   DebugDumpData("External Depends", \%extern_deps );
+}
 #-------------------------------------------------------------------------------
 sub cmd
+{
     my ($hcmd, @cmds ) = @_;
     Getopt::Long::Configure('pass_through');
-    GetOptions (
+    getOptionsFromArray ( \@cmds,
                 "help:+"        => \$opt_help,
                 "manual:3"      => \$opt_help,
+                'topackage:s'   => \$opt_toPackage,
+                'frompackage:s' => \$opt_fromPackage,
+                'justpackage:s' => \@opt_exactPackage,
+                'ignorepackage:s' => \@opt_ignorePackage,
                 ) || Error ("Invalid command line" );
     SubCommandHelp( $opt_help, $hcmd) if ($opt_help  );
+    #
+    #
     #   Extract and options
+    #
     Getopt::Long::Configure('pass_through');
-    GetOptions (
+    getOptionsFromArray ( \@cmd_opts,
                 "help:+"        => \$opt_help,
                 "manual:3"      => \$opt_help,
+                'topackage:s'   => \$opt_toPackage,
+                'frompackage:s' => \$opt_fromPackage,
+                'justpackage:s' => \@opt_exactPackage,
+                'ignorepackage:s' => \@opt_ignorePackage,
                 ) || Error ("Invalid command line" );
     SubCommandHelp( $opt_help, "Command $cmd") if ($opt_help );
+    #
+    #
     #   Extract and options
+    #
     Getopt::Long::Configure('pass_through');
-    GetOptions (
+    getOptionsFromArray ( \@cmds,
                 "help:+"        => \$opt_help,
                 "manual:3"      => \$opt_help,
+                'topackage:s'   => \$opt_toPackage,
+                'frompackage:s' => \$opt_fromPackage,
+                'justpackage:s' => \@opt_exactPackage,
+                'ignorepackage:s' => \@opt_ignorePackage,
                 ) || Error ("Invalid command line" );
     SubCommandHelp( $opt_help, "Clean") if ($opt_help );
+    #
+#
 sub cache
+{
     my (@opts) = @_;
-    GetOptions (
+    getOptionsFromArray ( \@opts,
                 "help:+"        => \$opt_help,
                 "manual:3"      => \$opt_help,
+                'topackage:s'   => \$opt_toPackage,
+                'frompackage:s' => \$opt_fromPackage,
+                'justpackage:s' => \@opt_exactPackage,
+                'ignorepackage:s' => \@opt_ignorePackage,
                 ) || Error ("Invalid command line" );
     SubCommandHelp( $opt_help, "Cache") if ($opt_help || $#ARGV >= 0 );
+    #
+    #
     Message("Cache External Dependencies");
     calc_sandbox_info();
+    #
-    #   Walk the list of external despondencies and cache each one
+    #   Walk the list of external dependencies and cache each one
+    #
     foreach my $de ( sort keys %extern_deps )
+    {
         my @vlist = keys %{$extern_deps{$de}};
         foreach my $pve ( @vlist )
         Error("GetDepends:Prepare failure" );
+    }
+}
 #-------------------------------------------------------------------------------
+# Function        : getOptionsFromArray
+#
+# Description     : Like getOptions, but handles an array
+#                   Provided as the version of Perl used does not have one
+#
+# Inputs          : pArray                  - Ref to array
+#                   ....                    - GetOptions arguments
+#
+# Returns         :
+#
+sub getOptionsFromArray
+{
+    my ($pArray, %args) = @_;
+    local ( @ARGV );
+    @ARGV = @$pArray;
+    my $rv = GetOptions ( %args );
+    @$pArray = @ARGV;
+    return $rv;
+}
+#-------------------------------------------------------------------------------
 # Function        : SubCommandHelp
+#
 # Description     : Provide help on a subcommand
+#
 # Inputs          : $help_level             - Help Level 1,2,3
  Options:
     -help[=n]          - Display help with specified detail
     -help -help        - Detailed help message
     -man               - Full documentation
+ Common Options:
+    -fromPackage=name          - Start building from package
+    -toPackage=name            - Stop building after package
+    -justPackage=name[,name]   - Build named packages
+    -ignorePackage=name[,name] - Do not build named packages
  Commands:
     help                - Same as -help
     create              - Create a sandbox in the current directory
     populate            - Populate the sandbox with packages
     delete              - Delete the sandbox
 =item B<-man>
 Prints the manual page and exits. This is the same a -help=3
+=item B<-fromPackage=name>
+This option is available in all commands that process multiple packages.
+Package processing will start at the named package.
+The default operation is to process all packages.
+=item B<-toPackage=name>
+This option is available in all commands that process multiple packages.
+Package processing will stop at the named package.
+The default operation is to process all packages.
+=item B<-justPackge=name[,name]>
+This option is available in all commands that process multiple packages. The
+named packages will be processed in the correct build order. Packages that are not
+named will be skipped.
+Multiple packages can be named either by separating names with a comma, or
+with multiple options.
+=item B<-ignorePackge=name[,name]>
+This option is available in all commands that process multiple packages. The
+named packages will not be processed.
+Multiple packages can be named either by separating names with a comma, or
+with multiple options.
+The exclusion of a package takes precedence over its inclusion.
 =back
 =head1 DESCRIPTION
 This program is the primary tool for the maintenance of Development Sandboxes.

Subversion Repositories DevTools

(root)/core_devl/branches/dpurdie_devl/TOOLS/jats_sandbox.pl – Rev 391 → 1273