usr.sbin/pkg_install/update/pkg_update.pl

   1 #!/usr/bin/perl -w
   2
   3 # Copyright (c) 2000
   4 #  Paul Richards. All rights reserved.
   5 #
   6 # Redistribution and use in source and binary forms, with or without
   7 # modification, are permitted provided that the following conditions
   8 # are met:
   9 # 1. Redistributions of source code must retain the above copyright
  10 #    notice, this list of conditions and the following disclaimer,
  11 #    verbatim and that no modifications are made prior to this
  12 #    point in the file.
  13 # 2. Redistributions in binary form must reproduce the above copyright
  14 #    notice, this list of conditions and the following disclaimer in the
  15 #    documentation and/or other materials provided with the distribution.
  16 #
  17 # THIS SOFTWARE IS PROVIDED BY PAUL RICHARDS ``AS IS'' AND
  18 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  19 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 # ARE DISCLAIMED.  IN NO EVENT SHALL PAUL RICHARDS BE LIABLE
  21 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  23 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  24 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  25 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  26 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  27 # SUCH DAMAGE.
  28 #
  29 # $FreeBSD: src/usr.sbin/pkg_install/update/pkg_update.pl,v 1.4.2.1 2001/03/16 04:36:01 paul Exp $
  30 # $DragonFly: src/usr.sbin/pkg_install/update/Attic/pkg_update.pl,v 1.2 2003/06/17 04:29:59 dillon Exp $
  31 #/
  32
  33 use strict;
  34
  35 use File::Basename;
  36 use Getopt::Std;
  37
  38 my $PKG_DB = "/var/db/pkg";
  39 my $PKG_DEP_FILE = "+REQUIRED_BY";
  40
  41 my $PKG_ADD = "/usr/sbin/pkg_add";
  42 my $PKG_CREATE = "/usr/sbin/pkg_create";
  43 my $PKG_DELETE = "/usr/sbin/pkg_delete -f";
  44 my $PKG_INFO = "/usr/sbin/pkg_info -Ia";
  45
  46 sub error ($) {
  47         my ($error) = @_;
  48
  49         print STDERR $error, "\n";
  50 }
  51
  52 sub get_version($) {
  53         my ($pkg) = @_;
  54
  55         $pkg =~ /(.+)-([0-9\.]+)/;
  56         if (! $2) {
  57                 return($pkg, "");
  58         } else {
  59                 return ($1, $2);
  60         }
  61 }
  62
  63 sub get_requires($$) {
  64         my ($pkg, $requires) = @_;
  65
  66         my $file = "$PKG_DB/$pkg/$PKG_DEP_FILE";
  67
  68         if (! -f $file) {
  69                 # Not all packages have dependencies
  70                 return 1;
  71         }
  72
  73         if (! open(REQUIRES, "< $file")) {
  74                 error("Can't open $file, $!");
  75                 return 0;
  76         }
  77
  78         while (<REQUIRES>) {
  79                 chomp $_;
  80                 $$requires{$_} = 1;
  81         }
  82
  83         close(REQUIRES) || warn("Can't close $file, $!");
  84
  85         return 1;
  86 }
  87
  88 sub put_requires($$) {
  89         my ($pkg, $requires) = @_;
  90
  91         my $file = "$PKG_DB/$pkg/$PKG_DEP_FILE";
  92
  93         if (! open(REQUIRES, "> $file")) {
  94                 error("Can't open $file, $!");
  95                 return 0;
  96         }
  97
  98         my $req;
  99         for $req (keys %$requires) {
 100                 print REQUIRES $req, "\n";
 101         }
 102
 103         if (! close(REQUIRES)) {
 104                 error("Can't close $file, $!");
 105                 return 0;
 106         }
 107
 108         return 1;
 109 }
 110
 111 #
 112 # Start of main program
 113 #
 114
 115 my @installed;
 116 my %requires;
 117 my $pkg = "";
 118 my $update_pkg = "";
 119
 120 use vars qw($opt_a $opt_c $opt_v $opt_r $opt_n);
 121 getopts('acnvr:');
 122
 123 if ($opt_a && $opt_c) {
 124         die("Options 'a' and 'c' are mutually exclusive");
 125 }
 126
 127 if ($opt_v) {
 128         $PKG_DELETE .= " -v";
 129         $PKG_ADD .= " -v";
 130         $PKG_CREATE .= " -v";
 131 }
 132
 133 if ($opt_n) {
 134         $PKG_DELETE .= " -n";
 135         $PKG_ADD .= " -n";
 136 }
 137
 138 if (scalar @ARGV < 1) {
 139         die("No package specified.\n");
 140 } elsif (scalar @ARGV > 1) {
 141         die("Only one package may be updated at a time.\n");
 142 }
 143
 144 my $pkgfile = $ARGV[0];
 145 if (! -f $pkgfile) {
 146         die("Can't find package file $pkgfile\n");
 147 }
 148
 149 my $newpkg = basename($pkgfile, '.tgz');
 150 my ($pkgname, $new_version) = get_version($newpkg);
 151
 152 if ($opt_r && $opt_r ne "") {
 153         my ($old_pkg, $old_version) = get_version($opt_r);
 154         print "Updating $old_pkg package version ";
 155         print "$old_version to $new_version\n";
 156         $update_pkg = $opt_r;
 157 } else {
 158         print "Updating $pkgname packages to version $new_version\n";
 159         $update_pkg = $pkgname;
 160 }
 161
 162 # Safety net to prevent all packages getting deleted
 163 if ($update_pkg eq "") {
 164         die ("Package to update is empty, aborting\n");
 165 }
 166
 167 # Find out what package versions are already installed
 168
 169 open(PKGINFO, "$PKG_INFO|") || die("Can't run $PKG_INFO, $!");
 170
 171 while (<PKGINFO>) {
 172         my ($pkg) = /^(.*?)\s+.*/;
 173
 174         if ($pkg =~ /^$update_pkg-[0-9\.]+/) {
 175                 push(@installed, $pkg);
 176         }
 177 }
 178
 179 close(PKGINFO) || die("Couldn't close pipe from $PKG_INFO, $!");
 180
 181 if (scalar @installed == 0) {
 182         if (! $opt_r) {
 183                 die("There are no $pkgname packages installed.\n");
 184         } else {
 185                 die("Package $opt_r is not installed.\n");
 186         }
 187 }
 188
 189 # For each installed package that matches get the dependencies
 190 my $old_pkg;
 191 for $old_pkg (@installed) {
 192         if (! get_requires($old_pkg, \%requires)) {
 193                 die("Failed to get requires from $old_pkg\n");
 194         }
 195 }
 196
 197 # Now delete all currently installed packages
 198 for $old_pkg (@installed) {
 199         if (! system("$PKG_DELETE $old_pkg")) {
 200                 print "Deleted $old_pkg\n" if ($opt_v);
 201         } else {
 202                 error("Couldn't remove package $old_pkg, $!");
 203         }
 204 }
 205
 206 if (system("$PKG_ADD $pkgfile")) {
 207         error("Command '$PKG_ADD $newpkg' failed, $!");
 208         if (scalar keys %requires) {
 209                 print "The following packages depended on previously\n";
 210                 print "installed versions of $pkgname.\n";
 211                 print "You need to add them to the +REQUIRES file when you\n";
 212                 print "succeed in installing $newpkg.\n";
 213                 my $req;
 214                 for $req (keys %requires) {
 215                         print $req, "\n";
 216                 }
 217         }
 218 } else {
 219         put_requires($pkgname . "-" . $new_version, \%requires);
 220 }
 221
 222 exit;