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