#!/usr/bin/perl -w # # update # # This program updates the current web site from the distribution # site. # # Any files which have been locally changed are left alone, # everything else is brought up to date. # # This is a standalone program to be run from shell access # on the web server. As it is standalone, you should be able # to copy this into a new place in the file tree and run it, # and create a new incarnation of the program. # # This is best run on a terminal emulator with a long screen # buffer and cut and paste, or by using two terminal emulators # side-by-side. # # This does rely upon optional modules for operation: # libwww Provides LWP::Simple # # The Makefile should have entries for: # clean Remove all non-essential files # localize Localize files # all Do everything # update Should call this procedure # # Config/defs.wh should have the following entries: # _APPL-NAME_ Name of the application # _HOME-BIN_ URL for programs # _HOME-FS_ Directory for data # _HOME-HOST_ Domain name of web server # _HOME-HTTP_ URL for static files # _HOME-OWNER_ User name of the owner of the application # _HOME-WWW_ Web server ID # _REAL-ADDR_ Email address of author # # Once this gets things going, it calls other programs which are # part of the distribution. So this isn't entirely stand-alone. # # Dave Regan # regan@peak.org # http://cornvalley.peak.org/update/ # Copyright 1998 Dave Regan, all rights reserved # # # Things this doesn't deal with: # ------------------------------ # # Doesn't deal with adding to /etc/group file. # # Doesn't ensure that mailing lists are created. # # Doesn't set aliases in /etc/aliases. # # This should check to see if the update program had been updated, # and jump into midstream into the new version. # ### ### Distribution information ### ### This section describes where the various packages come from. ### There are a number of ideas encoded here: ### 1) This application uses some custom code, but also ### includes a certain number of "standard" support ### packages. These packages are maintained in a common ### place. ### 2) There are both test and release versions. This ### allows users to choose how "cutting-edge" they ### want to be. If there is only one version, it gets ### used regardless of if it is "test" or "release". ### 3) This package needs to be able to get the support ### packages, so there is a "refresh" command line ### argument that gets the "test" versions of all of ### the support packages. If you are in development, you ### might as well be testing the support packages. ### 4) This program is made to carry all of the necessary ### information for a specific application. This means ### that there are no support files. This also means ### that the program is not pure; it contains distinct ### information for each of the different applications. ### 5) There can be redundant distribution sites. This allows ### the development site to be on a machine which isn't ### connected to the net full time. ### 6) The command line switches are: ### (none) Update everything from the "release" ### archives. ### -refresh Update all "support" packages from the ### "test" archives. ### -test Update all packages from the "test" ### archives. ### -package name Update only the specified package from ### the appropriate archive. ### -nobuild Don't make the resulting mess. ### -nocheck Don't do a bunch of sanity checks. ### 7) Many of the applications are documented here with a ### noinstall parameter. This will keep these packages ### from being installed unless specified with a -package. ### The version of this program distributed with applications ### should differ from the standard update program by simply ### commenting out the noinstall on the particular application. ### 8) If the file Config/testsite exists, then the default ### action of this program is to refresh all of the packages. ### If the file Config/distributionsite exists, then the ### default action is to do a -test. ### use vars qw(%AlwaysOverwrite $ConfigInformation); $ConfigInformation = << "EOF"; # The update package is a collection of a number of utility # programs needed by many applications. It includes the update # program proper, as well as a checksum and localize program. # This package is important to have early, as other packages will # want the checksum program. name = update class = support release = http://cornvalley.peak.org/update/update.tar.gz test = http://mordred.armoredpenguin.com/update/update.tar.gz # The banner program generates banner ads name = banner class = application release = http://cornvalley.peak.org/banner/banner.tar.gz test = http://www.armoredpenguin.com/~regan/ad/banner.tar.gz params = noinstall # Where to get the bugreport application (as opposed to the # bugreport support package). name = bugreporta class = application release = http://cornvalley.peak.org/bugreport/bugreporta.tar.gz test = http://mordred.armoredpenguin.com/bugreport/bugreporta.tar.gz params = noinstall # The crossword program generates crossword puzzles name = crossword class = application test = http://mordred.armoredpenguin.com/crossword/crossword.tar.gz params = noinstall # The CVOracle program allows users and experts to meet. name = cvoracle class = application release = http://cornvalley.peak.org/oracle/cvoracle.tar.gz test = http://mordred.armoredpenguin.com/oracle/cvoracle.tar.gz params = noinstall # The application surrounding edit.defs name = edit.defsa class = application # release = http://cornvalley.peak.org/edit.defs/edit.defsa.tar.gz test = http://mordred.armoredpenguin.com/edit.defs/edit.defs.tara.gz params = noinstall # The application surrounding faq name = faqa class = application # release = http://cornvalley.peak.org/faq/faqa.tar.gz test = http://mordred.armoredpenguin.com/faq/faqa.tar.gz params = noinstall # The application surrounding the in/out board name = inouta class = application # release = http://cornvalley.peak.org/inout/inouta.tar.gz test = http://mordred.armoredpenguin.com/inout/inouta.tar.gz params = noinstall # Where do we get the register application name = registera class = application release = http://cornvalley.peak.org/register/registera.tar.gz test = http://mordred.armoredpenguin.com/register/registera.tar.gz params = noinstall # Where do we get the taskmanagement application name = taskmanage class = application release = http://cornvalley.peak.org/taskmanage/taskmanage.tar.gz test = http://mordred.armoredpenguin.com/taskmanage/taskmanage.tar.gz params = noinstall # Where to get the update application (as opposed to the # update support package). name = updatea class = application release = http://cornvalley.peak.org/update/updatea.tar.gz test = http://mordred.armoredpenguin.com/update/updatea.tar.gz params = noinstall # Where to get the vote application (as opposed to the # vote support package). name = votea class = application release = http://cornvalley.peak.org/vote/votea.tar.gz test = http://mordred.armoredpenguin.com/vote/votea.tar.gz params = noinstall # Where to get the wordsearch application name = wordsearch class = application test = http://mordred.armoredpenguin.com/wordsearch/wordsearch.tar.gz params = noinstall # The bugreport program is a CGI program which submits bug # reports via email to specified addresses. This is useful as # a low mass way of reporting bugs. name = bugreport class = support # release = http://cornvalley.peak.org/bugreport/bugreport.tar.gz test = http://mordred.armoredpenguin.com/bugreport/bugreport.tar.gz # edit.defs is a program which allows editing of the defs.wh # file via the web. name = edit.defs class = support # release = http://cornvalley.peak.org/edit.defs/edit.defs.tar.gz test = http://mordred.armoredpenguin.com/edit.defs/edit.defs.tar.gz # faq is a program for processing FAQ entries. name = faq class = support # release = http://cornvalley.peak.org/faq/faq.tar.gz test = http://mordred.armoredpenguin.com/faq/faq.tar.gz # In / Out board name = inout class = support # release = http://cornvalley.peak.org/inout/inout.tar.gz test = http://mordred.armoredpenguin.com/inout/inout.tar.gz params = noinstall # The registration package is used to authenticate users and # administrators. This is a common feature to many applications. name = register class = support release = http://cornvalley.peak.org/register/register.tar.gz test = http://mordred.armoredpenguin.com/register/register.tar.gz # The webc package is a simple HTML preprocessor. name = webc class = support # release = http://cornvalley.peak.org/Webc/webcpkg.tar.gz test = http://mordred.armoredpenguin.com/Webc/webcpkg.tar.gz # The voting package is used to conduct web based elections. name = vote class = support release = http://cornvalley.peak.org/vote/vote.tar.gz test = http://mordred.armoredpenguin.com/vote/vote.tar.gz params = noinstall EOF # These files should never be altered by the user, and are always # overwritten if encountered. %AlwaysOverwrite = ( "SupportBin/update.template" => 1, "Config/application.files" => 1, "Config/data" => 1, ); ### ### Configuration ### use Config; use Cwd; use English; use File::Copy; use File::Path; use LWP::Simple; use Sys::Hostname; use vars qw(%Class $CommandMode $Email $HostName $NoBuild $NoCheck %Params $Perl $RealName %Release $ScriptAlias $ServerRoot %Test $UpdateVersion $WebPage $WebPID $WebUser $Root); $UpdateVersion = 'update v0.30 regan@armoredpenguin.com'; ### ### Main program ### my($arg, $argc, $file, $files, @files); # Make sure we have appropriate directories in our PATH. if ($ENV{'PATH'} !~ m#\:/usr/local/bin#) { $ENV{'PATH'} =~ s#$#:/usr/local/bin#; } # Look at parameters $CommandMode = "-update"; $CommandMode = "-refresh" if (-f "Config/testsite"); $CommandMode = "-test" if (-f "Config/distributionsite"); @Packages = (); $NoBuild = $NoCheck = 0; for ($argc = 0; defined($ARGV[$argc]); $argc++) { $arg = $ARGV[$argc]; if ($arg eq "-refresh" || $arg eq "-test") { $CommandMode = $arg; } elsif ($arg eq "-package") { push(@Packages, $ARGV[++$argc]); } elsif ($arg eq "-nobuild") { $NoBuild = 1; } elsif ($arg eq "-nocheck") { $NoCheck = 1; } elsif ($arg eq "-force") { # remove all *.tar.gz files system("rm -f *.tar.gz"); } elsif ($arg eq "-isdist") { ListDistributionSites() if (-f "Config/testsite"); exit 0; } else { print STDERR "Unknown argument: $arg\n" if ($arg ne "-help"); print STDERR "Usage:\n"; print STDERR "\tSupportBin/update [flags]\n"; print STDERR "The flags are;\n"; print STDERR "\t-test\t\tGet information from the test site.\n"; print STDERR "\t-refresh\tGet support packages.\n"; print STDERR "\t-package name\tGet the specific package.\n"; print STDERR "\t-nobuild\tDon't build when complete.\n"; print STDERR "\t-nocheck\tDon't look too closely.\n"; print STDERR "\t-force\t\tRemove all *.tar.gz files.\n"; print STDERR "\t-isdist\t\tPrint a final message if the user\n"; print STDERR "\t\t\tis making a distribution.\n"; exit 1; } } # Figure out where we are. Directories, host names, etc. # If we are in a SupportBin directory, use the directory above that. umask(002); FindIdentity(); # Collect the various packages and put them in their appropriate # places. InstallFiles(); if (!$NoCheck) { # See if we are configured in the web server. If not, offer # suggestions as to what should be in the configuration. # This involves finding the web server, and finding our directory # as part of it. ReadHeadWH(); FindWebServer(); # See if additional items have been added to defs.wh. If so, # slam simple #define's to the end of defs.wh and tell the # operator about it. If the file is read-only, then just chatter # to the guy about it. CheckDefs(); # See if the data directory exists. If not, give a chance # to create it. CheckDataDirectory(); # See if there is a configuration directory. If not, offer # something. CheckConfigDirectory(); # See if there are password files. If not, create bogus # files with owner/test and tell the user to change them. # Put in a bogus Accepted item for owner. They can change # it latter. CheckPasswordFiles(); } # Clean up the rest of the junk rmtree("$Root/Temp", 0, 0); if (!$NoBuild) { # Do a "make localize" to put things to right. # This should be done after all of the files are in place. Make("clean", 0); Make("localize", 0); # Do a "make perms" # Make("perms", 0); # Make("data_perms", 0); # Make the application Make("all", 0); # # If running as root, and if there is a "make owner" in the # # Makefile, do a "make owner". # Make("owner", 1); # Make("data_owner", 1); } # See if the user wants to send email about installation. SendNotification(); print "\n"; # Give a congratulations message. @files = `find . -name "*.dist"`; if (!defined($files[0])) { $files = "\tNo locally modified files\n"; } else { $files = ""; for $file (@files) { chomp($file); $files .= "\t$file\n"; } } print "\tYour update is complete\n\n"; if ($files eq "") { print "Please look at the files carefully. In particular, examine defs.wh\n"; print "and do a \"make static\" after any changes. In addition, double check\n"; print "the web server configuration. Some packages may have other items to\n"; print "configure such as mailing lists. These are noted in defs.wh.\n"; } else { print "You have some files which are locally modified. You may want to take\n"; print "a look at the *.diff files to see if anything interesting has changed.\n"; print "$files\n"; } print "Use your web browser to examine the static pages, and a sample\n"; print "of the dynamically generated pages to ensure that everything is\n"; print "working correctly.\n"; ### ### CheckConfigDirectory ### ### See if the (registration) configuration directory exists. ### If not, offer something up. ### ### Not all applications have a Config directory nor a data ### directory. However, if the registration package is run, ### then there must be one. ### sub CheckConfigDirectory { my($file, @files); my($dir) = Value(Head('_HOME-FS_')); ReadHeadWH(); return if ($dir eq "" || $dir eq "/dev/null"); # No data directory return if (-d "$dir/Configuration"); print "The registration configuration directory does not exist\n"; print "at: $dir/Configuration.\n"; if (getyn("Do you want to create it now?")) { mkpath("$dir/Configuration", 0, 0775); $uid = (getpwnam(Head('_HOME-WWW_')))[2] || -1; $gid = (getgrnam(Head('_HOME-OWNER_')))[2] || -1; chown($uid, $gid, $dir); if (!opendir(DIR, "$Root/Temp/Configuration")) { print "Cannot find Configuration/* files. Sorry.\n"; return; } @files = grep(!/\.save/, grep(!/\.old/, grep(!/^\./, readdir(DIR)))); closedir DIR; for $file (@files) { copy("$Root/Temp/Configuration/$file", "$dir/Configuration/$file"); chown((stat("$Root/Temp/Configuration/$file"))[4,5], "$dir/Configuration/$file"); } } } ### ### CheckDataDirectory ### ### See if the data directory exists. If not, create it. ### ### It is unclear who should own the directory or what mode ### it should be created in. ### sub CheckDataDirectory { my($dir, $gid, $uid); ReadHeadWH(); $dir = Value(Head('_HOME-FS_')); return if ($dir eq "" || $dir eq "/dev/null"); # No data directory return if (-d $dir); print "The data directory $dir does not exist.\n"; if (getyn("Do you want to create it now?")) { mkpath($dir, 0, 0775); $uid = (getpwnam(Head('_HOME-OWNER_')))[2] || -1; $gid = (getgrnam(Head('_HOME-OWNER_')))[2] || -1; chown($uid, $gid, $dir); } } ### ### CheckDefs ### ### See if the defs.wh file looks reasonable. ### sub CheckDefs { my($alias, $dir, $editdefs, $model); $editdefs = 0; $model = Head('_SECURITY-MODEL_'); # See how it looks w.r.t. to the local environment. # The web server should match, as should the directory. chdir($Root); if (Head('_HOME-HOST_') ne $HostName) { print "defs.wh says _HOME-HOST_ is ", Head('_HOME-HOST_'), "\n"; print "but it seems like $HostName might be a better choice.\n\n"; $editdefs++; } ($alias = "http://$HostName$ScriptAlias") =~ s#/$## if (defined($ScriptAlias)); if (defined($ScriptAlias) && (Head('_HOME-BIN_') ne $ScriptAlias && Head('_HOME-BIN_') ne $alias) && $model eq "ScriptAlias") { print "defs.wh says _HOME-BIN_ is ", Head('_HOME-BIN_'), "\n"; print "but it seems like $alias might be a better choice.\n\n"; $editdefs++; } if (Head('_HOME-HTTP_') ne $Root) { print "defs.wh says _HOME-HTTP_ is ", Head('_HOME-HTTP_'), "\n"; print "but it seems like $Root might be a better choice.\n\n"; $editdefs++; } $dir = Value(Head('_HOME-FS_')); if ($dir ne "" && $dir ne "/dev/null" && (! -d Head('_HOME-FS_'))) { print "defs.wh says _HOME-FS_ is $dir\n"; print "but that directory doesn't exist. Either create the\n"; print "directory, or change the definition.\n"; $editdefs++; } if (defined($WebUser) && Head('_HOME-WWW_') ne $WebUser && $model eq "ScriptAlias") { print "defs.wh says _HOME-WWW_ is ", Head('_HOME-WWW_'), "\n"; print "but it seems like $WebUser might be a better choice.\n\n"; $editdefs++; } # See how it compares to the distribution copy system("$Perl SupportBin/localize SupportBin/check.data bin/appl.lc >/dev/null"); system("SupportBin/check.data slave"); if ($? != 0) { $editdefs++; } elsif (! -f "Config/defs.wh.dist") { print "It looks like defs.wh has never been configured.\n"; $editdefs++; } if ($editdefs > 0) { print "It seems that you should update defs.wh.\n"; print "As you edit the specific items noted above, look at\n"; print "the rest of the items to ensure that they are reasonable\n"; print "as well.\n"; if (getyn("Would you like to edit defs.wh now?")) { EditFile("Config/defs.wh"); print "If there were problems editing Config/defs.wh, you\n"; print "can hit ^Z now, or start another telnet session to\n"; print "edit this file. It is important to have certain\n"; print "information correct in this file before proceeding.\n"; print "Hit the Enter key when you are ready to go on: "; $_ = ; } } } ### ### CheckPasswordFiles ### ### See that password files exist. ### sub CheckPasswordFiles { my($gid, $owner, $passwd, $salt, $uid); my($dir) = Value(Head('_HOME-FS_')); # Make sure a .htaccess file exists in the data directory. return if ($dir eq "" || $dir eq "/dev/null"); # No data directory if (! -f "$dir/.htaccess") { if (open(FILE, ">$dir/.htaccess")) { print FILE "Order deny,allow\n"; print FILE "Deny from all\n"; close FILE; } } # Check the password file return if (-f "$dir/passwd"); print "It appears that the password files don't exist. This is needed\n"; print "for the administration of the pages.\n"; return if (!getyn("Would you like to create an administrator account?")); if (!open(FILE, ">$dir/passwd")) { print "Cannot open $dir/passwd: $!\n"; return; } for ($owner = ""; $owner =~ /^\s*$/; ) { print "Please enter the account name to own this application: "; chomp($owner = ); $owner =~ s#[/]##g; } print "The owner is $owner\n"; for ($passwd = ""; $passwd =~ /^\s*$/; ) { print "Please enter the password: "; chomp($passwd = ); } $salt = sprintf("%02d", $$ % 100); $passwd = crypt($passwd, $salt); # print FILE "owner:164zuJWTlv5FI\n"; print FILE "$owner:$passwd\n"; close FILE; if (!open(FILE, ">$dir/passwd2")) { print "Cannot open $dir/passwd2: $!\n"; return; } # print FILE "owner:x:00000000:0\n"; print FILE "$owner:x:00000000:0\n"; close FILE; mkpath("$dir/Accepted", 0, 0755); if (!open(FILE, ">>$dir/Accepted/$owner")) { print "Cannot open $dir/Accepted/$owner: $!\n"; return; } print FILE "name\t$owner\n"; close FILE; chmod(0664, "$dir/passwd", "$dir/passwd2", "$dir/Accepted/$owner"); $uid = (getpwnam(Head('_HOME-WWW_')))[2] || -1; $gid = (getgrnam(Head('_HOME-OWNER_')))[2] || -1; chown($uid, $gid, "$dir/passwd", "$dir/passwd2", "$dir/Accepted/$owner"); } ### ### CopyFilesIntoPlace ### ### Look through the checksum file to identify all of the files. ### ### Any file not in the local tree, place in the appropriate place. ### ### Any file that already exists, but the existing file is one ### of the earlier distributions can be overwritten. ### ### Any file that exists and looks locally modified, indicate that ### there is a new file, name it $File.dist, create a $File.diff ### and tell the operator about the situation. ### ### The new code should have the checksum program. Use it for ### computing checksums. ### sub CopyFilesIntoPlace { my($fnm, $name, %application_files) = @_; my($cs, @cs, $cspgm, $dir, $first, $fname); if (!open(CS, "<$Root/Temp/Config/checksums")) { print "Cannot open $Root/Temp/Config/checksums: $!\n"; print "No point in continuing.\n"; exit 1; } @cs = ; close CS; push(@cs, "Config/data: (0 0 0)") if ($Class{$name} eq "application"); print "Copying files into the appropriate places.\n"; $cspgm = "/tmp/checksum.$$"; if (!copy("Temp/SupportBin/checksum", "/tmp/checksum.$$")) { if (-x "SupportBin/checksum") { $cspgm = "SupportBin/checksum"; } else { print STDERR "No checksum program, so we cannot continue\n"; exit 1; } } $first = 1; foreach (@cs) { chomp; next unless (/^(\S+): (.*)/); ($fname, $cs) = ($1, $2); next unless (-f "Temp/$fname"); # Don't worry about the file if it next if ($fname eq "Config/checksums"); # doesn't exist. unlink("$fname.dist"); # Delete the files if they exist unlink("$fname.diff"); # Application versions are more important next if (defined($application_files{$fname})); next if ($fname =~ /\.tar\.gz$/); unlink($fname) if (defined($AlwaysOverwrite{$fname})); if (! -f $fname) { # File doesn't exist. Move it into place. if ($fname =~ m#/#) { ($dir = $fname) =~ s#/[^/]+$##; mkpath($dir, 0, 0755); } dorename("Temp/$fname", $fname); } else { # File does exist. Is it one of the previous distribution files? chomp($local_cs = `$Perl $cspgm $fname`); $local_cs =~ s/\d+/\\d+/; if ($cs =~ /\(\d+ $local_cs\)/) { # It is one of ours. dounlink($fname); dorename("Temp/$fname", $fname); } else { # They have modified the file dorename("Temp/$fname", "$fname.dist"); system("diff $fname $fname.dist > $fname.diff"); if ($first) { $first = 0; print "The following files have local modifications and have not been updated.\n"; print "The new file is named *.dist so that you can make comparisons.\n"; } print "\t$fname\n"; } } } unlink("/tmp/checksum.$$"); # No problem if it doesn't exist # Lot's of checksum files, don't overwrite the application's file # unlink("$Root/Config/checksums"); # dorename("Temp/Config/checksums", "$Root/Config/checksums"); } ### ### dorename ### ### Rename a file. ### sub dorename { my($old, $new) = @_; return if (rename($old, $new)); print "Cannot rename $old to $new: $!\n"; print "This is unexpected.\n"; exit 1; } ### ### dosystem ### ### Do a system command. If it fails, we are dead. ### sub dosystem { my($cmd) = @_; if (system($cmd) != 0) { print "Command \"$cmd\" failed.\n"; exit 1; } } ### ### dounlink ### ### Remove a file. Barf if failure. ### sub dounlink { my($fname) = @_; return unless -f $fname; return if unlink($fname); print "Cannot delete $fname: $!\n"; print "This is unexpected.\n"; exit 1; } ### ### EditFile ### ### Edit the named file. If the file is read-only, use "vic" ### to edit the file, otherwise use VISUAL. ### ### Note that root can write on files regardless of write ### status, so the -w is not particularly useful. This lets ### root edit files that should really be edited with "vic". ### sub EditFile { my($fname) = @_; my($editor, $input); $editor = "vic"; if (-w $fname) { $editor = $ENV{'VISUAL'} || $ENV{'EDITOR'} || "vi"; } if (!InPath($editor)) { print "\nCannot find \"$editor\" in your path. You will need to\n" . "edit $fname in some other fashion. You can do that now\n" . "by using another window or by hitting ^Z here, and resuming\n" . "later. In many cases you can simply continue and deal with\n" . "the file at some later time.\n\n" . "Hit Enter or Return when ready to proceed.\n"; $input = ; # Wait for return key } else { system("$editor $fname"); } } ### ### FindIdentity ### ### Find out where we are, hostnames, etc. ### sub FindIdentity { # Find our position in the tree. ($Root = getcwd()) =~ s#/SupportBin.*##; if ($Root eq "" || $Root eq "/") { print "You cannot run this program from $Root. Please do a \"cd\"\n"; print "to the directory the program should be installed in and\n"; print "rerun this command.\n"; exit 1; } chdir($Root); # Find where Perl lives if ($EXECUTABLE_NAME =~ m#^/#) { $Perl = $EXECUTABLE_NAME; # Absolute path is unambiguous } else { # Look to see how we are supposed to start up. ($Perl = $Config{'startperl'}) =~ s/^#!//; } } ### ### FindWebServer ### ### The web server configuration should talk about this directory. ### Take a look in the config file and see what we can find. ### ### This relies upon an apache server running mod_info with ### a reasonable path. If this isn't the case, we don't get far. ### ### We could do a find looking for httpd.conf, but that is not ### defined to work either. ### ### If we are running with the security model of SUExec, there ### is little to gain from reading the web server information. ### sub FindWebServer { my($config, $hostname, $info, @infonames, $item, @items, $page, $pidfile, $retval, $tmp); my($aliases, $addrtype, $length, @addrs); # # Identify: # hostname # home file system ($Root) # If any is different from the definition in defs.wh, make # a note about a possible change. A possible exception is # to look at the specified hostname and see if it resolves # to the current machine. Ideally, we could also deal with # multi-homed hosts, but that is harder. # print "\n"; $hostname = hostname(); ($HostName, $aliases, $addrtype, $length, @addrs) = gethostbyname($hostname); $RealName = $HostName; # print "Host name is $HostName\n"; return if (Head('_SECURITY-MODEL_') eq "SUExec"); # # Look for web server information. This will allow us to find # the web server user, and where the config files are located. # This in turn lets us see if appropriate ScriptAliases are # already present. Also, determine the PID of the web server # which we will use after editing. # @infonames = qw(server-info info); for $info (@infonames) { last if (defined($WebPID)); # print "Fetch using $info\n"; # $page = get("http://127.0.0.1/$info"); # $page = get("http://$HostName/$info"); # get() is failing. This is harder, but works. $retcode = getstore("http://$HostName/$info", "$Root/Temp/info"); $page = undef; if ($retcode == 200 && open(FILE, "<$Root/Temp/info")) { $page = ""; while () { $page .= $_; } close FILE; } if (defined($page) && $page =~ /Apache Server Information/) { ($WebUser = $page) =~ s#.*User/Group.*?(\w+).*#$1#s; ($pidfile = $page) =~ s#.*PID File:.*?([^<]+).*#$1#s; ($HostName = $page) =~ s#.*Hostname/port:.*?([^<]+).*#$1#s; ($ServerRoot = $page) =~ s#.*Server Root:.*?([^<]+).*#$1#s; ($config = $page) =~ s#.*Config File:.*?([^<]+).*#$1#s; $HostName =~ s/:80//; # print "WebUser is $WebUser\n"; # print "pidfile is $pidfile\n"; # print "Hostname is $HostName\n"; # print "ServerRoot is $ServerRoot\n"; $pidfile = "$ServerRoot/$pidfile" unless ($pidfile =~ m#^/#); if (open(PID, "<$pidfile")) { chomp($WebPID = ); close PID; # print "WebPID is $WebPID\n"; } $tmp = $page; $tmp =~ s#VirtualHost.*?/VirtualHost##gis; @items = split(/ServerName/, $tmp); if (scalar(@items) > 2) { ($HostName = $items[2]) =~ s#^.*?(.*?).*#$1#si; # print "HostName is now $HostName\n"; } # See if we are under a virtual host $RealName = $HostName; @items = split(/;VirtualHost/, $page); for $item (@items) { if ($item =~ m#DocumentRoot ([^<]+).*#s) { if (index($Root, $1) != -1) { if ($item =~ m#ServerName ([^<]+).*#s) { $HostName = $1; # print "Found new hostname of $HostName\n"; } } } } # See if there is a ScriptAlias directive for this directory. if ($page =~ m#ScriptAlias (\S+)\s+\Q$Root\E/bin/#) { $ScriptAlias = $1; # print "ScriptAlias found of $ScriptAlias\n"; } } } # See if the web server looks up to snuff. # This involves a ScriptAlias for this directory. if (Head('_SECURITY-MODEL_') eq "ScriptAlias") { if (!defined($WebPID)) { ($tmp = Head('_HOME-BIN_')) =~ s#http://.*/##; print << "EOF"; I cannot find information about your web server. Sorry. Please make sure that you have a ScriptAlias directive in your web configuration file: httpd.conf It should look something like: ScriptAlias /$tmp/ $Root/bin/ This may be in a VirtualHost directive. EOF } else { if (!defined($ScriptAlias)) { ($tmp = Head('_HOME-BIN_')) =~ s#http://.*/##; print << "EOF"; I cannot find a ScriptAlias directive in the web server configuration file: $config It should look something like: ScriptAlias /$tmp/ $Root/bin/ EOF if ($RealName ne $HostName) { print << "EOF"; This directive should be in the VirtualHost section for $HostName. EOF } if ($> != 0) { print "You will need to edit $config as root and do:\n"; print "\tkill -HUP $WebPID\n"; print "to restart the web server.\n"; } elsif (getyn("Would you like to make changes to the web configuration file?")) { EditFile($config); print "Web server will be restarted\n"; kill('HUP', $WebPID); } } } } print "\n\n"; } ### ### GetDistribution ### ### Get a copy of the distribution to the local site. ### sub GetDistribution { my($list) = @_; my($dir, $dist, $distribution, $fname, @list, $retcode); # Create a place for it. die "Bad screwup with $Root" if ($Root eq "" || $Root eq "/"); # rmtree("$Root/Temp", 0, 0); if (! -d "$Root/Temp" && !mkdir("$Root/Temp", 0755)) { print "Cannot create $Root/Temp: $!\n"; print "This prevents us from continuing.\n"; exit 1; } # Get the file chomp($list); @list = split(/\n/, $list); for $dist (@list) { print "Getting distribution file from:\n\t$dist\n"; $retcode = getstore($dist, "$Root/Temp/appl.tar.gz"); if ($retcode == 200) { $distribution = $dist; last; } else { print "Problems retrieving the file: $retcode\n"; } } if (!defined($distribution)) { print "I cannot get any of the distribution files, no point in continuing.\n"; exit 1; } # If this is the file that we worked with last time, give it up. ($fname = $distribution) =~ s#.*/##; if (-f "$Root/$fname") { system("cmp -s $Root/$fname $Root/Temp/appl.tar.gz"); if ($? == 0) { print "The distribution of $fname has not changed since last time.\n"; # rmtree("$Root/Temp", 0, 0); return ""; } } # Now bust it apart. Not all systems have a modern tar, so no -z. # Also, sometimes tar on troi gets funky. Also, make a copy # of the original distribution. We will want it after a # successful installation. Hey! Troi isn't in use anymore. # print "If tar asks for volume 2, simply hit \".\".\n"; chdir("$Root/Temp"); unlink("appl.tar", $fname); copy("appl.tar.gz", $fname); dosystem("gzip -d appl.tar.gz"); if (! -f "appl.tar") { # Some tar's extract to the original filename my($fname2); ($fname2 = $fname) =~ s/\.gz$//; rename($fname2, "appl.tar"); } system("tar xpf appl.tar"); # This sometimes "fails". # $dir = `tar tvf appl.tar | head -1`; # chomp $dir; # $dir =~ s/.* //; # system("mv -f $dir/* ."); chdir($Root); print "\n"; return $fname; } ### ### getyn ### ### Get a yes or no answer. ### sub getyn { my($prompt) = @_; my($ans); print "$prompt "; $ans = ; return ($ans =~ /^y/i); } ### ### Head ### ### Return a variable from the %Head hash, and make all of the ### possible expansions from %Head. ### ### This is patterned from the Expand function in webc. ### sub Head { my($name) = @_; my($count1, $count2, $sym); $_ = $Head{$name}; return "" if (!defined($_)); for ($count1 = 0; $count1 < 100; $count1++) { $count2 = 0; for $sym (keys %Head) { next if (!defined($sym) || $sym eq "" || !defined($Head{$sym})); $count2 += s/$sym/$Head{$sym}/g; } last if ($count2 == 0); } return $_; } ### ### InPath ### ### See if a program is a file along the PATH. ### sub InPath { my($fname) = @_; my($item, @path); return -x $fname if ($fname =~ m#^/#); # Deal with absolute pathnames @path = split(/:/, $ENV{'PATH'}); for $item (@path) { return 1 if (-x "$item/$fname"); } return 0; } ### ### InstallFiles ### ### Collect the appropriate distribution packages, and install ### the contents in the appropriate places. ### sub InstallFiles { my(%application_files, $changed, $fname, $list, $name, @packages); ParseTable(); # Go through each of the packages and process it in turn. $changed = 0; for $name (@Packages) { next if ($CommandMode eq "-refresh" && Value($Class{$name}) eq "application"); print "\nProcessing package $name\n"; undef %application_files; if (!defined($Class{$name})) { print " *** Cannot find $name ***\n"; next; } %application_files = ReadApplicationFiles() if ($Class{$name} ne "application"); $list = $Release{$name}; $list = $Test{$name} if ($CommandMode ne "-update"); $list = ($Release{$name} || $Test{$name}) if (!defined($list)); # print "List is $list\n"; # Get a copy of the distribution onto the local site. # Pull it apart in a temp directory. Pay special attention # to the checksum file. $fname = GetDistribution($list); next if ($fname eq ""); # Same as old distribution # Go through the checksum file and identify all files in the # distibution. Copy the new ones into place. If there are # ones where the local file is different, copy the new file # to a .dist and make a .diff file and tell the user. The checksum # is funny, as it doesn't count information which might be changed # by the localization process. $changed++; CopyFilesIntoPlace($fname, $name, %application_files); # Clean up the temp directory. die "Bad screwup with $Root" if ($Root eq "" || $Root eq "/"); unlink("$Root/$fname"); rename("$Root/Temp/$fname", "$Root/$fname"); # rmtree("$Root/Temp", 0, 0); } # If nothing has changed, bail if ($changed == 0) { print "No new files, so there is no need to continue.\n"; exit 0; } } ### ### ListDistributionSites ### ### We are the test site. We were called to put out a comment ### in this situation reminding people to update the distribution ### sites. ### ### Hopefully, the user called this with something like: ### update -package oracle -isdist ### sub ListDistributionSites { my($count, $name, $release, @release); ParseTable(); exit 0 unless (-f "Config/testsite"); $count = 0; for $name (@Packages) { next unless (defined($Release{$name})); @release = split(/\n/, $Release{$name}); for $release (@release) { if ($count == 0) { print "If this is a \"final\" test distribution, then update the\n"; print "release sites for this package at:\n"; } $count++; print "\t$release\n"; } } if ($count > 0) { print "Telnet to each of the distribution sites and type:\n"; print "\tmake gettest\n"; print "\tmake distribution\n"; print "Of course, do appropriate testing before making the distribution.\n"; } exit 0; } ### ### Make ### ### Run "make" if the option exists in the makefile. ### sub Make { my($rule, $asroot) = @_; # Find the rules available. if (!defined(%Make)) { if (!open(MAKE, ") { next if (/^\s*#/ || /^\s/); next unless (/^(\S+)\s*:/); $Make{$1} = 1; } close MAKE; } # See if this is a rule we know about. return unless (defined($Make{$rule})); if ($asroot && $> != 0) { print "Cannot execute \"make $rule\" unless you are root.\n"; print "This may cause problems soon, but we'll continue.\n"; return; } print "Calling: make $rule\n"; system("make $rule"); print "\n\n"; } ### ### ParseTable ### ### Break the table into managable data structures. ### sub ParseTable { my($info, @info, $name, @packages, $pname, $value); # Parse the table into a form we can work with. @info = split(/\n/, $ConfigInformation); @packages = (); for $info (@info) { chomp $info; next if ($info =~ /^\s*$/ || $info =~ /^\s*#/); next unless ($info =~ /^\s*(.*?)\s*=\s*(.*)/); ($name, $value) = ($1, $2); if ($name eq "name") { $pname = $value; push(@packages, $value); } elsif ($name eq "class") { $Class{$pname} = $value; } elsif ($name eq "release") { $Release{$pname} = Value($Release{$pname}) . "$value\n"; } elsif ($name eq "test") { $Test{$pname} = Value($Test{$pname}) . "$value\n"; } elsif ($name eq "params") { $Params{$pname} = Value($Params{$pname}) . "$value\n"; } } # Make sure we have the list of packages. if (scalar(@Packages) == 0) { # If no packages were selected, select them all. for $name (@packages) { push(@Packages, $name) if (Value($Params{$name}) !~ /noinstall/); } } } ### ### ReadApplicationFiles ### ### Create a hash of the files within the application. ### Support packages cannot overwrite files in the application. ### sub ReadApplicationFiles { my(%hash); return () if (!open(APPL, "<$Root/Config/application.files")); while () { chomp; $hash{$_} = 1; } close APPL; return %hash; } ### ### ReadHeadWH ### ### Read the defs.wh file. Look for #define statments and make them ### variables in the %Head hash. ### ### The head.wh file used to have lots of definitions. Those ### definitions have been moved to defs.wh. ### sub ReadHeadWH { undef %Head; if (open(HEAD, "<$Root/Config/defs.wh")) { while () { chomp; $Head{$1} = $2 if (/^\s*#\s*define\s+(\S+)\s+(.*)/); } close HEAD; } } ### ### SendNotification ### ### Send email to the author. ### sub SendNotification { my($appl, $sendmail, $to, $val, $var); my(@sm) = ( "/usr/lib/sendmail", "/usr/sbin/sendmail" ); my(@vars) = qw(Distribution HostName RealName ScriptAlias ServerRoot UpdateVersion WebUser Root WebPage Email); print "Thanks for installing this package. As the author, I'd\n"; print "like to know who is using the package.\n"; return if (!getyn("Is it OK to send email to the author?")); $to = Head('_REAL-ADDR_'); $WebPage = Head('_HOME-URL_'); $Email = Head('_EMAIL-ADDR_'); for $sendmail (@sm) { if (-x $sendmail) { if (open(MAIL, "| $sendmail $to")) { $appl = Head('_APPL-NAME_'); $appl = "application" if (!defined($appl) || $appl eq ""); print MAIL "To: $to\n"; print MAIL "Subject: Installed $appl\n"; print MAIL "\n"; print MAIL "A copy of $appl has been installed or updated.\n\n"; for $var (@vars) { $val = eval("\$$var"); print MAIL "$var: $val\n" if (defined($val)); } close MAIL; return; } print "Cannot open $sendmail\n"; exit 1; } } print "Cannot find sendmail, so no mail sent.\n"; } ### ### Value ### ### Return a string value even if undefined. ### sub Value { my($str) = @_; return "" if (!defined($str)); return $str; }