#!/bin/sh
#! -*- perl -*-
eval 'exec perl -x -w $0 ${1+"$@"}'
  if 0;

# PCA - Patch Check Advanced
#       Analyze, download and install patches for Sun Solaris
#
# Author : Martin Paul <martin@par.univie.ac.at>
# Home   : http://www.par.univie.ac.at/solaris/pca/
my $version='5.7 (2007/08/30)';

use strict;

# Default paths
my $unzip= '/usr/bin/unzip';
my $showrev= '/usr/bin/showrev';
my $pkginfo= '/usr/bin/pkginfo';
my $pkgchk= '/usr/sbin/pkgchk';
my $uncompress= '/usr/bin/uncompress';
my $tar= '/usr/sbin/tar';
my $uname= '/usr/bin/uname';
my $pager= '/usr/bin/more';
my $file= '/usr/bin/file';

# Supported options, format is:
#   Long name, short name, argument type, argument text, default value, help
my @options=(
  "list|l|||0|List patches",
  "listhtml|L|||0|List patches, produce HTML output",
  "download|d|||0|Download patches",
  "install|i|||0|Install patches",
  "pretend|I|||0|Pretend to install patches",
  "readme|r|||0|Display patch READMEs",
  "getxref|x|||0|Download patch xref file",
  "xrefdir|X|s|DIR|/var/tmp|Location of patch xref file",
  "nocheckxref|y|||0|Do not check for updated patch xref file",
  "xrefown||||0|Give write permissions on xref file to user only",
  "nocache||||0|Tell proxy to not cache xref file",
  "patchdir|P|s|DIR|.|Patch download directory",
  "askauth|a|||0|Ask for Sun Online Account data interactively",
  "user||s|USER||Sun Online Account user name",
  "passwd||s|PASS||Sun Online Account password",
  "localurl||s|URL||DEPRECATED",
  "patchurl||s|URL||Local URL for patches and READMEs",
  "xrefurl||s|URL||Local URL for patchdiag.xref",
  "ignore||s@|ID||Ignore patch ID",
  "rec||s@|ID||Set Recommended flag on patch ID",
  "sec||s@|ID||Set Security flag on patch ID",
  "pattern|p|s|REGEX||List only patches whose synopsis matches REGEX",
  "noreboot|n|||0|Install only patches which do not require a reboot",
  "minage||i|DAYS|0|List only patches which are at least DAYS old",
  "syslog||s|TYPE||Log successful patch installs to syslog facility TYPE",
  "nobackup|k|||0|Make patchadd not back up files to be patched",
  "backdir|B|s|DIR||Saves patch backout data to DIR",
  "safe|s|||0|Check locally modified files for safe patch installation",
  "currentzone|G|||0|Make patchadd install patches in the current zone only",
  "patchadd||s|FILE|/usr/sbin/patchadd|Path to patchadd command",
  "noheader|H|||0|Don't display descriptive headers",
  "format||s|FORMAT|%p %i %e %c %r%s%b %a %y|Set output format to FORMAT",
  "fromfiles|f|s|DIR||Read uname/showrev/pkginfo output from files in DIR",
  "dltries||i|NUM|1|Try downloads from Sun download server NUM times",
  "force|F|||0|Force local caching proxy to download from Sun server",
  "root|R|s|DIR||Alternative root directory",
  "wget||s|FILE|/usr/sfw/bin/wget /usr/local/bin/wget /opt/csw/bin/wget /usr/bin/wget|Path to wget command",
  "wgetproxy||s|URL||Default proxy for wget",
  "logger||s|FILE|/usr/bin/logger|Path to logger command",
  "debug|V|||0|Print debug information",
  "help|h|||0|Display this help",
  "version|v|||0|Display version information",
  "operands||||missing|ENVFILE",
  "wgetq||||-q|INTERNAL",
  "patchadd_options|||||INTERNAL",
  "tmpdir||||/tmp|INTERNAL",
  "proxy||||0|INTERNAL",
  "pforce||||0|INTERNAL"
);

# Modules
use Getopt::Long;
use Time::Local;
use Cwd;
use File::Path;
use Fcntl;
use File::Basename;
use File::Copy;

# Variable declarations
my (%o, %input, %p, %pkgs, %u, %c, %locks);
my (@plist, @slist, @rlist);
my $xrefdl='';
my $sttyset=0;
my $patchxdir='';
my $currenttime=time();

# Force flush to stdout right after every print command without "\n"
$|= 1;

# Set signal handler
$SIG{HUP} = 'IGNORE';
$SIG{TERM} = $SIG{INT} = $SIG{QUIT} = \&handler;

# Main
#
parse_args();
check_prerequisites();

$o{proxy} && proxy();

expand_operands();

if ($o{readme} && ("@slist" =~ /^(\d{6}-\d{2} *)+$/)) {
  foreach my $pp (@slist) {
    my ($id, $rev)= split (/-/, $pp);
    init_patch ($id);
    $p{$id}{prev}=$rev;
    push (@plist, $id);
  }
  do_patch_list();
  exit 0;
}

get_current_xref();
if (!$o{list} && !$o{download} && !$o{install} && !$o{readme}) { exit 0; }

get_uname();
get_installed_packages();
get_installed_patches();
get_current_patches();
create_patch_list();
do_patch_list();

exit 0;

# Functions

sub do_patch_list {
  (@plist) || return;

  # Counters
  $c{current}=0;
  $c{total}=$#plist+1;
  $c{dl}=$c{skipdl}=$c{faildl}=$c{inst}=$c{skipinst}=$c{failinst}=0;
  $c{p_ci}=$c{p_bi}=$c{p_c}=$c{p_b}=0;

  print_header();

  foreach my $id (@plist) {
    $c{current}++;

    # Add revision to patch id
    my $pp="";
    ($p{$id}{irev} ne "00") && ($pp="$id-$p{$id}{irev}");
    ($p{$id}{crev} ne "00") && ($pp="$id-$p{$id}{crev}");
    ($p{$id}{prev} ne "00") && ($pp="$id-$p{$id}{prev}");
    $pp || err ("Unknown patch-id $id");

    if ($o{list} || $o{download} || $o{install}) {
      print_patch ($id);
    }
    if ($o{download} || $o{install}) {
      printf " " x 23 . "Download %d/%d: ", $c{current}, $c{total};
      download_patch($pp);
      print $p{$id}{dloutput};
    }
    if ($o{install}) {
      printf " " x 23 . "Install  %d/%d: ", $c{current}, $c{total};
      install_patch($pp);
      if (-x '/var/run/nopatch') {
        `/var/run/nopatch`;
        last
      }
    }
    if ($o{readme}) {
      my $rtmp=get_readme ($pp);
      ($rtmp) && (push (@rlist, $rtmp));
    }
    ($o{download} || $o{install}) && print "\n";
  }

  if ($o{download} || $o{install}) {
    printf "Download Summary: %d total, %d successful, ", $c{total}, $c{dl};
    printf "%d skipped, %d failed\n", $c{skipdl}, $c{faildl};
  }
  if ($o{install}) {
    printf "Install Summary : %d total, %d successful, ", $c{total}, $c{inst};
    printf "%d skipped, %d failed\n", $c{skipinst}, $c{failinst};

       if ($c{p_ci}) { print "\nReconfiguration reboot (boot -r) required.\n" }
    elsif ($c{p_bi}) { print "\nReboot required.\n" }
    elsif ($c{p_c }) { print "\nReconfiguation reboot (boot -r) recommended.\n" }
    elsif ($c{p_b }) { print "\nReboot recommended.\n"}
  }
  if ($o{readme} && (@rlist)) {
    system ("$pager @rlist");
    unlink (@rlist);
  }
  print_footer();
}

sub expand_operands {
  my @tlist=@ARGV; my $again=1; my %fc;

  while ($again) {
    $again=0; @slist=();
    foreach my $s (@tlist) {
      if ($s =~ /^(missingr?s?|installedr?s?|allr?s?|totalr?s?|unbundledr?s?|badr?s?)$/) {
        push (@slist, $s);
      } elsif ($s =~ /^(mr?s?|ir?s?|ar?s?|tr?s?|ur?s?|br?s?)$/) {
        push (@slist, $s);
      } elsif ($s =~ /^(\d{6}|\d{6}-\d{2})$/) {
        push (@slist, $s);
      } elsif ($s =~ /(\d{6}-\d{2})\.(zip|tar\.Z|tar)$/) {
        push (@slist, $1);
      } elsif (-f $s) {
        if ($fc{$s}) { err ("Recursive file inclusion: $s") } else { $fc{$s}=1 }
        open (LIST, "<$s") || err ("Can't open $s ($!)");
        while (<LIST>) {
          chomp;
          next unless $_;
          push (@slist, (split (/ /, $_))[0]);
          $again=1;
        }
      } else {
        err ("Unknown operand: $s");
      }
    }
    @tlist=@slist;
  }
  dbg ("Expanded patch list: @slist");
}

sub create_patch_list {
  if ("@slist" =~ /^(\d{6}-\d{2} *)+$/) {
    foreach my $pp (@slist) {
      my ($id, $rev)= split (/-/, $pp);
      init_patch ($id);
      $p{$id}{prev}=$rev;
      push (@plist, $id);
    }
  } else {
    foreach my $id (sort keys %p) {
      add_patch_list ($id,0);
    }
  }
}

sub add_patch_list {
  my $id=$_[0];
  my $type=$_[1];

  # Ignore patches which have been listed already.
  ($p{$id}{listed}) && return (0);

  $type=match_patch_list($id,$type);
  $type || return (0);

  if ($p{$id}{requires} ne '') {
    REQ: foreach my $r (split (/;/, $p{$id}{requires})) {
      my ($r_id, $r_rev)= split (/-/, $r);

      # If a required patch has been obsoleted by another patch, we
      # continue with the patch that obsoleted it.
      while ($p{$r_id}{obsoletedby} ne '') {
        my ($oby_id, $oby_rev)= split (/-/, $p{$r_id}{obsoletedby});
        dbg ("$r_id-$r_rev required by $id: obsolete, replaced with $oby_id-$oby_rev");
        ($r_id, $r_rev)= ($oby_id, $oby_rev);
      }
      # Check if patch requires itself
      if ($r_id eq $id) {
        dbg ("$r_id-$r_rev required by $id: patch requires itself");
        next;
      }
      # Check if the required patch is in our database. Normally we should
      # stop with an error here, but maybe information in patchdiag.xref
      # is wrong and the patch will install without the missing required patch.
      if ($p{$r_id}{crev} eq "00") {
         dbg ("$r_id-$r_rev required by $id: unknown patch");
         next;
      }
      # Check circular patch dependencies (only one level). This won't
      # catch patch A req B, B req C, and C req A.
      if ($p{$r_id}{requires} ne '') {
        foreach my $s (split (/;/, $p{$r_id}{requires})) {
          (my $s_id, my $s_rev)= split (/-/, $s);
          if ($id eq $s_id) {
            dbg ("$r_id-$r_rev required by $id: Circular patch dependency");
            next REQ;
          }
        }
      }
      # Ignore patches already in our list.
      if ($p{$r_id}{listed}) {
        dbg ("$r_id-$r_rev required by $id: already listed");
        next;
      }
      # Ignore patches already installed.
      if ($p{$r_id}{irev} ge $r_rev) {
        dbg ("$r_id-$r_rev required by $id: already installed");
        next;
      }

      dbg ("$r_id-$r_rev required by $id");
      if (!add_patch_list($r_id,$type)) {
        dbg ("$r_id-$r_rev required by $id: does not match");
      }
    }
  }
  $p{$id}{listed}=1;
  push (@plist, $id);
  return (1);
}

