Browse Source

Perl-5.6 glob now working, vanquished many undefs.

master
freesource 24 years ago
parent
commit
8d6ed2cad4
  1. 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…
Cancel
Save