mirror of
https://github.com/fspc/gbootroot.git
synced 2025-10-31 15:45:36 -04:00
Perl-5.6 glob now working, vanquished many undefs.
This commit is contained in:
freesource
parent
aa07bac3b2
commit
8d6ed2cad4
60
Yard.pm
60
Yard.pm
@ -54,6 +54,16 @@ my $objcopy = "objcopy";
|
||||
my($Warnings) = 0;
|
||||
my $verbosity;
|
||||
|
||||
# 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);
|
||||
|
||||
sub warning {
|
||||
@ -61,20 +71,6 @@ sub warning {
|
||||
$Warnings++;
|
||||
}
|
||||
|
||||
# This is a good thing to be used for all device checking in
|
||||
# gBootRoot, but it may be restrictive since sometimes it is a
|
||||
# good thing to mount a whole device .. cdroms for instance.
|
||||
# Check for sane device choice before we start using it.
|
||||
#@@ check_device();
|
||||
|
||||
# Make sure $::device isn't already mounted and $::mount_point is free
|
||||
#@@ load_mount_info();
|
||||
|
||||
# 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
|
||||
## shells. Anotherwards, yard_glob get changed.
|
||||
#@@ test_glob();
|
||||
|
||||
## REQUIRES $kernel opt. $kernel_version
|
||||
sub kernel_version_check {
|
||||
|
||||
@ -121,7 +117,7 @@ sub kernel_version_check {
|
||||
## cf_die, must_be_abs, replaced_by, yard_glob
|
||||
## REQUIRES $contents_file
|
||||
sub read_contents_file {
|
||||
|
||||
|
||||
my ($contents_file) = @_;
|
||||
|
||||
info(0, "\n\nPASS 1: Reading $contents_file");
|
||||
@ -132,6 +128,7 @@ sub read_contents_file {
|
||||
my($line);
|
||||
|
||||
LINE: while (defined($line = <CONTENTS>)) {
|
||||
|
||||
my(@files);
|
||||
$cf_line++;
|
||||
chomp $line;
|
||||
@ -155,14 +152,14 @@ sub read_contents_file {
|
||||
##### 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;
|
||||
$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;
|
||||
info(1, "$line links $abs_file to $rel_link\n");
|
||||
$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
|
||||
@ -209,8 +206,8 @@ sub read_contents_file {
|
||||
for $expr (split(' ', $line)) {
|
||||
my(@globbed) = yard_glob($expr);
|
||||
if ($#globbed == -1) {
|
||||
cf_warn($contents_file, $line,
|
||||
"Warning: No files matched $expr");
|
||||
cf_warn($contents_file, $expr,
|
||||
"Warning: No files matched $line");
|
||||
} elsif (!($#globbed == 0 and $globbed[0] eq $expr)) {
|
||||
info(1, "Expanding $expr to @globbed\n");
|
||||
}
|
||||
@ -893,6 +890,7 @@ sub sys {
|
||||
0; # like system()
|
||||
}
|
||||
|
||||
## history
|
||||
sub load_mount_info {
|
||||
undef %::mounted;
|
||||
undef %::fs_type;
|
||||
@ -955,7 +953,7 @@ sub find_file_in_path {
|
||||
|
||||
if (!@path) {
|
||||
##### Initialize @pathlist if necessary
|
||||
if (!defined(@pathlist)) {
|
||||
if (!@pathlist) {
|
||||
@pathlist = split(':', $ENV{'PATH'});
|
||||
if (defined(@::additional_dirs)) {
|
||||
unshift(@pathlist, @::additional_dirs);
|
||||
@ -1012,6 +1010,7 @@ 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
|
||||
@ -1023,17 +1022,21 @@ sub make_link_relative {
|
||||
$newlink = $link;
|
||||
}
|
||||
cleanup_link($newlink);
|
||||
}
|
||||
}
|
||||
|
||||
# I don't know if this information is worth caching.
|
||||
my(%path_length);
|
||||
sub path_length {
|
||||
my($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
|
||||
|
||||
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
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -1169,11 +1172,14 @@ sub kernel_version {
|
||||
# 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.
|
||||
@ -1193,11 +1199,11 @@ sub test_glob {
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
##### 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);
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user