sub match_patch_list {
  my $id=$_[0];
  my $type=$_[1];
  my $found;

  S: foreach my $s (@slist) {
    # Complete patch id with revision (123456-78)
    if ($s =~ /\d{6}-\d{2}/) {
      my ($s_id,$s_rev)= split(/-/,$s);
      init_patch($s_id);
      if ($id eq $s_id) {
        $p{$id}{prev}=$s_rev;
        return (1);
      }
    }
    # Incomplete patch id (123456)
    if ($s =~ /\d{6}/) {
      init_patch($id);
      if ($id eq $s) { return (2); }
      if ($type == 2) { return (2); }
    }
    # installed or all
    if (($s =~ /^i/) || ($s =~ /^a/)) {
      # Check for R/S, minage, pattern, ignore
      if (!check_rs($s,$id)) { next; }

      # Check if patch is installed.
      if ($p{$id}{irev} ne '00') { return (3); }
    }
    # unbundled
    if ($s =~ /^u/) {
      # Check if patch is Unbundled and has an empy packages list.
      if (!(($p{$id}{os} eq "Unbundled") && ($p{$id}{pkgs} eq ""))) { next; }

      # Ignore obsolete and bad patches
      if ($p{$id}{obs} || $p{$id}{bad}) { next; }

      # Check for R/S, minage, pattern, ignore
      if (!check_rs($s,$id)) { next; }

      return (4);
    }
    # missing or all
    if (($s =~ /^m/) || ($s =~ /^a/)) {
      # Ignore obsolete and bad patches
      if ($p{$id}{obs} || $p{$id}{bad}) { next; }

      # Ignore patches which are installed in the current or higher revision
      if ($p{$id}{irev} ge $p{$id}{crev}) { next; }

      # Ignore patches for foreign architectures.
      $found=0;
      foreach my $j (split (/\;/, $p{$id}{archs})) {
        if (($j eq $u{arch}) || ($j eq "all") || ($j eq "Solaris") || ($j eq "$u{arch}.$u{model}")) {
          $found=1; last;
        }
      }
      if (!$found) { next; }

      # Ignore patches for packages that are not installed.
      $found=0;
      foreach my $j (split (/\;/, $p{$id}{pkgs})) {
        my ($package, $version)= split (/:/, $j);
        if ($pkgs{$package} && ($pkgs{$package} eq $version)) {
          $found=1; last;
        }
      }
      if (!$found) { next; }

      if (!patch_apply_check($id)) { next; }

      # Check for R/S, minage, pattern, ignore
      if (!check_rs($s,$id) && ($type != 5)) { next; }

      return (5);
    }
    # Total set of patches
    if ($s =~ /^t/) {
      if ($p{$id}{crev} eq "00") { next; }

      # Check for R/S, minage, pattern, ignore
      if (!check_rs($s,$id)) { next; }

      return (6);
    }
    # Installed bad patches
    if ($s =~ /^b/) {
      if (!$p{$id}{ibad}) { next; }

      # Check if bad patch has been obsoleted by an installed patch
      my $oby_id= $id; my $oby_rev;
      while ($p{$oby_id}{obsoletedby} ne '') {
        ($oby_id, $oby_rev)= split (/-/, $p{$oby_id}{obsoletedby});
        if ($p{$oby_id}{irev} ge $oby_rev) { next S; }
      }
      # Check for R/S, minage, pattern, ignore
      if (!check_rs($s,$id)) { next; }

      return (7);
    }
  }
  return (0);
}

sub check_rs {
  my $s=$_[0]; my $id=$_[1];

  # Check for R/S flags
  if ($s =~ /rs$/) {
    if (!($p{$id}{rec} || $p{$id}{recf} || $p{$id}{sec} || $p{$id}{secf})) { return(0); }
  } else {
    if (($s =~ /r$/) && (!$p{$id}{rec}) && (!$p{$id}{recf})) { return(0); }
    if (($s =~ /s$/) && (!$p{$id}{sec}) && (!$p{$id}{secf})) { return(0); }
  }
  # Ignore patches in the ignore list.
  if ($p{$id}{ignore} eq "00") { return 0 }
  if ($p{$id}{ignore} eq $p{$id}{crev}) { return 0 }

  # Check for minage and pattern
  if (($o{minage}) && (calculateage($p{$id}{reldate}) <= $o{minage})) { return(0); }
  if (($o{pattern}) && ($p{$id}{synopsis} !~ /$o{pattern}/)) { return(0); }

  return(1);
}

sub download_patch {
  my $pp=$_[0];
  my ($id, $rev)= split (/-/, $pp);

  lock_free($o{patchdir}, "download.$pp", 300) || err ("Another instance of pca is downloading $pp to $o{patchdir} right now");

  # Check if patch exists
  if (-d "$o{patchdir}/$pp") {
    $p{$id}{dloutput}= "skipped - directory exists\n"; $c{skipdl}++; return;
  }
  foreach my $ext ('.zip','.tar.Z','.tar') {
    if (-f "$o{patchdir}/$pp$ext") {
      if (-s "$o{patchdir}/$pp$ext") {
        $p{$id}{dloutput}= "skipped - file exists\n"; $c{skipdl}++; return;
      }
      unlink "$o{patchdir}/$pp$ext";
    }
  }

  # Remember if we downloaded the patch for install only
  $o{download} || ($p{$id}{dfori}=1);

  (-w $o{patchdir}) || err ("Can't write to patch download directory $o{patchdir} ($!)");

  lock_create($o{patchdir}, "download.$pp", 1) || err ("Another instance of pca is downloading $pp to $o{patchdir} right now");

  # Try to get patch from local patch server
  if ($o{patchurl} && ($o{patchurl} =~ /^file:/)) {
    my $path=$o{patchurl}; $path =~ s/^file://;
    foreach my $ext ('.zip','.tar.Z','.tar') {
      $p{$id}{dlfile}="$o{patchdir}/$pp$ext";
      (-r "$path/$pp$ext") && copy ("$path/$pp$ext", $p{$id}{dlfile});
      $p{$id}{dlfile}="";
      if (-s "$o{patchdir}/$pp$ext") {
        $p{$id}{dloutput}= "done\n"; $c{dl}++;
        lock_remove($o{patchdir}, "download.$pp");
        return;
      }
      unlink "$o{patchdir}/$pp$ext";
    }
  }
  # Without wget we can't download the patch
  if (!$o{wget}) {
    $p{$id}{dloutput}= "failed - can't find wget executable\n"; $c{faildl}++;
    lock_remove($o{patchdir}, "download.$pp");
    return;
  }
  # Try to get patch from local patch server with wget
  if ($o{patchurl} && ($o{patchurl} =~ /^http:|^https:|^ftp:/)) {
    foreach my $ext ('.zip','.tar.Z','.tar') {
      $p{$id}{dlfile}="$o{patchdir}/$pp$ext";
      my $force=''; if ($o{force} && ($o{patchurl} =~ /pca-proxy\.cgi/)) { $force=":force" }
      `$o{wget} $o{wgetq} --timeout=3600 "$o{patchurl}$pp$ext$force" -O $p{$id}{dlfile}`;
      $p{$id}{dlfile}="";
      if ((!$?) && (-s "$o{patchdir}/$pp$ext")) {
        $p{$id}{dloutput}= "done\n"; $c{dl}++;
        lock_remove($o{patchdir}, "download.$pp");
        return;
      }
      unlink "$o{patchdir}/$pp$ext";
    }
  }
  # Try download from restricted patch server, if the user provided
  # Sun Online Account data
  if ($o{user} && $o{passwd}) {
    my $try=1;
    while ($try <= $o{dltries} ) {
      $p{$id}{dlfile}="$o{patchdir}/$pp.tmp";
      my $furl= "$o{tmpdir}/furl." . time() . $$;
      open (FURL, ">$furl") || err ("Can't write $furl ($!)");
      print FURL "http://$o{user}:$o{passwd}\@sunsolve.sun.com/pdownload.do?target=$pp&method=h\n";
      close FURL; chmod 0600, $furl;
      `$o{wget} -i $furl $o{wgetq} $o{wgetproxy} -O $o{patchdir}/$pp.tmp`;
      unlink "$furl";
      $p{$id}{dlfile}="";
      if ((!$?) && (-s "$o{patchdir}/$pp.tmp")) {
        my $file=`LC_MESSAGES=C; export LC_MESSAGES; $file $o{patchdir}/$pp.tmp`;
        if ($file =~ /tar archive/i) {
          rename ("$o{patchdir}/$pp.tmp", "$o{patchdir}/$pp.tar");
          $p{$id}{dloutput}= "done\n"; $c{dl}++;
          lock_remove($o{patchdir}, "download.$pp");
          return;
        } elsif ($file =~ /compress/i) {
          rename ("$o{patchdir}/$pp.tmp", "$o{patchdir}/$pp.tar.Z");
          $p{$id}{dloutput}= "done\n"; $c{dl}++;
          lock_remove($o{patchdir}, "download.$pp");
          return;
        } elsif ($file =~ /zip/i) {
          rename ("$o{patchdir}/$pp.tmp", "$o{patchdir}/$pp.zip");
          $p{$id}{dloutput}= "done\n"; $c{dl}++;
          lock_remove($o{patchdir}, "download.$pp");
          return;
        } else {
          dbg ("Unknown file type: $file");
        }
      }
      unlink "$o{patchdir}/$pp.tmp";
      $try++; if ($try <= $o{dltries}) { sleep ($try*2) }
    }
  } else {
    $p{$id}{dloutput}= "failed - no Sun Online Account data\n"; $c{faildl}++;
    lock_remove($o{patchdir}, "download.$pp");
    return;
  }
  $p{$id}{dloutput}= "failed - patch not found\n"; $c{faildl}++;
  lock_remove($o{patchdir}, "download.$pp");
}

