WebSVN – DevTools – Diff – /core_devl/trunk/TOOLS/LIB/jats_runtime.pm

 $VERSION = 1.00;
 @ISA = qw(Exporter);
 # Symbols to autoexport (:DEFAULT tag)
 @EXPORT = qw( rmlitter
+              rm_opr
               rm_rf
               rm_f
               mkpath
               printenv
               printargs
+              echo
             );
 use File::Path qw(rmtree);
+our %opts;
 #BEGIN
 #{
 #    print "-------jats_runtime initiated\n";
 #}
 #-------------------------------------------------------------------------------
+# Function        : process_options
+#
+# Description     : Extract options from the front of the command stream
+#                   Stops at the first argument that doesn't start with a
+#                   '--'
+#
+#                   Options of the form --Opt=Val are split out
+#                   Options of the form --Opt will set (or increment a value)
+#
+# Inputs          : None: Uses global ARGV
+#
+# Returns         : None: Resets global argv
+#                         Populates the %opts hash
+#
+sub process_options
+{
+    while ( my $entry = shift @ARGV )
+    {
+        last if ( $entry eq '--' );
+        if ( $entry =~  m/^--(.*)/  )
+        {
+            if ( $1 =~ m/(.*)=(.*)/ )
+            {
+                $opts{$1} = $2;
+            }
+            else
+            {
+                $opts{$1}++;
+            }
+        }
+        else
+        {
+            unshift @ARGV, $entry;
+            last;
+        }
+    }
+    #
+    #   Process some known options
+    #
+    $opts{'Progress'} = $opts{'Verbose'}    if ( $opts{'Verbose'} );
+    ErrorConfig( 'name', $opts{Name})       if ( $opts{'Name'} );
+    ErrorConfig( 'verbose', $opts{Verbose}) if ( $opts{'Verbose'} );
+    DebugDumpData("RunTime Opts", \%opts )  if ( $opts{'ShowOpts'} );;
+    Message ("RunTime args: @ARGV")         if ( $opts{'ShowArgs'} );
+    printenv()                              if ( $opts{'ShowEnv'} );
+    Message ($opts{'Message'})              if ( $opts{'Message'} );
+}
+#-------------------------------------------------------------------------------
 # Function        : rmlitter
+#
 # Description     : Remove litter from a build directory
+#
 # Inputs          : ARGV    A list of files (with wildcards) to delete in the
+#
 # Returns         : 0
+#
 sub rmlitter
+{
+    process_options();
     my @flist;
     my @dlist = '.';
+    #
     #   Parse arguments
             my $path = "$dir/$file";
             $path =~ s~ ~\\ ~g;
             my @del = glob ( $path );
             if ( @del )
+            {
+                Message ("rmlitter. @del") if ($opts{'Progress'} );
                 chmod '777', @del;
                 unlink @del;
+            }
+        }
+    }
+#
 # Returns         : Nothing
+#
 sub rm_rf
