Commit | Line | Data |
---|---|---|
805e021f CE |
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 | } |