sub install_patch {
  my $pp=$_[0];
  my ($id, $rev)= split (/-/, $pp);
  my $output;
  my $dfile='';

  $patchxdir= "$o{tmpdir}/pca." . time() . $$;
  mkdir $patchxdir,0755 || err ("Can't create temporary directory $patchxdir ($!)");

  if (-d "$o{patchdir}/$pp") {
    symlink ("$o{patchdir}/$pp", "$patchxdir/$pp");
  } elsif (-f "$o{patchdir}/$pp.zip") {
    `$unzip -n $o{patchdir}/$pp.zip -d $patchxdir 2>&1`;
    $p{$id}{dfori} && ($dfile= "$o{patchdir}/$pp.zip")
  } elsif (-f "$o{patchdir}/$pp.tar.Z") {
    `cd $patchxdir; $uncompress -c $o{patchdir}/$pp.tar.Z | $tar xf -`;
    $p{$id}{dfori} && ($dfile= "$o{patchdir}/$pp.tar.Z")
  } elsif (-f "$o{patchdir}/$pp.tar") {
    `cd $patchxdir; $tar xf $o{patchdir}/$pp.tar`;
    $p{$id}{dfori} && ($dfile= "$o{patchdir}/$pp.tar")
  } else {
    print "failed - missing patch file\n";
    rmdir $patchxdir; $patchxdir="";
    $c{failinst}++; return;
  }
  if (($?) || (! -d "$patchxdir/$pp")) {
    print "failed - uncompress failed\n";
    rmtree ($patchxdir); $patchxdir="";
    $c{failinst}++; return;
  }
  my $readme= "$patchxdir/$pp/README.$pp";
  my $patchinfo= "$patchxdir/$pp/patchinfo";

  if (($o{safe}) && !verify_files($id, $readme)) {
    rmtree ($patchxdir); $patchxdir="";
    $c{failinst}++; return;
  }

  # Do we need a reboot?
  my $p_b=0; my $p_bi=0; my $p_c=0; my $p_ci=0;
  if (-f $patchinfo) {
    open(PATCHINFO,$patchinfo) || err ("Can't open $patchinfo ($!)");
    dbg ("Checking for reboot/reconfig in patchinfo");
    while (<PATCHINFO>) {
      if (/PATCH_PROPERTIES=.*reconfigimmediate/) { $p_ci=1; last }
      if (/PATCH_PROPERTIES=.*rebootimmediate/) { $p_bi=1; last }
      if (/PATCH_PROPERTIES=.*reconfigafter/) { $p_c=1; last }
      if (/PATCH_PROPERTIES=.*rebootafter/) { $p_b=1; last }
    }
    close PATCHINFO;
  } elsif (-f $readme) {
    open(README,$readme) || err ("Can't open $readme ($!)");
    dbg ("Checking for reboot/reconfig in README");
    while(<README>) {
      if (/Reconfig.*immediate.*after.*install/) { $p_ci=1; last }
      if (/Reboot.*immediate.*after.*install/) { $p_bi=1; last }
      if (/Reconfig.*after.*install/) { $p_c=1; last }
      if (/Reboot.*after.*install/) { $p_b=1; last }
    }
    close README;
  }

  # If the patchadd command doesn't exist, try installpatch, which
  # comes with patches for Solaris <= 2.5.1.
  (-x $o{patchadd}) || ($o{patchadd}="$patchxdir/$pp/installpatch");
  (-x $o{patchadd}) || err ("Can't execute patchadd/installpatch");

  # Sun Studio 11 patches on Solaris 10 must be installed with -G
  # Patches 119254-34 and 119255-34 fix this in patchadd
  my $minusg='';
  my ($major, $minor) = split (/\./, $u{osrel});
  if (($minor == 10) && ($p{$id}{synopsis} =~ /^Sun Studio 11/) && ($o{patchadd_options} !~ /-G/)) {
    if (!($p{119254}{irev} ge '34') && !($p{119255}{irev} ge '34')) {
      dbg ("Adding -G to patchadd for Sun Studio 11 on Solaris 10");
      $minusg="-G";
    }
  }

  if ($o{noreboot} && ($p_ci || $p_bi || $p_c || $p_b)) {
    print "skipped"; $c{skipinst}++;
  } elsif ($o{pretend}) {
    print "pretended"; $c{skipinst}++;
  } else {
    lock_create($o{tmpdir}, "install", 1) || err ("Another instance of pca is installing patches right now");
    dbg ("$o{patchadd} $o{root} $o{patchadd_options} $minusg $patchxdir/$pp");
    $SIG{INT}='IGNORE';
    $output=`$o{patchadd} $o{root} $o{patchadd_options} $minusg $patchxdir/$pp </dev/null 2>&1`;
    $SIG{INT}=\&handler;
    my $rc=$?;
    lock_remove($o{tmpdir}, "install");
    if ($rc) {
      print "\n$output\n";
      printf "failed - Exit code %d\n", $rc / 256;
      rmtree ($patchxdir); $patchxdir="";
      $c{failinst}++; return;
    }
    dbg ("\n$output");
    print "done"; $c{inst}++;
    $dfile && unlink ($dfile);
    log_msg("Installed patch $pp ($p{$id}{synopsis})");
  }
     if ($p_ci) { print " - reconfig required"; $o{noreboot} || $c{p_ci}++ }
  elsif ($p_bi) { print " - reboot required"; $o{noreboot} || $c{p_bi}++ }
  elsif ($p_c ) { print " - reconfig recommended"; $o{noreboot} || $c{p_c}++ }
  elsif ($p_b ) { print " - reboot recommended"; $o{noreboot} || $c{p_b}++ }
  print "\n";
  rmtree ($patchxdir); $patchxdir="";
}

sub proxy {
  my $f=$o{proxy};
  my $odir=getcwd();

  if ($o{pforce}) { unlink ("$odir/$f") }

  if ($f =~ /patchdiag.xref/) {
    $o{xrefown}=1; $o{nocheckxref}=0;
    get_current_xref();
  }
  if (($f =~ /README/) && (! -f "$odir/$f")) {
    my $pp=$f; $pp =~ s/^.*(\d{6}-\d{2}).*$/$1/;
    my $rtmp=get_readme ($pp);
    if ($rtmp) {
      copy ($rtmp, "$odir/$f");
      unlink ($rtmp);
    }
  }
  if ($f =~ /\d{6}-\d{2}\.(zip|tar|tar\.Z)/) {
    my $pp=$f; $pp =~ s/^.*(\d{6}-\d{2}).*$/$1/;
    download_patch($pp);
  }

  if (-f "$odir/$f") {
    print "Location: $f\n\n";
  } else {
    err ("$f not found");
  }
  exit (0);
}

sub check_prerequisites {
  # Must be root to install patches
  if ($o{install} && ($< != 0) && !$o{pretend}) {
    err ("You must be root to install patches");
  }
  if ($o{install} && $o{safe} && ($< != 0)) {
    err ("You must be root to use safe mode");
  }

  # Set umask (esp. for patchxdir)
  umask (0022);

  # Check for wget executable
  my $found='';
  foreach my $i (split (/ /, $o{wget})) {
    if (-x $i) {
      $found= $i;
      dbg ("Using $found");
      last;
    }
  }
  $o{wget}=$found;

  # Get patchdiag.xref location
  $input{xref}="$o{xrefdir}/patchdiag.xref";

  # Check patch download directory
  (-d $o{patchdir}) || err ("Can't find patch directory $o{patchdir}");

  # Check for pager
  $ENV{PAGER} && ($pager=$ENV{PAGER});

  # Check for valid prefix in $fromfiles and set input files/commands
  if ($o{fromfiles}) {
    if (-f "$o{fromfiles}/sysconfig/uname-a.out") {
      $input{pkginfo}= "<$o{fromfiles}/patch+pkg/pkginfo-l.out";
      $input{showrev}= "<$o{fromfiles}/patch+pkg/showrev-p.out";
      $input{uname}  = "<$o{fromfiles}/sysconfig/uname-a.out";
    } elsif (-f "$o{fromfiles}uname.out") {
      $input{pkginfo}= "<$o{fromfiles}pkginfo.out";
      $input{showrev}= "<$o{fromfiles}showrev.out";
      $input{uname}  = "<$o{fromfiles}uname.out";
    } elsif (-f "$o{fromfiles}/uname.out") {
      $input{pkginfo}= "<$o{fromfiles}/pkginfo.out";
      $input{showrev}= "<$o{fromfiles}/showrev.out";
      $input{uname}  = "<$o{fromfiles}/uname.out";
    } else {
      err ("Can't find pkginfo/showrev/uname output with prefix $o{fromfiles}");
    }
    dbg ("Using $o{fromfiles} as prefix to read .out files");
  } else {
    $input{pkginfo}= "$pkginfo -x $o{root} |";
    $input{uname}  = "$uname -a |";
  }

  # Ask for Sun Online Account data interactively
  if ($o{download} || $o{install} || $o{readme} || $o{listhtml}) {
    if ($o{askauth}) {
      print "Sun Online Account User: ";
      chomp($o{user} = <STDIN>);
    }
    if ($o{askauth} || ($o{user} && !$o{passwd})) {
      system "stty -echo"; $sttyset=1;
      print "Sun Online Account Password";
      if ($o{askauth}) { print ": " } else { print " for $o{user}: " }
      chomp($o{passwd} = <STDIN>);
      print "\n";
      system "stty echo"; $sttyset=0;
    }
  }
  if ($o{user}) {
    $o{user} =~ s/\@/%40/g;
    dbg ("Sun Online Account user is set");
  }
  if ($o{passwd}) { 
    $o{passwd} =~ s/\@/%40/g;
    dbg ("Sun Online Account passwd is set");
  }

  # Set default locale for forks
  $ENV{LC_ALL}='C';
}

