mirror of
https://github.com/fspc/gbootroot.git
synced 2025-02-23 00:53:23 -05:00
Perl-5.6 glob now working, vanquished many undefs.
This commit is contained in:
parent
aa07bac3b2
commit
8d6ed2cad4
60
Yard.pm
60
Yard.pm
@ -54,6 +54,16 @@ my $objcopy = "objcopy";
|
|||||||
my($Warnings) = 0;
|
my($Warnings) = 0;
|
||||||
my $verbosity;
|
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);
|
STDOUT->autoflush(1);
|
||||||
|
|
||||||
sub warning {
|
sub warning {
|
||||||
@ -61,20 +71,6 @@ sub warning {
|
|||||||
$Warnings++;
|
$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
|
## REQUIRES $kernel opt. $kernel_version
|
||||||
sub kernel_version_check {
|
sub kernel_version_check {
|
||||||
|
|
||||||
@ -121,7 +117,7 @@ sub kernel_version_check {
|
|||||||
## cf_die, must_be_abs, replaced_by, yard_glob
|
## cf_die, must_be_abs, replaced_by, yard_glob
|
||||||
## REQUIRES $contents_file
|
## REQUIRES $contents_file
|
||||||
sub read_contents_file {
|
sub read_contents_file {
|
||||||
|
|
||||||
my ($contents_file) = @_;
|
my ($contents_file) = @_;
|
||||||
|
|
||||||
info(0, "\n\nPASS 1: Reading $contents_file");
|
info(0, "\n\nPASS 1: Reading $contents_file");
|
||||||
@ -132,6 +128,7 @@ sub read_contents_file {
|
|||||||
my($line);
|
my($line);
|
||||||
|
|
||||||
LINE: while (defined($line = <CONTENTS>)) {
|
LINE: while (defined($line = <CONTENTS>)) {
|
||||||
|
|
||||||
my(@files);
|
my(@files);
|
||||||
$cf_line++;
|
$cf_line++;
|
||||||
chomp $line;
|
chomp $line;
|
||||||
@ -155,14 +152,14 @@ sub read_contents_file {
|
|||||||
##### call include_file until pass two after all explicit links
|
##### call include_file until pass two after all explicit links
|
||||||
##### have been seen.
|
##### have been seen.
|
||||||
my($abs_file) = find_file_in_path($file);
|
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
|
#### Have to be careful here. Record the rel link for use
|
||||||
#### in setting up the root fs, but use the abs_link in @files
|
#### in setting up the root fs, but use the abs_link in @files
|
||||||
#### so next loop gets any actual files.
|
#### so next loop gets any actual files.
|
||||||
my($abs_link) = make_link_absolute($abs_file, $link);
|
my($abs_link) = make_link_absolute($abs_file, $link);
|
||||||
my($rel_link) = make_link_relative($abs_file, $link);
|
my($rel_link) = make_link_relative($abs_file, $link);
|
||||||
$links_to{$abs_file} = $rel_link;
|
$links_to{$abs_file} = $rel_link if $abs_file;
|
||||||
info(1, "$line links $abs_file to $rel_link\n");
|
info(1, "$line links $abs_file to $rel_link\n") if $abs_file;
|
||||||
@files = ($abs_link);
|
@files = ($abs_link);
|
||||||
|
|
||||||
} elsif ($line =~ /<=/) { ##### REPLACEMENT SPEC
|
} elsif ($line =~ /<=/) { ##### REPLACEMENT SPEC
|
||||||
@ -209,8 +206,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($contents_file, $line,
|
cf_warn($contents_file, $expr,
|
||||||
"Warning: No files matched $expr");
|
"Warning: No files matched $line");
|
||||||
} 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");
|
||||||
}
|
}
|
||||||
@ -893,6 +890,7 @@ sub sys {
|
|||||||
0; # like system()
|
0; # like system()
|
||||||
}
|
}
|
||||||
|
|
||||||
|
## history
|
||||||
sub load_mount_info {
|
sub load_mount_info {
|
||||||
undef %::mounted;
|
undef %::mounted;
|
||||||
undef %::fs_type;
|
undef %::fs_type;
|
||||||
@ -955,7 +953,7 @@ sub find_file_in_path {
|
|||||||
|
|
||||||
if (!@path) {
|
if (!@path) {
|
||||||
##### Initialize @pathlist if necessary
|
##### Initialize @pathlist if necessary
|
||||||
if (!defined(@pathlist)) {
|
if (!@pathlist) {
|
||||||
@pathlist = split(':', $ENV{'PATH'});
|
@pathlist = split(':', $ENV{'PATH'});
|
||||||
if (defined(@::additional_dirs)) {
|
if (defined(@::additional_dirs)) {
|
||||||
unshift(@pathlist, @::additional_dirs);
|
unshift(@pathlist, @::additional_dirs);
|
||||||
@ -1012,6 +1010,7 @@ sub make_link_relative {
|
|||||||
my($abs_file, $link) = @_;
|
my($abs_file, $link) = @_;
|
||||||
my($newlink);
|
my($newlink);
|
||||||
|
|
||||||
|
if ($abs_file) {
|
||||||
if ($link =~ m|^/(.*)$|) {
|
if ($link =~ m|^/(.*)$|) {
|
||||||
# It's absolute -- we have to relativize it
|
# It's absolute -- we have to relativize it
|
||||||
# The abs_file guaranteed not to have any funny
|
# The abs_file guaranteed not to have any funny
|
||||||
@ -1023,17 +1022,21 @@ sub make_link_relative {
|
|||||||
$newlink = $link;
|
$newlink = $link;
|
||||||
}
|
}
|
||||||
cleanup_link($newlink);
|
cleanup_link($newlink);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# I don't know if this information is worth caching.
|
# I don't know if this information is worth caching.
|
||||||
my(%path_length);
|
my(%path_length);
|
||||||
sub path_length {
|
sub path_length {
|
||||||
my($path) = @_;
|
my($path) = @_;
|
||||||
return $path_length{$path} if defined($path_length{$path});
|
|
||||||
my($length) = -1;
|
if ($path) {
|
||||||
while ($path =~ m|/|g) { $length++ } # count slashes
|
return $path_length{$path} if defined($path_length{$path});
|
||||||
$path_length{$path} = $length;
|
my($length) = -1;
|
||||||
$length
|
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
|
# 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.
|
# except that beginning must be dotted triple and it's space delimited.
|
||||||
my($version) = $str =~ /^(\d+\.\d+\.\d+\S*)\s/;
|
my($version) = $str =~ /^(\d+\.\d+\.\d+\S*)\s/;
|
||||||
|
|
||||||
return $version
|
return $version
|
||||||
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
## HISTORY
|
||||||
##### Eventually move this into configure since it doesn't have to be
|
##### 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
|
##### done with every make_root_fs. But yard_glob would have to be
|
||||||
##### configured, and yard_utils.pl isn't configured.
|
##### 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.
|
##### Check glob() -- In some Perl versions it's reported not to work.
|
||||||
sub yard_glob {
|
sub yard_glob {
|
||||||
my($expr) = @_;
|
my($expr) = @_;
|
||||||
|
|
||||||
|
## first part HISTORY
|
||||||
if ($glob_broken) {
|
if ($glob_broken) {
|
||||||
my($line) = `echo $expr`;
|
my($line) = `echo $expr`;
|
||||||
chop($line);
|
chop($line);
|
||||||
|
Loading…
x
Reference in New Issue
Block a user