l4/tool/lib/L4/ModList.pm

   1
   2 package L4::ModList;
   3 use Exporter;
   4 use vars qw(@ISA @EXPORT);
   5 @ISA    = qw(Exporter);
   6 @EXPORT = qw(get_module_entry search_file get_entries);
   7
   8 my @internal_searchpaths;
   9
  10 # extract an entry with modules from a modules.list file
  11 sub get_module_entry($$)
  12 {
  13   my ($mod_file, $entry_to_pick) = @_;
  14   my @mods;
  15   my %groups;
  16
  17   if ($entry_to_pick eq 'auto-build-entry') {
  18     print "Automatic build entry is being built.\n";
  19     print "This image is useless but it always builds.\n";
  20
  21     $mods[0] = { command => 'Makefile', cmdline => 'Makefile', type => 'bin'};
  22     $mods[1] = { command => 'Makefile', cmdline => 'Makefile', type => 'bin'};
  23     $mods[2] = { command => 'Makefile', cmdline => 'Makefile', type => 'bin'};
  24
  25     return (
  26       mods    => [ @mods ],
  27       modaddr => 0x200000,
  28     );
  29   }
  30
  31   open(M, $mod_file) || die "Cannot open $mod_file!: $!";
  32
  33   # preseed first 3 modules
  34   $mods[0] = { command => 'fiasco',   cmdline => 'fiasco',   type => 'bin'};
  35   $mods[1] = { command => 'sigma0',   cmdline => 'sigma0',   type => 'bin'};
  36   $mods[2] = { command => 'roottask', cmdline => 'moe',      type => 'bin'};
  37
  38   my $arglen = 200;
  39   my $line = 0;
  40   my $process_mode = undef;
  41   my $found_entry = 0;
  42   my $global = 1;
  43   my $modaddr_title;
  44   my $modaddr_global;
  45   my $bootstrap_command = "bootstrap";
  46   my $bootstrap_cmdline = "bootstrap";
  47   my $linux_initrd;
  48   my $is_mode_linux;
  49   while (<M>) {
  50     $line++;
  51     chomp;
  52     s/#.*$//;
  53     s/^\s*//;
  54     next if /^$/;
  55
  56     if (/^modaddr\s+(\S+)/) {
  57       $modaddr_global = $1 if  $global;
  58       $modaddr_title  = $1 if !$global;
  59       next;
  60     }
  61
  62     my ($type, $remaining) = split /\s+/, $_, 2;
  63     $type = lc($type);
  64
  65     $type = 'bin'   if $type eq 'module';
  66
  67     if ($type =~ /^(entry|title)$/) {
  68       if (lc($entry_to_pick) eq lc($remaining)) {
  69         $process_mode = 'entry';
  70         $found_entry = 1;
  71       } else {
  72         $process_mode = undef;
  73       }
  74       $global = 0;
  75       next;
  76     } elsif ($type eq 'searchpath') {
  77       push @internal_searchpaths, $remaining;
  78       next;
  79     } elsif ($type eq 'group') {
  80       $process_mode = 'group';
  81       $current_group_name = (split /\s+/, $remaining)[0];
  82       next;
  83     }
  84
  85     next unless $process_mode;
  86
  87     my @valid_types = ( 'bin', 'data', 'bin-nostrip', 'data-nostrip',
  88                         'bootstrap', 'roottask', 'kernel', 'sigma0',
  89                         'module-perl', 'module-shell', 'module-glob',
  90                         'module-group', 'initrd', 'set');
  91     die "$line: Invalid type \"$type\""
  92       unless grep(/^$type$/, @valid_types);
  93
  94     @m = ( $remaining );
  95
  96     if ($type eq 'set') {
  97       my ($varname, $value) = split /\s+/, $remaining, 2;
  98       $is_mode_linux = 1 if $varname eq 'mode' and lc($value) eq 'linux';
  99     }
 100
 101     if ($type eq 'module-perl') {
 102       @m = eval $remaining;
 103       die $@ if $@;
 104       $type = 'bin';
 105     } elsif ($type eq 'module-shell') {
 106       @m = split /\n/, `$remaining`;
 107       die "Shell command on line $line failed\n" if $?;
 108       $type = 'bin';
 109     } elsif ($type eq 'module-glob') {
 110       @m = glob $remaining;
 111       $type = 'bin';
 112     } elsif ($type eq 'module-group') {
 113       @m = ();
 114       foreach (split /\s+/, $remaining) {
 115         die "Unknown group '$_'" unless defined $groups{$_};
 116         push @m, @{$groups{$_}};
 117       }
 118       $type = 'bin';
 119     }
 120
 121     if ($process_mode eq 'entry') {
 122       foreach my $m (@m) {
 123
 124         my ($file, $args) = split /\s+/, $m, 2;
 125
 126         my $full = $file;
 127         $full .= " $args" if defined $args;
 128         $full =~ s/"/\\"/g;
 129
 130         if (length($full) > $arglen) {
 131           print "$line: \"$full\" too long...\n";
 132           exit 1;
 133         }
 134
 135         # special cases
 136         if ($type eq 'bootstrap') {
 137           $bootstrap_command = $file;
 138           $bootstrap_cmdline = $full;
 139         } elsif ($type =~ /(rmgr|roottask)/i) {
 140           $mods[2]{command}  = $file;
 141           $mods[2]{cmdline}  = $full;
 142         } elsif ($type eq 'kernel') {
 143           $mods[0]{command}  = $file;
 144           $mods[0]{cmdline}  = $full;
 145         } elsif ($type eq 'sigma0') {
 146           $mods[1]{command}  = $file;
 147           $mods[1]{cmdline}  = $full;
 148         } elsif ($type eq 'initrd') {
 149           $linux_initrd      = $file;
 150           $is_mode_linux     = 1;
 151         } else {
 152           push @mods, {
 153                         type    => $type,
 154                         command => $file,
 155                         cmdline => $full,
 156                       };
 157         }
 158       }
 159     } elsif ($process_mode eq 'group') {
 160       push @{$groups{$current_group_name}}, @m;
 161     } else {
 162       die "Invalid mode '$process_mode'";
 163     }
 164   }
 165
 166   close M;
 167
 168   die "Unknown entry \"$entry_to_pick\"!" unless $found_entry;
 169   die "'modaddr' not set" unless $modaddr_title || $modaddr_global;
 170
 171   my $m = $modaddr_title || $modaddr_global;
 172   if (defined $is_mode_linux)
 173     {
 174       die "No Linux kernel image defined" unless defined $mods[0]{cmdline};
 175       print "Entry '$entry_to_pick' is a Linux type entry\n";
 176       my @files;
 177       # @files is actually redundant but eases file selection for entry
 178       # generators
 179       push @files, $mods[0]{command};
 180       push @files, $linux_initrd if defined $linux_initrd;
 181       my %r;
 182       %r = (
 183              # actually bootstrap is always the kernel in this
 184              # environment, for convenience we use $mods[0] because that
 185              # are the contents of 'kernel xxx' which sounds more
 186              # reasonable
 187              bootstrap => { command => $mods[0]{command},
 188                             cmdline => $mods[0]{cmdline}},
 189              type      => 'Linux',
 190              files     => [ @files ],
 191            );
 192       $r{initrd} = { cmdline => $linux_initrd } if defined $linux_initrd;
 193       return %r;
 194     }
 195
 196   # now some implicit stuff
 197   if ($bootstrap_cmdline =~ /-modaddr\s+/) {
 198     $bootstrap_cmdline =~ s/(-modaddr\s+)%modaddr%/$1$m/;
 199   } else {
 200     $bootstrap_cmdline .= " -modaddr $m";
 201   }
 202
 203   my @filse; # again, this is redundant but helps generator functions
 204   push @files, $bootstrap_command;
 205   push @files, $_->{command} foreach @mods;
 206
 207   return (
 208            bootstrap => { command => $bootstrap_command,
 209                           cmdline => $bootstrap_cmdline },
 210            mods    => [ @mods ],
 211            modaddr => $modaddr_title || $modaddr_global,
 212            type    => 'MB',
 213            files   => [ @files ],
 214          );
 215 }
 216
 217 sub entry_is_linux(%)
 218 {
 219   my %e = @_;
 220   return defined $e{type} && $e{type} eq 'Linux';
 221 }
 222
 223 sub entry_is_mb(%)
 224 {
 225   my %e = @_;
 226   return defined $e{type} and $e{type} eq 'MB';
 227 }
 228
 229 sub get_entries($)
 230 {
 231   my ($mod_file) = @_;
 232   my @entry_list;
 233
 234   open(M, $mod_file) || die "Cannot open $mod_file!: $!";
 235
 236   while (<M>) {
 237     chomp;
 238     s/#.*$//;
 239     s/^\s*//;
 240     next if /^$/;
 241     push @entry_list, $2 if /^(entry|title)\s+(.+)/;
 242   }
 243
 244   close M;
 245
 246   return @entry_list;
 247 }
 248
 249 # Search for a file by using a path list (single string, split with colons
 250 # or spaces, see the split)
 251 # return undef if it could not be found, the complete path otherwise
 252 sub search_file($$)
 253 {
 254   my $file = shift;
 255   my $paths = shift;
 256
 257   foreach my $p (split(/[:\s]+/, $paths), @internal_searchpaths) {
 258     return "$p/$file" if -e "$p/$file" and ! -d "$p/$file";
 259   }
 260
 261   return $file if $file =~ /^\// && -e $file;
 262
 263   undef;
 264 }
 265
 266 sub search_file_or_die($$)
 267 {
 268   my $file = shift;
 269   my $paths = shift;
 270   my $f = search_file($file, $paths);
 271   die "Could not find '$file' with path '$paths'" unless defined $f;
 272   $f;
 273 }
 274
 275 sub get_file_uncompressed_or_die($$$)
 276 {
 277   my $command = shift;
 278   my $paths   = shift;
 279   my $tmpdir  = shift;
 280
 281   my $fp = L4::ModList::search_file_or_die($command, $paths);
 282
 283   open F, $fp || die "connot open '$fp': $!";
 284   my $buf;
 285   read F, $buf, 2;
 286   close F;
 287
 288   if (length($buf) >= 2 && unpack("n", $buf) == 0x1f8b) {
 289     (my $tf = $fp) =~ s|.*/||;
 290     $tf = $tmpdir.'/'.$tf;
 291     print "'$fp' is a zipped file, uncompressing to '$tf'\n";
 292     system("zcat $fp >$tf");
 293     $fp = $tf;
 294   }
 295
 296   $fp;
 297 }
 298
 299
 300
 301
 302 sub generate_grub1_entry($$%)
 303 {
 304   my $entryname = shift;
 305   my $prefix = shift;
 306   $prefix = '' unless defined $prefix;
 307   $prefix = "/$prefix" if $prefix ne '' and $prefix !~ /^\//;
 308   my %entry = @_;
 309   my $s = "title $entryname\n";
 310   my $c = $entry{bootstrap}{cmdline};
 311   $c =~ s/^\S*\/([^\/]+\s*)/$1/;
 312   $s .= "kernel $prefix/$c\n";
 313
 314   if (entry_is_linux(%entry) and defined $entry{initrd})
 315     {
 316       $c = $entry{initrd}{cmdline};
 317       $c =~ s/^\S*\/([^\/]+\s*)/$1/;
 318       $s .= "initrd $prefix/$c\n";
 319       return $s;
 320     }
 321
 322   foreach my $m (@{$entry{mods}})
 323     {
 324       $c = $m->{cmdline};
 325       $c =~ s/^\S*\/([^\/]+\s*)/$1/;
 326       $s .= "module $prefix/$c\n";
 327     }
 328   $s;
 329 }
 330
 331 sub generate_grub2_entry($$%)
 332 {
 333   my $entryname = shift;
 334   my $prefix = shift;
 335   $prefix = '' unless defined $prefix;
 336   $prefix = "/$prefix" if $prefix ne '' and $prefix !~ /^\//;
 337   my %entry = @_;
 338   # basename of first path
 339   my ($c, $args) = split(/\s+/, $entry{bootstrap}{cmdline}, 2);
 340   my $bn = (reverse split(/\/+/, $c))[0];
 341   my $s = "menuentry \"$entryname\" {\n";
 342
 343   if (entry_is_linux(%entry))
 344     {
 345       $s .= "  echo Loading '$prefix/$bn $args'\n";
 346       $s .= "  linux $prefix/$bn $args\n";
 347       if (defined $entry{initrd})
 348         {
 349           $bn = (reverse split(/\/+/, $entry{initrd}{cmdline}))[0];
 350           my $c = $entry{initrd}{cmdline};
 351           $c =~ s/^\S*(\/[^\/]+\s*)/$1/;
 352           $s .= "  initrd $prefix$c\n";
 353         }
 354     }
 355   else
 356     {
 357       $s .= "  echo Loading '$prefix/$bn $prefix/$bn $args'\n";
 358       $s .= "  multiboot $prefix/$bn $prefix/$bn $args\n";
 359       foreach my $m (@{$entry{mods}})
 360         {
 361           # basename
 362           $bn = (reverse split(/\/+/, $m->{command}))[0];
 363           my $c = $m->{cmdline};
 364           $c =~ s/^\S*(\/[^\/]+\s*)/$1/;
 365           $s .= "  echo Loading '$prefix/$bn $c'\n";
 366           $s .= "  module $prefix/$bn $c\n";
 367         }
 368     }
 369   $s .= "  echo Done, booting...\n";
 370   $s .= "}\n";
 371 }
 372
 373
 374 return 1;