sub verify_files {
  my $id=$_[0]; my $readme=$_[1]; my @files=(); my %wl;

  # All
  $wl{all}="/etc/name_to_major /etc/driver_aliases /etc/driver_classes /etc/minor_perm /etc/security/exec_attr";
  # 7/SPARC
  $wl{106541}="/etc/devlink.tab /etc/rmmount.conf /etc/syslog.conf /etc/vold.conf";
  $wl{106857}="/usr/openwin/share/locale/C/props/basic_setting";
  $wl{106978}="/etc/nsswitch.conf";
  $wl{107589}="/etc/default/kbd";
  $wl{107684}="/etc/inet/services /etc/mail/main.cf /etc/mail/subsidiary.cf";
  $wl{107738}="/usr/openwin/lib/locale/compose.dir /usr/openwin/lib/locale/locale.alias /usr/openwin/lib/locale/locale.dir";
  $wl{108800}="/etc/inet/inetd.conf /etc/init.d/cachefs.daemon";
  # 8/SPARC
  $wl{108725}="/kernel/drv/st.conf";
  $wl{108968}="/etc/rmmount.conf /etc/vold.conf";
  $wl{108993}="/etc/asppp.cf /etc/nsswitch.conf /etc/pam.conf /etc/default/login";
  $wl{108999}="/etc/pam.conf";
  $wl{109077}="/etc/security/auth_attr /etc/security/prof_attr";
  $wl{109134}="/etc/security/auth_attr /etc/security/prof_attr";
  $wl{109695}="/etc/smartcard/opencard.properties";
  $wl{109766}="/usr/openwin/lib/locale/ja/X11/fonts/TT/fonts.alias";
  $wl{109887}="/etc/smartcard/ocf.classpath";
  $wl{110369}="/etc/iu.ap";
  $wl{110386}="/etc/security/auth_attr /etc/security/prof_attr";
  $wl{110615}="/etc/mail/main.cf /etc/mail/subsidiary.cf";
  $wl{110896}="/etc/inet/inetd.conf";
  $wl{112438}="/etc/devlink.tab";
  $wl{112663}="/usr/openwin/server/etc/OWconfig";
  $wl{114542}="/usr/openwin/lib/X11/fonts/TrueType/ttmap/ttmaps.dir /usr/openwin/lib/X11/fonts/encodings/encodings.dir";
  $wl{116973}="/etc/apache/mime.types";
  $wl{117518}="/usr/openwin/lib/X11/fonts/F3bitmaps/fonts.dir";
  # 9/SPARC
  $wl{112233}="/etc/iu.ap";
  $wl{112874}="/etc/name_to_sysnum /etc/security/crypt.conf /etc/security/policy.conf";
  $wl{112908}="/etc/krb5/krb5.conf";
  $wl{112954}="/kernel/drv/uata.conf";
  $wl{113073}="/etc/inet/inetd.conf";
  $wl{113085}="/usr/openwin/lib/X11/fonts/TrueType/ttmap/ttmaps.dir /usr/openwin/lib/X11/fonts/encodings/encodings.dir";
  $wl{113096}="/usr/openwin/server/etc/OWconfig";
  $wl{113277}="/kernel/drv/st.conf /kernel/drv/sd.conf";
  $wl{113471}="/usr/bin/cputrack";
  $wl{113575}="/etc/mail/main.cf /etc/mail/subsidiary.cf";
  $wl{114320}="/usr/openwin/server/etc/OWconfig";
  $wl{114352}="/etc/inet/inetd.conf";
  $wl{123184}="/usr/openwin/lib/X11/fonts/TrueType/ttmap/ttmaps.dir /usr/openwin/lib/X11/fonts/encodings/encodings.dir";
  # 9/x86
  $wl{114137}="/etc/mail/main.cf /etc/mail/subsidiary.cf";
  $wl{114353}="/etc/inet/inetd.conf";
  $wl{115168}="/etc/krb5/krb5.conf";
  $wl{122300}="/etc/rc0.d/K05volmgt /etc/rc1.d/K05volmgt /etc/rc2.d/K05volmgt /etc/rc3.d/S81volmgt /etc/rcS.d/K05volmgt /etc/security/audit_class /etc/security/audit_event";
  # 10/SPARC
  $wl{116298}="/usr/bin/wscompile /usr/bin/wsdeploy";
  $wl{118822}="/etc/security/device_policy";
  $wl{118833}="/etc/logindevperm /etc/security/prof_attr /etc/vold.conf";
  $wl{118929}="/etc/iu.ap";
  $wl{119090}="/etc/ima.conf /kernel/drv/iscsi.conf";
  $wl{119130}="/kernel/drv/fp.conf /kernel/drv/qlc.conf";
  $wl{119313}="/etc/security/auth_attr";
  $wl{120222}="/kernel/drv/emlxs.conf";
  $wl{120346}="/etc/hba.conf";
  $wl{120410}="/etc/gtk-2.0/gtk.immodules /etc/sparcv9/gtk-2.0/gtk.immodules";
  $wl{120460}="/etc/gtk-2.0/gtk.immodules /etc/sparcv9/gtk-2.0/gtk.immodules";
  $wl{121430}="/etc/default/lu";
  $wl{122212}="/etc/gconf/gconf.xml.defaults/apps/panel/default_setup/general/%gconf.xml";
  $wl{122539}="/etc/security/auth_attr";
  $wl{124393}="/etc/security/auth_attr /etc/security/prof_attr";
  $wl{125166}="/kernel/drv/qlc.conf";
  $wl{121474}="/etc/security/audit_event";
  $wl{125131}="/etc/passwd /etc/shadow";
  # 10/x86
  $wl{118844}="/boot/solaris/bootenv.rc /etc/security/device_policy";
  $wl{118855}="/etc/logindevperm /etc/security/prof_attr /etc/vold.conf /lib/libc.so.1 /etc/security/device_policy /etc/ipf/pfil.ap /boot/solaris/devicedb/master";
  $wl{119091}="/etc/ima.conf /kernel/drv/iscsi.conf";
  $wl{119131}="/kernel/drv/fp.conf /kernel/drv/qlc.conf";
  $wl{119314}="/etc/security/auth_attr";
  $wl{120037}="/lib/libc.so.1";
  $wl{120223}="/kernel/drv/emlxs.conf";
  $wl{120273}="/etc/sma/snmp/snmpd.conf";
  $wl{120347}="/etc/hba.conf";
  $wl{120411}="/etc/gtk-2.0/gtk.immodules /etc/amd64/gtk-2.0/gtk.immodules";
  $wl{120461}="/etc/gtk-2.0/gtk.immodules /etc/amd64/gtk-2.0/gtk.immodules";
  $wl{120846}="/etc/security/audit_event";
  $wl{121431}="/etc/default/lu";
  $wl{122213}="/etc/gconf/gconf.xml.defaults/apps/panel/default_setup/general/%gconf.xml";
  $wl{122255}="/platform/sun4u-us3/lib/libc_psr.so.1 /platform/sun4u-us3/lib/sparcv9/libc_psr.so.1";
  $wl{122532}="/etc/security/auth_attr";
  $wl{124394}="/etc/security/auth_attr /etc/security/prof_attr";
  $wl{125165}="/kernel/drv/qlc.conf";
  $wl{125100}="/etc/iu.ap";
  $wl{125132}="/etc/passwd /etc/shadow";
  $wl{118666}="/etc/.java/.systemPrefs/.system.lock /etc/.java/.systemPrefs/.systemRootModFile";

  (-f $readme) || return (1);
  open (README, "<$readme") || err ("Can't open $readme ($!)");

  FILE: while (<README>) {
    next if ($_ !~ /Files included with this patch:/);
    LINE: while (<README>) {
      chomp;
      next if (/^$/);
      last FILE if (! /\//);
      s/\s+\(deleted\)//;
      s/^\s+//;
      s/^/\// unless /^\//;

      foreach my $i (split (/ /, $wl{all})) { ($_ eq $i) && next LINE; }
      if ($wl{$id}) {
        foreach my $i (split (/ /, $wl{$id})) { ($_ eq $i) && next LINE; }
      }
      push (@files, $_);
    }
  }
  close (README);
  dbg ("Number of files to check: %d", $#files+1);
  ($#files == -1) && return (1);

  # pkgchk has a limit of 1024 pathnames
  my @tfiles=@files; my $out='';
  while ($#tfiles != -1) {
    my $fc=$#tfiles;
    ($fc >= 1023) && ($fc=1023);
    $out .= `$pkgchk $o{root} -q -p \"@tfiles[0..$fc]\" 2>&1`;
    for (0..1023) { shift @tfiles; }
  }
  ($out) || return (1);

  if ($out =~ /file size |file cksum |pathname /) {
    print "failed file verification:\n\n$out";
    return (0);
  }
  return (1);
}

sub patch_apply_check {
  my $id=$_[0];

  if ($id =~ /113039|113040|113041|113042|113043/) {
    if (!$pkgs{"SUNWsan"}) { return (0); }
  }

  if ($id =~ /114045/) {
    if ((exists $p{114049}) && ($p{114049}{irev} gt '03')) { return (0); }
  }

  if (($id =~ /114046|119209/) && ($u{osrel} ne "5.8")) { return (0); }
  if (($id =~ /114049|114050/) && ($u{osrel} ne "5.9")) { return (0); }
  if (($id =~ /119211|119212/) && ($u{osrel} ne "5.9")) { return (0); }

  if ($id =~ /114790/) {
    if (!$pkgs{"SUNWdcar"}  || $pkgs{"SUNWdcar"}  ne "1.1.0,REV=2002.05.29.15.02") { return (0); }
    if (!$pkgs{"SUNWcrypr"} || $pkgs{"SUNWcrypr"} ne "1.1.0,REV=2002.05.29.15.00") { return (0); }
  }

  if (($id =~ /117765|117766/) && ($u{osrel} ne "5.8")) { return (0); }
  if (($id =~ /117767|117768/) && ($u{osrel} ne "5.9")) { return (0); }

  if ($id =~ /113332/) {
    if (($pkgs{"SUNWhea"}) || ($pkgs{"SUNWmdb"})) { return (1); }
    if (($u{model} eq 'sun4u') || ($u{model} eq 'sun4us')) { return (1); }
    return (0);
  }

  if ($id =~ /115010|116478/) {
    if (($pkgs{"SUNWhea"}) || ($pkgs{"SUNWmdb"})) { return (1); }
    if ($u{model} eq 'sun4u') { return (1); }
    return (0);
  }

  if ($id =~ /109077|109078/) {
    if ((!$pkgs{"SUNWdhcm"}) && (!$pkgs{"SUNWdhcsu"})) { return (0); }
    if ($pkgs{"SUNWj3rt"}) { return (1); }
    return (0);
  }

  if ($id =~ /118739|116706/) {
    if (!$pkgs{"SUNWtsr"} || $pkgs{"SUNWtsr"} ne "2.5.0,REV=2003.04.03.21.27") { return (0); }
  }
  if ($id =~ /118740|116707/) {
    if (!$pkgs{"SUNWtsr"} || $pkgs{"SUNWtsr"} ne "2.5.0,REV=2003.04.03.19.26") { return (0); }
  }
  if ($id =~ /118741/) {
    if (!$pkgs{"SUNWtsr"} || $pkgs{"SUNWtsr"} ne "2.5.0,REV=2003.11.11.23.55") { return (0); }
  }
  if ($id =~ /118742/) {
    if (!$pkgs{"SUNWtsr"} || $pkgs{"SUNWtsr"} ne "2.5.0,REV=2003.11.11.20.36") { return (0); }
  }

  if ($id =~ /110692/) {
    if ((exists $p{108806}) && ($p{108806}{irev} ge '01')) { return (0); }
    if ((exists $p{108806}) && ($p{108806}{crev} ge '01')) { return (0); }
  }

  if ($id =~ /111412/) {
    if (!$pkgs{"SUNWmdi"} || $pkgs{"SUNWmdi"} ne "11.8.0,REV=2001.01.19.01.02") { return (0); }
    if (!$pkgs{"SUNWsan"}) { return (0); }
  }
  if ($id =~ /111095|111096|111413/) {
    if (!$pkgs{"SUNWsan"}) { return (0); }
  }
  if ($id =~ /111097/) {
    if (!$pkgs{"SUNWsan"}) { return (0); }
    if (!$pkgs{"SUNWqlc"}) { return (0); }
  }

  if ($id =~ /111656/) {
    if (!((exists $p{109460}) && ($p{109460}{irev} eq '05'))) { return (0); }
  }
  if ($id =~ /111658/) {
    if (!((exists $p{107469}) && ($p{107469}{irev} eq '08'))) { return (0); }
  }
  if ($id =~ /111079/) {
    if (!((exists $p{105375}) && ($p{105375}{irev} eq '26'))) { return (0); }
  }

  if ($id =~ /107474/) {
    if ((exists $p{107292}) && ($p{107292}{irev} ge '02')) { return (1); }
    return (0);
  }

  if ($id =~ /106533/) {
    if ($u{platform} ne 'SUNW,UltraSPARC-IIi-cEngine') { return (0); }
  }
  if ($id =~ /106629/) {
    if ($u{platform} ne 'CYRS,Superserver-6400') { return (0); }
  }
  if ($id =~ /112780/) {
    if (!($u{model} eq 'sun4u')) { return (0); }
  }
  if ($id =~ /112327/) {
    if (($u{osrel} ne "5.6") && ($u{osrel} ne "5.7")) { return (0); }
  }

  if ($id =~ /11464[456789]|11465[0123]|11481[67]|11578[01]|11752[01]/) {
    if ($u{osrel} ne "5.8") { return (0); }
  }
  if ($id =~ /11468[6789]|11469[012345]|11481[89]|11578[23]|11752[67]/) {
    if ($u{osrel} ne "5.9") { return (0); }
  }

  if ($id =~ /111891/) {
    if (!$pkgs{"SUNWutr"} || $pkgs{"SUNWutr"} ne "1.3_12.c,REV=2001.07.16.20.52") { return (0); }
  }

  if (($id =~ /114255/) && ($u{arch} ne "sparc")) { return (0); }
  if (($id =~ /114256/) && ($u{arch} ne "i386")) { return (0); }

  if (($id =~ /115328/) && ($u{osrel} ne "5.8")) { return (0); }
  if (($id =~ /115342/) && ($u{osrel} ne "5.9")) { return (0); }
  if (($id =~ /115343/) && ($u{osrel} ne "5.9")) { return (0); }
  if (($id =~ /119346/) && ($u{osrel} ne "5.10")) { return (0); }

  if (($id =~ /115766/) && ($u{arch} ne "sparc")) { return (0); }
  if (($id =~ /120091/) && ($u{arch} ne "i386")) { return (0); }
  if (($id =~ /120879/) && ($u{arch} ne "sparc")) { return (0); }
  if (($id =~ /120880/) && ($u{arch} ne "i386")) { return (0); }
  if (($id =~ /120954/) && ($u{arch} ne "sparc")) { return (0); }
  if (($id =~ /120955/) && ($u{arch} ne "i386")) { return (0); }

  if (($id =~ /115835|115836/) && (!$pkgs{"SUNWgscr"})) { return (0); }

  if (($id =~ /119300/) && ($u{osrel} ne "5.8")) { return (0); }
  if (($id =~ /119301/) && ($u{osrel} ne "5.9")) { return (0); }
  if (($id =~ /119302/) && ($u{osrel} ne "5.10")) { return (0); }

  if (($id =~ /122752|122753/) && (!$pkgs{"SUNWsmaS"} && !$pkgs{"SUNWsmagt"} && !$pkgs{"SUNWsmcmd"} && !$pkgs{"SUNWsmmgr"})) { return (0) }

  if ($id =~ /109357/) {
    if ((exists $p{109778}) && ($p{109778}{irev} ge '08')) { return (0); }
    if ((exists $p{109778}) && ($p{109778}{crev} ge '08')) { return (0); }
  }
  if (($id eq "113434") && (!$pkgs{"SUNWwbsup"})) { return (0) }

  if (($id eq "109700") && ($u{osrel} ne "5.6")) { return (0); }
  if (($id eq "109701") && ($u{osrel} ne "5.7")) { return (0); }
  if (($id eq "111248") && ($u{osrel} ne "5.6")) { return (0); }
  if (($id eq "111249") && ($u{osrel} ne "5.7")) { return (0); }
  if (($id eq "111250") && ($u{osrel} ne "5.8")) { return (0); }
  if (($id eq "115548") && ($u{osrel} ne "5.9")) { return (0); }

  if (($id eq "108553") && ($u{osrel} ne "5.8")) { return (0); }
  if (($id eq "108834") && (($u{osrel} ne "5.5.1") || ($u{osrel} ne "5.6") || ($u{osrel} ne "5.7"))) { return (0); }
  if (($id eq "112125") && (($u{osrel} ne "5.6") || ($u{osrel} ne "5.7"))) { return (0); }
  if (($id eq "112126") && (($u{osrel} ne "5.8") || ($u{osrel} ne "5.9"))) { return (0); }

  if (($id eq "123200") && ($u{osrel} ne "5.8")) { return (0); }
  if (($id eq "123201") && ($u{osrel} ne "5.9")) { return (0); }

  if (($id =~ /119527/) && ($u{arch} ne "sparc")) { return (0); }
  if (($id =~ /119528/) && ($u{arch} ne "i386")) { return (0); }
  if (($id =~ /119530/) && ($u{arch} ne "sparc")) { return (0); }
  if (($id =~ /119531/) && ($u{arch} ne "i386")) { return (0); }
  if (($id =~ /119325/) && ($u{arch} ne "sparc")) { return (0); }
  if (($id =~ /119326/) && ($u{arch} ne "i386")) { return (0); }

  if (($id eq "127498") && ($u{osrel} ne "5.8")) { return (0); }
  if (($id eq "127499") && ($u{osrel} ne "5.8")) { return (0); }

  return (1);
}

sub get_uname {
  # Get information about host
  open(UNAME, $input{uname}) || err ("Can't open $input{uname} ($!)");
  $_=<UNAME>;
  $_ || err ("Empty uname output");
  chomp;
  close UNAME;

  ($u{osname}, $u{hostname}, $u{osrel}, $u{osversion}, $u{model}, $u{arch}, $u{platform})= split (/ /, $_);
  ($u{osname} && $u{hostname} && $u{osrel} && $u{osversion} && $u{model} && $u{arch} && $u{platform}) || err ("Can't parse ouput from $input{uname}:\n  $_");

  my ($major, $minor) = split (/\./, $u{osrel});
  ($minor <= 9) && ($o{patchadd_options} =~ /-G/) && err ("Option -G supported on Solaris >= 10 only");
}

sub get_installed_packages {
  my $package;

  # Read pkginfo
  open(PKGINFO, $input{pkginfo}) || err ("Can't open $input{pkginfo} ($!)");
  if ($input{pkginfo} =~ /pkginfo-l.out/) {
    while(<PKGINFO>) {
      if (/\s+PKGINST:\s+(\S+)$/) { $package = $1; }
      if (/\s+VERSION:\s+(\S+)$/) { $pkgs{$package}=$1; }
    }
  } else {
    while(<PKGINFO>) {
      ($_ =~ /^(\S+) /) || err ("Can't parse output from $input{pkginfo}:\n  $_");
      $package=$1;
      # Removing trailing .2/.3/... (multiple versions of same package)
      $package =~ s/\..*//;
      $_= <PKGINFO>;
      ($_ =~ / (\S+)$/) || err ("Can't parse output from $input{pkginfo}:\n  $_");
      $pkgs{$package}=$1;
    }
  }
  close(PKGINFO);
}

sub get_installed_patches {
  my $list='';
  my $done=0;

  my $showrev_cmd=$showrev; ( -x $showrev_cmd) || ($showrev_cmd='');
  my $patchadd_cmd=$o{patchadd}; ( -x $patchadd_cmd) || ($patchadd_cmd='');

  # On Solaris <= 8, showrev doesn't support -R. Use patchadd instead.
  my ($major, $minor) = split (/\./, $u{osrel});
  if (($minor <= 8) && $o{root}) { $showrev_cmd='' }

  if ($o{fromfiles}) {
    dbg ("Reading from $input{showrev}");
    open(SHOWREV, $input{showrev}) || err ("Can't open $input{showrev} ($!)");
    $/=""; $list= <SHOWREV>; $/="\n";
    close SHOWREV;
    $done=1;
  } else {
    foreach my $cmd ($showrev_cmd, $patchadd_cmd) {
      next unless $cmd;
      $input{showrev}="$cmd -p $o{root}";
      dbg ("Reading from $input{showrev}");
      $list=`$input{showrev}`;
      if (!$?) { $done=1; last } else { dbg ("Failed: $list") }
    }
  }
  $done || err ("Couldn't get list of installed patches");

  $list || ($list= "No patches are installed\n");
  my @list= split(/\n/, $list);

  foreach my $i (sort @list) {
    # Known formats of patch IDs:
    #   123456-78      : Regular Sun
    #   IDR123456-78   : Unsupported (pre-release) Sun
    #   123-45         : EMC
    #   CKPSP123456-78 : Checkpoint
    #   CPFWSP410002-01: Checkpoint
    #   KDE20060107-01 : KDE
    #   IDCE32-02      : DCE
    #   DP550001-05    : HP Data Protector
    #   DP550011-1     : HP Data Protector
    #   PSE400SOL023   : Citrix
    #   ME113SB222     : Citrix
    #   Q995801-01     : SUNWluxop
    #   T000000-01     : Terix DST patch
    if (
      ($i =~ /^Patch:\s+(\d{3,6})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+IDR(\d{6})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+CKPSP(\d{6})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+CPFWSP(\d{6})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+KDE(\d{8})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+IDCE(\d{2})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+DP(\d{6})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+DP(\d{6})-(\d{1}).*/) ||
      ($i =~ /^Patch:\s+PSE(\d{3})SOL(\d{3}).*/) ||
      ($i =~ /^Patch:\s+ME(\d{3})SB(\d{3}).*/) ||
      ($i =~ /^Patch:\s+Q(\d{6})-(\d{2}).*/) ||
      ($i =~ /^Patch:\s+T(\d{6})-(\d{2}).*/)
    ) {
      my ($id, $rev)=($1,$2);
      init_patch($id);
      $p{$id}{irev}= $rev;
      if ($i =~ / Obsoletes: ([-0-9, ]*) /) {
        for my $j (split (/,* /, $1)) {
          my ($oid, $orev) = split (/-/, $j);
          ($id eq $oid) && next;
          init_patch($oid);
          $p{$oid}{iobsoletedby}="$id-$rev";
          #dbg ("$oid-$orev obsoleted by $id-$rev");
        }
      }
      if ($i =~ / Incompatibles: ([-0-9, ]*) /) {
        for my $j (split (/,* /, $1)) {
          my ($iid, $irev) = split (/-/, $j);
          init_patch($iid);
          #dbg ("$iid-$irev incompatible with $id-$rev");
        }
      }
      next;
    }
    next if ($i =~ "No patches are installed");
    next if ($i =~ "No patches installed");
    next if ($i =~ /^$/);
    print ("WARNING: Can't parse output from $input{showrev}:\n  $i\n");
  }
}

sub get_current_xref {
  # Download most recent patchdiag.xref, if requested

  return if ($o{nocheckxref});

  lock_free($o{xrefdir}, "xref", 60) || err ("Another instance of pca is downloading $input{xref} right now");

  # Remove possibly left-over size zero file
  if (-z $input{xref}) { unlink ($input{xref}) }

  # If a local copy of the xref file exists, and is older than a
  # certain time period, we try to download it, but only if we
  # can write to the directory where it is located.
  if ((-f $input{xref}) && (!$o{getxref})) {
    my $interval=10800;
    my $current=(stat($input{xref}))[9];
    my $now=time();
    my $age=$now-$current;
    dbg ("xref now    : " . localtime($now));
    dbg ("xref current: " . localtime($current));
    dbg ("xref age    : " . $age);
    if ($age < $interval) {
      return;
    } elsif (! -w $o{xrefdir}) {
      print "Can't download xref file, as $o{xrefdir} is unwritable\n";
      return;
    }
  }
  print "Download xref-file to $input{xref}: " unless $o{noheader};

  (-w $o{xrefdir}) || err ("Can't write to xref download directory $o{xrefdir}");
  if ((-f $input{xref}) && (! -w $input{xref})) {
    if ($o{getxref}) { 
      err ("Can't write to $input{xref}\n");
    } else {
      print "Can't write to $input{xref}\n";
      return;
    }
  }

  lock_create($o{xrefdir}, "xref", 1) || err ("Another instance of pca is downloading $input{xref} right now");
  my $success=0;
  if ($o{xrefurl} && ($o{xrefurl} =~ /^file:/)) {
    dbg ("Getting patchdiag.xref from $o{xrefurl}");
    my $path=$o{xrefurl}; $path =~ s/^file://;
    if (-r "$path/patchdiag.xref") {
      if (-s $input{xref}) {
        my $mtime1=(stat("$path/patchdiag.xref"))[9];
        my $mtime2=(stat($input{xref}))[9];
        if ($mtime2 >= $mtime1) { $success=1; }
      }
      if (!$success) {
        copy ("$path/patchdiag.xref", $input{xref});
        my ($atime, $mtime)=(stat("$path/patchdiag.xref"))[8..9];
        $success=1;
      }
    }
  }
  if (!$success && $o{xrefurl} && ($o{xrefurl} =~ /^http:|^https:|^ftp/)) {
    dbg ("Getting patchdiag.xref from $o{xrefurl}");
    $o{wget} || err ("Can't find wget executable");
    $xrefdl="$input{xref}";
    my $force=''; if ($o{force} && ($o{xrefurl} =~ /pca-proxy\.cgi/)) { $force=":force" }
    `$o{wget} $o{wgetq} "$o{xrefurl}patchdiag.xref$force" -O $input{xref}`;
    $xrefdl="";
    if (!$? && (-s $input{xref})) { $success=1 }
  }
  if (!$success) {
    dbg ("Getting patchdiag.xref from sunsolve.sun.com");
    $o{wget} || err ("Can't find wget executable");
    $xrefdl="$input{xref}";
    (-s $input{xref}) && rename ("$input{xref}", "$input{xref}.tmp");
    if ($o{nocache}) { $o{nocache}='--cache=off' } else { $o{nocache}='' }
    my $try=1;
    while ($try <= $o{dltries} ) {
      if ($o{user} && $o{passwd}) {
        my $furl= "$o{tmpdir}/furl." . time() . $$;
        open (FURL, ">$furl") || err ("Can't write $furl ($!)");
        print FURL "http://$o{user}:$o{passwd}\@sunsolve.sun.com/pdownload.do?target=patchdiag.xref\n";
        close FURL; chmod 0600, $furl;
        `$o{wget} -i $furl $o{wgetq} $o{wgetproxy} $o{nocache} -O $input{xref}`;
        unlink "$furl";
      } else {
        `$o{wget} $o{wgetq} $o{wgetproxy} $o{nocache} --header "Cookie: SunSolve_SLA=accept=y" "http://sunsolve.sun.com/pdownload.do?target=patchdiag.xref" -O $input{xref}`;
      }
      last if (!$? && (-s $input{xref}));
      $try++; if ($try <= $o{dltries}) { sleep ($try*2) }
    }
    $xrefdl="";
    if (!$? && (-s $input{xref})) {
      $success=1;
      (-s "$input{xref}.tmp") && unlink ("$input{xref}.tmp")
    } else {
      (-s "$input{xref}.tmp") && rename ("$input{xref}.tmp", "$input{xref}")
    }
  }
  lock_remove($o{xrefdir}, "xref");
  
  if ($success) {
    print "done\n" unless $o{noheader};
    my $now=time();
    utime $now, $now, $input{xref};
    if ($o{xrefown} || ($o{xrefdir} =~ /\/home\//)) {
      chmod 0644, $input{xref};
    } else {
      chmod 0666, $input{xref};
    }
  } else {
    (-z $input{xref}) && unlink ($input{xref});
    print "failed\n" unless $o{noheader};
  }
}

sub get_current_patches {
  # Read patchdiag.xref
  #
  open(XREF, "<$input{xref}") || err ("Can't open xref file $input{xref} ($!)");
  $_=<XREF>;
  $_ || err ("Empty file $input{xref}");
  if ($_ =~ /PATCHDIAG TOOL CROSS-REFERENCE FILE AS OF (.*) /) {
    print "Using $input{xref} from $1\n" unless $o{noheader};
  }
  $/=""; my $xref= <XREF>; $/="\n";
  close XREF;

  my @xref= split( /\n/, $xref );

  # Temporary
  push (@xref, '126509|02|Jun/28/07| | | |  |Unbundled|||QFS 4.6 Linux Patch');

  # Build our patch information table from the xref file.
  # patchdiag.xref is sorted, so if multiple revisions of a patch are listed,
  # the one with the highest revision comes last.
  #
  foreach my $i (sort @xref) {
    # Ignore comment lines
    if ($i =~ /^##/) { next; }
    if ($i !~ /^\d{6}\|\d{2}\|.*\|.\|.\|.\|..\|.*\|.*\|.*\|.*$/) { err ("Can't parse input from $input{xref}:\n  $i") }

    my ($id, $crev, $reldate, $rFlag, $sFlag, $oFlag, $byFlag, $os,
      $archs, $pkgs, $synopsis )= split( /\|/, $i);

    init_patch($id);

    # If an installed patch revision is marked bad, note this.
    if (($p{$id}{irev} eq $crev) && ($byFlag =~ ".B")) {
      $p{$id}{ibad}= 1;
      dbg ("Bad patch installed: $id-$p{$id}{irev}");
    }

    # If a patch revision is obsoleted or bad, use either the highest
    # non-obsoleted revision, or the highest obsoleted revision if all
    # revisions are obsoleted or bad.
    #
    if ($p{$id}{crev} ne "00") {
      if (($oFlag eq "O") || ($byFlag =~ ".B")) {
        if (!$p{$id}{obs} && !$p{$id}{bad}) { next; }
      }
    }

    $p{$id}{crev}=$crev;
    if ($reldate ne '') { $p{$id}{reldate}=$reldate; }
    $p{$id}{rec}=0; if ($rFlag  eq 'R' ) { $p{$id}{rec}=1; }
    $p{$id}{sec}=0; if ($sFlag  eq 'S' ) { $p{$id}{sec}=1; }
    $p{$id}{obs}=0; if ($oFlag  eq 'O' ) { $p{$id}{obs}=1; }
    $p{$id}{bad}=0; if ($byFlag =~ ".B") { $p{$id}{bad}=1; }
    $p{$id}{y2k}=0; if ($byFlag =~ "Y.") { $p{$id}{y2k}=1; }
    $p{$id}{os}=$os;
    $p{$id}{synopsis}=$synopsis;

    # If a patch is obsoleted by another patch, note it.
    # There are (at least) two forms, one with a patch revision
    # and one without. We check for both.
    #
    if ($p{$id}{obs}) {
      if ($synopsis =~ /Obsoleted by[ :]*(\d{6})-(\d{2})/) {
        if ($id ne $1) {
          $p{$id}{obsoletedby}="$1-$2";
          #dbg ("$id-$crev obsoleted by $p{$id}{obsoletedby}");
        }
      }
      if ($synopsis =~ /OBSOLETED by (\d{6})/) {
        if ($id ne $1) {
          $p{$id}{obsoletedby}="$1-01";
          #dbg ("$id-$crev obsoleted by $p{$id}{obsoletedby}");
        }
      }
    }

    # Patches might be obsoleted by installed patches, which are not
    # (yet) listed in patchdiag.xref.
    #
    if (($p{$id}{iobsoletedby}) && (!$p{$id}{obs})) {
      $p{$id}{obs}=1;
      $p{$id}{obsoletedby}=$p{$id}{iobsoletedby};
    }

    # Patch requires are coded into the archs field - separate them.
    $p{$id}{archs}='';
    $p{$id}{requires}='';
    foreach my $r (split /\;/, $archs) {
      if ($r =~ /^\d{6}-\d{2}/) {
        $p{$id}{requires} .= "$r;";
        # We run init_patch here for required patches because they might
        # be missing in the xref file, and would be uninitialized later.
        my ($r_id, $r_rev)= split (/-/, $r);
        init_patch($r_id);
      } else {
        $p{$id}{archs} .= "$r;";
      }
    }
    # Patch incompatibilities are coded into the pkgs field
    $p{$id}{pkgs}='';
    foreach my $r (split /\;/, $pkgs) {
      if ($r =~ /^\d{6}-\d{2}/) {
        my ($r_id, $r_rev)= split (/-/, $r);
        init_patch($r_id);
        #dbg ("$r_id-$r_rev incompatible with $id-$crev");
      } else {
        $p{$id}{pkgs} .= "$r;";
      }
    }
  }
}

sub init_patch {
  my $id=$_[0];

  # Every patch should be initialized only once.
  return if ($p{$id}{init});

  $p{$id}{irev}= $p{$id}{crev}= $p{$id}{prev}= '00';
  $p{$id}{synopsis}= 'NOT FOUND IN CROSS REFERENCE FILE!';
  $p{$id}{rec}= $p{$id}{sec}= $p{$id}{obs}= $p{$id}{bad}= $p{$id}{y2k}= 0;
  $p{$id}{recf}= $p{$id}{secf}= 0;
  $p{$id}{os}= '';
  $p{$id}{pkgs}= '';
  $p{$id}{ignore}= '';
  $p{$id}{reldate}= 'Jan/01/70';
  $p{$id}{obsoletedby}= '';
  $p{$id}{iobsoletedby}= '';
  $p{$id}{archs}= '';
  $p{$id}{requires}= '';
  $p{$id}{listed}= 0;
  $p{$id}{ibad}= 0;
  $p{$id}{init}= 1;
  $p{$id}{dfori}= 0;
  $p{$id}{dloutput}= '';
  $p{$id}{dlfile}= '';
}

sub print_patch {
  my $id=$_[0];
  my ($char, $h_char, $irev, $crev, $rec, $sec, $bad, $age, $synopsis);

  if ($p{$id}{irev} lt $p{$id}{crev}) { $char='<'; $h_char='&lt;'; }
  if ($p{$id}{irev} eq $p{$id}{crev}) { $char='='; $h_char='='; }
  if ($p{$id}{irev} gt $p{$id}{crev}) { $char='>'; $h_char='&gt;'; }

  $irev= $p{$id}{irev}; if ($irev eq "00") { $irev= '--' };
  $crev= $p{$id}{crev}; if ($crev eq "00") { $crev= '--' };

  $rec='-'; if ($p{$id}{recf}) { $rec='r'; }; if ($p{$id}{rec}) { $rec='R'; }
  $sec='-'; if ($p{$id}{secf}) { $sec='s'; }; if ($p{$id}{sec}) { $sec='S'; }
  $bad='-';
  if (($p{$id}{irev} eq "00") && ($p{$id}{bad} )) { $bad='B' }
  if (($p{$id}{irev} ne "00") && ($p{$id}{ibad})) { $bad='B' }

  $synopsis= $p{$id}{synopsis};

  $age=calculateage($p{$id}{reldate});
  if ($age > 999) { $age=999; }

  if (!$o{listhtml}) {
    my $out=$o{format};
    $id=sprintf ("%6d", $id); $out =~ s/%p/$id/;
    $out =~ s/%i/$irev/; $out =~ s/%e/$char/; $out =~ s/%c/$crev/;
    $out =~ s/%r/$rec/; $out =~ s/%s/$sec/; $out =~ s/%b/$bad/;
    $age=sprintf ("%3d", $age); $out =~ s/%a/$age/;
    $out =~ s/%y/$synopsis/;
    print "$out\n";
  } else {
    # The patch download link will only work for patches in zip format,
    # there is no way to determine if it's in zip or tar.Z here.
    #
    $synopsis =~ s/\&/\&amp;/;
    printf "<tr>";
    if ($o{patchurl} && $o{patchurl} =~ /pca-proxy\.cgi/) {
      printf "<td><a href=\"$o{patchurl}$id-$crev.zip\">%6d</a>", $id;
    } else {
      printf "<td><a href=\"http://sunsolve.sun.com/pdownload.do?target=$id-$crev&method=h\">%6d</a>", $id;
    }
    printf "<td>%2s<td>%1s<td>%2s<td>%1s%1s%1s<td align=right>%3s", $irev, $h_char, $crev, $rec, $sec, $bad, $age;
    if ($o{patchurl} && $o{patchurl} =~ /pca-proxy\.cgi/) {
      printf "<td><a href=\"$o{patchurl}README.$id-$crev\">%s</a></tr>\n", $synopsis;
    } elsif ($o{user} && $o{passwd}) {
      printf "<td><a href=\"http://sunsolve.sun.com/private-cgi/getpatch.pl?documentId=$id\">%s</a></tr>\n", $synopsis;
    } else {
      printf "<td><a href=\"http://sunsolve.sun.com/search/document.do?assetkey=$id\">%s</a></tr>\n", $synopsis;
    }  
  }
}

sub print_header {
  if (!$o{listhtml} && !$o{noheader}) {
    print "Host: $u{hostname} ($u{osname} $u{osrel}/$u{osversion}/$u{arch}/$u{model})\n";
    if ($o{root}) { my $r=$o{root}; $r =~ s/-R //; print "Root: $r\n" }
    print "List: @slist\n\n";

    my $hdr= my $sep=$o{format};
    $hdr =~ s/%p/Patch /; $hdr =~ s/%i/IR/; $hdr =~ s/%e/ /;
    $hdr =~ s/%c/CR/; $hdr =~ s/%r/R/; $hdr =~ s/%s/S/;
    $hdr =~ s/%b/B/; $hdr =~ s/%a/Age/; $hdr =~ s/%y/Synopsis/;
    $sep =~ s/%p/------/; $sep =~ s/%i/--/; $sep =~ s/%e/-/; $sep =~ s/%c/--/;
    $sep =~ s/%r/-/; $sep =~ s/%s/-/; $sep =~ s/%b/-/; $sep =~ s/%a/---/;
    if ($sep =~ /%y/) {
      my $ysep = '-' x (78 - (length ($sep)-2)); $sep =~ s/%y/$ysep/;
    }
    print "$hdr\n$sep\n";
  }
  if ($o{listhtml}) {
    print "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"";
    print "\n  \"http://www.w3.org/TR/html4/loose.dtd\">\n";
    print "<html>\n<head>\n";
    print "<title>PCA report for $u{hostname}</title>\n";
    print "</head>\n<body>\n";
    print "<h2>Host: $u{hostname} ($u{osname} $u{osrel}/$u{osversion}/$u{arch}/$u{model})<br>\n";
    if ($o{root}) { my $r=$o{root}; $r =~ s/-R //; print "Root: $r<br>\n" }
    print "List: @slist</h2>\n<table>\n";
    print "<tr><th>Patch</th>";
    print "<th><span title='Installed Revision'>IR</span></th><th></th>";
    print "<th><span title='Current Revision'>CR</span></th>";
    print "<th><span title='Recommended/Security/Bad Status'>RSB</span></th>";
    print "<th>Age</th>";
    print "<th>Synopsis</th></tr>\n";
  }
}

sub print_footer {
  if ($o{listhtml}) {
    print "</table>\n</body>\n</html>\n";
  }
}

sub get_readme {
  my $pp=$_[0];
  my ($id, $rev)= split (/-/, $pp);

  my $rfile="$o{tmpdir}/README.$pp" . time() . $$;
  $p{$id}{dlfile}=$rfile;
  print STDERR "Download README for $pp: " unless $o{proxy};

  # If patch is available in unzipped format, use its README
  if (-f "$o{patchdir}/$pp/README.$pp") {
    dbg ("Getting README from $o{patchdir}/$pp");
    copy ("$o{patchdir}/$pp/README.$pp", $rfile);
  }
  # If we have the zip file, extract README from there. This doesn't work
  # for tar/tar.Z files, as Sun's tar cannot extract files to stdout.
  if ((-f "$o{patchdir}/$pp.zip") && !$o{pforce}) {
    dbg ("Getting README from $o{patchdir}/$pp.zip");
    `$unzip -p $o{patchdir}/$pp.zip $pp/README.$pp >$rfile 2>/dev/null`;
  }
  # Try to get README from local patch server
  if ((! -s $rfile) && $o{patchurl} && ($o{patchurl} =~ /^file:/)) {
    my $path=$o{patchurl}; $path =~ s/^file://;
    dbg ("Getting README from $o{patchurl}");
    (-r "$path/README.$pp") && copy ("$path/README.$pp", $rfile);
  }
  if ((! -s $rfile) && $o{patchurl} && ($o{patchurl} =~ /^http:|^https:|^ftp/)) {
    dbg ("Getting README from $o{patchurl}");
    $o{wget} || err ("Can't find wget executable");
    my $force=''; if ($o{force} && ($o{patchurl} =~ /pca-proxy\.cgi/)) { $force=":force" }
    `$o{wget} $o{wgetq} -O $rfile $o{patchurl}README.$pp$force`;
  }
  # Try download from restricted patch server, if the user provided
  # Sun Online Account data
  if ((! -s $rfile) && $o{user} && $o{passwd}) {
    dbg ("Getting README from sunsolve.sun.com");
    $o{wget} || err ("Can't find wget executable");
    my $try=1;
    while ($try <= $o{dltries}) {
      my $furl= "$o{tmpdir}/furl." . time() . $$;
      open (FURL, ">$furl") || err ("Can't write $furl ($!)");
      print FURL "http://$o{user}:$o{passwd}\@sunsolve.sun.com/pdownload.do?target=$pp&method=r\n";
      close FURL; chmod 0600, $furl;
      `$o{wget} -i $furl $o{wgetq} $o{wgetproxy} -O $rfile`;
      unlink "$furl";
      if (!$? && (-s $rfile)) { last; }
      $try++; if ($try <= $o{dltries}) { sleep ($try*2) }
    }
  } else {
    dbg ("No Sun Online Account data provided");
  }
  $p{$id}{dlfile}="";

  if (-s $rfile) {
    print STDERR "done\n" unless $o{proxy};
    return ($rfile);
  } else {
    print STDERR "failed\n" unless $o{proxy};
    unlink ($rfile);
    return ();
  }
}

sub dbg {
  $o{debug} || return;
  print "## "; printf @_; print "\n";
}

sub calculateage {
  my ($tmonth, $day, $year)=split(/\//, $_[0]);
  my %months=("Jan",0,"Feb",1,"Mar",2,"Apr",3,"May",4,"Jun",5,"Jul",6,"Aug",7,"Sep",8,"Oct",9,"Nov",10,"Dec",11);
  my $month=$months{$tmonth};

  return (int(($currenttime-timelocal(0,0,0,$day,$month,$year))/86400));
}

sub lock_create {
  my $lockd=$_[0]; my $tag=$_[1]; my $maxretry=$_[2];
  my $lockf="$lockd/.pcaLock.$tag";

  lock_free ($lockd, $tag, $maxretry) || return (0);

  unlink "$lockf";
  sysopen (LOCKF, $lockf, O_RDWR|O_CREAT|O_EXCL) || err ("Can't write $lockf ($!)");
  print LOCKF "$$\n";
  close LOCKF;
  chmod 0666, $lockf;
  $locks{$tag}=$lockf;
  return (1);
}

sub lock_free {
  my $lockd=$_[0]; my $tag=$_[1]; my $maxretry=$_[2];
  my $lockf="$lockd/.pcaLock.$tag";

  my $retry=0;
  while ($retry < $maxretry) {
    if (-s "$lockf") {
      open (LOCKF, "<$lockf");
      chomp(my $pid = <LOCKF>);
      close LOCKF;
      if (kill (0, $pid) || ($! eq "Not owner")) {
        dbg ("Locking $lockf failed");
        $retry++;
        ($retry < $maxretry) && sleep (1);
        next;
      }
    }
    return (1);
  }
  return (0);
}

sub lock_remove {
  my $lockd=$_[0];
  my $tag=$_[1];

  unlink "$locks{$tag}";
  $locks{$tag}='';
}

sub log_msg {
  ($o{syslog}) && system("$o{logger} -t pca -p $o{syslog}.info \"@_\"");
}

sub err {
  if ($o{proxy}) {
    print "Content-type: text/plain\n";
    print "Status: 404 Not Found\n\n";
    print "Internal Error: @_\n";
  } else {
    print STDERR "\nERROR: @_\n";
  }
  cleanup();
  exit (1);
}

sub handler {
  err ("Caught a SIG@_");
}

sub cleanup {
  dbg ("Cleanup");
  if ($xrefdl) {
    dbg ("Removing $xrefdl");
    unlink "$xrefdl";
  }
  foreach my $id (keys %p) {
    if ($p{$id}{dlfile}) {
      dbg ("Removing $p{$id}{dlfile}");
      unlink "$p{$id}{dlfile}";
    }
  }
  if (@rlist) {
    dbg ("Removing @rlist");
    unlink (@rlist);
  }
  $patchxdir && rmtree ($patchxdir);
  foreach my $tag (keys %locks) {
    if ($locks{$tag}) {
      dbg ("Removing $locks{$tag}");
      unlink "$locks{$tag}";
    }
  }
  $sttyset && system "stty echo";
}

sub parse_args {
  # Get internal defaults
  foreach my $opt (@options) {
    my ($long, $short, $arg, $argtxt, $default, $help)=split (/\|/, $opt);
    if ($arg =~ /@/) {
      @{$o{$long}}=split (/ /, $default);
    } else {
      $o{$long}=$default;
    }
  }

  # Get defaults from optional configuration file(s)
  my @conf=(); my $conf_dbg='';
  push (@conf, dirname($0)."/pca.conf");
  push (@conf, dirname(dirname($0))."/etc/pca.conf");
  push (@conf, "/etc/pca.conf");
  $ENV{HOME} && push (@conf, $ENV{HOME}."/.pca");
  push (@conf, "pca.conf");

  foreach my $i (@conf) {
    open (CONF, "<$i") || next;
    $conf_dbg .= "$i ";
    while (<CONF>) {
      chomp;
      s/\s*#.*$//; s/^\s*//; s/\s*$//;
      next if /^$/;

      # Deprecated
      if (/(\d{6})\s+ignore/) { push (@{$o{ignore}}, $1); next }
      if (/(\d{6}-\d{2})\s+ignore/) { push (@{$o{ignore}}, $1); next }
      if (/(\d{6})\s+\+rec/) { push (@{$o{rec}}, $1); next }
      if (/(\d{6})\s+\+sec/) { push (@{$o{sec}}, $1); next }

      next unless (/(\w+)\s*=\s*(.+)/); my ($name, $value)=($1,$2);
      foreach my $opt (@options) {
        my ($long, $short, $arg, $argtxt, $default, $help)=split (/\|/, $opt);
        next if ($help eq "INTERNAL");
        next unless ($name eq $long);
        if ($arg =~ /@/) {
          push (@{$o{$long}}, split (/ /, $value))
        } else {
          $o{$long}=$value
        }
        last
      }
    }
  }

  # Get defaults from optional environment variables (PCA_*)
  foreach my $opt (@options) {
    my ($long, $short, $arg, $argtxt, $default, $help)=split (/\|/, $opt);
    next if ($help eq "INTERNAL");
    my $env=uc("PCA_$long");
    next unless ($ENV{$env});
    if ($arg =~ /@/) {
      push (@{$o{$long}}, split (/ /, $ENV{$env}))
    } else {
      $o{$long}=$ENV{$env}
    }
  }
  ($ENV{TMPDIR}) && (-d $ENV{TMPDIR}) && ($o{tmpdir}= $ENV{TMPDIR});

  # Proxy mode ?
  if (basename($0) eq "pca-proxy.cgi") {
    $o{proxy}=1;
    if ($#ARGV != 0) { err ("Missing argument") }
    if ($ARGV[0] =~ /:force/) { $ARGV[0] =~ s/:force//; $o{pforce}=1 }
    if ((($ARGV[0] !~ /^patchdiag.xref$/) &&
        ($ARGV[0] !~ /^\d{6}-\d{2}\.(zip|tar|tar\.Z)$/) &&
        ($ARGV[0] !~ /^README\.\d{6}-\d{2}$/))) {
      err ("Illegal argument");
    }
    $o{proxy}=$ARGV[0];
    $o{patchurl}=""; $o{xrefurl}=""; $o{noheader}=1; $o{safe}=0;
    $o{xrefdir}=$o{patchdir}=getcwd();
    $o{wgetproxy} && ($o{wgetproxy}="--execute http_proxy=$o{wgetproxy}");
    return;
  }

  # Get command line options
  my @olist=();
  foreach my $opt (@options) {
    my ($long, $short, $arg, $argtxt, $default, $help)=split (/\|/, $opt);
    next if (($help eq "INTERNAL") || ($help eq "ENVFILE"));
    $short && ($long="$long|$short");
    $arg && ($long="$long=$arg");
    push (@olist, $long);
  }
  Getopt::Long::config ("bundling", "no_ignore_case");
  GetOptions (\%o, @olist) || usage() && exit 1;

  if ($o{help}) { usage(); exit 0 }
  if ($o{version}) { version(); exit 0 }

  $o{listhtml} && ($o{list}=1);
  $o{pretend} && ($o{install}=1);
  $o{readme} && ($o{noheader}=1);
  $o{root} && ($o{root}="-R $o{root}");
  $o{nobackup} && ($o{patchadd_options}.="-d ");
  $o{backdir} && ($o{patchadd_options}.="-B $o{backdir} ");
  $o{currentzone} && ($o{patchadd_options}.="-G ");
  $o{wgetproxy} && ($o{wgetproxy}="--execute http_proxy=$o{wgetproxy}");
  $o{debug} && ($o{wgetq}='');
  if (!$o{patchurl} && $o{localurl}) { $o{patchurl}=$o{localurl} }
  if (!$o{xrefurl} && $o{localurl}) { $o{xrefurl}=$o{localurl} }
  if ($o{patchurl} && $o{patchurl} =~ /pca-proxy\.cgi$/) { $o{patchurl} .= "?"; }
  if ($o{xrefurl} && $o{xrefurl} =~ /pca-proxy\.cgi$/) { $o{xrefurl} .= "?"; }
  ($o{patchdir} !~ /^\//) && ($o{patchdir}= getcwd()."/$o{patchdir}");

  # Set defaults
  $o{operands} && !@ARGV && (@ARGV=(split (/\s+/, $o{operands})));
  ($o{download} || $o{install} || $o{readme} || $o{getxref}) || ($o{list}=1);

  foreach my $opt (@options) {
    my ($long, $short, $arg, $argtxt, $default, $help)=split (/\|/, $opt);
    if ($arg =~ /@/) {
      next unless (@{$o{$long}});
      dbg ("Option $long: @{$o{$long}}");
    } else {
      next if ($o{$long} eq $default);
      dbg ("Option $long: $o{$long}")
    }
  }
  dbg ("ARGV: @ARGV");
  dbg ("Version: $version");
  ($conf_dbg) && dbg ("Config files: $conf_dbg");

  foreach my $i (@{$o{ignore}}) {
    #dbg ("Ignore: $i");
    if ($i =~ /^(\d{6})$/) { init_patch($1); ($p{$1}{ignore}= "00"); next }
    if ($i =~ /^(\d{6})-(\d{2})$/) { init_patch($1); ($p{$1}{ignore}= $2); next }
    err ("Invalid patch ID with --ignore: $i")
  }
  foreach my $i (@{$o{rec}}) {
    #dbg ("Rec: $i");
    if ($i =~ /^(\d{6})(-\d{2})*$/) { init_patch($1); ($p{$1}{recf}= 1); next }
    err ("Invalid patch ID with --rec: $i")
  }
  foreach my $i (@{$o{sec}}) {
    #dbg ("Sec: $i");
    if ($i =~ /^(\d{6})(-\d{2})*$/) { init_patch($1); ($p{$1}{secf}= 1); next }
    err ("Invalid patch ID with --sec: $i")
  }
}

sub usage {
  print<<EOT
Usage: $0 [OPTION] .. [OPERAND] ..

Operands:
  patch group:    missing, installed, all, total, unbundled, bad
                  Add r, s or rs at the end to list Recommended,
                  Security or Recommended/Security patches only.
  patch ID:       123456, 123456-78
  patch file:     123456-78.zip, 123456-78.tar.Z
  file name:      patchlist.txt

Options:

EOT
;

  foreach my $opt (@options) {
    my ($long, $short, $arg, $argtxt, $default, $help)=split (/\|/, $opt);
    next if (($help eq "INTERNAL") || ($help eq "ENVFILE") || ($help eq "DEPRECATED"));
    $short && ($short="-$short,");
    $argtxt && ($long="$long=$argtxt");
    printf "  %3s --%-15s%s\n", $short, $long, $help;
  }
  return 1;
}

sub version {
  print "pca $version\n";
}