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

 use Pod::Usage;                             # required for help support
 use Getopt::Long qw(:config require_order); # Stop on non-option
 use Digest;
 my $VERSION = "1.0.0";                      # Update this
+my $SCANDEPTH = 3;                          # Almost a constant
+#
 #   Options
+#
 my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
 my $GBE_DPKG_REPLICA    = $ENV{'GBE_DPKG_REPLICA'};
+#
 #   Globals
+#
-my @stopped = ();                         # Stopped entries
+my @stopped = ();                               # Stopped entries
-my @build_order = ();                     # Build Ordered list of entries
+my @build_order = ();                           # Build Ordered list of entries
-my %extern_deps;                          # Hash of external dependencies
+my %extern_deps;                                # Hash of external dependencies
-my %packages;                             # Hash of packages
+my %packages;                                   # Hash of packages
-my $currentPkgTag;                        # Tag of the current package - if any
+my $currentPkgTag;                              # Tag of the current package - if any
+my $scanDepth;                                  # Depth for build file scan
+#
+#   Known files
+#
+my $cacheFile  = $GBE_DPKG_SBOX . '/location_cache';
+my $depthFile  = $GBE_DPKG_SBOX . '/scanDepth';
+my $filterFile = $GBE_SANDBOX   . '/buildfilter';
 #-------------------------------------------------------------------------------
 # Function        : Mainline Entry Point
+#
 # Description     :
 buildfilter(@ARGV)                      if ( $cmd =~ m/^buildfilter$/  );
 skipBuild(0, @ARGV)                     if ( $cmd =~ m/^skip$/  );
 skipBuild(1, @ARGV)                     if ( $cmd =~ m/^unskip$/  );
 fingerPrintPkg(@ARGV)                   if ( $cmd =~ m/^finger/i );
 testLinks(@ARGV)                        if ( $cmd =~ m/^testlinks/i );
+setScanDepth(@ARGV)                     if ( $cmd =~ m/^scandepth/i );
 Error ("Unknown sandbox command: $cmd");
 exit 1;