+{
+    process_options();
     expand_wildcards();
     my @dirs =  grep -e $_,@ARGV;
     if ( @dirs )
+    {
         rmtree(\@dirs,0,0);
 # Function        : rm_f
+#
 # Description     : Remove all named files
 #                   Will not remove directores - even if named
+#
+#                   Unix Note:
+#                   Need to handle broken soft links
+#
+#
 # Inputs          : @ARGV       - A list of files to delete
+#
 # Returns         :
+#
 sub rm_f {
+    process_options();
     expand_wildcards();
     foreach my $file (@ARGV) {
-        next unless -f $file;
+        Message ("Delete: $file") if ($opts{'Progress'} );
-        next if _unlink($file);
+        next if -d $file;
-        chmod(0777, $file);
+        next unless ( -e $file || -l $file );
         next if _unlink($file);
         Warning "Cannot delete $file: $!";
+    }
+}
 #-------------------------------------------------------------------------------
+# Function        : rm_opr
+#
+# Description     : Combo deletion operation
+#                   Parameter driven to delete many things in one command
+#
+# Inputs          : Options and paths
+#                   Options. Set mode for following paths
+#                       -f   remove named file
+#                       -d   remove named directory if empty
+#                       -rf  remove directory or file
+#                       -fd  remove file and directory if empty
+#
+# Returns         :
+#
+sub rm_opr
+{
+    my $mode = '-f';
+    process_options();
+    foreach my $file (@ARGV) {
+        if ( $file eq '-f' ) {
+            $mode = $file;
+        } elsif ( $file eq '-d' ) {
+            $mode =$file;
+        } elsif ( $file eq '-rf' ) {
+            $mode =$file;
+        } elsif ( $file eq '-fd' ) {
+            $mode =$file;
+        } elsif ( $file =~ m/^-/ ) {
+            Error ("rm_opr - unknown option: $file");
+        } else {
+            #
+            #   Not an option must be a file/dir to delete
+            #
+            if ( $mode eq '-f' ) {
+                Message ("Delete File: $file") if ($opts{'Progress'} );
+                _unlink($file);
+            } elsif ( $mode eq '-d' ) {
+                Message ("Delete Empty Dir: $file") if ($opts{'Progress'} );
+                rmdir $file;
+            } elsif ( $mode eq '-rf' ) {
+                Message ("Delete Dir: $file") if ($opts{'Progress'} );
+                rmtree($file,0,0);
+            } elsif ( $mode eq '-fd' ) {
+                Message ("Delete File: $file") if ($opts{'Progress'} );
+                _unlink($file);
+                my $dir = $file;
+                $dir =~ tr~\\/~/~s;
+                Message ("Remove Empty Dir: $dir") if ($opts{'Progress'} );
+                if ( $dir =~ s~/[^/]+$~~ )
+                {
+                    rmdir $dir;
+                }
+            }
+        }
+    }
+}
+#-------------------------------------------------------------------------------
 # Function        : mkpath
+#
 # Description     : Create a directory tree
 #                   This will create all the parent directories in the path
+#
+#
 # Returns         :
+#
 sub mkpath
+{
+    process_options();
     expand_wildcards();
     File::Path::mkpath([@ARGV],0,0777);
+}
 #-------------------------------------------------------------------------------
 # Function        : _unlink
+#
 # Description     : Helper function
 #                   Unlink a list of files
+#
-# Inputs          : A list of files to delete
+# Inputs          : A file to delete
+#
-# Returns         : The number of files that have been deleted
+# Returns         : False: File still exists
+#
 sub _unlink {
-    my $files_unlinked = 0;
+    my ($file) = @_;
-    foreach my $file (@_)
+    if ( ! unlink $file  )
+    {
-        my $delete_count = 0;
+        chmod(0777, $file);
-        $delete_count++ while unlink $file;
+        return unlink $file;
-        $files_unlinked++ if $delete_count;
+    }
-    return $files_unlinked;
+    return 1;
+}
 #-------------------------------------------------------------------------------
 # Function        : printenv
+#
+#
 sub printenv
+{
     foreach my $entry ( sort keys %ENV )
+    {
-        print "------------------- $entry=$ENV{$entry}\n";
+        print "    $entry=$ENV{$entry}\n";
+    }
+}
 #-------------------------------------------------------------------------------
 # Function        : printargs
+#
 # Inputs          : User arguments
+#
 # Returns         : Nothing
+#
-my $PSPLIT=':';
 sub printargs
+{
+    Message "Arguments", @ARGV;
+}
+#-------------------------------------------------------------------------------
+# Function        : echo
+#
+# Description     : echo my argumements
+#
+# Inputs          : User arguments
+#
+# Returns         : Nothing
+#
+sub echo
+{
+    process_options();
+    Message @ARGV;
+}
+#-------------------------------------------------------------------------------
+# Function        : printArgsEnv
+#
+# Description     : Print my argumements nd environmen
+#
+# Inputs          : User arguments
+#
+# Returns         : Nothing
+#
+my $PSPLIT=':';
+sub printArgsEnv
+{
     Message "printargs....";
     Message "Program arguments", @ARGV;
     $PSPLIT = ';' if ( $ENV{GBE_MACHTYPE} eq 'win32' );

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/LIB/jats_runtime.pm – Rev 255 → 321