[MacPerl] Y2K Auditing

[Chris Nandor <pudge@pobox.com>]

I wrote this to scan my hard drive and report all the programs I have installed,
so some guy somewhere can tell whether or not I am Y2K-compliant.  You can
adjust it to suit your needs; I had it find all sorts of apps, inits, cdevs,
etc., plus Perl modules/scripts.  Have fun.

Beware: give MacPerl lots of memory (20MB is good) and don't touch it until it is done.  It crashed on me a couple of times.  Save your work first.  And also note that I got over 6,000 "programs" on my way through my hard drive.

#!perl -wl
use strict;
use File::Find;
use File::Basename;
use DB_File;
use Mac::Memory;
use Mac::Resources;
use MacPerl qw(GetFileInfo Volumes MakePath);
use vars qw($l_file $l_vers $old_feed $c $leave);

open(STDERR, '>Dev:Console:Errors') or die $!;
open(LOG, '>y2klog') or die $!;
#unlink('y2kdb');
tie(my(%db), 'DB_File', 'y2kdb', O_RDWR|O_CREAT, 0755, $DB_BTREE) or die $!;

foreach my $vol (Volumes) { find(\&wanted, MakePath($vol)) }
#find(\&wanted, MakePath('PowerPudgeV:'));
report();

sub report {
  my($ct) = scalar keys %db;
  print "Total files: $ct\n";
  foreach my $file (keys %db) { # {basename($a) cmp basename($b)} ?
    local($l_file, $l_vers) = ($file, $db{$file} || '????');
    write(LOG);
  }
}

sub wanted {
  my($file, $dir) = ($File::Find::name, $File::Find::dir);

  lstat($file);  # get data about file

  # print directory names to STDOUT
  if (-d _) {
    my($sp_num) = ' ' x $#{[split(':', $file)]};
    print "$sp_num$_";
  }

  # don't want to do aliases or directories, or files in $leave
  return if (/$leave/ || -l _ || -d _);

  my $type = (GetFileInfo($file))[1];
  my($name, $path, $suf) = fileparse($file, "\\..{1,4}");
  my($vers, $ckd);

  if (($suf && $suf =~ /\.(?:pm|pl|t|ph|plx)$/)
  	   || ($type && $type =~ /^(?:McPL)$/)) {
    local(*F, $/), my($f);
    open(F, "<$file") or die $!;
    $f = <F>;
    $f =~ /(?:\$VERSION\s*=\s*)+([^;]+)/s if $f; #;;
    $vers = eval($1) if $1;
  }

  # if application
  elsif ($type && $type =~ /^(?:APPL                # application
                               |cdev                # control panel
                               |PRER|RDEV           # chooser, printers
                               |cbnd|tbnd|fbnd      # comm tools
                               |shlb|libr           # libraries
                               |SITL|appe|thng|INIT # extensions
                               |adev|ndrv|mdev
                               )$/x) {

    # resource code stolen from "Brian L. Matthews" <blm@halcyon.com>
    my($rfd, $res, $data, @vers);
    $rfd = OpenResFile($file) or warn("Can't get RF of $file: $^E\n");

    if ($rfd) {
      # get version
      $res = Get1Resource('vers', 1);
      if ($res) {
        $data = $res->get();
        ReleaseResource($res);
      }
      CloseResFile($rfd);

      if ($data) {  # unpack version
        @vers = unpack('CCCCnC', $data);
        @vers[5,6] = unpack("x7 A$vers[5] x A*", $data);
        $vers = $vers[5];
      }
    }
  }
  
  else { return }  # don't count this one

  $db{$file} = $vers || '';
#  report(), exit if ++$c == 20;
}

BEGIN {
  my($top, $main, @leave);

  @leave = (
  );  # skip things beginning with strings in here

  $leave = '^(?:' . join('|', map {quotemeta($_)} @leave) . ')';

  $old_feed = $^L;
  $^L = "\n";
  $top = <<'EOT';
File                                                                                                                                        Version
----------------------------------------------------------------------------------------------------------------------  ---------------------------
.
EOT
  $main = <<'EOT';
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<  @>>>>>>>>>>>>>>>>>>>>>>>>>>
$l_file, $l_vers
.
EOT
  for (qw(STDOUT LOG)) {
    eval("format ${_}_TOP =\n$top\nformat $_ =\n$main\n");
  }
}

END {
  $^L = $old_feed;
}


-- 
Chris Nandor          mailto:pudge@pobox.com         http://pudge.net/
%PGPKey = ('B76E72AD', [1024, '0824090B CE73CA10  1FF77F13 8180B6B6'])

***** Want to unsubscribe from this list?
***** Send mail with body "unsubscribe" to mac-perl-request@iis.ee.ethz.ch