jv@squirrel.mh.nl (Johan Vromans) (03/06/90)
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(":",@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(":",@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@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" -------------------------