Upgrade patch dusage.pl 1.7 to 1.8

[Johan Vromans]

This patch upgrades dusage.pl 1.7 [comp.sources.misc v10i065] to
version 1.8.

Changes are:

 * Corrected bug in retain handling. Empty entries were always retained.

 * Use getopts from perl library. The routine supplied with Perl
   3.0 patchlevel 12 is ok to use.
   Existing users at a lower patchlevel should retain the getopts code
   from the previous version of dusage.pl.

Diffs from 1.7 to 1.8.

*** dusage.pl	Mon Mar  5 18:05:07 1990
--- new/dusage.pl	Mon Mar  5 18:05:09 1990
***************
*** 1,7
  #!/usr/bin/perl
! 
! # This program requires perl version 3.0, patchlevel 4 or higher.
! 
  # Copyright 1990 Johan Vromans, all rights reserved.
  # Peaceware. This program may be used, modified and distributed as long as
  # this copyright notice remains part of the source. It may not be sold, or 

--- 1,9 -----
  #!/usr/bin/perl
! #
! #	@(#)dusage	1.8
! #
! # This program requires perl version 3.0, patchlevel 12 or higher.
! #
  # Copyright 1990 Johan Vromans, all rights reserved.
  # This program may be used, modified and distributed as long as
  # this copyright notice remains part of the source. It may not be sold, or 
***************
*** 3,9
  # This program requires perl version 3.0, patchlevel 4 or higher.
  
  # Copyright 1990 Johan Vromans, all rights reserved.
! # Peaceware. This program may be used, modified and distributed as long as
  # this copyright notice remains part of the source. It may not be sold, or 
  # be used to harm any living creature including the world and the universe.
  

--- 5,11 -----
  # This program requires perl version 3.0, patchlevel 12 or higher.
  #
  # Copyright 1990 Johan Vromans, all rights reserved.
! # This program may be used, modified and distributed as long as
  # this copyright notice remains part of the source. It may not be sold, or 
  # be used to harm any living creature including the world and the universe.
  
***************
*** 57,63
  
    # Command line options. We use a modified version of getopts.pl.
  
!   &usage (0) if &Getopts ("Dafghi:p:ru");
    &usage (1) if $opt_h;
    &usage (0) if $#ARGV > 0;
  

--- 59,68 -----
  
    # Command line options. We use a modified version of getopts.pl.
  
!   do "getopts.pl" || die "Cannot load getopts.pl, stopped";
!   die $@ if $@;
! 
!   &usage (0) if !&Getopts ("Dafghi:p:ru");
    &usage (1) if $opt_h;
    &usage (0) if $#ARGV > 0;
  
***************
*** 80,86
    $table    = ($#ARGV == 0) ? shift (@ARGV) : "$prefix.du.ctl";
    $runtype = $allfiles ? "file" : "directory";
    if ($debug) {
!     print STDERR "@(#)@ dusage	1.7 - dusage.pl\n";
      print STDERR "Options:";
      print STDERR " debug" if $debug;	# silly, isn't it...
      print STDERR $noupdate ? " no" : " ", "update";

--- 85,91 -----
    $table    = ($#ARGV == 0) ? shift (@ARGV) : "$prefix.du.ctl";
    $runtype = $allfiles ? "file" : "directory";
    if ($debug) {
!     print STDERR "@(#)@ dusage	1.8 - dusage.pl\n";
      print STDERR "Options:";
      print STDERR " debug" if $debug;	# silly, isn't it...
      print STDERR $noupdate ? " no" : " ", "update";
***************
*** 298,304
      unshift (@a, $newblocks{$name}) if $gather;
      $name = "." if $name eq $root;
      $name = $' if $name =~ /^$prefix/;		#';
!     if ($#a < 0) {	# no data?
        if ($retain) {
  	@a = ("","","","","","","","");
        }

--- 303,314 -----
      unshift (@a, $newblocks{$name}) if $gather;
      $name = "." if $name eq $root;
      $name = $' if $name =~ /^$prefix/;		#';
!     print STDERR "Warning: ", 1+$#a, " entries for $name\n"
!       if ($debug && $#a != 8);
! 
!     # check for valid data
!     $try = join(":", at a[0..7]);
!     if ( $try eq ":::::::") {
        if ($retain) {
  	@a = ("","","","","","","","");
        }
***************
*** 308,316
  	next;
        }
      }
!     print STDERR "Warning: ", 1+$#a, " entries for $name\n"
!       if ($debug && $#a != 8);
!     $line = "$name\t" . join(":", at a[0..7]) . "\n";
      print tb $line unless $noupdate;
      print STDERR "tb: $line" if $debug;
  

--- 318,325 -----
  	next;
        }
      }
! 
!     $line = "$name\t$try\n";
      print tb $line unless $noupdate;
      print STDERR "tb: $line" if $debug;
  
***************
*** 333,379
  
    # Close control file, if opened
    close (tb) unless $noupdate;
- }
- 
- # Modified version of getopts ...
- 
- sub Getopts {
-     local($argumentative) = @_;
-     local(@args,$_,$first,$rest);
-     local($opterr) = 0;
- 
-     @args = split( / */, $argumentative );
-     while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
- 	($first,$rest) = ($1,$2);
- 	$pos = index($argumentative,$first);
- 	if($pos >= $[) {
- 	    if($args[$pos+1] eq ':') {
- 		shift(@ARGV);
- 		if($rest eq '') {
- 		    $rest = shift(@ARGV);
- 		}
- 		eval "\$opt_$first = \$rest;";
- 	    }
- 	    else {
- 		eval "\$opt_$first = 1";
- 		if($rest eq '') {
- 		    shift(@ARGV);
- 		}
- 		else {
- 		    $ARGV[0] = "-$rest";
- 		}
- 	    }
- 	}
- 	else {
- 	    print stderr "Unknown option: $first\n";
- 	    $opterr++;
- 	    if($rest ne '') {
- 		$ARGV[0] = "-$rest";
- 	    }
- 	    else {
- 		shift(@ARGV);
- 	    }
- 	}
-     }
-     return $opterr;
  }

--- 342,345 -----
  
    # Close control file, if opened
    close (tb) unless $noupdate;
  }


End of diffs.

Johan Vromans				       jv at mh.nl via internet backbones
Multihouse Automatisering bv		       uucp: ..!{uunet,hp4nl}!mh.nl!jv
Doesburgweg 7, 2803 PL Gouda, The Netherlands  phone/fax: +31 1820 62944/62500
------------------------ "Arms are made for hugging" -------------------------