src/afsinstall/bin/AFSinstall

   1 #!/bin/perl
   2 # Copyright 2000, International Business Machines Corporation and others.
   3 # All Rights Reserved.
   4 #
   5 # This software has been released under the terms of the IBM Public
   6 # License.  For details, see the LICENSE file in the top-level source
   7 # directory or online at http://www.openafs.org/dl/license10.html
   8
   9 # A Perl5 script to install AFS from a distribution directory. Installs in
  10 # sets called "packages", and offers a Tk based GUI for ease of use.
  11 #
  12
  13 $| = 1;
  14 $Debug = 0;
  15 $RSHas = "root";   # Default ID to use for remote installs through rsh
  16 $Wish = "wish4.0"; # Location of Tcl/Tk shell
  17 $Indent = "    ";  # Indent package output lines with this string
  18
  19 &GetPaths;
  20 &GetSysname;
  21 &ReadConfigFile;
  22 &ParseArgs;
  23 if ($GUI) {
  24   &RunGUI;  }
  25 else {
  26   &CommandlineInstallPackages;  };
  27
  28
  29
  30
  31
  32 #
  33 # Find out where this script is. The InstallGuides ought to be in a directory
  34 # next to this script
  35 #
  36 sub GetPaths {
  37   my($libs);
  38   $Command = $0;
  39   $Command =~ s:.*/::;
  40
  41   $BinDir = $0;
  42   $BinDir =~ s:$Command$::;
  43   $BinDir = "." if ($BinDir eq "");
  44   chdir($BinDir);
  45   $BinDir = `/bin/pwd`;  chop $BinDir;
  46
  47   $Command = "$BinDir/$Command";
  48
  49   $libs = $BinDir;
  50   $libs =~ s:bin$:lib:;
  51   require "$libs/patch.pl";
  52
  53   $InstallGuideDir = "$libs/InstallGuides";
  54 }
  55
  56
  57
  58
  59 # Try to deduce the system type
  60 sub GetSysname {
  61   my($OS, $revision, $version, $hardware);
  62
  63   if (!$ENV{HOST}) {
  64     $ENV{HOST} = `/bin/uname -n`;
  65     chop $ENV{HOST}; };
  66
  67   if ($ENV{SYS_NAME}) {
  68     $Sysname = $ENV{SYS_NAME};
  69     return;  };
  70
  71   $OS = `/bin/uname -s`;  chop $OS;
  72   $revision = `/bin/uname -r`; chop $revision;
  73   $revision =~ s/\.//g;  # x.y.z   -->  xyz
  74   $version  = `/bin/uname -v`; chop $version;
  75
  76   if ($OS eq "AIX") {
  77     $revision = "2" if ($version == 4 && $revision == 3);
  78     $Sysname = "rs_aix$version$revision";  };
  79
  80   if ($OS eq "HP-UX") {
  81     $revision =~ s/^[A-Z]*//;
  82     $revision =~ s/^0//;
  83     chop $revision;   # only 2 digits are used for HPUX
  84
  85     if ($revision < 102) {
  86       $hardware = `/bin/uname -m`; chop $hardware;
  87       $hardware =~ s:.*/(.).*:${1}00:; };
  88     $Sysname = "hp${hardware}_ux$revision";  };
  89
  90   if ($OS =~ /IRIX/) {
  91     $Sysname = "sgi_$revision";  };
  92
  93   if ($OS eq "OSF1") {
  94     $revision =~ s/^V//;
  95     $revision = "32c" if ($version == 148);
  96     $version = "osf";
  97     $version = "dux" if ($revision >= 4  && $revision < 10);
  98     $version = "dux" if ($revision >= 40 && $revision < 100);
  99     $Sysname = "alpha_$version$revision";  };
 100
 101   if ($OS eq "SunOS") {
 102     $hardware = `/bin/uname -m`; chop $hardware;
 103     $revision = int($revision/10) if ($revision >= 500);
 104     $hardware = "sun4x" if ($revision >= 55 && $revision < 100);
 105     $revision = 412 if ($revision == 413);
 106     $Sysname = "${hardware}_$revision"; }
 107 }
 108
 109
 110
 111
 112 # Read the config file afsinstall.rc to find out the install path buttons for
 113 # the GUI, the default install path, the package names and descriptions and
 114 # the client configuration options
 115 #
 116 sub ReadConfigFile {
 117   my(@RCfiles, $rc, $filename, $name, $line, @fields, $value);
 118   unshift(@Section, "Reading Config File");
 119
 120   # Read in the GENERIC afsinstall.rc file for basic options, then read the
 121   # system specific file, then potentially read a custome file in the user's
 122   # home directory
 123   push(@RCfiles, "$InstallGuideDir/GENERIC/afsinstall.rc");
 124
 125   # The system specific file
 126   $filename = &PickInstallGuide("afsinstall.rc");
 127   unless($filename eq "N/A" || $filename eq "SKIP" || $filename =~ /GENERIC/) {
 128     push(@RCfiles, $filename);  };
 129
 130   # The personal file
 131   $filename = $ENV{'HOME'};
 132   $filename .= "/" unless ($filename =~ /\/$/);
 133   $filename .= ".afsinstall.rc";
 134   for $name (0 .. $#ARGV) {
 135     next unless (@ARGV[$name] =~ /^-pref/);
 136     $filename = @ARGV[$name + 1];
 137     last; };
 138   push(@RCfiles, $filename);
 139
 140   for $filename (@RCfiles) {
 141     $rc = open(RC, $filename);
 142     next if (!$rc);
 143
 144     while ($line = <RC>) {
 145       chomp $line;
 146       next if ($line =~ /\#/);
 147       next if ($line =~ /^$/);
 148       # Look for leading "sysname:" string
 149       if ($line =~ /^(\s*([a-zA-Z_0-9]*)\s*:)/) {
 150         $specific = $1;
 151         $sys = $2;
 152         $sys =~ s:x:\.\*:g;
 153         $sys =~ tr/A-Z/a-z/;
 154         next unless ($Sysname =~ /$sys/);
 155         $line =~ s/^$specific//; }
 156       # Read possible install paths
 157       if ($line =~ /^\s*\w+\s+\//) {
 158         @fields = split(/\s+/, $line);
 159         shift(@fields) if (@fields[0] eq "");
 160         $name = shift @fields;
 161         $value = shift @fields;
 162         $DefaultPaths{$name} = $value;
 163         if ($name ne "default") {
 164           unless (grep(/^$name$/, @DefaultPathsList)) {
 165             push(@DefaultPathsList, $name);  } }
 166         else {
 167           $InstallPath = $value;  }
 168         next;  }
 169       # Read package names
 170       if ($line =~ /^\s*\w+\s+\d\s*.*/) {
 171         @fields = split(/\s+/, $line);
 172         shift(@fields) if (@fields[0] eq "");
 173         $name = shift @fields;
 174         $InstallByDefault{$name} = shift @fields;
 175         $PkgDescription{$name} =  join(" ", @fields) if ($#fields >= 0);
 176         unless (grep(/^$name$/, @AvailPackages)) {
 177           push(@AvailPackages, $name);  }
 178         next;  };
 179
 180       # Read configuration options
 181       if ($line =~ /\w+=.*/) {
 182         ($name,$value) = split(/=/, $line);
 183         $Configuration{$name} = $value;
 184         next;
 185       }
 186       &ErrorMsg("Unable to parse line in $filename: $line");
 187     }
 188     close(RC);
 189   }
 190   shift @Section;
 191 }
 192
 193
 194
 195
 196 # Parse the command line args.
 197 sub ParseArgs {
 198   my($pkgs, $arg);
 199   unshift(@Section, "Initialization");
 200   while ($arg = shift @ARGV) {
 201     if ($arg =~ /^-h/)   { &Usage;  };
 202     if ($arg eq "-v"  )  { $InstallVerbose = 1;           $pkgs = 0; next;  };
 203     if ($arg eq "-gui")  { $GUI = 1;                      $pkgs = 0; next;  };
 204     if ($arg eq "-info") { $InfoOnly= 1;                  $pkgs = 0; next;  };
 205     if ($arg eq "-src")  { $InstallPath = shift @ARGV;    $pkgs = 0; next;  };
 206     if ($arg =~ /^-pref/){ shift @ARGV;                   $pkgs = 0; next;  };
 207     if ($arg =~ /^-noback/){ $NoOldFiles = 1;             $pkgs = 0; next;  };
 208     if ($arg eq "-pkg")  { $arg = shift @ARGV;            $pkgs = 1;        };
 209     if ($pkgs)  {
 210       push(@Packages, $arg) unless grep(/^$arg$/, @Packages);
 211       next;  };
 212     &ErrorMsg("Unknown arg", $arg);
 213     exit;  };
 214
 215   # If no packages specified, install default packages in afsinstall.rc file.
 216   if ($#Packages >= 0) {
 217     undef %InstallByDefault;
 218     for $pkgs (@Packages) {
 219       $InstallByDefault{$pkgs} = 1;  };
 220     $InstallSet = "custom"; }
 221   else {
 222     if (!$GUI) {
 223       for $pkgs (@AvailPackages) {
 224         push(@Packages, $pkgs) if ($InstallByDefault{$pkgs});  };  }
 225     else {
 226       @Packages = @AvailPackages;  };
 227     $InstallSet = "default";  };
 228
 229   if ($GUI || $InfoOnly) {
 230     shift @Section;
 231     return; };
 232
 233   # Where to find the distribution.
 234   if ($InstallPath eq "") {
 235     &ErrorMsg("You need to specify a source directory with -src");
 236     exit;  };
 237   foreach $subdir ("", "/$Sysname", "/$Sysname/dest") {
 238     next if (!-d "$InstallPath$subdir/root.client" );
 239     $InstallPath .= $subdir;
 240     last;  };
 241   if (!-d "$InstallPath/root.client") {
 242     &ErrorMsg("No AFS distribution under $InstallPath for type", $Sysname);
 243     exit 1;  };
 244   shift @Section;
 245 }
 246
 247
 248
 249
 250 sub Usage {
 251   print <<"EOUSAGE";
 252
 253 Usage: AFSinstall.pl -pkg <package>+ -src <srcdir> [-nobackup] [-v] [-gui]
 254
 255   <package>  Specify what package(s) to install
 256   <srcdir>   Specifies the AFS build tree from which to fetch the files.
 257              The subdirectories ".", <sysname>, and <sysname>/dest will
 258              be searched
 259   [-noback]  Do not keep previous copy of replaced files as .old files
 260   [-v]       Verbose output
 261   [-gui]     Use a graphical interface to select and install packages
 262
 263 EOUSAGE
 264   exit;
 265 }
 266
 267
 268
 269
 270
 271 #
 272 #  Command line install
 273 #
 274
 275
 276 sub CommandlineInstallPackages {
 277   my($Package, $InstallGuide, $exitcode);
 278   foreach $Package (@Packages) {
 279     unshift(@Section, $Package);
 280     print "\nInstalling package $Package\n";
 281
 282     # Find package
 283     if ($InfoOnly) {
 284       $InstallGuide = "$InstallGuideDir/info/$Package.toc";  }
 285     else {
 286       $InstallGuide = &PickInstallGuide($Package);  };
 287
 288     if ($InstallGuide eq "SKIP") {
 289       print  "Package $Package does not apply to $Sysname\n";
 290       shift @Section;
 291       next;  };
 292     if ($InstallGuide eq "N/A") {
 293       &ErrorMsg("No package named $Package for $Sysname systems\n");
 294       $exitcode++;
 295       shift @Section;
 296       next;  }
 297
 298     &ReadInstallGuide ($InstallGuide);
 299     chdir($InstallPath);
 300     &ErrorsAreFatal(0);
 301     if (!defined(&$Package)) {
 302       &ErrorMsg("Subroutine for $Package isn't defined in Install Guide",
 303                 $InstallGuide);
 304       shift @Section;
 305       next;  };
 306     DOPACKAGE: { &$Package;  };  };
 307   exit $exitcode;
 308 }
 309
 310
 311
 312
 313 # Try to find the package among the install guide directories. First look in
 314 # the directory matching the sysname. If the package isn't there, go to the
 315 # gerenalized sysnames. They have names like ALPHA_x, HPx_10x, or SGI_6x
 316 # Find the longest matching generalized sysname that has the package.
 317 # If no generalized sysnames have the package, use the GENERIC sysname.
 318 sub PickInstallGuide {
 319   my($pkg, $best, $caps, $candidate, $wildcard, $skip);
 320   $pkg = @_[0];
 321
 322   if (-f "$InstallGuideDir/$Sysname/$pkg") {
 323     return "$InstallGuideDir/$Sysname/$pkg";  };
 324   if (-f "$InstallGuideDir/$Sysname/$pkg.skip") {
 325     return "SKIP";  };
 326
 327   $caps = $Sysname;
 328   $caps =~ tr/a-z/A-Z/;
 329
 330   opendir(IG, $InstallGuideDir);
 331   while ($candidate = readdir(IG)) {
 332     next unless ($candidate =~ /[A-Z]/);
 333     next if ($candidate eq "GENERIC");
 334     $wildcard = $candidate;
 335     $wildcard =~ s/x/.*/g;
 336     next unless ($caps =~ /$wildcard/);
 337     if (-f "$InstallGuideDir/$candidate/$pkg") {
 338       $best = $candidate if (length($candidate) > length($best));
 339       $skip = 0;  };
 340     if (-f "$InstallGuideDir/$candidate/$pkg.skip") {
 341       $best = $candidate if (length($candidate) >= length($best));
 342       $skip = 1;  };  };
 343   closedir(IG);
 344   return("SKIP") if ($skip);
 345   $best = "GENERIC" if ($best eq "");
 346
 347   return("N/A") unless (-f "$InstallGuideDir/$best/$pkg");
 348   return("$InstallGuideDir/$best/$pkg");
 349 }
 350
 351
 352
 353
 354
 355 #
 356 # GUI section
 357 #
 358
 359
 360 # The main input routine. It creates the selection window and reads input from
 361 # it on READTCL. Once install(s) start, it adds their file descriptors to the
 362 # vector ReadVec and select()'s on them as well
 363 sub RunGUI {
 364   my($selected, $command, $i, $fh, $hostname, $output, $line, $rc);
 365   local($ReadVec);
 366   &ForkTCL;
 367   &DrawMainWindow;
 368   vec($ReadVec, fileno(READTCL), 1) = 1;
 369   while(1) {
 370     select($selected = $ReadVec, undef, undef, undef);
 371     if (vec($selected, fileno(READTCL), 1)) {
 372       $command = &TclRead;
 373       print "Command: [$command]\n" if ($Debug >= 1);
 374       if ($command =~ /HOST:/)   { &NewHost($command);              next;  };
 375       if ($command =~ /SHOW:/)   { &ForceOutputWindow($command);    next;  };
 376       if ($command =~ /STOP:/)   { &EndInstall($command);           next;  };
 377       if ($command =~ /DISMISS:/){ &DestroyOutputWindow($command);  next;  };
 378       if ($command eq "DEFAULT") { &DisablePackages;                next;  };
 379       if ($command eq "CUSTOM")  { &EnablePackages;                 next;  };
 380       if ($command eq "PROG")    { &DestroyProgressWindow;          next;  };
 381       if ($command eq "HELP")    { &GUIHelp;                        next;  };
 382       if ($command eq "INFO")    { &GUIInstall(" -info -v");        next;  };
 383       if ($command eq "INSTALL") { &GUIInstall;                     next;  };
 384       if ($command eq "EXIT")    {                                  last;  };
 385       print "Unknown command from GUI: \"$command\" \n";  };
 386
 387     # Check if any pipes produced output
 388     for $i (0 .. $#InstallHosts) {
 389       $fh = "COM$i";
 390       next unless (vec($selected, fileno($fh), 1));
 391       $hostname = @InstallHosts[$i];
 392       $output = "HostOutput$hostname";
 393
 394       # Read output from install command
 395       print STDOUT "Reading from file handle \"$fh\" \n" if ($Debug >= 3);
 396       $line = <$fh>;      chop $line;
 397       print STDOUT "Subprocess $i: ($.) [$line]\n" if ($Debug >= 3);
 398
 399       if ($line) {
 400         if (&TkWidgetExists(".out$i")) {
 401           &AppendOutputWindow($i, $line); };
 402
 403         push(@$output, $line);  };
 404
 405       # Terminate quickly if rsh is failing
 406       if ($line eq "No remote authentication") {
 407         &ErrorWindow(" Rsh is not working on ", $hostname);
 408         @InstallResult[$i] = "FAILED";
 409         &EndInstall($i);
 410         next;  };
 411
 412       # Terminate quickly if Perl is wrong version
 413       if ($line =~ /syntax error.*my\(/i) {
 414         &ErrorWindow("Perl must be version 5 on", $hostname);
 415         &EndInstall($i);
 416         &DestroyOutputWindow($i);
 417         undef @$output;
 418         next;  };
 419
 420       # Fill in status boxes in Progress window as package names appear
 421       if ($line =~ /Installing package /) {
 422         $nextpkg = $';
 423         if (@Installing[$i]) {
 424           &TclPrint("set InstallResult-$i-@Installing[$i] SUCCESS"); };
 425         @Installing[$i] = $nextpkg;
 426         &TclPrint("set InstallResult-$i-@Installing[$i] WORKING"); };
 427
 428       # If an error occurs, put an error message in package's result box.
 429       # Set the @Installing package name to "error" so that when the next
 430       # package name comes up this one doesn't get reset to "success"
 431       if ($line =~ /^ *ERROR:/) {
 432         if (@Installing[$i]) {
 433           &TclPrint("set InstallResult-$i-@Installing[$i] ERROR");
 434           @Installing[$i] = "ERROR"; };
 435         @InstallResult[$i] = "ERRORS"; };
 436
 437       # When installation is done, set the last status box to done. If it
 438       # had an error, the @Installing pkg name is safely set to ERROR anyway.
 439       # If no packages were installed, it's a failure.
 440       # End the installation
 441       if (eof($fh)) {
 442         if (@Installing[$i]) {
 443           &TclPrint("set InstallResult-$i-@Installing[$i] SUCCESS"); }
 444         else {
 445           @InstallResult[$i] = "FAILED"; }
 446         &EndInstall($i); }; }; };
 447
 448   &TclPrint("exit");
 449 }
 450
 451
 452
 453
 454 # Create a TCL process and attach its STDOUT and STDIN to this Perl script
 455 sub ForkTCL {
 456   my($ready);
 457   pipe R0, WRITETCL;
 458   pipe READTCL, W1;
 459   $TclPid = fork;
 460   if ($TclPid == 0) {
 461     open(STDIN,  "<&R0");
 462     open(STDOUT, ">&W1");
 463     close(WRITETCL);
 464     close(READTCL);
 465     select(STDOUT);
 466     exec $Wish;
 467     print "Could not run wish4.0\n";
 468     exit;  };
 469
 470   vec($ready, fileno(WRITETCL), 1) = 1;
 471   select(undef, $ready, undef, 5);
 472   if (vec($ready, fileno(WRITETCL), 1) == 0) {
 473     print "Tcl/Tk didn't start\n";
 474     exit; };
 475
 476   close(R0);
 477   close(W1);
 478   select WRITETCL;
 479   $| = 1;
 480   &TclPrint("wm geometry . 100x200+50+50");
 481   &TclPrint("proc print {args} { puts \"[lrange \$args 0 end]\"; \\");
 482   &TclPrint( "flush stdout }");
 483   select STDOUT;
 484 }
 485
 486
 487
 488
 489 sub DrawMainWindow {
 490   my($path, $safepath, $pkg, $n, $packer, $shortpacker, $fit);
 491   # Typical attributes
 492   $packer      = " -anchor w -padx 10 -pady 5 ";
 493   $shortpacker = " -anchor w -padx 10";
 494   $fit = " -fill x -expand 1";
 495
 496   &TclPrint("wm title . \"AFS Install\" ");
 497
 498   # Header
 499   &TclPrint("set Hostname $ENV{HOST}");
 500   &TclPrint("frame .host -rel flat -height 3");
 501   &TclPrint("frame .host.name -rel flat");
 502   &TclPrint("label .host.name.l -text Hostname: -width 16 -anchor w");
 503   &TclPrint("entry .host.name.e -textvar Hostname -bd 2 -rel sunk");
 504   &TclPrint("bind  .host.name.e <Key-Return> {print \"HOST:\$Hostname\"}");
 505   &TclPrint("pack  .host.name.l -side left");
 506   &TclPrint("pack  .host.name.e -side right -anchor e $fit");
 507   &TclPrint("pack  .host.name $shortpacker $fit");
 508   &TclPrint("pack  .host $packer $fit");
 509
 510   # Path
 511   &TclPrint("set Path \"$InstallPath\"");
 512   &TclPrint("frame .path -rel raised -bd 2");
 513   &TclPrint("label .path.l -text Path -anchor w");
 514   &TclPrint("entry .path.e -textvar Path -wid 50 -bd 2 -rel sunk");
 515   &TclPrint("frame .path.go -rel flat");
 516
 517   $n=0;
 518   for $path (@DefaultPathsList) {
 519     $safepath = $path;
 520     $safepath =~ s/\$/\\\$/;
 521     &TclPrint("button .path.go.g$n -text \"$safepath\" \\");
 522     &TclPrint( "-command { set Path \"$DefaultPaths{$path}\" } -bd 2");
 523     &TclPrint("pack .path.go.g$n -side left");
 524     $n++;  };
 525   &TclPrint("button .path.go.g$n -text CLEAR -command {set Path \"\"} -bd 2");
 526   &TclPrint("pack .path.go.g$n -side left");
 527
 528   &TclPrint("pack .path.l .path.e $packer $fit");
 529   &TclPrint("pack .path.go $shortpacker $fit");
 530   &TclPrint("pack .path $packer $fit");
 531
 532   # packages
 533   &TclPrint("frame .pkgchoose -rel raised -bd 2");
 534   &TclPrint("label .pkgchoose.l -text Packages ");
 535   &TclPrint("pack  .pkgchoose.l $packer");
 536
 537   &TclPrint("set InstallSet $InstallSet");
 538   &TclPrint("radiobutton .pkgchoose.default -text \\");
 539   &TclPrint( "\"Default Installation\" -var InstallSet -value default");
 540   &TclPrint("radiobutton .pkgchoose.custom -text \"Custom Installation:\" \\");
 541   &TclPrint( "-var InstallSet -value custom");
 542   &TclPrint(".pkgchoose.default config -command { print DEFAULT }");
 543   &TclPrint(".pkgchoose.custom config -command { print CUSTOM }");
 544   &Hilight(".pkgchoose.default", "#B04040");
 545   &Hilight(".pkgchoose.custom", "#B04040");
 546   &TclPrint("pack .pkgchoose.default .pkgchoose.custom $shortpacker");
 547   &TclPrint("pack .pkgchoose $shortpacker $fit");
 548
 549   &TclPrint("frame .pkg -rel raised -bd 2");
 550   $n=0;
 551   for $pkg (@AvailPackages) {
 552     &TclPrint("set cb$n ", 0 + $InstallByDefault{$pkg});
 553     &TclPrint("checkbutton .pkg.c$n -text \"$PkgDescription{$pkg}\" \\");
 554     &TclPrint( "-var cb$n");
 555     &Hilight(".pkg.c$n", "#B04040");
 556     &TclPrint("pack .pkg.c$n $shortpacker");
 557     $n++;  };
 558
 559   &DisablePackages if ($InstallSet eq "default");
 560   &TclPrint("pack .pkg $shortpacker $fit");
 561
 562   # Options
 563   &TclPrint("frame .opt -rel raised -bd 2 ");
 564   &TclPrint("label .opt.label -text Options ");
 565   &TclPrint("pack .opt.label $shortpacker");
 566
 567   &TclPrint("set Verbose 1") if ($InstallVerbose);
 568   &TclPrint("checkbutton .opt.verbose -text Verbose -var Verbose ");
 569   &Hilight (".opt.verbose", "#B04040");
 570   &TclPrint("pack .opt.verbose $shortpacker");
 571
 572   &TclPrint("set Nooldfiles 1") if ($NoOldFiles);
 573   &TclPrint("checkbutton .opt.backup -text \"Don't keep backup files\" \\");
 574   &TclPrint(" -var Nooldfiles");
 575   &Hilight (".opt.backup", "#B04040");
 576   &TclPrint("pack .opt.backup $shortpacker");
 577
 578   &TclPrint("pack .opt $packer $fit");
 579
 580   # Actions
 581   &TclPrint("frame  .action -rel flat -bd 2");
 582   &TclPrint("button .action.exit -text EXIT -command {print EXIT} -bd 2");
 583   &TclPrint("button .action.help -text HELP -command {print HELP} -bd 2");
 584   &TclPrint("button .action.info -text \"INFO ONLY\" -com {print INFO} -bd 2");
 585   &TclPrint("button .action.go   -text INSTALL  -com {print INSTALL} -bd 2");
 586   &TclPrint("pack   .action.exit .action.help -side left");
 587   &TclPrint("pack   .action.go .action.info -side right");
 588   &TclPrint("pack   .action $packer  -fill x -expand 1");
 589
 590   &TclPrint("wm geometry . \"\"");
 591 }
 592
 593
 594
 595
 596 # After user presses ENTER in Hostname: box, determine if newly entered
 597 # hostname is local machine or a remote machine or a filename
 598 sub NewHost {
 599   my($hostname);
 600   $hostname = @_[0];
 601   $hostname =~ s/^HOST://;
 602
 603   if (-f $hostname && -r $hostname) {
 604     &TclPrint(".host.name.l configure -text Filename: ");  }
 605   else {
 606     &TclPrint(".host.name.l configure -text Hostname: ");  };
 607
 608   # Local install
 609   if ($hostname eq $ENV{HOST})  {
 610     return unless (&TkWidgetExists(".host.id"));
 611     &TclPrint("destroy .host.id");
 612     return; };
 613
 614   # Remote install
 615   return if (&TkWidgetExists(".host.id"));
 616   &TclPrint("set UserID $RSHas");
 617   &TclPrint("frame .host.id -rel flat");
 618   &TclPrint("label .host.id.l -text \"rsh as username:\" -width 16");
 619   &TclPrint("entry .host.id.e -textvar UserID -bd 2 -rel sunk");
 620   &TclPrint("pack  .host.id.l -side left -anchor w");
 621   &TclPrint("pack  .host.id.e -side right -ancho e -fill x -expand 1");
 622   &TclPrint("pack  .host.id -side top -padx 10 -after .host.name \\");
 623   &TclPrint(" -fill x -expand 1");
 624 }
 625
 626
 627
 628
 629
 630 #
 631 # The "Default" installation is selected, so turn off the packages
 632 #
 633 sub DisablePackages {
 634   local($pkg, $n);
 635   $n = 0;
 636   for $pkg (@AvailPackages) {
 637     &TclPrint(".pkg.c$n config -state disabled");
 638     &TclPrint(".pkg.c$n config -selectcolor [ .pkg cget -bg ]");
 639     $n++;  };
 640 }
 641
 642
 643 #
 644 # The "Custom" installation is selected, so turn on the packages
 645 #
 646 sub EnablePackages {
 647   local($pkg, $n);
 648   $n = 0;
 649   for $pkg (@AvailPackages) {
 650     &TclPrint(".pkg.c$n config -state normal");
 651     &Hilight(".pkg.c$n", "#B04040");
 652     $n++;  };
 653 }
 654
 655
 656
 657
 658
 659 #
 660 # GUI Based install procedure
 661 #
 662
 663 # Help screen
 664 sub GUIHelp {
 665   my($line, $rc);
 666
 667   $rc = open(HELP, "$InstallGuideDir/info/gui.toc");
 668   if (!$rc) {
 669     &ErrorWindow("Sorry, could not find the help file");
 670     return; };
 671
 672   &CreateOutputWindow(0, "help");
 673   while ($line = <HELP>) {
 674     chop $line;
 675     $line =~ s/\"/\\\"/g;
 676     &AppendOutputWindow(0, $line); };
 677   close(HELP);
 678   &TclPrint(".out0.f.t see 1.0");
 679 }
 680
 681
 682
 683
 684 # Start up all pipes to start installs. Also set ReadVec with bits for all
 685 # running pipes.
 686 sub GUIInstall {
 687   my($rc);
 688   if (&TkWidgetExists(".prog")) {
 689     &ErrorWindow("Please close the current install window first");
 690     return; };
 691
 692   $rc = &GatherData(@_);
 693   return if ($rc);
 694
 695   $rc = &StartInstalls;
 696   return if ($rc);
 697
 698   if (@_[0]) {
 699     &CreateOutputWindow(0, @InstallHosts[0]);  }
 700   else {
 701     &CreateProgressWindow; };
 702 }
 703
 704
 705
 706
 707 # Get the data in the boxes of the window.
 708 # Sets @InstallHosts, $InstallID, $InstallPath, $InstallPkgs,
 709 # $InstallVerbose, and $InstallOpts
 710 #
 711 sub GatherData {
 712   my($pkg, $hostORfilename, $rc);
 713
 714   @InstallHosts = ($ENV{HOST});
 715   undef $InstallID;
 716   $InstallPkgs = "";
 717   $InstallOpts = @_[0];  # This will be "-info -v" for Info Only install
 718
 719   # Read the package checkbuttons. Build a list of selected package names
 720   &TclPrint("print \$InstallSet install");
 721   $InstallSet = &TclRead;
 722   if ($InstallSet eq "custom install") {
 723     for $pkg (0 .. $#AvailPackages) {
 724       &TclPrint("print \$cb$pkg");
 725       $InstallPkgs .= " @AvailPackages[$pkg]" if (&TclRead);  };
 726     $InstallPkgs =~ s/^ //;
 727     if (!$InstallPkgs) {
 728       &ErrorWindow("No install packages specified");
 729       return 1;  }; };
 730
 731   return 0 if ($InstallOpts);  # Info only install
 732
 733   # Get the hostname or filename to install on
 734   &TclPrint("print \$Hostname");
 735   $hostORfilename = &TclRead;
 736   if (!$hostORfilename) {
 737     &ErrorWindow("Need to specify a hostname at top");
 738     return 1;  };
 739
 740   # File containing hostnames
 741   if (-f $hostORfilename) {
 742     undef @InstallHosts;
 743     $rc = open(HOSTS, $hostORfilename);
 744     if (!$rc) {
 745       &ErrorWindow("Cannot read", $hostORfilename);
 746       return 1; };
 747     @InstallHosts = <HOSTS>;
 748     chomp @InstallHosts;
 749     close(HOSTS); }
 750   else {
 751     @InstallHosts = ($hostORfilename); };
 752
 753   # Remote host named. Get the username under which to rsh
 754   if ($hostORfilename ne $ENV{HOST}) {
 755     if (&TkWidgetExists(".host.id")) {
 756       &TclPrint("print \$UserID");
 757       $InstallID = &TclRead; };
 758     $InstallID = $RSHas  if (!$InstallID);  };
 759
 760   &TclPrint("print \$Path");
 761   $InstallPath = &TclRead;
 762   if (!$InstallPath) {
 763     &ErrorWindow("Need to specify a path to install from");
 764     return 1;  };
 765
 766   &TclPrint("print \$Verbose");
 767   $InstallVerbose = &TclRead;
 768   $InstallOpts .= "-v "   if ($InstallVerbose);
 769
 770   &TclPrint("print \$Nooldfiles");
 771   $NoOldFiles = &TclRead;
 772   $InstallOpts .= "-nobackup "   if ($NoOldFiles);
 773
 774   return 0;
 775 }
 776
 777
 778
 779
 780 # Start all install processes. Splice out hostnames that couldn't be started
 781 # Truncates fully qualified hostnames down to hostname
 782 # Sets @Pid, $ReadVec, and filehandle COM<i>
 783 # Clears @HostOuput<hostname> and @Installing
 784 #
 785 # Returns 0 if install(s) are started, 1 otherwise
 786 #
 787 sub StartInstalls {
 788   my($i, $fh, $output, $command, @brokenpipes);
 789
 790   undef @Installing;
 791   $i = 0;   # Cannot let $i start off undefined; must be numerical
 792   while ($i <= $#InstallHosts) {
 793     $command = "";
 794     $command = "rsh -n -l $InstallID @InstallHosts[$i] " if ($InstallID);
 795     $command .= "$Command ";
 796     $command .= "-src $InstallPath ";
 797     $command .= "-pkg $InstallPkgs " if ($InstallPkgs);
 798     $command .= $InstallOpts;
 799     #$command = "/bin/echo Installing package rc\n";
 800
 801     print STDOUT "COMMAND: \"$command\" \n" if ($Debug >= 2);
 802
 803     $fh = "COM$i";
 804     @Pid[$i] = open($fh, "$command 2>&1 |");
 805     if (@Pid[$i]) {
 806       @InstallHosts[$i] =~ s:\..*::;
 807       print STDOUT "Install on @InstallHosts[$i] started\n" if ($Debug >= 1);
 808       $output = "HostOutput@InstallHosts[$i]";
 809       undef @$output;
 810       vec($ReadVec, fileno($fh), 1) = 1;
 811       $i++;  }
 812     else {
 813       push(@brokenpipes, splice(@InstallHosts, $i, 1));   };  };
 814
 815   if ($#brokenpipes >= 0) {
 816     &ErrorWindow("Could not create pipes for:", @brokenpipes);  };
 817
 818   print STDOUT $#InstallHosts + 1, " installs started\n" if ($Debug >= 1);
 819   return 0 if ($#InstallHosts >=0);
 820   return 1;
 821 }
 822
 823
 824
 825
 826 # An install process is done
 827 # Parameter passed in is "STOP: i" where "i" is the index into @Pid, COM<i>,
 828 # and @InstallHosts
 829 #
 830 # Kill the process, reset its @Pid, close it's file handle
 831 #
 832 sub EndInstall {
 833   my($num, $fh);
 834   $num =  @_[0];
 835   $num =~ s/[^0-9]//g;
 836   @InstallResult[$num] = "KILLED" if (@_[0] =~ /^STOP/);
 837
 838   kill 9, @Pid[$num] if (@Pid[$num] > 0);
 839   print STDOUT "Process \"$num\" killed\n" if ($Debug >= 2);
 840   @Pid[$num] = -1;
 841   if (&TkWidgetExists(".out$num.act.stop")) {
 842     &TclPrint("destroy .out$num.act.stop"); };
 843
 844   $fh = "COM$num";
 845   vec($ReadVec, fileno($fh), 1) = 0;
 846   close($fh);
 847
 848   &TclPrint("set InstallResult-$num-done @InstallResult[$num]");
 849 }
 850
 851
 852
 853
 854 # Set the colors of a Tk widget
 855 sub Hilight {
 856   my($widget, $color) = @_;
 857   &TclPrint("$widget configure -activebackground [ $widget cget -bg ]");
 858   &TclPrint("$widget configure -activeforeground black ");
 859   &TclPrint("$widget configure -selectcolor \"$color\" ");
 860 }
 861
 862
 863
 864
 865 # Create a window to show progress of install
 866 sub CreateProgressWindow {
 867   my($pkg, $host, $i, @pkglist, $dx, $dy);
 868   &TclPrint(".action.go   config -state disabled");
 869   &TclPrint(".action.info config -state disabled");
 870   &TclPrint("toplevel .prog");
 871   &TclPrint("wm geometry .prog 100x100+100+150");
 872   &TclPrint("wm title .prog Installing");
 873   &TclPrint("wm protocol .prog WM_DELETE_WINDOW { print PROG }");
 874
 875   # Create a "Packages" label  in UL corner
 876   # &TclPrint("label .prog.pkg -text \"Packages\" -width 20 -anchor w");
 877   # &TclPrint("place .prog.pkg -x 10 -y 10");
 878
 879   # Create the lefthand column of package names
 880   @pkglist = split(/ /, $InstallPkgs);
 881   @pkglist = @AvailPackages if ($#pkglist < 0);
 882   $dy = 45;
 883   foreach $pkg (@pkglist, "done") {
 884     &TclPrint("label .prog.$pkg -text \"$pkg\"");
 885     &TclPrint("place .prog.$pkg -in .prog -x 10 -y $dy");
 886     $dy += 30; };
 887
 888   # Create a column of indicators for each host
 889   $i = 0;
 890   $dx = 100;
 891   foreach $host (@InstallHosts) {
 892     &TclPrint("button .prog.h$i -text \"$host\" -command { print SHOW: $i }");
 893     &TclPrint("place  .prog.h$i -in .prog -x $dx -y 10");
 894     $dy = 40;
 895     $dx += 5;
 896
 897     # Lights for each package for this host
 898     foreach $pkg (@pkglist, "done") {
 899       &TclPrint("set InstallResult-$i-$pkg \"\"");
 900       &TclPrint("entry .prog.h$i-$pkg -width 8 -text InstallResult-$i-$pkg");
 901       &TclPrint("place .prog.h$i-$pkg -in .prog -x $dx -y $dy");
 902       &TclPrint(".prog.h$i-$pkg config -state disabled");
 903       $dy += 30;  };
 904     @InstallResult[$i] = "SUCCESS";   # gotta be optimistic
 905     $dx += 75;
 906     $i++; };
 907
 908   # Create a "go away" button
 909   $dy += 15;
 910   &TclPrint("label .prog.verbose -text \"Click hostname to view output\"");
 911   &TclPrint("place .prog.verbose -in .prog -x 10 -y $dy");
 912   $dy += 30;
 913   &TclPrint("button .prog.exit -text DISMISS -com { print PROG }");
 914   &TclPrint("place  .prog.exit -in .prog -x 10 -y $dy");
 915   $dy += 35;
 916   $dx = 200 if ($dx < 200);
 917
 918   # Display everything
 919   $i = $dx . "x" . $dy . "+100+150";
 920   &TclPrint("wm geometry .prog $i");
 921 }
 922
 923
 924
 925
 926 # Delete the progress window
 927 sub DestroyProgressWindow {
 928   my($hostname, $output);
 929   &TclPrint("destroy .prog") if (&TkWidgetExists(".prog"));
 930   &TclPrint(".action.go   config -state normal");
 931   &TclPrint(".action.info config -state normal");
 932
 933   # Clear install output from memory
 934   for $hostname (@InstallHosts) {
 935     $output = "HostOutput$hostname";
 936     undef @$output;  };
 937 }
 938
 939
 940
 941
 942 # Create the 2nd window into which install output is written.
 943 sub CreateOutputWindow {
 944   my($i, $hostname, $x);
 945   $i = shift @_;
 946   $hostname = shift @_;
 947   &TclPrint("destroy .out$i") if (&TkWidgetExists(".out$i"));
 948
 949   if (&TkWidgetExists(".prog.h$i")) {
 950     &TclPrint(".prog.h$i config -state disabled");  };
 951
 952   $x = 250 + $i * 10;
 953   &TclPrint("toplevel .out$i");
 954   &TclPrint("wm geometry .out$i 100x100+$x+150");
 955   &TclPrint("wm title .out$i \"Command Output $hostname\"");
 956   &TclPrint("wm protocol .out$i WM_DELETE_WINDOW { print DISMISS: $i }");
 957
 958   &TclPrint("frame .out$i.f -bd 2");
 959   &TclPrint("text  .out$i.f.t -width 80 -height 20 -bd 2");
 960   &TclPrint("scrollbar .out$i.f.s  -command \".out$i.f.t yview\" -bd 2");
 961   &TclPrint(".out$i.f.t config -yscr \".out$i.f.s set\"");
 962   &TclPrint("pack .out$i.f.t -side left -expand yes -fill both");
 963   &TclPrint("pack .out$i.f.s -side right -fill y");
 964   &TclPrint("pack .out$i.f   -side top  -expand yes -fill both");
 965
 966   &TclPrint("frame .out$i.act -relief flat");
 967   if(@Pid[$i] > 0) {
 968     &TclPrint("button .out$i.act.stop -text \"STOP INSTALL\" \\");
 969     &TclPrint( "-com {print STOP: $i } -bd 2");
 970     &TclPrint("pack .out$i.act.stop -padx 20 -side left"); };
 971   &TclPrint("button .out$i.act.dismiss -text DISMISS \\");
 972   &TclPrint( "-com {print DISMISS: $i } -bd 2");
 973   &TclPrint("pack .out$i.act.dismiss -padx 20 -side right");
 974
 975   &TclPrint("pack .out$i.act  -side bottom");
 976
 977   &TclPrint("wm geometry .out$i \"\" ");
 978
 979   # Create some tags in the text box for easy highlighting
 980   &TclPrint(".out$i.f.t tag add err 1.0 1.0");
 981   &TclPrint(".out$i.f.t tag configure err -background \\#B04040");
 982   &TclPrint(".out$i.f.t tag add header 1.0 1.0");
 983   &TclPrint(".out$i.f.t tag configure header -background \\#A0A0A0");
 984   &TclPrint(".out$i.f.t tag add normal 1.0 1.0");
 985 }
 986
 987
 988
 989
 990 # Print in the output window
 991 # Parameters passed in are the window number and the text to print
 992 sub AppendOutputWindow {
 993   my($i, $line, $padlen);
 994   $i = shift @_;
 995   for $line (@_) {
 996     # Backslash escape any quote characters that aren't already escaped
 997     $line =~ s/([^\\])\"/$1\\\"/g;
 998     # Backslash escape any bracket characters that aren't already escaped
 999     $line =~ s/([^\\])([\[\]])/$1\\$2/g;
1000
1001     # Errors turn red
1002     if ($line =~ /^ *ERROR:/) {
1003       &TclPrint(".out$i.f.t insert end \"$Indent\" normal \"ERROR:\" err \\");
1004       &TclPrint( "\"$'\\n\" normal");
1005       next;  }
1006     # Package names get highlighted in grey
1007     elsif ($line =~ /^Installing package/) {
1008       &TclPrint(".out$i.f.t insert end \"\\n\" normal \"$line \" header \\");
1009       &TclPrint("\"\\n\" normal");
1010       next;  }
1011     # Normal text
1012     else {
1013       &TclPrint(".out$i.f.t insert end \"$line\\n\" normal");  };  };
1014
1015   # Scroll window to end of output
1016   &TclPrint(".out$i.f.t see end");
1017 }
1018
1019
1020
1021
1022 # Create the output window and dump to it all of the lines of output that
1023 # have been accumulated so far
1024 sub ForceOutputWindow {
1025   my($i, $hostname, $output);
1026   $i = @_[0];
1027   $i =~ s/^SHOW: //;
1028   return if (&TkWidgetExists(".out$i"));
1029
1030   $hostname = @InstallHosts[$i];
1031   $output = "HostOutput$hostname";
1032
1033   &CreateOutputWindow($i, $hostname);
1034   &AppendOutputWindow($i, @$output);
1035 }
1036
1037
1038
1039
1040 sub DestroyOutputWindow {
1041   my($i);
1042   $i = @_[0];
1043   $i =~ s/[^0-9]//g;
1044   &TclPrint("destroy .out$i") if (&TkWidgetExists(".out$i"));
1045   &TclPrint(".prog.h$i config -state normal") if(&TkWidgetExists(".prog.h$i"));
1046 }
1047
1048
1049
1050
1051 # Create a temp window with a message and an OK button
1052 sub ErrorWindow {
1053   my($win, $phrase, $i);
1054   $win = ".err$ErrorWindowNumber";
1055   $ErrorWindowNumber++;
1056   &TclPrint("toplevel $win");
1057   &TclPrint("wm geometry $win 100x20+", 50 + $ErrorWindowNumber * 5, "+150");
1058   &TclPrint("wm title $win Message");
1059   &TclPrint("wm protocol $win WM_DELETE_WINDOW { destroy $win }");
1060
1061   $i = 0;
1062   for $phrase (@_) {
1063     &TclPrint("label $win.l$i -text \"$phrase\"");
1064     &TclPrint("pack  $win.l$i -side top -padx 10");
1065     $i++;  };
1066   &TclPrint("button $win.b -text OK -command { destroy $win }");
1067   &TclPrint("pack $win.b -pady 10 -anchor center");
1068
1069   &TclPrint("wm geometry $win \"\" ");
1070 }
1071
1072
1073
1074
1075
1076 #
1077 # Routines for the Install Guides to use
1078 #
1079
1080
1081 # Read an InstallGuide file into the Perl context
1082 sub ReadInstallGuide {
1083   my($ig, $rc, $contents, $line);
1084   $ig = @_[0];
1085
1086   $rc = open(IG, $ig);
1087   if (!$rc) {
1088     &ErrorMsg("Could not read Install Guide", $ig);
1089     return 1;  };
1090   while ($line = <IG>) {
1091     $contents .= $line;  };
1092   close(IG);
1093
1094   eval $contents;
1095   &ErrorMsg("$ig could not be avalulated:$@") if ($@ ne "");
1096
1097 }
1098
1099
1100
1101
1102 # Copy a file. Because there are so many error checks in this routine, a
1103 # wrapper is put around it so any errors can return() without a lot of
1104 # cleanup code.
1105 sub Copy {
1106   my(@msg);
1107   unshift(@Section, "Copy");
1108
1109   @msg = &CopyWrapper(@_);
1110   &ErrorMsg(@msg) unless (@msg[0] eq "OK");
1111   close(SRC);
1112   close(DST);
1113
1114   shift @Section;
1115 }
1116
1117 sub CopyWrapper {
1118   my($srcprog, $dstprog, $prog, @prog, $mode, $rc, $olddstprog, $different);
1119   my($dbytes, $dstbuf, $sbytes, $srcbuf);
1120   $different = $olddstprog = 0;
1121
1122   return("Wrong number of args") if ($#_ != 1);
1123   $srcprog = shift @_;
1124   $dstprog = shift @_;
1125
1126   # If a directory was given as the dest, append the filename
1127   @prog = split(/\//, $srcprog);
1128   $prog = pop(@prog);
1129   $dstprog =~ s:/$::;
1130   $dstprog .= "/$prog" if (-d $dstprog);
1131
1132   # Open the src and new dest file
1133   $rc = open(SRC, $srcprog);
1134   return("Could not open src file to Copy", $srcprog) if (!$rc);
1135
1136   $newdstprog = "$dstprog.new";
1137   $rc = open(NEW, ">$newdstprog");
1138   return("Could not open new dst file for Copy", $newdstprog) if (!$rc);
1139
1140   if (-e $dstprog) {
1141     $rc = open(DST, $dstprog);
1142     $olddstprog = "$dstprog.old";   }
1143   while ($sbytes = read(SRC, $srcbuf, 4096)) {
1144     if ($olddstprog) {
1145       $dbytes = read(DST, $dstbuf, 4096);
1146       if (!$different) {
1147         if ($sbytes != $dbytes || $srcbuf ne $dstbuf) {
1148           $different = 1;  }; };  };
1149     print NEW $srcbuf; };
1150
1151   if (!$olddstprog || $different) {
1152     &VPrint ("Copying file: \"$srcprog\" to \"$dstprog\"");
1153     if ($olddstprog && !$NoOldFiles) {
1154       unlink($olddstprog);
1155       rename($dstprog, $olddstprog); };
1156     $rc = rename($newdstprog, $dstprog);
1157     if (!$rc) {
1158       if ($! eq "Text file busy") {
1159         rename($dstprog, "$dstprog.busy");
1160         $rc = rename($newdstprog, $dstprog); }
1161       &ErrorMsg("Could not install new version of", $newdstprog) if (!$rc); };
1162
1163     # Set the mode bits of the dst file identical to the src file
1164     &Chown(0,2, $dstprog);
1165     &Chmod(0755, $dstprog);  }
1166   else {
1167     &VPrint("\"$dstprog\" is already a copy of \"$srcprog\"");
1168     unlink($newdstprog); };
1169   return("OK");
1170 }
1171
1172
1173
1174
1175 # Read a file, looking for an AFS marker
1176 sub AFSversion {
1177   my($filename, $version, $rc, $line);
1178   $filename = @_[0];
1179   $rc = open(FILE, $filename);
1180   return("") if (!$rc);
1181   while ($line = <FILE>) {
1182     next unless ($line =~ /Base configuration afs/);
1183     $line =~ s/.*Base configuration //;
1184     $line =~ s/\000.*//;
1185     last;  };
1186   close(FILE);
1187
1188   if ($line) {
1189     $version = $line;
1190     $version =~ s/;.*//;
1191     chomp $version;
1192     $version .= "+" if ($&);
1193     $version =~ s/ /-/g; };
1194   return($version);
1195 }
1196
1197
1198
1199 # Copy a file from one place to another. At the destination site, keep a hard
1200 # link to the file naming what version the file is. The version string will
1201 # be ".orig" for non-AFS files, or the AFS version number (eg -afs3.4-5.00)
1202 # for AFS files. Attempt to preserve old ,orig files and NOT preserve multiple
1203 # AFS versions.
1204 sub VersionCopyFile {
1205   my(@msg);
1206   unshift(@Section, "VersionCopyFile");
1207
1208   @msg = &VersionCopyFileWrapper(@_);
1209   &ErrorMsg(@msg) unless (@msg[0] eq "OK");
1210   shift @Section;
1211 }
1212
1213 sub VersionCopyFileWrapper {
1214   my($from, $to, $link, $rc, $inode, @paths, $dir, $file);
1215   my($from_vers, $to_vers, $old_vers, $buf);
1216   $from = shift @_;
1217   $to = shift @_;
1218
1219   # Error check
1220   return("No such file", $from) if (!-f $from);
1221   $from_vers = &AFSversion($from);
1222
1223   # Check if there is already a file in the destination place
1224   if (-e $to) {
1225     @stats = stat(_);
1226     $to_vers = &AFSversion($to);
1227
1228     # If the $to file is a soft link, just remove it
1229     if (-l $to) {
1230       &VPrint("Removing soft link \"$to\"");
1231       $rc = unlink($to);
1232       return("Could not remove symlink", $to) if ($rc != 1); }
1233
1234     # Cannot work if $to is a directory
1235     elsif (-d $to) {
1236       return("$to is a directory"); }
1237
1238     # The $to file exists but was not a soft symlink. Move aside or delete it.
1239     # If the $to file is the same version as $from, just remove $to.
1240     # Otherwise move $to aside
1241     else {
1242       if ($to_vers eq $from_vers) {
1243         &VPrint("Removing \"$to\" that is same version as \"$from\"");
1244         $rc = unlink($to);
1245         return("Could not remove \"$to\"") if (!$rc);  }
1246       else {
1247         # Make a new name to which to move the old $to file
1248         if ($to_vers) {
1249           $file = "$to-$to_vers"; }
1250         else {
1251           $file = "$to.orig"; };
1252         &VPrint("Moving \"$to\" to \"$file\"");
1253         return("Cannot move old \"$to\" to \"$file\"") if (-d $file);
1254         unlink($file);
1255         $rc = rename($to, $file);
1256         return("Could not move \"$to\" to", $file) if (!$rc); }; }; };
1257
1258   # Do the actual copy
1259   &VPrint("Copying \"$from\" to \"$to\"");
1260   $rc = open(SRC, $from);
1261   return("Could not read original file", $from) if (!$rc);
1262   $rc = open(DST, ">$to");
1263   return("Could not open for writing", $to) if (!$rc);
1264   while(read(SRC, $buf, 4096)) {
1265     $rc = print DST $buf;
1266     return("write() failed to", $to) if (!$rc); };
1267   close(DST);
1268   close(SRC);
1269
1270   # Create a hard link of the dest file
1271   $version = &AFSversion($to);
1272   if ($version) {
1273     $link = "$to-$version"; }
1274   else {
1275     $link = "$to.orig"; };
1276
1277   # If a file already exists where the hard link is to be, delete it
1278   if (-f $link) {
1279     &VPrint("Removing \"$link\" to place a new hard link there");
1280     $rc = unlink($link);
1281     return("Could not ($!) remove old", $link) if (!$rc); };
1282
1283   # Make the hardlink
1284   &VPrint("Creating new hard link \"$link\"");
1285   $rc = link($to, $link);
1286   return("Could not make hardlink \"$to\" to", $link) if (!$rc);
1287   return("OK");
1288 }
1289
1290
1291
1292
1293 # Create a list of directories and any parent directories required
1294 # Only use absolute paths that start with /
1295 sub CreateDir {
1296   my($dir, $path, @subdirs, $subdir, $rc);
1297   unshift(@Section, "CreateDir");
1298   foreach $dir (@_) {
1299
1300     # Make sure an absolute path was given
1301     if (substr($dir, 0, 1) ne "/") {
1302       &ErrorMsg("Won't mkdir relative directory", $dir);
1303       shift @Section;
1304       return;  };
1305
1306     # Check each parent directory. Work up parent dirs with $path variable.
1307     # Split up the entire path into an array. Since $dir starts with a /, the
1308     # first scalar in the array will be "". Remove it.
1309     $path = "";
1310     @subdirs = split(/\//, $dir);
1311     shift @subdirs;
1312
1313     VPrint("Creating directory: \"$dir\"");
1314
1315     foreach $subdir (@subdirs) {
1316       $path .= "/$subdir";
1317       next if (-d $path);
1318       next if (-l $path);
1319
1320       # Create the directory and check the return code
1321       $rc = mkdir($path, 0775);
1322       next if ($rc);
1323       &ErrorMsg("Cannot create directory", $path);
1324       shift @Section;
1325       return;  };  };
1326   shift @Section;
1327 }
1328
1329
1330
1331
1332 # Create a symlink. Carefully.
1333 sub Symlink {
1334   my($filename, $linkname, $rc);
1335   unshift(@Section, "Symlink");
1336   $filename = @_[0];
1337   $linkname = @_[1];
1338   &VPrint("Making \"$linkname\" point to \"$filename\"");
1339   &DisplaceFile($linkname);
1340   $rc = symlink($filename, $linkname);
1341   &ErrorMsg("Could not make symlink", "$linkname -> $filename") if (!$rc);
1342   shift @Section;
1343 }
1344
1345
1346
1347
1348 # Move a file aside. Because there are so many error checks in this routine, a
1349 # wrapper is put around it so any errors can return() without a lot of
1350 # cleanup code.
1351 sub DisplaceFile {
1352   my(@msg);
1353   unshift(@Section, "DisplaceFile");
1354
1355   @msg = &DisplaceWrapper(@_);
1356   &ErrorMsg(@msg) unless (@msg[0] eq "OK");
1357   shift @Section;
1358 }
1359
1360 # Move a file aside. If it is an AFS file, delete it. Otherwise move it
1361 # to .orig   This is for files like fsck and login that have AFS equivalents
1362 sub DisplaceWrapper {
1363   my($rc, $displace, $line, $isAFS);
1364
1365   $displace = @_[0];
1366   return("OK") if (!-e $displace);
1367
1368   # If destination is just a symlink, remove it
1369   if (readlink($displace)) {
1370     &VPrint("Removing old \"$displace\" symlink");
1371     $rc = unlink($displace);
1372     return("Could not remove link", $displace) if (!$rc);
1373     return("OK"); };
1374
1375   # If dest is not a file, (ie a directory) this is unfixable
1376   return("Not a file", $displace) if (-d $displace);
1377
1378   # Read the file, looking for an AFS marker
1379   $isAFS = &AFSversion($displace);
1380
1381   # Either remove an AFS file or rename a non-AFS file
1382   if ($isAFS) {
1383     $rc = unlink($displace);
1384     return("Could not remove file", $displace) if (!$rc); }
1385   else {
1386     &VPrint("Moving old file \"$displace\" aside");
1387     $rc = rename($displace, "$displace.orig");
1388     return("Could not rename file", $displace) if (!$rc); };
1389   return("OK");
1390 }
1391
1392
1393
1394
1395 # Change the mode bits of a file
1396 sub Chmod {
1397   my ($mode, $file, $rc);
1398   unshift(@Section, "Chmod");
1399   $mode = shift @_;
1400   while ($file = shift @_)  {
1401     &VPrint("Setting mode bits on $file to ", sprintf("%lo", $mode));
1402     $rc = chmod($mode, $file);
1403     &ErrorMsg("Could not change mode bits of", $file) if (!$rc);  };
1404   shift @Section;
1405 }
1406
1407
1408
1409
1410 # Change the owner of a file
1411 sub Chown {
1412   my ($user, $group, $file, $rc);
1413   unshift(@Section, "Chown");
1414   $user = shift @_;
1415   $group = shift @_;
1416   while ($file = shift @_) {
1417     &VPrint("Setting owner of \"$file\" to $user,$group");
1418     $rc = chown $user, $group, $file;
1419     &ErrorMsg("Could not change mode bits of", $file) if (!$rc);  };
1420   shift @Section;
1421 }
1422
1423
1424
1425
1426 # Copy the UID, GID, and MODE info from one file to another
1427 sub CopyStat {
1428   my ($user, $group, $srcfile, $destfile, $mode, $rc, @statinfo);
1429   unshift(@Section, "CopyStat");
1430   $srcfile = shift @_;
1431   $destfile = shift @_;
1432   @statinfo = stat($srcfile);
1433   $mode = $statinfo[2];
1434   $user = $statinfo[4];
1435   $group = $statinfo[5];
1436   &VPrint("Copying owner,group,mode of \"$srcfile\" to \"$destfile\"");
1437   $rc = chown $user, $group, $destfile;
1438   &ErrorMsg("Could not change mode bits of", $destfile) if (!$rc);
1439   $rc = chmod $mode, $destfile;
1440   &ErrorMsg("Could not change mode bits of", $destfile) if (!$rc);
1441   shift @Section;
1442 }
1443
1444
1445
1446 #
1447 # Misc printing routines
1448 #
1449
1450
1451 # This routine causes calls to ErrorMsg to be fatal
1452 sub ErrorsAreFatal {
1453   $Fatal = @_[0];
1454 }
1455
1456
1457
1458
1459 # Print a line with a prepended indent string
1460 sub Print {
1461   my($text);
1462   $text = join("", @_);
1463   print "$Indent$text\n";
1464 }
1465
1466
1467
1468
1469 # Print only if in Verbose mode
1470 sub VPrint {
1471   return unless ($InstallVerbose);
1472   &Print(@_);
1473 }
1474
1475
1476
1477
1478 # A routine to make consistent error messages
1479 sub ErrorMsg {
1480   my($msg, $prog);
1481   $msg = "ERROR: @Section[0]: ";
1482   $msg .= shift @_;
1483   $prog = shift @_;
1484   if ($prog) {
1485     $prog =~ s:^$InstallPath::;
1486     $msg .= " \"$prog\"";  };
1487   $msg .= " ($!)" if (($? >> 8) && $Debug);
1488   &Print($msg);
1489   last DOPACKAGE if ($Fatal);
1490 }
1491
1492
1493
1494
1495 # Write a Tcl/Tk command to the $Wish process
1496 sub TclPrint {
1497   my($text);
1498   $text = join("", @_);
1499   print STDOUT "TO TCL:\"$text\" \n" if($Debug >= 4);
1500   if ($text =~ /\\$/) {
1501     $text =~ s:\\$: :;
1502     print WRITETCL $text;  }
1503   else {
1504     print WRITETCL "$text\n";  };
1505 }
1506
1507
1508
1509
1510 # Read a line from Tcl/Tk, and chop off any {} symbols Tcl tacks on
1511 sub TclRead {
1512   my($line);
1513   print STDOUT "Reading from Tcl\n" if ($Debug >= 4);
1514   $line = <READTCL>;
1515   chop $line;
1516   $line =~ s:{::;
1517   $line =~ s:}::;
1518   print STDOUT "FROM TCL:\'$line\' \n" if ($Debug >= 4);
1519   return($line);
1520 }
1521
1522
1523
1524
1525 # Query Tcl/Tk if a particular widget is drawn. 1=yes 0=no
1526 sub TkWidgetExists {
1527   my($reply);
1528   &TclPrint("print reply: [ info command @_[0] ]");
1529   $reply = &TclRead;
1530   return 0 if ($reply eq "reply: ");
1531   return 1;
1532 }