bike
/
gbootroot
mirror of https://github.com/fspc/gbootroot.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

Cleaned up some more.

master
freesource 24 years ago
parent
d6af87d3fb
commit
f9c2273010
1 changed files with 86 additions and 176 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 262
      Yard.pm

262
Yard.pm
View File

@ -31,8 +31,8 @@ package Yard;
use vars qw(@ISA @EXPORT %EXPORT_TAGS); use vars qw(@ISA @EXPORT %EXPORT_TAGS);
use Exporter; use Exporter;
@ISA = qw(Exporter); @ISA = qw(Exporter);
@EXPORT = qw(kernel_version_check read_contents_file extra_links @EXPORT = qw(start_logging_output kernel_version_check read_contents_file
library_dependencies hard_links space_check extra_links library_dependencies hard_links space_check
create_filesytem); create_filesytem);
use strict; use strict;
@ -51,45 +51,15 @@ my $BLKFLSBUF_ioctl = 4705;
my $EXT2_BLOCK_SIZE = 1024; my $EXT2_BLOCK_SIZE = 1024;
my $INODE_SIZE = 1024; my $INODE_SIZE = 1024;
my $objcopy = "objcopy"; my $objcopy = "objcopy";
my($Warnings) = 0;
STDOUT->autoflush(1); STDOUT->autoflush(1);
#@@ start_logging_output();
#@@ info(0, "root_fs\n");
#@@ info(1, "(running under Perl $PERL_VERSION)\n");
my($Warnings) = 0;
sub warning { sub warning {
info(0, "Warning: ", @_); info(0, "Warning: ", @_);
$Warnings++; $Warnings++;
} }
##############################################################################
##### Check some basic things before starting.
##### There's probably a more graceful way to maintain and check
##### a set of user options (via a Perl module), but I'm too lazy
##### to track it down.
##############################################################################
# Too restrictive for gBootRoot
#if ($REAL_USER_ID != 0) {
# error("This script must be run as root\n");
#}
# Not necessary, gBootRoot handles this stuff.
#if (!defined($::device) and !defined($::mount_point)) {
# error("Nothing defined in CFG package. You probably just copied\n",
# "an old Config.pl file.\n";
#}
# Check mount point
#if (-d $::mount_point and -w _) {
# info(1, "Using $::mount_point as mount point for $::device\n");
#} else {
# error("Mount point $::mount_point must be a directory and\n",
# "must be write-enabled.\n";
#}
# This is a good thing to be used for all device checking in # This is a good thing to be used for all device checking in
# gBootRoot, but it may be restrictive since sometimes it is a # gBootRoot, but it may be restrictive since sometimes it is a
# good thing to mount a whole device .. cdroms for instance. # good thing to mount a whole device .. cdroms for instance.
@ -99,70 +69,34 @@ sub warning {
# Make sure $::device isn't already mounted and $::mount_point is free # Make sure $::device isn't already mounted and $::mount_point is free
#@@ load_mount_info(); #@@ load_mount_info();
## This is put here for reference, and is from Config.pl
## loopback is the standard for building a filesytem in gBootRoot.
## No choice here.
# $device: string (device name)
#
# The device for building the filesystem. This can be /dev/ram0 or a
# spare partition. You can turn off swapping temporarily and use the
# swap partition on your hard disk. You can use a loopback device if
# your kernel supports them -- see the section "Using a Loopback
# Device" in the Yard documentation for instructions.
# It should not be a symbolic link.
#
#$device = "/dev/ram0";
#if (defined($::mounted{$::device})) {
# if ($::mounted{$::device} eq $::mount_point) {
# #info(1, "Device $::device is already mounted on $::mount_point\n");
# info(1, "Unmounting it automatically.\n");
# sys("umount $::mount_point");
# } else {
# error("$::device is already mounted elsewhere (on $::mounted{$::device})\n",
# "Unmount it first.\n");
# }
#} elsif (defined($::mounted{$::mount_point})) {
# error("Some other device is already mounted on $::mount_point\n");
#}
# Have to test this every time so we can work around. # Have to test this every time so we can work around.
## This will get replaced with a readdir loop, no sense relying on people's ## This will get replaced with a readdir loop, no sense relying on people's
## shells. Anotherwards, yard_glob get changed. ## shells. Anotherwards, yard_glob get changed.
#@@ test_glob(); #@@ test_glob();
##### Determine release of $::kernel for modules. ## REQUIRES $kernel opt. $kernel_version
##### Set RELEASE environment variable for use in contents.
## Still need an option for this, may become part of beginners section.
## uses kernel_version .. will probably just run these in relation to
## gBootRoots checks.
## 'use Yard; $kernel = "/root/HDB/vmlinuz-2.2.14-ncr"; $kernel_version = "1.2"; kernel_version_check();
## requires $kernel && $kernel_version
sub kernel_version_check { sub kernel_version_check {
if (defined($::kernel_version)) { my($kernel,$kernel_version) = @_;
if (defined($kernel_version)) {
# Check to see if it agrees # Check to see if it agrees
my($version_guess) = kernel_version($::kernel); my($version_guess) = kernel_version($kernel);
if ($version_guess ne $::kernel_version) { if ($version_guess ne $kernel_version) {
## Is this really necessary, it can be assumed a person knows ## Is this really necessary, it can be assumed a person knows
## what they are doing. ## what they are doing.
info(0, info(0,
"You declared kernel $::kernel to be version $::kernel_version\n", "You declared kernel $kernel to be version $kernel_version\n",
"even though a probe says $version_guess.", "even though a probe says $version_guess.",
" I'll assume you're right.\n") " I'll assume you're right.\n")
} }
$ENV{'RELEASE'} = $::kernel_version; $ENV{'RELEASE'} = $kernel_version;
} elsif (defined($ENV{'RELEASE'} = kernel_version($::kernel))) { } elsif (defined($ENV{'RELEASE'} = kernel_version($kernel))) {
info(0, "Version probe of $::kernel returns: $ENV{'RELEASE'}\n"); info(0, "Version probe of $kernel returns: $ENV{'RELEASE'}\n");
} else { } else {
warning "Can't determine kernel version of $::kernel\n"; warning "Can't determine kernel version of $kernel\n";
my($release) = `uname -r`; my($release) = `uname -r`;
if ($release) { if ($release) {
chomp($release); chomp($release);
@ -174,39 +108,25 @@ sub kernel_version_check {
} }
} }
} # end sub kernel_version } # end sub kernel_version_check
## This checks lib/modules/$version for rd.o, ext2.o, floppy.o ## This checks lib/modules/$version for rd.o, ext2.o, floppy.o
## Perhaps just extra stuff, this could be made real fancy, too. ## Perhaps just extra stuff, this could be made real fancy, too.
#@@warn_about_module_dependencies($ENV{'RELEASE'}); #@@warn_about_module_dependencies($ENV{'RELEASE'});
## gBootRoot does this as a separate process
#if ($::disk_set !~ /^(single|double|base\+extra)$/) {
# error("Config variable disk_set is set to \"$::disk_set\"\n",
# "which is not a valid value.\n");
#}
############################ ############################
##### READ IN CONTENTS FILE ##### READ IN CONTENTS FILE
############################ ############################
## Uses info, error, cf_warn, make_link_absolute, make_link_relative,
## uses info, resolve_file, error, cf_warn, make_link_absolute, ## cf_die, must_be_abs, replaced_by, yard_glob
## make_link_relative, cf_die, must_be_abs, replaced_by, yard_glob, ## REQUIRES $contents_file
## include_file
## requires $contents_file
sub read_contents_file { sub read_contents_file {
my ($contents_file) = @_;
my($contents_file) = resolve_file($::contents_file); info(0, "\n\nPASS 1: Reading $contents_file");
info(0, "\n\nPASS 1: Reading $::contents_file");
#info 0, " ($contents_file)" if $contents_file ne $::contents_file;
info(0, "\n"); info(0, "\n");
#my(%Included);
#my(%replaced_by);
#my(%links_to);
#my(%is_module);
open(CONTENTS, "<$contents_file") or error("$contents_file: $!"); open(CONTENTS, "<$contents_file") or error("$contents_file: $!");
my($line); my($line);
@ -246,25 +166,29 @@ sub read_contents_file {
@files = ($abs_link); @files = ($abs_link);
} elsif ($line =~ /<=/) { ##### REPLACEMENT SPEC } elsif ($line =~ /<=/) { ##### REPLACEMENT SPEC
cf_die($line, "Can't use wildcard in replacement specification") if cf_die($contents_file, $line,
$line =~ /[\*\?\[]/; "Can't use wildcard in replacement specification") if
$line =~ /[\*\?\[]/;
my($file, $replacement) = $line =~ /^(\S+)\s*<=\s*(\S+)\s*$/; my($file, $replacement) = $line =~ /^(\S+)\s*<=\s*(\S+)\s*$/;
if (!defined($replacement)) { if (!defined($replacement)) {
cf_warn($line, "Can't parse this replacement spec"); cf_warn($contents_file, $line,
"Can't parse this replacement spec");
next LINE; next LINE;
} else { } else {
must_be_abs($file); must_be_abs($file);
(-d $file) and cf_warn($line, "left-hand side can't be directory"); (-d $file) and cf_warn($contents_file, $line,
"left-hand side can't be directory");
my($abs_replacement) = find_file_in_path($replacement); my($abs_replacement) = find_file_in_path($replacement);
if (!(defined($abs_replacement) and -e $abs_replacement)) { if (!(defined($abs_replacement) and -e $abs_replacement)) {
cf_warn($line, "Can't find $replacement"); cf_warn($contents_file, $line, "Can't find $replacement");
} elsif ($replacement =~ m|^/dev/(?!null)|) { } elsif ($replacement =~ m|^/dev/(?!null)|) {
# Allow /dev/null but no other devices # Allow /dev/null but no other devices
cf_warn($line, "Can't replace a file with a device"); cf_warn($contents_file, $line,
"Can't replace a file with a device");
} else { } else {
$replaced_by{$file} = $abs_replacement; $replaced_by{$file} = $abs_replacement;
@ -275,7 +199,7 @@ sub read_contents_file {
} # End of replacement spec } # End of replacement spec
} elsif ($line =~ /(<-|=>)/) { } elsif ($line =~ /(<-|=>)/) {
cf_warn($line, "Not a valid arrow."); cf_warn($contents_file, $line, "Not a valid arrow.");
next LINE; next LINE;
} else { } else {
@ -285,7 +209,8 @@ sub read_contents_file {
for $expr (split(' ', $line)) { for $expr (split(' ', $line)) {
my(@globbed) = yard_glob($expr); my(@globbed) = yard_glob($expr);
if ($#globbed == -1) { if ($#globbed == -1) {
cf_warn($line, "Warning: No files matched $expr"); cf_warn($contents_file, $line,
"Warning: No files matched $expr");
} elsif (!($#globbed == 0 and $globbed[0] eq $expr)) { } elsif (!($#globbed == 0 and $globbed[0] eq $expr)) {
info(1, "Expanding $expr to @globbed\n"); info(1, "Expanding $expr to @globbed\n");
} }
@ -299,7 +224,8 @@ sub read_contents_file {
if ($file =~ m|^/|) { ##### Absolute filename if ($file =~ m|^/|) { ##### Absolute filename
if (-l $file and readlink($file) =~ m|^/proc/|) { if (-l $file and readlink($file) =~ m|^/proc/|) {
info(1, "Recording proc link $file -> ", readlink($file), "\n"); info(1, "Recording proc link $file -> ", readlink($file),
"\n");
$Included{$file} = 1; $Included{$file} = 1;
$links_to{$file} = readlink($file); $links_to{$file} = readlink($file);
@ -313,7 +239,8 @@ sub read_contents_file {
next FILE; next FILE;
} else { } else {
cf_warn($line, "Absolute filename $file doesn't exist"); cf_warn($contents_file, $line,
"Absolute filename $file doesn't exist");
} }
} else { ##### Relative filename } else { ##### Relative filename
@ -322,42 +249,39 @@ sub read_contents_file {
info(1, "Found $file at $abs_file\n"); info(1, "Found $file at $abs_file\n");
$Included{$abs_file} = 1; $Included{$abs_file} = 1;
} else { } else {
cf_warn($line, "Didn't find $file anywhere in path"); cf_warn($contents_file, $line,
"Didn't find $file anywhere in path");
} }
} }
} # End of FILE loop } # End of FILE loop
} # End of LINE loop } # End of LINE loop
info(0, "\nDone with $contents_file\n\n"); info(0, "\nDone with $contents_file\n\n");
##if ($::disk_set eq "base+extra") {
## include_file(find_file_in_path("tar"))
##}
close(CONTENTS) or error("close on $contents_file: $!"); close(CONTENTS) or error("close on $contents_file: $!");
## may or may not include this in read_contents_file
} # end read_contents_file } # end read_contents_file
#####################################
# Uses include_file
sub extra_links { sub extra_links {
my ($contents_file) = @_;
info(0, "\n\nPASS 2: Picking up extra files from links...\n"); info(0, "\n\nPASS 2: Picking up extra files from links...\n");
for (keys %Included) { for (keys %Included) {
include_file($_); # watch for "" - GBteam
include_file($contents_file, $_) if $_ ne "";
} }
info(0, "Done.\n\n"); info(0, "Done.\n\n");
} }
#####################################
sub library_dependencies { sub library_dependencies {
my ($contents_file) = @_;
info(0, "PASS 3: Checking library dependencies...\n"); info(0, "PASS 3: Checking library dependencies...\n");
info(1, "(Ignore any 'statically linked' messages.)\n"); info(1, "(Ignore any 'statically linked' messages.)\n");
@ -389,8 +313,8 @@ sub library_dependencies {
$is_module{$file} = 1; $is_module{$file} = 1;
} elsif ($file_line =~ m/shared object/) { } elsif ($file_line =~ m/shared object/) {
##### Any library (shared object) seen here was explicitly included ##### Any library (shared object) seen here was explicitly
##### by the user. ##### included by the user.
push(@{$lib_needed_by{$file}}, "INCLUDED BY USER"); push(@{$lib_needed_by{$file}}, "INCLUDED BY USER");
} }
@ -406,15 +330,18 @@ sub library_dependencies {
my($abs_lib) = $lib; my($abs_lib) = $lib;
if ($lib =~ /not found/) { if ($lib =~ /not found/) {
warning "File $file needs library $lib, which does not exist!"; warning "File $file needs library $lib," .
" which does not exist!";
} else { } else {
##### Right-hand side of the ldd output may be a symbolic link. ##### Right-hand side of the ldd output may be
##### a symbolic link.
##### Resolve the lib absolutely. ##### Resolve the lib absolutely.
##### include_file follows links and adds each file; ##### include_file follows links and adds each file;
##### the while loop makes sure we get the last. ##### the while loop makes sure we get the last.
$abs_lib = $lib; $abs_lib = $lib;
include_file($lib); include_file($contents_file, $lib);
while (1) { while (1) {
if (defined($links_to{$abs_lib})) { if (defined($links_to{$abs_lib})) {
$abs_lib = make_link_absolute($abs_lib, $abs_lib = make_link_absolute($abs_lib,
@ -476,7 +403,7 @@ sub library_dependencies {
} }
$line .= $binary . " "; $line .= $binary . " ";
} }
##info(1, $line, "\n" if $line); info(1, $line, "\n") if $line;
if (!($seen_ELF_lib and $seen_AOUT_lib)) { if (!($seen_ELF_lib and $seen_AOUT_lib)) {
@ -519,7 +446,7 @@ sub library_dependencies {
my($ld_file) = (yard_glob("/lib/ld-linux.so.?"))[-1]; # Get last one my($ld_file) = (yard_glob("/lib/ld-linux.so.?"))[-1]; # Get last one
if (defined($ld_file)) { if (defined($ld_file)) {
info(1, "Adding loader $ld_file for ELF libraries\n"); info(1, "Adding loader $ld_file for ELF libraries\n");
include_file($ld_file); include_file($contents_file, $ld_file);
} else { } else {
info(0, "Can't find ELF loader /lib/ld-linux.so.?"); info(0, "Can't find ELF loader /lib/ld-linux.so.?");
} }
@ -530,7 +457,7 @@ sub library_dependencies {
my($ld_file); my($ld_file);
foreach $ld_file (yard_glob("/lib/ld.so")) { foreach $ld_file (yard_glob("/lib/ld.so")) {
info(1, "Adding loader $ld_file for a.out libraries\n"); info(1, "Adding loader $ld_file for a.out libraries\n");
include_file($ld_file); include_file($contents_file, $ld_file);
} }
} }
@ -565,9 +492,12 @@ sub hard_links {
########################## ##########################
# REQUIRES $fs_size $strip_objfile (0|1)
# GBteam adds stripped file size check using stripper()
sub space_check { sub space_check {
info(0, "Checking space needed.\n"); info(0, "Checking space needed.\n");
my ($fs_size, $strip_objfiles) = @_;
my($total_bytes) = 0; my($total_bytes) = 0;
my(%counted); my(%counted);
@ -592,10 +522,12 @@ sub space_check {
} elsif ($devino = $hardlinked{$file}) { } elsif ($devino = $hardlinked{$file}) {
##### This file is hard-linked to another. We don't necessarily ##### This file is hard-linked to another. We don't necessarily
##### know that the others are going to be in the file set. Count ##### know that the others are going to be in the file set.
##### the first and mark the dev/inode so we don't count it again. ##### Count the first and mark the dev/inode so we don't count
##### it again.
if (!$counted{$devino}) { if (!$counted{$devino}) {
info(1, "Counting ", -s _, " bytes of hard-linked file $file\n"); info(1, "Counting ", -s _,
" bytes of hard-linked file $file\n");
$total_bytes += bytes_allocated($file); $total_bytes += bytes_allocated($file);
$counted{$devino} = 1; $counted{$devino} = 1;
} else { } else {
@ -622,9 +554,9 @@ sub space_check {
info(0, "Total space needed is ", bytes_to_K($total_bytes), " Kbytes\n"); info(0, "Total space needed is ", bytes_to_K($total_bytes), " Kbytes\n");
if (bytes_to_K($total_bytes) > $::fs_size) { if (bytes_to_K($total_bytes) > $fs_size) {
info(0, "This is more than $::fs_size Kbytes allowed.\n"); info(0, "This is more than $fs_size Kbytes allowed.\n");
if ($::strip_objfiles) { if ($strip_objfiles) {
info(0, "But since object files will be stripped, more space\n", info(0, "But since object files will be stripped, more space\n",
"may become available. Continuing...\n"); "may become available. Continuing...\n");
} else { } else {
@ -645,6 +577,7 @@ sub space_check {
# This could be broken up into a lot of functions # This could be broken up into a lot of functions
## copy_strip_file will be modified.
sub create_filesystem { sub create_filesystem {
my $file; my $file;
@ -795,15 +728,15 @@ sub create_filesystem {
} # end sub create_filesystem } # end sub create_filesystem
############################################################################# #######################################
##### Utility subs for make_root_fs.pl ##### Utility subs for make_root_fs.pl
############################################################################# #######################################
##### Add file to the file set. File has to be an absolute filename. ##### 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 ##### If file is a symlink, add it and chase the link(s) until a file is
##### reached. ##### reached.
sub include_file { sub include_file {
my($file) = @_; my($contents_file, $file) = @_;
must_be_abs($file); must_be_abs($file);
if (onto_proc_filesystem($file)) { if (onto_proc_filesystem($file)) {
@ -837,7 +770,7 @@ sub include_file {
info(1, "File $file is a symbolic link to $link\n"); info(1, "File $file is a symbolic link to $link\n");
#info(1, "\t(which resolves to $abs_target),\n" #info(1, "\t(which resolves to $abs_target),\n"
# if $link ne $abs_target); # if $link ne $abs_target);
info(1, "\twhich was not included in $::contents_file.\n"); info(1, "\twhich was not included in $contents_file.\n");
if (-e $abs_target) { if (-e $abs_target) {
info(1, "\t ==> Adding it to file set.\n\n"); info(1, "\t ==> Adding it to file set.\n\n");
$Included{$abs_target} = $file; $Included{$abs_target} = $file;
@ -849,19 +782,17 @@ sub include_file {
} }
} }
##### More informative versions of warn and die, for the contents file ##### More informative versions of warn and die, for the contents file
sub cf_die { sub cf_die {
my($line, @msgs) = @_; my($contents_file, $line, @msgs) = @_;
info(0, "$::contents_file($cf_line): $line\n"); info(0, "$contents_file($cf_line): $line\n");
foreach (@msgs) { info(0, "\t$_\n"); } foreach (@msgs) { info(0, "\t$_\n"); }
exit; exit;
} }
sub cf_warn { sub cf_warn {
my($line, @msgs) = @_; my($contents_file, $line, @msgs) = @_;
info(0, "$::contents_file($cf_line): $line\n"); info(0, "$contents_file($cf_line): $line\n");
$Warnings++; $Warnings++;
foreach (@msgs) { info(0, "\t$_\n"); } foreach (@msgs) { info(0, "\t$_\n"); }
} }
@ -905,19 +836,12 @@ sub copy_strip_file {
##### End of make_root_fs ##### End of make_root_fs
##############################################################
##############################################################
##############################################################
###############################################################
###############################################################
######################################################## ########################################################
## ##
## YARD_UTILS.PL -- Utilities for the Yard scripts. ## YARD_UTILS.PL -- Utilities for the Yard scripts.
## ##
######################################################## ########################################################
# Get device number of /proc filesystem # Get device number of /proc filesystem
my($proc_dev) = (stat("/proc"))[0]; my($proc_dev) = (stat("/proc"))[0];
@ -935,11 +859,12 @@ sub error {
} }
sub start_logging_output { sub start_logging_output {
#my($logfile) = basename($PROGRAM_NAME, ('.pl','.perl')) . ".log";
my ($yard_temp) = @_;
my $logfile; my $logfile;
if (defined($::yard_temp) and $::yard_temp) {
$logfile = $::yard_temp; if (defined($yard_temp) and $yard_temp) {
$logfile = $yard_temp;
} }
# ERRORCHECK # ERRORCHECK
open(LOGFILE, ">$logfile") or die "open($logfile): $!\n"; open(LOGFILE, ">$logfile") or die "open($logfile): $!\n";
@ -958,8 +883,6 @@ sub sys {
0; # like system() 0; # like system()
} }
sub load_mount_info { sub load_mount_info {
undef %::mounted; undef %::mounted;
undef %::fs_type; undef %::fs_type;
@ -1005,18 +928,6 @@ sub must_be_abs {
} }
# resolve_file: Resolve a file name.
# NB. This now resolves relative names WRT config_dest rather than cwd.
sub resolve_file {
my($file) = @_;
if ($file =~ m|^/|) {
$file; # File is absolute, just return it
} else {
"$::config_dest/$file";
}
}
sub sync { sub sync {
# Parts of unix are still a black art # Parts of unix are still a black art
system("sync") and die "Couldn't sync!"; system("sync") and die "Couldn't sync!";
@ -1029,6 +940,7 @@ sub sync {
# If file is relative, file is resolved relative to config_dest and lib_dest. # If file is relative, file is resolved relative to config_dest and lib_dest.
my(@pathlist); my(@pathlist);
sub find_file_in_path { sub find_file_in_path {
my($file, @path) = @_; my($file, @path) = @_;
if (!@path) { if (!@path) {
@ -1047,20 +959,18 @@ sub find_file_in_path {
} }
if ($file =~ m|/|) {
##### file contains a slash; don't search for it.
resolve_file($file);
} else { if ($file) {
##### Relative filename, search for it ##### Relative filename, search for it
my($dir); my($dir);
foreach $dir (@path, $::config_dest, $::lib_dest) { foreach $dir (@path) {
my($abs_file) = "$dir/$file"; my($abs_file) = "$dir/$file";
return $abs_file if -e $abs_file; return $abs_file if -e $abs_file;
} }
undef; undef;
} }
} }
# Note that this does not verify existence of the returned file. # Note that this does not verify existence of the returned file.

Write Preview
Loading…
Cancel
Save