diff --git a/Yard.pm b/Yard.pm deleted file mode 100644 index daae09a..0000000 --- a/Yard.pm +++ /dev/null @@ -1,2128 +0,0 @@ -############################################################################# -## -## Yard.pm combining -## MAKE_ROOT_FS, CHECK_ROOT_FS, and YARD_UTILS.PL by Tom Fawcett -## Copyright (C) 1996,1997,1998 Tom Fawcett (fawcett@croftj.net) -## Copyright (C) 2000 Modifications by the gBootRoot Team -## -## This program is free software; you may redistribute it and/or modify -## it under the terms of the GNU General Public License as published by -## the Free Software Foundation; either version 2 of the License, or -## (at your option) any later version. -## -## This program is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. -## -## You should have received a copy of the GNU General Public License -## along with this program; if not, write to the Free Software -## Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -## -##### -## -## This is a heavily modified version of several scripts from the Yard -## Suite (v2.0) by Tom Fawcett. The modifications allow gBootRoot to use -## Yard as a Method. -## -############################################################################## - -package Yard; -use vars qw(@ISA @EXPORT %EXPORT_TAGS); -use Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(start_logging_output info kernel_version_check verbosity - read_contents_file extra_links library_dependencies hard_links - space_check create_filesystem find_file_in_path sys - text_insert error logadj *LOGFILE which_tests); - -use strict; -use File::Basename; -use File::Path; -use FileHandle; -use Cwd; # I am not even sure if this is being used here now -use English; # I think this can be ditched for portability -use File::Find; # used by check_root_fs -use Error; - -my (%Included, %replaced_by, %links_to, %is_module, %hardlinked, - %strippable, %lib_needed_by, @Libs); -my $cf_line = 0; -my $BLKGETSIZE_ioctl = 4704; -my $BLKFLSBUF_ioctl = 4705; -my $EXT2_BLOCK_SIZE = 1024; -my $INODE_SIZE = 1024; -my $objcopy = "objcopy"; -my($Warnings) = 0; -my $verbosity; -my ($text_insert,$red,$blue); -my $logadj; -my ($device, $mount_point); - - -# This solves an annoying problem with the new Perl-5.6 built in glob, -# allowing earlier versions of Perl to run. -# But the new glob is a good thing for this program since it doesn't have to -# depend on outside programs, making Tom's test_glob() history. -BEGIN { - if ($] =~ /006/) { - require File::Glob; - } -} - -STDOUT->autoflush(1); - -$SIG{__WARN__} = - sub { warn @_ unless $_[0] =~ /Subroutine [\w:]+ redefined/io }; - -sub warning { - info(0, "Warning: ", @_); - $Warnings++; -} - -sub verbosity { $verbosity = $_[0]; } -sub text_insert { $text_insert = $_[0]; $red = $_[1]; $blue = $_[2]; } -sub logadj { $logadj = $_[0]; } - -## REQUIRES $kernel opt. $kernel_version -sub kernel_version_check { - - my($kernel,$kernel_version) = @_; - - if (defined($kernel_version)) { - # Check to see if it agrees - my($version_guess) = kernel_version($kernel); - if ($version_guess ne $kernel_version) { - ## Is this really necessary, it can be assumed a person knows - ## what they are doing. - info(0, - "You declared kernel $kernel to be version $kernel_version\n", - "even though a probe says $version_guess.", - " I'll assume you're right.\n") - } - $ENV{'RELEASE'} = $kernel_version; - - } elsif (defined($ENV{'RELEASE'} = kernel_version($kernel))) { - info(0, "\nVersion probe of $kernel returns: $ENV{'RELEASE'}\n"); - } else { - warning "Can't determine kernel version of $kernel\n"; - my($release) = `uname -r`; - if ($release) { - chomp($release); - info(0, "Will use version of current running kernel ($release)\n", - "Make sure this is OK\n"); - $ENV{'RELEASE'} = $release; - } else { - my $error = error( - "And can't determine running kernel's version either!\n"); - return "ERROR" if $error && $error eq "ERROR"; - } - } - -} # end sub kernel_version_check - -## This checks lib/modules/$version for rd.o, ext2.o, floppy.o -## Perhaps just extra stuff, this could be made real fancy, too. -#@@warn_about_module_dependencies($ENV{'RELEASE'}); - -############################ -##### READ IN CONTENTS FILE -############################ -## Uses info, error, cf_warn, make_link_absolute, make_link_relative, -## cf_die, must_be_abs, replaced_by, yard_glob -## REQUIRES $contents_file -sub read_contents_file { - - my ($contents_file) = @_; - my $error; - - info(0, "\n\nPASS 1: Reading $contents_file"); - info(0, "\n"); - - open(CONTENTS, "<$contents_file") or - ($error = error("$contents_file: $!")); - return "ERROR"if $error && $error eq "ERROR"; - - my($line); - - LINE: while (defined($line = )) { - - my(@files); - $cf_line++; - chomp $line; - $line =~ s/[\#%].*$//; # Kill comments - next if $line =~ /^\s*$/; # Ignore blank/empty line - - $line =~ s/^\s+//; # Delete leading/trailing whitespace - $line =~ s/\s+$//; - - if ($line =~ /->/) { ##### EXPLICIT LINK - if ($line =~ /[\*\?\[]/) { - cf_warn($line, "Can't use wildcards in link specification!"); - next LINE; - } - my($file, $link) = $line =~ /^(\S+)\s*->\s*(\S+)\s*$/; - if (!defined($link)) { - cf_warn($line, "Can't parse this link"); - next LINE; - } - ##### The '->' supersedes file structure on the disk, so don't - ##### call include_file until pass two after all explicit links - ##### have been seen. - my($abs_file) = find_file_in_path($file); - $Included{$abs_file} = 1 if $abs_file; - #### Have to be careful here. Record the rel link for use - #### in setting up the root fs, but use the abs_link in @files - #### so next loop gets any actual files. - my($abs_link) = make_link_absolute($abs_file, $link); - my($rel_link) = make_link_relative($abs_file, $link); - $links_to{$abs_file} = $rel_link if $abs_file; - info(1, "$line links $abs_file to $rel_link\n") if $abs_file; - @files = ($abs_link); - - } elsif ($line =~ /<=/) { ##### REPLACEMENT SPEC - $error = cf_die($contents_file, $line, - "Can't use wildcard in replacement specification") if - $line =~ /[\*\?\[]/; - return "ERROR" if $error && $error eq "ERROR"; - - my($file, $replacement) = $line =~ /^(\S+)\s*<=\s*(\S+)\s*$/; - - if (!defined($replacement)) { - cf_warn($contents_file, $line, - "Can't parse this replacement spec"); - next LINE; - - } else { - must_be_abs($file); - (-d $file) and cf_warn($contents_file, $line, - "left-hand side can't be directory"); - my($abs_replacement) = find_file_in_path($replacement); - if (!(defined($abs_replacement) and -e $abs_replacement)) { - cf_warn($contents_file, $line, "Can't find $replacement"); - - } elsif ($replacement =~ m|^/dev/(?!null)|) { - # Allow /dev/null but no other devices - cf_warn($contents_file, $line, - "Can't replace a file with a device"); - - } else { - $replaced_by{$file} = $abs_replacement; - $Included{$file} = 1; - } - - next LINE; - } # End of replacement spec - - } elsif ($line =~ /(<-|=>)/) { - cf_warn($contents_file, $line, "Not a valid arrow."); - next LINE; - - } else { - - @files = (); - my($expr); - for $expr (split(' ', $line)) { - my(@globbed) = yard_glob($expr); - if ($#globbed == -1) { - cf_warn($contents_file, $expr, - "Warning: No files matched $expr"); - } elsif (!($#globbed == 0 and $globbed[0] eq $expr)) { - info(1, "Expanding $expr to @globbed\n"); - } - push(@files, @globbed); - } - } - - my($file); - FILE: foreach $file (@files) { - - if ($file =~ m|^/|) { ##### Absolute filename - - # This complains for non-existent $files for some reason. - # like /dev/pilot, but can't replicate - if (-l $file and readlink($file) =~ m|^/proc/|) { - info(1, "Recording proc link $file -> ", readlink($file), - "\n"); - $Included{$file} = 1; - $links_to{$file} = readlink($file); - - } elsif (-e $file) { - - $Included{$file} = 1; - - } elsif ($file =~ m|^$::oldroot/(.*)$|o and -e "/$1") { - ### Don't complain about links to files that will be mounted - ### under $oldroot, the hard disk root mount point. - next FILE; - - } else { - cf_warn($contents_file, $line, - "Absolute filename $file doesn't exist"); - } - - } else { ##### Relative filename - my($abs_file) = find_file_in_path($file); - if ($abs_file) { - info(1, "Found $file at $abs_file\n"); - $Included{$abs_file} = 1; - } else { - cf_warn($contents_file, $line, - "Didn't find $file anywhere in path"); - } - } - } # End of FILE loop - } # End of LINE loop - - info(0, "\nDone with $contents_file\n\n"); - close(CONTENTS) or ($error = error("close on $contents_file: $!")); - return "ERROR"if $error && $error eq "ERROR"; - -} # end read_contents_file - - -# Uses include_file -sub extra_links { - - my ($contents_file) = @_; - - info(0, "PASS 2: Picking up extra files from links...\n"); - - for (keys %Included) { - # watch for "" - GBteam - include_file($contents_file, $_) if $_ ne ""; - } - - info(0, "Done.\n\n"); -} - - -sub library_dependencies { - - my ($contents_file) = @_; - my $error; - - info(0, "PASS 4: Checking library dependencies...\n"); - info(1, "(Ignore any 'statically linked' messages.)\n"); - - # Normal file X: X in %Included. - # X -> Y: X in %links_to, Y in %Included - # X <= Y: X in %Included and %replaced_by - - my($file); - foreach $file (keys %Included) { - - ##### Use replacement file if specified - $file = $replaced_by{$file} if defined($replaced_by{$file}); - - ##### Skip links (target will be checked) - next if defined($links_to{$file}); # Symbolic (declared) - next if -l $file; # Symbolic (on disk) - - my($file_line) = `file $file`; - ##### See whether it's strippable and make a note. - ##### This will prevent us from wasting time later running objcopy - ##### on binaries that are already stripped. - if ($file_line =~ m/not stripped/) { - $strippable{$file} = 1; - } - ##### See whether it's a module and mark the info for later - ##### so that we strip it correctly. - if ($file_line =~ m/relocatable/) { - info(1, "Marking $file as a module\n"); - $is_module{$file} = 1; - - } elsif ($file_line =~ m/shared object/) { - ##### Any library (shared object) seen here was explicitly - ##### included by the user. - - push(@{$lib_needed_by{$file}}, "INCLUDED BY USER"); - } - - if (-f $file and -B _ and -x _ and $file_line =~ /executable/) { - - ##### EXECUTABLE LOADABLE BINARY - ##### Run ldd to get library dependencies. - my $line; - foreach $line (`ldd $file`) { - my($lib) = $line =~ / => (\S+)/; - next unless $lib; - my($abs_lib) = $lib; - - if ($lib =~ /not found/) { - warning "File $file needs library $lib," . - " which does not exist!"; - } else { - - ##### Right-hand side of the ldd output may be - ##### a symbolic link. - - ##### Resolve the lib absolutely. - ##### include_file follows links and adds each file; - ##### the while loop makes sure we get the last. - $abs_lib = $lib; - include_file($contents_file, $lib); - while (1) { - if (defined($links_to{$abs_lib})) { - $abs_lib = make_link_absolute($abs_lib, - $links_to{$abs_lib}); - } - if (defined($replaced_by{$abs_lib})) { - $abs_lib = $replaced_by{$abs_lib}; - } - last unless -l $abs_lib; - my($link) = readlink($abs_lib) or - ($error = error("readlink($abs_lib): $!")); - return "ERROR"if $error && $error eq "ERROR"; - $abs_lib = make_link_absolute($abs_lib, $link); - - } - } - if (!defined($lib_needed_by{$abs_lib})) { - info(0, "\t$abs_lib\n"); - } - push(@{$lib_needed_by{$abs_lib}}, $file); - } - } - } - - #################################### - ##### Check libraries and loader(s) - #################################### - (@Libs) = keys %lib_needed_by; - - my($seen_ELF_lib, $seen_AOUT_lib); - my(%full_name); - - if (@Libs) { - info(1, "\nYou need these libraries:\n"); - - my($lib); - foreach $lib (@Libs) { - my($size) = bytes_to_K(-s $lib); - my($line) = " " x 15; - my($file_output) = `file $lib`; - - if ($file_output =~ m/symbolic link/) { - $error = error( - "Yiiiiii, library file $lib is a symbolic link!\n", - "This shouldn't happen!\n", - "Please report this error(to the Yard author\n"); - return "ERROR"if $error && $error eq "ERROR"; - } - - my($lib_type) = $file_output =~ /:\s*(ELF|Linux)/m; - - ##### All libraries are strippable - $strippable{$lib} = 1; - - info(1, "$lib (type $lib_type, $size K) needed by:\n"); - - my($binary); - for $binary (sort map(basename($_), @{$lib_needed_by{$lib}})) { - if (length($line) + length($binary) > 78) { - info(1, $line, "\n"); - $line = " " x 15; - } - $line .= $binary . " "; - } - info(1, $line, "\n") if $line; - - if (!($seen_ELF_lib and $seen_AOUT_lib)) { - - ##### Check library to make sure we have the right loader. - ##### (A better way is to do "ldconfig -p" and parse the output) - ##### Strings from /usr/lib/magic of file 3.19 - - if (!defined($lib_type)) { - $error = error( - "Didn't understand `file` output for $lib:\n", - `file $lib`, "\n"); - return "ERROR"if $error && $error eq "ERROR"; - - } elsif ($lib_type eq 'ELF') { - $seen_ELF_lib = 1; - - } elsif ($lib_type eq 'Linux') { # ie, a.out - $seen_AOUT_lib = 1; - } - } - - ##### See if some other version of this library file is - ##### being loaded, eg libc.so.3.1.2 and libc.so.5.2.18. - ##### Not an error, but worth warning the user about. - - my($lib_stem) = basename($lib) =~ /^(.*?\.so)/; - if (defined($full_name{$lib_stem})) { - warning "You need both $lib and $full_name{$lib_stem}\n", - "Check log file for details.\n"; - } else { - ##### eg, $full_name{"libc.so"} = "/lib/libc.so.5.2.18" - $full_name{$lib_stem} = $lib; - } - } - } - - info(1, "\n"); - if ($seen_ELF_lib) { - # There's no official way to get the loader file, AFAIK. - # This expression should get the latest version, and Yard will grab any - # hard-linked file. - my($ld_file) = (yard_glob("/lib/ld-linux.so.?"))[-1]; # Get last one - if (defined($ld_file)) { - info(1, "Adding loader $ld_file for ELF libraries\n"); - include_file($contents_file, $ld_file); - } else { - info(0, "Can't find ELF loader /lib/ld-linux.so.?"); - } - } - if ($seen_AOUT_lib) { - # Was: yard_glob("/lib/ld.so*") - # Same as above, but ld.so seems to have no version number appended. - my($ld_file); - foreach $ld_file (yard_glob("/lib/ld.so")) { - info(1, "Adding loader $ld_file for a.out libraries\n"); - include_file($contents_file, $ld_file); - } - } - - info(0, "Done\n\n"); - -} # end sub library_dependencies - -sub hard_links { - - info(0, "PASS 3: Recording hard links...\n"); - - ##### Finally, scan all files for hard links. - - my($file); - foreach $file (keys %Included) { - - next if $links_to{$file} or $replaced_by{$file}; - ##### $file is guaranteed to be absolute and not symbolically linked. - - ##### Record hard links on plain files - if (-f $file) { - my($dev, $inode, $mode, $nlink) = stat(_); - if ($nlink > 1) { - info(1,"$file is hardlinked\n"); - $hardlinked{$file} = "$dev/$inode"; - } - } - } - - info(0, "Done.\n\n"); - -} # end sub hard_links - -########################## - -# GBteam added stripped file size check. -sub space_check { - - - info(0, "Checking space needed.\n"); - - # For libs [obj_count 1 = "all" 0 = "debug"] - my ($fs_size, $strip_lib, $strip_bin, - $strip_module, $obj_count, $tmp) = @_; - - my($total_bytes) = 0; - my(%counted); - - # %Included synopsis - # /path/file (1|symlink) - # %replaced_by /path/file /path/file .. <= - # %links_to /path/file-symnlink actual-file - # %hardlinked /path/file dev/inode -> stat() - - my ($file); - foreach $file (keys %Included) { - - my $not_stripped = `file $file`; - my $filename = basename($file); - - my($replacement, $devino); - if ($replacement = $replaced_by{$file}) { - ## strip count for replace - ## Check for libraries %lib_needed_by, modules %is_module, - ## and everything else if strippable, and strip is chosen - ## and for lib two states are possible - ##### Use the replacement file instead of this one. In the - ##### future, improve this so that replacement is resolved WRT - ##### %links_to - if ($strip_lib) { - my $not_stripped = `file $file`; - if ($not_stripped =~ m,not stripped,) { - if ($obj_count == 0) { - if ($lib_needed_by{$replacement}) { - my $tmp_strip = "$tmp/" . basename($replacement); - sys("objcopy --strip-debug $replacement $tmp_strip"); - info(1, - "Counting bytes of replacement $replacement", - " (STRIPPED DEBUG)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - elsif ($obj_count == 1) { - if ($lib_needed_by{$replacement}) { - my $tmp_strip = "$tmp/" . basename($replacement); - sys("objcopy --strip-debug $replacement $tmp_strip"); - info(1, - "Counting bytes of replacement $replacement", - " (STRIPPED ALL)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - } - } - - if ($strip_module) { - my $not_stripped = `file $replacement`; - if ($not_stripped =~ m,not stripped,) { - if ($is_module{$replacement}) { - my $tmp_strip = "$tmp/" . basename($replacement); - sys("objcopy --strip-debug $replacement $tmp_strip"); - info(1, - "Counting bytes of replacement $replacement", - " (STRIPPED DEBUG)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - } - - if ($strip_bin) { - my $not_stripped = `file $replacement`; - if ($not_stripped =~ m,not stripped,) { - my $tmp_strip = "$tmp/" . basename($replacement); - sys("objcopy --strip-all $replacement $tmp_strip"); - info(1, "Counting bytes of replacement $replacement", - " (STRIPPED ALL)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - info(1, "Counting bytes of replacement $replacement\n"); - $total_bytes += bytes_allocated($replacement); - - } elsif (-l $file or $links_to{$file}) { ## no strip - ##### Implicit or explicit symbolic link. Only count link size. - ##### I don't think -l test is needed. - my($size) = (-l $file) ? length(readlink($file)) - : length($links_to{$file}); - info(1, "$file (link) size $size\n"); - $total_bytes += $size; - } elsif ($devino = $hardlinked{$file}) { - ##### This file is hard-linked to another. We don't necessarily - ##### know that the others are going to be in the file set. - ##### Count the first and mark the dev/inode so we don't count - ##### it again. .. pretty cool - if (!$counted{$devino}) { ## 1 strip for hardlinked file - if ($strip_bin) { - my $not_stripped = `file $file`; - if ($not_stripped =~ m,not stripped,) { - my $tmp_strip = "$tmp/" . basename($file); - sys("objcopy --strip-all $file $tmp_strip"); - info(1, "Counting ", -s $tmp_strip, - " bytes of hard-linked file $tmp_strip", - " (STRIPPED ALL)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - info(1, "Counting ", -s _, - " bytes of hard-linked file $file\n"); - $total_bytes += bytes_allocated($file); - $counted{$devino} = 1; - } else { - info(1, "Not counting bytes of hard-linked file $file\n"); - } - - } elsif (-d $file) { ## no strip - $total_bytes += $INODE_SIZE; - info(1, "Directory $file = ", $INODE_SIZE, " bytes\n"); - } elsif ($file =~ m|^/proc/|) { ## no strip - ##### /proc files screw us up (eg, /proc/kcore), and there's no - ##### Perl file test that will detect them otherwise. - next; - - } elsif (-f $file) { ## - ## At this point hardlinked, dirs, replaced_by and /proc have - ## been filtered out. If strip is chosen - ## check for libraries (%lib_needed_by), modules (%is_module), - ## and everything else if strippable. For lib two states are - ## posible - ##### Count space for plain files - if ($strip_lib) { - my $not_stripped = `file $file`; - if ($not_stripped =~ m,not stripped,) { - if ($obj_count == 0) { - if ($lib_needed_by{$file}) { - my $tmp_strip = "$tmp/" . basename($file); - sys("objcopy --strip-debug $file $tmp_strip"); - info(1, "$file size ", - -s $tmp_strip, " (LIB STRIPPED DEBUG)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - elsif ($obj_count == 1) { - if ($lib_needed_by{$file}) { - my $tmp_strip = "$tmp/" . basename($file); - sys("objcopy --strip-debug $file $tmp_strip"); - info(1, "$file size ", - -s $tmp_strip, " (LIB STRIPPED ALL)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - } - } - - if ($strip_module) { - my $not_stripped = `file $file`; - if ($not_stripped =~ m,not stripped,) { - if ($is_module{$file}) { - my $tmp_strip = "$tmp/" . basename($file); - sys("objcopy --strip-debug $file $tmp_strip"); - info(1, "$file size ", - -s $tmp_strip, " (MODULE STRIPPED)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - } - - - if ($strip_bin) { - my $not_stripped = `file $file`; - if ($not_stripped =~ m,not stripped,) { - my $tmp_strip = "$tmp/" . basename($file); - sys("objcopy --strip-all $file $tmp_strip"); - info(1, "$file size ", - -s $tmp_strip, " (BIN STRIPPED)\n"); - $total_bytes += bytes_allocated($tmp_strip); - unlink($tmp_strip); - next; - } - } - - info(1, "$file size ", -s $file, "\n"); - $total_bytes += bytes_allocated($file); - - } - } - - # Libraries are already included in the count - - info(0, "Total space needed is ", bytes_to_K($total_bytes), " Kbytes\n"); - - ## One interesting thought: This isn't looking at the penalty for - ## ext2 filesystem info .. and other filesystems may be allowed in the - ## future. 8192 inodes == 1.63% penalty or at iso9660 - if (bytes_to_K($total_bytes) > $fs_size) { - info(0, "This is more than the $fs_size Kbytes allowed.\n"); - return; - } - - info(0, "\n"); - -} # end sub space_check - -######################## -##### Create filesystem -######################## - - -sub create_filesystem { - - my ($filename, $fs_size, $fs_type, $inode_size, $mnt, $strip_lib, - $strip_bin, $strip_module, $obj_count) = @_; - - $device = "$mnt/$filename"; - $mount_point = "$mnt/loopback"; - - my $file; - my $error; - - info(0, "Creating root filesystem.\n"); - info(0, "Description: $fs_size K ext2 file system\n"); - info(0, "Where: $device\n"); - - sync(); - sys("dd if=/dev/zero of=$device bs=1k count=$fs_size"); - sync(); - - if (-f $device) { - ##### If device is a plain file, it means we're using some loopback - ##### device. Use -F switch in mke2fs so it won't complain. - ## Options here can be changed. - ## Originally, this was -b 1024 switched with the inode approach. - if (sys("mke2fs -F -m 0 -i $inode_size $device $fs_size") !~ - /^0$/ ) { - $error = error("Can not make $fs_type filesystem"); - return "ERROR" if $error && $error eq "ERROR"; - } - } else { - if (sys("mke2fs -m 0 -i $inode_size $device $fs_size") !~ - /^0$/ ) { - $error = error("Can not make $fs_type filesystem"); - return "ERROR" if $error && $error eq "ERROR"; - } - } - - if (!-d $mount_point) { - return "ERROR" if errmk(sys("mkdir $mount_point")) == 2; - } - - return "ERROR" if errm(mount_device($device,$mount_point)) == 2; - ##### lost+found on a ramdisk is pointless - sys("rm -rf $mount_point/lost+found"); - - sync(); - - ##### Setting up the file structure is tricky. Given a tangled set - ##### of symbolic links and directories, we have to create the - ##### directories, symlinks and files in the right order so that no - ##### dependencies are missed. - - ##### First, create directories for symlink targets that are supposed - ##### to be directories. Symlink targets can't be superseded so - ##### sorting them by path length should give us a linear ordering. - info(0, "Creating directories for symlink targets\n"); - - for $file (sort { path_length($a) <=> path_length($b) } - keys %links_to) { - my($link_target) = $links_to{$file}; - my($abs_file) = make_link_absolute($file, $link_target); - if (-d $abs_file) { - my($floppy_file) = $mount_point . $abs_file; - my($newdir); - foreach $newdir (mkpath($floppy_file)) { - info(1, "\tCreating $newdir as a link target for $file\n"); - } - } - } - - - ##### Next, set up actual symlinks, plus any directories that weren't - ##### created in the first pass. Sorting by path length ensures that - ##### parent symlinks get set up before child traversals. - info(0, "Creating symlinks and remaining directories.\n"); - for $file (sort { path_length($a) <=> path_length($b) } - keys %Included) { - - my($target); - if (defined($target = $links_to{$file})) { - my($floppy_file) = $mount_point . $file; - mkpath(dirname($floppy_file)); - info(1, "\tLink\t$floppy_file -> $target\n"); - symlink($target, $floppy_file) or - ($error = error("symlink($target, $floppy_file): $!\n")); - return "ERROR"if $error && $error eq "ERROR"; - delete $Included{$file}; # Get rid of it so next pass doesn't copit - - } elsif (-d $file) { - my($floppy_file) = $mount_point . $file; - my($newdir); - foreach $newdir (mkpath($floppy_file)) { - info(1, "\tCreate\t$newdir\n"); - } - delete $Included{$file}; # Get rid of it so next pass doesn't copy it - } - } - - - ##### Tricky stuff is over with, now copy the remaining files. - - info(0, "\nCopying files to $device\n"); - - my(%copied); - - while (($file) = each %Included) { - my($floppy_file) = $mount_point . $file; - - my($replacement); - if (defined($replacement = $replaced_by{$file})) { - $file = $replacement; - } - - if ($file =~ m|^/proc/|) { - ##### Ignore /proc files - next; - - } elsif (-f $file) { - ##### A normal file. - mkpath(dirname($floppy_file)); - - ##### Maybe a hard link. - my($devino, $firstfile); - if (defined($devino = $hardlinked{$file})) { - ##### It's a hard link - see if the linked file is already - ##### on the root filesystem. - if (defined($firstfile = $copied{$devino})) { - ##### YES - just hard link it to existing file. - info(1, "Hard linking $floppy_file to $firstfile\n"); - sys("ln $firstfile $floppy_file"); - next; # Skip copy - - } else { - ##### NO - copy it. - $copied{$devino} = $floppy_file; - } - } - info(1, "$file -> $floppy_file\n"); - copy_strip_file($file, $floppy_file, $obj_count, $strip_lib, - $strip_bin, $strip_module); - - } elsif (-d $file) { - ##### A directory. - info(1, "Creating directory $floppy_file\n"); - mkpath($floppy_file); - - } elsif ($file eq '/dev/null' and - $floppy_file ne "$mount_point/dev/null") { # I hate this - info(1, "Creating empty file $floppy_file\n"); - mkpath(dirname($floppy_file)); - sys("touch $floppy_file"); - - } else { - ##### Some special file. - info(1, "Copying special $file to $floppy_file\n"); - mkpath(dirname($floppy_file)); - # The 'R' flag here allows cp command to handle devices and FIFOs. - sys("cp -dpR $file $floppy_file"); - } - } - - - info(0, "\nFinished creating root filesystem.\n"); - - if (@Libs) { - - info(0, "Re-generating /etc/ld.so.cache on root fs.\n"); - info(1, "Ignore warnings about missing directories\n"); - - sys("ldconfig -v -r $mount_point"); - } - - ## Probably will want to umount here - return "ERROR" if errum(sys("umount $mount_point")) == 2; - - info(0, "\nDone making the root filesystem. $Warnings warnings.\n", - "$device is now umounted from $mount_point\n\n"); - - #info(0, "All done!\n"); - #info(0, "You can run more tests with the UML kernel\n", - # "or construct a distribution by using this root\n", - # "filesystem with a boot method."); - -} # end sub create_filesystem - -####################################### -##### Utility subs for make_root_fs.pl -####################################### - -##### Add file to the file set. File has to be an absolute filename. -##### If file is a symlink, add it and chase the link(s) until a file is -##### reached. -sub include_file { - my($contents_file, $file) = @_; - my $error; - - must_be_abs($file); - if (onto_proc_filesystem($file)) { - info(1, "File $file points into proc filesystem -- not pursued.\n"); - return; - } - - $Included{$file} = 1; - - ##### If we have links A -> B -> C -> D -> E - ##### on disk and A -> D is set explicitly, then we pick up - ##### files A and D in pass 1, and E on pass 2. - - while (!defined($links_to{$file}) and !defined($replaced_by{$file}) - and -l $file) { - - ##### SYMBOLIC LINK on disk, not overridden by explicit link or - ##### replacement. Relativize the link for use later, but also - ##### check and resolve the target so it gets onto the rescue disk. - my($link) = readlink($file) or ($error = error("readlink($file): $!")); - return "ERROR"if $error && $error eq "ERROR"; - my($rel_link) = make_link_relative($file, $link); - $links_to{$file} = $rel_link; - - my($abs_target) = make_link_absolute($file, $link); - if (onto_proc_filesystem($abs_target)) { - info(1, "$file points to $abs_target, on proc filesystem\n"); - last; - } - - if (!$Included{$abs_target}) { - info(1, "File $file is a symbolic link to $link\n"); - #info(1, "\t(which resolves to $abs_target),\n" - # if $link ne $abs_target); - info(1, "\twhich was not included in $contents_file.\n"); - if (-e $abs_target) { - info(1, "\t ==> Adding it to file set.\n\n"); - $Included{$abs_target} = $file; - } else { - info(0, "\t ==> $abs_target does not exist. Fix this!\n"); - } - } - $file = $abs_target; # For next iteration of while loop - } -} - -##### More informative versions of warn and die, for the contents file -sub cf_die { - my($contents_file, $line, @msgs) = @_; - info(0, "$contents_file($cf_line): $line\n"); - foreach (@msgs) { info(0, "\t$_\n"); } - my $output = join("\n",@msgs); - error_window("gBootRoot: ERROR: ", $output); - return "ERROR"; -} - -sub cf_warn { - my($contents_file, $line, @msgs) = @_; - info(0, "$contents_file($cf_line): $line\n"); - $Warnings++; - foreach (@msgs) { info(0, "\t$_\n"); } -} - - -## Modified for user chosen defaults -# Copy a file, possibly stripping it. Stripping is done if the file -# is strippable and stripping is desired by the user, and if the -# objcopy program exists. -sub copy_strip_file { - - my($from, $to, $strip_objfiles, - $strip_lib, $strip_bin, $strip_module) = @_; - my $error; - - if ($strippable{$from}) { - # Copy it stripped - - if ($strip_lib) { - if (defined($lib_needed_by{$from})) { - # It's a library - if ($strip_objfiles == 1) { - info(1, "Copy/stripping library $from to $to\n"); - sys("$objcopy --strip-all $from $to"); - } - elsif ($strip_objfiles == 0) { - info(1, "Copy/stripping library $from to $to\n"); - sys("$objcopy --strip-debug $from $to"); - } - } - - # Copy file perms and owner - my($mode, $uid, $gid); - (undef, undef, $mode, undef, $uid, $gid) = stat $from; - my $from_base = basename($from); - chown($uid, $gid, $to) or ($error = - error("chown: $! \($from_base\)\n")); - return "ERROR"if $error && $error eq "ERROR"; - chmod($mode, $to) or ($error = - error("chmod: $! \($from_base\)\n")); - return "ERROR"if $error && $error eq "ERROR"; - } - elsif ($strip_module) { - info(1, "Copy/stripping module $from to $to\n"); - sys("$objcopy --strip-debug $from $to"); - - # Copy file perms and owner - my($mode, $uid, $gid); - (undef, undef, $mode, undef, $uid, $gid) = stat $from; - my $from_base = basename($from); - chown($uid, $gid, $to) or ($error = - error("chown: $! \($from_base\)\n")); - return "ERROR"if $error && $error eq "ERROR"; - chmod($mode, $to) or ($error = - error("chmod: $! \($from_base\)\n")); - return "ERROR"if $error && $error eq "ERROR"; - } elsif ($strip_bin) { - # It's a binary executable - info(1, "Copy/stripping binary executable $from to $to\n"); - sys("$objcopy --strip-all $from $to"); - - # Copy file perms and owner - my($mode, $uid, $gid); - (undef, undef, $mode, undef, $uid, $gid) = stat $from; - my $from_base = basename($from); - chown($uid, $gid, $to) or ($error = - error("chown: $! \($from_base\)\n")); - return "ERROR"if $error && $error eq "ERROR"; - chmod($mode, $to) or ($error = - error("chmod: $! \($from_base\)\n")); - return "ERROR"if $error && $error eq "ERROR"; - } - else { - # Normal copy, no strip - sys("cp $from $to"); - } - } - else { - # Normal copy, no strip - sys("cp $from $to"); - } - -} - - -##### End of make_root_fs - -######################################################## -## -## YARD_UTILS.PL -- Utilities for the Yard scripts. -## -######################################################## - -# Get device number of /proc filesystem -## not a sub -my($proc_dev) = (stat("/proc"))[0]; - -sub info { - my($level, @msgs) = @_; - - if ($level != 3) { - print LOGFILE @msgs; - } - $level = 0x if $level == 3; - - my $output = join("",@msgs); - if ($verbosity >= $level) { - if ($text_insert) { - $text_insert->freeze(); - if ($level == 0) { - $text_insert->insert( undef, $blue, undef, $output ); - } - elsif ($level == 1) { - $text_insert->insert( undef, $red, undef, $output ); - } - $text_insert->thaw(); - $logadj->set_value($logadj->upper - $logadj->page_size); - while (Gtk->events_pending) { Gtk->main_iteration; } - } - } - -} - -## This will produce red. -sub error { - - print LOGFILE "Error: ", @_; - info(0, "Error: ", @_); - error_window("gBootRoot: ERROR: ", @_); - return "ERROR"; - -} - -sub start_logging_output { - - my ($yard_temp,$verb_level) = @_; - my $logfile; - $verbosity = $verb_level; - - if (defined($yard_temp) and $yard_temp) { - $logfile = $yard_temp; - } - # ERRORCHECK - ## If logfile doesn't open in /tmp there is some type of fatal problem. - open(LOGFILE, ">>$logfile") or error("open($logfile): $!\n"); - # &::verbosity_box() if !visible $verbosity_window; - info(1, "Logging output to $logfile\n") -} - -##### Same as system() but obeys $verbosity setting for both STDOUT -##### and STDERR. -sub sys { - my $error; - - # when using sys on yard_chrooted_tests - my $dont = pop @_; - if ($dont ne "TESTING") { - push @_, $dont; - } - - open(SYS, "@_ 2>&1 |") or ($error = error("open on sys(@_) failed: $!")); - return "ERROR"if $error && $error eq "ERROR"; - while () { - if ($dont ne "TESTING") { - print LOGFILE unless $_ =~ m,\/.*file\n$,; - } - if ($verbosity > 0) { - if ($dont ne "TESTING") { - info(1,$_) unless $_ =~ m,\/.*file\n$,; - } - else { - info(3,$_) unless $_ =~ m,\/.*file\n$,; - } - } - } - close(SYS) or return $?; - 0; # like system() -} - -# This is history, simply because the mount point is unique to -# the session, and umount is always used between stages, and -# there are checks in place for it's failure. -# Just need to add error_window. -my (%mounted, %fs_type); -sub load_mount_info { - undef %mounted; - undef %fs_type; - - open(MTAB, ") { - my($dev, $mp, $type) = split; - next if $dev eq 'none'; - $mounted{$dev} = $mp; - $mounted{$mp} = $dev; - $fs_type{$dev} = $type; - } - close(MTAB); -} - -sub mount_device_if_necessary { - load_mount_info(); - - # obviously these should be lexical to the whole package. - my ($device,$mount_point); - - if (defined($mounted{$device})) { - - if ($mounted{$device} eq $mount_point) { - info(0, "Device $device already mounted on $mount_point\n"); - - } else { - info(0, "$device is mounted \(on ", $mounted{$device}, "\)\n"); - info(0, "Can't mount it under $mount_point.\n"); - } - - } elsif ($mounted{$mount_point} eq $device) { - info(0, "Another device \(", $mounted{$mount_point}, - "\) is already mounted on $mount_point\n"); - } -} - - -sub must_be_abs { - my($file) = @_; - # Matches / or ./ or ../ - $file =~ m|^\.{0,2}/| - or info(0, "file $file must be absolute but isn't.\n"); -} - - -sub sync { - # Parts of unix are still a black art - system("sync") and error("Couldn't sync!"); - system("sync") and error("Couldn't sync!"); -} - -## Need to put error() checking here -## This is used for ./Replacements config_dest == /etc/yard -# find_file_in_path(file, path) -# Finds filename in path. Path defaults to @pathlist if not provided. -# If file is relative, file is resolved relative to config_dest and lib_dest. -my(@pathlist); -sub find_file_in_path { - - my($file, @path) = @_; - - if (!@path) { - ##### Initialize @pathlist if necessary - if (!@pathlist) { - @pathlist = split(':', $ENV{'PATH'}); - if (defined(@::additional_dirs)) { - unshift(@pathlist, @::additional_dirs); - ### Changed this to work as documented - $ENV{"PATH"} = join(":", @::additional_dirs) . - ":$ENV{'PATH'}"; - } - info(1, "Using search path:\n", join(" ", @pathlist), "\n"); - } - @path = @pathlist; - } - - - if ($file) { - - ##### Relative filename, search for it - my($dir); - ## foreach $dir (@path, $config_dest, $lib_dest - foreach $dir (@path) { - my($abs_file) = "$dir/$file"; - return $abs_file if -e $abs_file; - } -# if ( !-e "$path[$#path]/$file") { -# info(1,"gBootRoot Error: Couldn't find $file\n"); -# } - undef; - } - -} - -# Note that this does not verify existence of the returned file. -sub make_link_absolute { - my($file, $target) = @_; - - if ($target =~ m|^/|) { - $target; # Target is absolute, just return it - } else { - cleanup_link(dirname($file) . "/$target"); - } -} - - -sub cleanup_link { - my($link) = @_; - # Collapse all occurrences of /./ - 1 while $link =~ s|/\./|/|g; - # Cancel occurrences of /somedir/../ - # Make sure somedir isn't ".." - 1 while $link =~ s|/(?!\.\.)[^/]+/\.\./|/|g; - $link -} - - -# Given an absolute file name and a symlink, make the symlink relative -# if it's not already. -sub make_link_relative { - my($abs_file, $link) = @_; - my($newlink); - - if ($abs_file) { - if ($link =~ m|^/(.*)$|) { - # It's absolute -- we have to relativize it - # The abs_file guaranteed not to have any funny - # stuff like "/./" or "/foo/../../bar" already in it. - $newlink = ("../" x path_length($abs_file)) . $1; - - } else { - # Already relative - $newlink = $link; - } - cleanup_link($newlink); - } -} - -# I don't know if this information is worth caching. -my(%path_length); -sub path_length { - my($path) = @_; - - if ($path) { - return $path_length{$path} if defined($path_length{$path}); - my($length) = -1; - while ($path =~ m|/|g) { $length++ } # count slashes - $path_length{$path} = $length; - $length - } -} - - -sub bytes_to_K { - my($bytes) = @_; - int($bytes / 1024) + ($bytes % 1024 ? 1 : 0); -} - - - -# Device capacity in K -sub get_device_size_K { - my($device) = @_; - my($DEV_BSIZE) = 512; # Blocksize, from sys/param.h - - my($result) = pack("L", 0); - open(FD, $device) or die "open($device): $!"; - my($return) = ioctl(FD, $BLKGETSIZE_ioctl, $result); - close(FD); - if ($return) { - my($bytes) = unpack("L", $result) * $DEV_BSIZE; - bytes_to_K( $bytes ); - } else { - warn "Can't get size of $device"; - undef; - } -} - -##### Thanks to Rick Lyons for this: "If you do a BLKFLSBUF on a device, you -##### get a sync (via fsync()) as well as an invalidation of all of the -##### buffers. That is, anything stored in the buffer cache for that device -##### is tossed out and any accesses to the device needs to go to the -##### hardware. BLKFLSBUF is slightly different for /dev/ram in that no -##### dirty buffers are written (since there's no corresponding hardware), -##### and the buffer invalidation causes all of the memory allocated to the -##### ramdisk to be unlocked and made available for reuse." -sub flush_device_buffer_cache { - my($device) = @_; - my($junk) = "stuff"; - - open(FD, $device) && ioctl(FD, $BLKFLSBUF_ioctl, $junk); - close(FD); -} - -##### This is a kludge but is probably the best way to check for -##### module support. -sub warn_about_module_dependencies { - my($version) = @_; - - if (defined($version)) { - - my($ramdisk_module) = "/lib/modules/$version/block/rd.o"; - my($ext2fs_module) = "/lib/modules/$version/fs/ext2.o"; - my($floppy_module) = "/lib/modules/$version/block/floppy.o"; - - if (-e $ramdisk_module) { - info(0, "***** Warning: Chosen kernel ($version) may have\n", - " modular ramdisk support. ($ramdisk_module exists)\n", - " The kernel used for the ", - " rescue disk must have BUILT-IN ramdisk support.\n"); - } - if (-e $ext2fs_module) { - info(0, "***** Warning: Chosen kernel ($version) may have\n", - " modular ext2 fs support. ($ext2fs_module exists)\n", - " The kernel used for the ", - " rescue disk must have BUILT-IN ext2 fs support.\n"); - } - if (-e $floppy_module) { - info(0, "***** Warning: Chosen kernel ($version) may have\n", - " modular floppy support. ($floppy_module exists)\n", - " The kernel used for the ", - " rescue disk must have BUILT-IN floppy support.\n"); - } - } -} - - -##### This is a hack but there's no system command to return a -##### (non-running) kernel version. Returns undef if it can't -##### determine the version. -# sub kernel_version { -# my($image) = @_; - -# my($str) = "phlogiston"; -# my($version_start) = 1164; -# my($version_length) = 10; - -# open(DATA, $image) or return(undef); -# seek(DATA, $version_start, 0); -# read(DATA, $str, $version_length); -# close(DATA); -# ###### Do careful matching in case we got some random string. -# my($version) = $str =~ /^(\d+\.\d+\.\d+)\s/; -# $version -# } - - -# kernel_version supplied by Andreas Degert . -# This procedure is tested with kernels v2.0.33 and v2.1.103 on i386 -# Returns undef if it can't determine the version (or bails out with error) -sub kernel_version { - my($image) = @_; - my $error; - - # check if we have a normal file (-f dereferences symbolic links) - if (!-f $image) { - $error = error("Kernel image ($image) is not a plain file.\n"); - return "ERROR"if $error && $error eq "ERROR"; - - } else { - my($str) = ""; - my($version_start) = ""; - - open(DATA, $image) or ($error = error("can't open $image.\n")); - return "ERROR"if $error && $error eq "ERROR"; - # check signature of kernel image - seek(DATA, 514, 0); - read(DATA, $str, 4); - $error = error( - "Kernel image file ($image) does not have Linux kernel signature\n") - unless $str =~ "HdrS"; - return "ERROR"if $error && $error eq "ERROR"; - # setup header version should be 0x201 - read(DATA, $str, 2); - $str = unpack("S",$str); - #info (0, "Kernel setup header version is 0x"); - - - # 2.4.0 kernels now use Start Text 0x202 - unless ($str == 0x201 - || $str == 0x0202) { - print sprintf("%04x",$str); - print "(expected 0x201 or 0x202).\n"; - } - - # get ofset of version string (indirect) and read version string - seek(DATA, 526, 0); - read(DATA, $version_start, 2) or ($error = error( - "can't read from $image.\n")); - return "ERROR"if $error && $error eq "ERROR"; - $version_start = unpack("S",$version_start) + 512; - seek(DATA, $version_start, 0); - read(DATA, $str, 30) or - ($error = error("can't read from offset $version_start of $image.\n")); - return "ERROR"if $error && $error eq "ERROR"; - close(DATA); - # Extract the version number. - # Usually this is something like 2.2.15, but because of kernel packages - # it can also be something like 2.2.15-27mdk. Don't make any assumptions - # except that beginning must be dotted triple and it's space delimited. - my($version) = $str =~ /^(\d+\.\d+\.\d+\S*)\s/; - - return $version - - } -} - - -## HISTORY -##### Eventually move this into configure since it doesn't have to be -##### done with every make_root_fs. But yard_glob would have to be -##### configured, and yard_utils.pl isn't configured. Will use for -##### other things, though. -my($glob_broken); -sub test_glob { - my($globbed) = join(' ', glob("/*")); - my($echoed) = join(' ', `echo /*`); - chop($echoed); - - if ($globbed ne $echoed) { - info 0, "\n***** The glob() function seems to be broken here ", - "(Perl version $PERL_VERSION)\n", - "I'll use a slower version that works.\n"; - $glob_broken = 1; - } else { - $glob_broken = 0; - } -} - -##### Check glob() -- In some Perl versions it's reported not to work. -sub yard_glob { - my($expr) = @_; - - ## first part HISTORY - if ($glob_broken) { - my($line) = `echo $expr`; - chop($line); - my(@files) = split(' ', $line); - - } else { - glob($expr); - } -} - - -sub mount_device { - - my ($device,$mount_point) = @_; - my($options); - - if (-f $device) { - $options = "-o loop "; - } else { - $options = ""; - } - - errmk(sys("mount $options -t ext2 $device $mount_point")); -} - - -##### Called by make_root_fs to do basic checks on choice of $::device. -sub check_device { - - my $fs_size; # @_ - - if (!-e $::device) { - error("Device $::device does not exist\n"); - - } elsif (-l $::device) { - error("$::device is a symbolic link\n", - "Please provide a real device to avoid confusion.\n"); - - } elsif (-f $::device) { - info(0, "Device $::device is a normal file.\n", - "Assuming loopback device is being used.\n"); - - } elsif (-c $::device) { - error("\$::device ($::device) is a character special file\n", - "It must be a block device\n"); - - } elsif (-b $::device) { - - if ($::device =~ m|^/dev/[hs]d[abcd]$|) { -# error("You've specified an entire hard disk ($::device) as the device\n", - # "on which to build the root filesystem.\n"; - # "Please specify a single partition.\n"; - } - ##### If we can check device size, make sure it isn't less than - ##### what's declared. - - my($max) = get_device_size_K($::device); - - if (defined($max)) { - if ($max < $fs_size) { - info 0, "You've declared file system size (fs_size) to be ", - "$fs_size K\n", - "but Linux says $::device may only hold $max K\n"; - if ($::device =~ m|^/dev/ram|) { - info 0, "(Increase ramdisk size"; - (info 0, " in lilo.conf") if -e "/etc/lilo.conf"; - info(0, ")\n"); - } - exit; - } - } else { - info 0, "Warning: Yard can't determine the real size of ", - "$::device.\n", - "Assuming it's $fs_size as declared.\n", - "I hope you're not lying.\n"; - } - - } else { - error("I have no idea what your \$device ($::device) is!\n", - "It should either be a block special file (eg, /dev/ram or\n", - "/dev/hda2) or a plain file for use with a loopback device.\n"); - } -} - - -# Copy a file, substituting values for variables in the file. -# First try using a configuration variable (in CFG package), -# then issue a warning. -sub copy_file_with_substitution { - my($from, $to) = @_; - - open(FROM, "<$from") or error("Can't open $from: $!\n"); - open(TO, ">$to") or error "$to: $!"; - - local($WARNING) = 0; # Turn off warnings from eval - while () { -## s/\$(\w+)/(eval("\$::$1")/eg; - print TO; -# took this out from space above -# or info(0, "Warning: $1 (in $from) has no known value\n") - } - - close(FROM); - close(TO); -} - -sub bytes_allocated { - my($file) = @_; - - my($size) = -s $file; - - if ($size % $EXT2_BLOCK_SIZE == 0) { - $size - } else { - (int($size / $EXT2_BLOCK_SIZE) + 1) * $EXT2_BLOCK_SIZE - } -} - - -sub onto_proc_filesystem { - my($file) = @_; - my($sdev) = (stat($file))[0]; - my($ldev) = (lstat($file))[0]; - $sdev == $proc_dev or $ldev == $proc_dev -} - - -################# -## -## CHECK_ROOT_FS -## -################# - -### GLOBAL VARIABLES -my(%Termcap); # Defs from /etc/termcap -my($checked_for_getty_files); # Scalar -- have we checked getty files yet? -my(%checked); # Hash table of files we've already checked -my $login_binary; - -sub warning_test { - info(0, "\n", @_); -} - -sub which_tests { - - my ($chosen_tests) = @_; - my ($action, $label); - - return "ERROR" if errm(mount_device($device,$mount_point)) == 2; - - # This is a little crude. Technically we should read /etc/conf.getty - # to make sure we're not supposed to be using a different login binary. - - ## Originally, this was "$mount_point/usr/bin/login" but this is assuming - ## to much. It is better just to find the local version since this varies - ## from distribution to distribution, and more than likely this is the - ## "login" used in the mounted version, too. - ## Once PATH is complete, there will be a separate check just to look at - ## the non-local $mount_point PATH. - - $login_binary = "$mount_point" . find_file_in_path("login"); - - # This goes first so we define %Termcap for use in children - check_termcap(); - - ##### Here are the tests. - my $t_fstab = $chosen_tests->{30}{test_fstab}; - my $t_inittab = $chosen_tests->{31}{test_inittab}; - my $t_scripts = $chosen_tests->{32}{test_scripts}; - - sys("yard_chrooted_tests $mount_point $t_fstab $t_inittab $t_scripts", - "TESTING"); - - # Now the question is whether or not these next tests depend on - # chroot, since they must have before. - if ( $chosen_tests->{33}{test_links} == 1 ) { - info(0,"\nTEST: links\n"); - check_links(); - } - if ( $chosen_tests->{34}{test_passwd} == 1 ) { - info(0,"\nTEST: passwd\n"); - check_passwd(); - } - if ( $chosen_tests->{35}{test_pam} == 1 ) { - info(0,"\nTEST: pam\n"); - check_pam(); - } - if ( $chosen_tests->{36}{test_nss} == 1 ) { - info(0,"\nTEST: nss\n"); - check_nss(); - } - - return "ERROR" if errum(sys("umount $mount_point")) == 2; - -} # end sub which_tests - - -##### This could be made much more complete, but for typical rc type -##### files it seems to catch the common problems. -sub scan_command_file { - my($cmdfile, @args) = @_; - my(%warned, $line); - - return if $checked{$cmdfile}; - info(0, "\nScanning $cmdfile\n"); - open(CMDFILE, "<$cmdfile") or error("$cmdfile: $!"); - - while ($line = ) { - chomp($line); - next if $line =~ /^\#/ or /^\s*$/; - - next if $line =~ /^\w+=/; - - while ($line =~ m!(/(usr|var|bin|sbin|etc|dev)/\S+)(\s|$)!g) { - my($abs_file) = $1; - # next if $abs_file =~ m/[*?]/; # Skip meta chars - we don't trust glob - next if $warned{$abs_file}; # Only warn once per file - if (!-e $abs_file) { - warning_test("$cmdfile($.): $line\n\t$1: missing on root filesystem\n"); - $warned{$abs_file} = 1; - } - } - } - close(CMDFILE) or error("close($cmdfile): $!"); - - $checked{$cmdfile} = 1; - info(0, "Done scanning $cmdfile\n"); -} - - -##### Check_passwd is NOT run under chroot. -sub check_passwd { - my $error; - my($passwd_file) = "$mount_point/etc/passwd"; - open(PASSWD, "<$passwd_file") or - ($error = error("Can't read passwd file: $!\n")); - return if $error && $error eq "ERROR"; - - info(0, "\nChecking passwd file $passwd_file\n"); - - while () { - chomp; - next if /^\s*$/; # Skip blank/empty lines - my($line) = $_; - my($login_name, $passwd, $UID, $GID, $user_name, $home, $shell) = - split(':'); - - next if $passwd eq "*"; # Skip warnings if user can't login - - -d ($mount_point . $home) or - warning_test "$passwd_file($.): $line\n", - "\tHome directory of $login_name ($mount_point$home) is missing\n"; - -e ($mount_point . $shell) or - warning_test "$passwd_file($.): $line\n", - "\tShell of $login_name ($mount_point$shell) doesn't exist\n"; - - check_init_files($login_name, $home, $shell); - } - close(PASSWD); - info(0, "Done checking $passwd_file\n"); -} - - -##### Simple PAM configuration checks. -##### Tests whether PAM is needed, and whether the configuration libraries exist. -##### Check_pam is NOT run under chroot. -sub check_pam { - my($pam_configured) = 0; # Have we seen some pam config file yet? - info(0, "Checking for PAM\n"); - - my($pamd_dir) = "$mount_point/etc/pam.d"; - my($pam_conf) = "$mount_point/etc/pam.conf"; - - if (-e $pam_conf) { - info(0, "Checking $pam_conf\n"); - $pam_configured = 1; - open(PAM, $pam_conf) or error("Can't open pam.conf: $!\n"); - while () { - chomp; - next if /^\#/ or /^\s*$/; # Skip comments and empty lines - my($file) = (split)[3]; # Get fourth field - if (!-e "$mount_point/$file") { - warning_test "$pam_conf($.): $_\n", - "\tLibrary $file does not exist on root fs\n"; - } - # That's all we check for now - } - close(PAM) or error("Closing PAM: $!"); - info(0, "Done with $pam_conf\n"); - } - - - if (-e $pamd_dir) { - info(0, "Checking files in $pamd_dir\n"); - opendir(PAMD, $pamd_dir) or error("Can't open $pamd_dir: $!"); - my($file); - while (defined($file = readdir(PAMD))) { - my($file2) = "$pamd_dir/$file"; - next unless -f $file2; # Skip directories, etc. - open(PF, $file2) or error("$file2: $!"); - while () { - chomp; - next if /^\#/ or /^\s*$/; # Skip comments and empty lines - my($file) = (split)[3]; # Get fourth field - $pam_configured = 1; - if (!-e "$mount_point/$file") { - warning_test "$file2($.): $_\n", - "\tLibrary $file does not exist on root fs\n"; - } - } - close(PF); - } - closedir(PAMD); - } - - # Finally, see whether PAM configuration is needed - if (!$pam_configured and -e $login_binary) { - my($dependencies) = scalar(`ldd $login_binary`); - if (defined($dependencies) and $dependencies =~ /libpam/) { - warning_test "Warning: login ($login_binary) needs PAM, but you haven't\n", - "\tconfigured it (in /etc/pam.conf or /etc/pam.d/)\n", - "\tYou probably won't be able to login.\n"; - } - } - info(0, "Done with PAM\n"); -} - - - -##### Basic checks for nsswitch.conf. -##### check_nss is NOT run under chroot. -##### From the nsswitch.conf(5) manpage: -##### For glibc, you must have a file called /lib/libnss_SERVICE.so.X for -##### every SERVICE you are using. On a standard installation, you could -##### use `files', `db', `nis' and `nisplus'. For hosts, you could specify -##### `dns' as extra service, for passwd, group and shadow `compat'. These -##### services will not be used by libc5 with NYS. The version number X -##### is 1 for glibc 2.0 and 2 for glibc 2.1. - -sub check_nss { - my($nss_conf) = "$mount_point/etc/nsswitch.conf"; - info(0, "Checking for NSS\n"); - - my($libc) = yard_glob("$mount_point/lib/libc-2*"); - my($libc_version) = $libc =~ m|/lib/libc-2.(\d)|; - if (!defined($libc_version)) { - warning_test "Can't determine your libc version\n"; - } else { - info(0, "You're using $libc\n"); - } - my($X) = $libc_version + 1; - - if (-e $nss_conf) { - open(NSS, "<$nss_conf") or die "open($nss_conf): $!"; - - my($line); - while (defined($line = )) { - chomp $line; - next if $line =~ /^\#/; - next if $line =~ /^\s*$/; - my($db, $entries) = $line =~ m/^(\w+):\s*(.+)$/; - # Remove bracketed expressions (action specifiers) - $entries =~ s/\[[^\]]*\]//g; - my(@entries) = split(' ', $entries); - my($entry); - for $entry (@entries) { - next if $entry =~ /^\[/; # ignore action specifiers - my($lib) = "$mount_point/lib/libnss_${entry}.so.${X}"; - if (!-e $lib) { - warning_test "$nss_conf($.):\n$line\n", - "\tRoot filesystem needs $lib to support $entry\n"; - } - } - } - - } else { - # No nsswitch.conf is present, figure out if maybe there should be one. - if (-e $login_binary) { - my($dependencies) = scalar(`ldd $login_binary`); - my($libc_version) = ($dependencies =~ /libc\.so\.(\d+)/m); - if ($libc_version > 5) { - # Needs libc 6 or greater - warning_test "Warning: $login_binary on rescue disk needs libc.so.$libc_version,\n" - . "\tbut there is no NSS configuration file ($nss_conf)\n" - . "\ton root filesystem.\n"; - } - } - } - info(0, "Done with NSS\n"); -} - -sub check_links { - info(0, "\nChecking links relative to $mount_point\n"); - - sub wanted { - if (-l $File::Find::name) { - local($::raw_link) = readlink($File::Find::name); - local($::target) = make_link_absolute($File::Find::name, $::raw_link); - - # I added this next test for /dev/stdout link hair. - # This really should be more complicated to handle link chains, - # but as a hack this works for three. - if (onto_proc_filesystem($File::Find::name)) { - - } elsif (-l $::target) { - chase_link($::target, 16); - - } elsif (!-e $::target) { - warning_test "Warning: Unresolved link: $File::Find::name -> $::raw_link\n"; - } - } - }; - - finddepth(\&wanted, $mount_point); -} - - -sub chase_link { - my($file, $link_depth) = @_; - - if ($link_depth == 0) { - warning_test "Warning: Probable link circularity involving $file\n"; - - } elsif (-l $file) { - chase_link(make_link_absolute($file, readlink($file)), - $link_depth-1); - } -} - - -sub check_scripts { - info(0, "\nChecking script interpreters\n"); - local($::prog); - - sub check_interpreter { - if (-x $File::Find::name and -f _ and -T _) { - open(SCRIPT, $File::Find::name) or error "$File::Find::name: $!"; - my($prog, $firstline); - chomp($firstline =