+{
     my (@cmd_opts ) = @_;
     my $show = 0;
     my $showUsage = 0;
     my $showFingerPrint = 0;
+    my $showDependencies = 1;
+    my $showOrder = 1;
     Getopt::Long::Configure('pass_through');
     getOptionsFromArray ( \@cmd_opts,
-                          'verbose:+'   => \$show,
+                          'verbose:+'       => \$show,
-                          'usedby'      => \$showUsage,
+                          'usedby'          => \$showUsage,
-                          'fingerprint' => \$showFingerPrint,
+                          'fingerprint!'    => \$showFingerPrint,
+                          'dependencies!'   => \$showDependencies,
+                          'buildorder!'     => \$showOrder,
                         ) || Error ("Invalid command line" );
     SubCommandHelp( $opt_help, "Sandbox Information") if ($opt_help || $#cmd_opts >=0 );
     $showUsage = 1 if ($show >= 2);
+    #
     #   Display information
+    #
     Message ("Scope      : " . ($opt_allSandbox ? 'Entire Sandbox' : $packages{$currentPkgTag}{dname} ));
     Message ("Base       : $GBE_SANDBOX");
     Message ("Archive    : $GBE_DPKG_SBOX");
-    Message ("BuildFilter: $GBE_BUILDFILTER" . ( (-f $GBE_SANDBOX . '/buildfilter')  ? ' - Local to sandbox' : ''));
+    Message ("BuildFilter: $GBE_BUILDFILTER" . ( (-f $filterFile)  ? ' - Local to sandbox' : ''));
-    Message ("Build Order");
+    if ($showOrder)
-    foreach my $pname ( @stopped )
-    {
-        Message( "    Level:" . "-"  . " [---] Name: " . $pname . ' (Stopped)');
-    }
-    foreach my $fe ( @build_order )
+    {
-        displayHeader($fe, { indent => '    ', testFingerPrint =>  $showFingerPrint, showIcons => 1});
+        Message ("Build Order");
-        if ( $show )
+        foreach my $pname ( @stopped )
+        {
-            Message( DisplayPath ("        Path: $fe->{dir}" ));
+            Message( "    Level:" . "--"  . " [---] Name: " . $pname . ' (Stopped)');
-            foreach my $idep ( sort values %{$fe->{'ideps'}} )
-            {
+        }
-                Message ("        I:$idep");
+        foreach my $fe ( @build_order )
-            }
+        {
+            displayHeader($fe, { indent => '    ', testFingerPrint =>  $showFingerPrint, showIcons => 1});
-            foreach my $edep ( sort keys %{$fe->{'edeps'}} )
+            if ( $show )
+            {
+                Message( DisplayPath ("        Path: $fe->{dir}" ));
+                foreach my $idep ( sort values %{$fe->{'ideps'}} )
+                {
+                    Message ("        I:$idep");
+                }
+                foreach my $edep ( sort keys %{$fe->{'edeps'}} )
+                {
-                my ($ppn,$ppv) = split( $; , $edep);
+                    my ($ppn,$ppv) = split( $; , $edep);
-                Message ("        E:$ppn $ppv");
+                    Message ("        E:$ppn $ppv");
+                }
+            }
-        }
-        if ($showUsage && exists($fe->{'usedBy'}))
+            if ($showUsage && exists($fe->{'usedBy'}))
-        {
-            foreach my $edep ( sort {uc($a) cmp uc($b)} @{$fe->{'usedBy'}} )
+            {
+                foreach my $edep ( sort {uc($a) cmp uc($b)} @{$fe->{'usedBy'}} )
+                {
-                Message ("        U:$packages{$edep}{dname}");
+                    Message ("        U:$packages{$edep}{dname}");
+                }
+            }
+        }
+    }
+    #
     #   External dependencies flags
     #       * - Package does not exist in dpkg_archive
     #       + - Multiple versions of this package are used
-    Message("External Dependencies");
+    if ($showDependencies)
-    foreach my $de ( sort {uc($a) cmp uc($b)} keys %extern_deps )
+    {
-        my @vlist = keys %{$extern_deps{$de}};
+        Message("External Dependencies");
-        my $flag = $#vlist ? '+' : '';
-        foreach my $pve ( sort {uc($a) cmp uc($b)} @vlist )
+        foreach my $de ( sort {uc($a) cmp uc($b)} keys %extern_deps )
+        {
-            my ($pn,$pv) = split( $; , $pve );
+            my @vlist = keys %{$extern_deps{$de}};
-            my $exists = check_package_existance($pn,$pv  ) ? '' : '*';
+            my $flag = $#vlist ? '+' : '';
-            my $flags = sprintf ("%4.4s", $flag . $exists);
+            foreach my $pve ( sort {uc($a) cmp uc($b)} @vlist )
-            Message ("${flags}${pn} ${pv}");
-            if ( $show || $showUsage )
+            {
+                my ($pn,$pv) = split( $; , $pve );
-                foreach my $pkg ( sort {uc($a) cmp uc($b)} @{$extern_deps{$de}{$pve}} )
+                my $exists = check_package_existance($pn,$pv  ) ? '' : '*';
+                my $flags = sprintf ("%4.4s", $flag . $exists);
+                Message ("${flags}${pn} ${pv}");
+                if ( $show || $showUsage )
+                {
+                    foreach my $pkg ( sort {uc($a) cmp uc($b)} @{$extern_deps{$de}{$pve}} )
+                    {
-                    my $ppn = join ('.', split( $; , $pkg));
+                        my $ppn = join ('.', split( $; , $pkg));
-                    Message ("        U:$ppn");
+                        Message ("        U:$ppn");
+                    }
+                }
-            }
+            }
+        }
+    }
     if ( $show > 2 || $opt_verbose > 2 )
+    {
 # Description     : Test the lnk files in the sandbox directory
 #                   These may be stake after packages are deleted
+#
 # Inputs          :
+#
-# Returns         :
+# Returns         : This function will not return
+#
 sub testLinks
+{
     my ( @cmd_opts ) = @_;
     my $opt_delete;
                 "help:+"        => \$opt_help,
                 "manual:3"      => \$opt_help,
                 'delete!'       => \$opt_delete,
                 ) || Error ("Invalid command line" );
-    SubCommandHelp( $opt_help, "Sandbox Test Links") if ($opt_help || $#ARGV >= 0 );
+    SubCommandHelp( $opt_help, "Sandbox Test Links") if ($opt_help || ($#ARGV >= 0) );
     Error ("Command must be executed from within a Sandbox") unless ( $GBE_SANDBOX );
+    #
     #   Process all packages in the sandbox
+    #
+    }
     exit (0);
+}
+#-------------------------------------------------------------------------------
+# Function        : setScanDepth
+#
+# Description     : Set the depth of the build file scan usd in this sandbox
+#
+# Inputs          : Command line arguments
+#
+# Returns         : This function will not return
+#
+sub setScanDepth
+{
+    my ( @cmd_opts ) = @_;
+    GetOptions (
+                "help:+"        => \$opt_help,
+                "manual:3"      => \$opt_help,
+                ) || Error ("Invalid command line" );
+    SubCommandHelp( $opt_help, "Sandbox Scan Depth") if ($opt_help || ($#ARGV > 0 ));
+    Error ("Command must be executed from within a Sandbox") unless ( $GBE_SANDBOX );
+    if (defined $ARGV[0])
+    {
+        FileCreate($depthFile, $ARGV[0]);
+        #
+        #   Force a rescan of the cached information
+        #
+        unlink $cacheFile;
+        exit 0;
+    }
+    #
+    #   Report the current scan depth
+    #
+    getScanDepth();
+    Information ("Build File scan depth: ". $scanDepth);
+    exit (0);
+}
+#-------------------------------------------------------------------------------
+# Function        : getScanDepth
+#
+# Description     : Determine the build file scan depth for the current sandbox
+#                   Non-default data is maintained in a data file
+#
+# Inputs          : None
+#
+# Returns         : Nothing
+#
+sub getScanDepth
+{
+    my $depth = $SCANDEPTH;
+    if ( -f $depthFile)
+    {
+        $depth = TagFileRead($depthFile);
+        my $invalid = 0;
+        if ($depth !~ m~^\d+$~) {
+            $invalid = 1;
+        } elsif ( $depth lt 0) {
+            $invalid = 1;
+        }
+        if ($invalid)
+        {
+            unlink $depthFile;
+            Warning ("Invalid scandepth file. File deleted.");
+            $depth = $SCANDEPTH;
+        }
+    }
+    $scanDepth = $depth;
+}
 #-------------------------------------------------------------------------------
 # Function        : check_package_existance
+#
 # Description     : Determine if a given package-version exists
 #                       @build_order - build ordered array of build entries
+#
 sub calc_sandbox_info
+{
     my ($quiet) = @_;
-    my $cacheFile = $GBE_DPKG_SBOX . '/location_cache';
+    my $buildFileDepth = 0;
+    getScanDepth();
+    #
     #   Start from the root of the sandbox
+    #
     Error ("Command must be executed from within a Sandbox") unless ( $GBE_SANDBOX );
     my $startDir = Getcwd();
         if ($rootFingerPrint eq $currentRootFingerPrint )
+        {
             while (<$lf>)
+            {
+                s~\s+$~~;
                 my @locationEntry = split($;, $_);
                 my $pname = $locationEntry[0];
+                if ($locationEntry[1] eq ':STOP:') {
+                    push @stopped, $pname;
+                    Verbose("Package contains stop file: $pname");
+                    next;
+                }
+                #
                 #   Locate the build files in each package
                 #   Scan the build files and extract dependancy information
+                #
                 my $bscanner = BuildFileScanner( $pname, 'build.pl',
                                                          '--LocateAll',
-                                                         '--LimitDepth=4',
+                                                         '--LimitDepth=' . $scanDepth,
                                                          '--ScanDependencies' );
                 unless ($bscanner->setLocation($_)) {
                     Verbose("Build file missing: Force full scan");
                     @build_list = ();
                     last;
             if ( -f "$pname/stop" || -f "$pname/stop.$GBE_MACHTYPE" )
+            {
                 push @stopped, $pname;
                 Warning("Package contains stop file: $pname");
+                push @locationData, join($;, $pname, ':STOP:');
                 next;
+            }
+            #
             #   Locate the build files in each package
             #   Scan the build files and extract dependancy information
+            #
             my $bscanner = BuildFileScanner( $pname, 'build.pl',
                                                      '--LocateAll',
-                                                     '--LimitDepth=4',
+                                                     '--LimitDepth=' . $scanDepth,
                                                      '--ScanDependencies' );
             $bscanner->scan();
             my @blist = $bscanner->getInfo();
             unless ($quiet) {
                 Warning ("Package does not have build files: $pname") unless ( @blist );
                 Warning ("Package has multiple build files: $pname") if ( $#blist > 0 );
+            }
             push @build_list, @blist;
             push @locationData, $bscanner->getLocation();
+            #
+            #   Determine max build file depth - just to show user
+            #
+            foreach ( @blist)
+            {
+                my $count = () = $_->{dir} =~ m~/~g;
+                $buildFileDepth = $count if ($count > $buildFileDepth)
+            }
+        }
+        Message ("Max Build File Depth : " . ($buildFileDepth + 1));
+        Message ("Build File Scan Depth: ". $scanDepth) if ($SCANDEPTH ne $scanDepth);
+        #
         #   Save (cache) location information
+        #
         FileAppend($cacheFile, @locationData);
+    #
     #   Write out a new file
+    #
     if ($modified)
+    {
-        FileCreate($GBE_DPKG_SBOX . '/buildfilter', @filter_list);
+        FileCreate($filterFile, @filter_list);
+    }
+    #
     # This command does not return
+    #
     my $indent = $args->{indent} || '';
     my $showPath = $args->{showPath};
     my ($status, $estatus) = addBuildInfo($fe, $args);
-    my $msg1 = $indent . 'Level:' . $fe->{level} . " [$status]" . ' Name: ' . $fe->{dname} . $estatus;
+    my $msg1 = $indent . sprintf('Level:%02d [%s] Name: %s', $fe->{level}, $status, $fe->{dname} . $estatus );
     if ( $showPath) {
         my $msg1Len = length($msg1);
         if ($msg1Len < 80) {
             $msg1 .= ' ' . '=' x (79 - $msg1Len);
+        }
     info [[-v]-v]       - Sandbox information. -v: Be more verbose
     buildfilter         - Modify and display sandbox buildfilter
     [un]skip            - Mark a package to be skipped during the build
     fingerprint         - Various fingerprint operations
     testlinks           - Test / Delete broken package symlinks
+    scandepth           - Set/Display the build file scan depth
     cmd                 - Do commands in all sandbox components
     all                 - Do 'build', if required, then a make in all 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
     -justPackage=name[,name]   - Build named packages
     -ignorePackage=name[,name] - Do not build named packages
     -entireSandbox             - Process the entire sandbox
     -users                     - Process package users, not dependencies
     -fingerprint               - Display fingerprint information
+    -[no]dependencies          - Display external dependencies (default)
+    -[no]buildorder            - Display build order (default)
 =head2 OPTIONS
 =over
 This option will cause the information display to include that status of each packages fingerprint.
 This will slow down the display as the calculation can be time consuming.
+=item B<-[no]dependencies>
+This option will cause the information display to include all the external dependencies.
+=item B<-[no]buildorder>
+This option will cause the information display to include all the build order.
 =back
 =head2 DESCRIPTION
 The 'info' command will display information about the build order and the
 =head2 DESCRIPTION
 The 'testlinks' command, will by default, examine symbolic links within the sandbox and report on
 broken links.
-An option allwos the broken links to be deleted.
+An option allows the broken links to be deleted.
 Each package in the sandbox will have a symbolic link to the packages 'package' area. If a package is removed
 from the sandbox the link file may be left in the sandbox and cause a 'build' to fail.
 =head2 EXAMPLES
     jats sandbox testlinks
 will test the symbolic links in the sandbox metadata.
+=head1 Sandbox Scan Depth
+=head2 NAME
+Set and Display the build file scanner depth
+=head2 SYNOPSIS
+jats sandbox scandepth [options] [depth]
+ Command Options
+    -help[=n]               - Command specific help, [n=1,2,3]
+    -man                    - Same as -help=3
+=head2 ARGUMENTS
+This command takes one optional argument. A positive number that control the
+depth of the build filter scanner.
+The default value is '3'. Deeper scans may be required for sandboxes containing badly formed
+packages. The tradoff is speed for all sandbox operations.
+Setting the scan depth will force a rescan of the sandbox build files on the next command that
+requires the information.
+=head2 OPTIONS
+The scandepth command only accepts the standard help and man options.
+=head2 DESCRIPTION
+The scandepth command, will by default, display the current value for the build file scanner.
+If a numeric argument is provided this will set the future build file scan depth.
+=head2 EXAMPLES
+The command
+    jats sandbox scandepth 5
+will set future build file scan to a maximum of 5 directories below the root of the sandbox.
 =cut

Subversion Repositories DevTools

(root)/core_devl/branches/gitBuilder/TOOLS/jats_sandbox.pl – Rev 7304 → 7306