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 "$.: \"$full\" too long...\n";
  22     exit 1;
  23   }
  24
  25   ($file, $full);
  26 }
  27
  28 sub error($)
  29 {
  30   print STDERR shift;
  31   exit(1);
  32 }
  33
  34 sub handle_options($)
  35 {
  36   my $optstring = shift;
  37   my %opts;
  38
  39   foreach (split /\s*,\s*/, $optstring)
  40     {
  41       if (/(\S+)\s*=\s*(.+)/)
  42         {
  43           $opts{$1} = $2;
  44         }
  45       else
  46         {
  47           $opts{$_} = undef;
  48         }
  49     }
  50
  51   return %opts;
  52 }
  53
  54 sub handle_line
  55 {
  56   my $r = shift;
  57   my $mod_file = shift;
  58   my %opts = @_;
  59
  60   $r =~ s/\s+$//;
  61
  62   if (exists $opts{perl})
  63     {
  64       my @m = eval $r;
  65       die "perl: ".$@ if $@;
  66       return @m;
  67     }
  68
  69   if (exists $opts{shell})
  70     {
  71       my @m = split /\n/, `$r`;
  72       error "$mod_file:$.: Shell command failed\n" if $?;
  73       return @m;
  74     }
  75
  76   return ( glob $r ) if exists $opts{glob};
  77
  78
  79   # Deprecated start -- remove in 2016
  80   if ($r =~ /^((perl|glob|shell):\s+)/)
  81     {
  82       substr $r, 0, length($1), "";
  83
  84       print STDERR "ATTENTION:\n".
  85                    "  Using deprecated syntax '$2:' on line $.\n".
  86                    "  Use option syntax now: <command>[$2] $r\n";
  87
  88       if ($2 eq 'perl')
  89         {
  90           my @m = eval $r;
  91           die "perl: ".$@ if $@;
  92           return @m;
  93         }
  94       elsif ($2 eq 'shell')
  95         {
  96           my @m = split /\n/, `$r`;
  97           error "$mod_file:$.: Shell command failed\n" if $?;
  98           return @m;
  99         }
 100       elsif ($2 eq 'glob')
 101         {
 102           return ( glob $r );
 103         }
 104       else
 105         {
 106           die "should not happen";
 107         }
 108     }
 109   # Deprecated end
 110
 111   return ( $r );
 112 }
 113
 114 sub handle_line_first
 115 {
 116   return (handle_line(shift, shift, @_))[0];
 117 }
 118
 119 sub readin_config($)
 120 {
 121   my ($mod_file) = @_;
 122
 123   my @fs_fds;
 124   my @fs_filenames;
 125   my @mod_files_for_include;
 126   my $fd;
 127   my @contents;
 128   my %file_to_id;
 129   my %id_to_file;
 130   my $file_id_cur = 0;
 131
 132   push @mod_files_for_include, $mod_file;
 133
 134   while (1)
 135     {
 136       if (@mod_files_for_include)
 137         {
 138           my $f = shift @mod_files_for_include;
 139
 140           if (grep { /^$f$/ } @fs_filenames)
 141             {
 142               print STDERR "$mod_file:$.: Warning: $f already included, skipping.\n";
 143               next;
 144             }
 145
 146           push @fs_filenames, $mod_file;
 147           push @fs_fds, $fd;
 148
 149           undef $fd;
 150           $mod_file = $f;
 151           open($fd, $f) || error "Cannot open '$f': $!\n";
 152
 153           $id_to_file{$file_id_cur} = $f;
 154           $file_to_id{$f} = $file_id_cur++;
 155         }
 156
 157       while (<$fd>)
 158         {
 159           chomp;
 160           s/#.*$//;
 161           s/^\s*//;
 162           next if /^$/;
 163
 164           my ($cmd, $remaining) = split /\s+/, $_, 2;
 165           $cmd = lc($cmd);
 166
 167           if ($cmd eq 'include')
 168             {
 169               my @f = handle_line($remaining, $mod_file);
 170               foreach my $f (@f)
 171                 {
 172                   my $abs;
 173                   if ($f =~ /^\//)
 174                     {
 175                       $abs = $f;
 176                     }
 177                   else
 178                     {
 179                       my @tmp = split /\/+/, $mod_file;
 180                       $tmp[@tmp - 1] = $f;
 181                       $abs = join('/', @tmp);
 182                     }
 183                   unshift @mod_files_for_include, glob $abs;
 184                 }
 185
 186               last;
 187             }
 188
 189           push @contents, [ $file_to_id{$mod_file}, $., $_ ];
 190         }
 191
 192       unless (defined $_)
 193         {
 194           close $fd;
 195
 196           $fd       = pop @fs_fds;
 197           $mod_file = pop @fs_filenames;
 198
 199           last unless defined $fd;
 200         }
 201     }
 202
 203
 204   if (0)
 205     {
 206       print "$id_to_file{$$_[0]}($$_[0]):$$_[1]: $$_[2]\n" foreach (@contents);
 207     }
 208
 209   return (
 210            contents => [ @contents ],
 211            file_to_id => { %file_to_id },
 212            id_to_file => { %id_to_file },
 213          );
 214 }
 215
 216 # extract an entry with modules from a modules.list file
 217 sub get_module_entry($$)
 218 {
 219   my ($mod_file, $entry_to_pick) = @_;
 220   my @mods;
 221   my %groups;
 222
 223   if ($entry_to_pick eq 'auto-build-entry') {
 224     # Automatic build entry is being built.
 225     # This image is useless but it always builds.
 226
 227     $mods[0] = { command => 'Makefile', cmdline => 'Makefile', type => 'bin'};
 228     $mods[1] = { command => 'Makefile', cmdline => 'Makefile', type => 'bin'};
 229     $mods[2] = { command => 'Makefile', cmdline => 'Makefile', type => 'bin'};
 230
 231     return (
 232       bootstrap => { command => 'bootstrap',
 233                      cmdline => 'bootstrap' },
 234       mods    => [ @mods ],
 235       modaddr => 0x200000,
 236     );
 237   }
 238
 239   # preseed first 3 modules
 240   $mods[0] = { command => 'fiasco',   cmdline => 'fiasco',   type => 'bin'};
 241   $mods[1] = { command => 'sigma0',   cmdline => 'sigma0',   type => 'bin'};
 242   $mods[2] = { command => 'roottask', cmdline => 'moe',      type => 'bin'};
 243
 244   my $process_mode = undef;
 245   my $found_entry = 0;
 246   my $global = 1;
 247   my $modaddr_title;
 248   my $modaddr_global;
 249   my $bootstrap_command = "bootstrap";
 250   my $bootstrap_cmdline = "bootstrap";
 251   my $linux_initrd;
 252   my $is_mode_linux;
 253
 254   my %mod_file_db = readin_config($mod_file);
 255
 256   foreach my $fileentry (@{$mod_file_db{contents}})
 257     {
 258       $_ = $$fileentry[2];
 259       $. = $$fileentry[1];
 260
 261       chomp;
 262       s/#.*$//;
 263       s/^\s*//;
 264       next if /^$/;
 265
 266       if (/^modaddr\s+(\S+)/) {
 267         $modaddr_global = $1 if  $global;
 268         $modaddr_title  = $1 if !$global and $process_mode;
 269         next;
 270       }
 271
 272       /^([^\s\[]+)(\[\s*(.*)\s*\])?(\s+(.*))?/;
 273       my ($type, $opts, $remaining) = ($1, $3, $5);
 274
 275       my %opts;
 276       %opts = handle_options($opts) if defined $opts;
 277
 278       print "Options: ",
 279             join(", ", map { $opts{$_} ? "$_=$opts{$_}" : $_ } keys %opts),
 280             "\n"
 281         if %opts && 0;
 282
 283       $type = lc($type);
 284
 285       $type = 'bin'   if $type eq 'module';
 286
 287       if ($type =~ /^(entry|title)$/) {
 288         ($remaining) = handle_line($remaining, $mod_file, %opts);
 289         if (lc($entry_to_pick) eq lc($remaining)) {
 290           $process_mode = 'entry';
 291           $found_entry = 1;
 292         } else {
 293           $process_mode = undef;
 294         }
 295         $global = 0;
 296         next;
 297       }
 298
 299       if ($type eq 'searchpath') {
 300         push @internal_searchpaths, handle_line($remaining, $mod_file, %opts);
 301         next;
 302       } elsif ($type eq 'group') {
 303         $process_mode = 'group';
 304         $current_group_name = (split /\s+/, handle_line_first($remaining, $mod_file, %opts))[0];
 305         next;
 306       } elsif ($type eq 'default-bootstrap') {
 307         my ($file, $full) = get_command_and_cmdline(handle_line_first($remaining, $mod_file, %opts));
 308         $bootstrap_command = $file;
 309         $bootstrap_cmdline = $full;
 310         next;
 311       } elsif ($type eq 'default-kernel') {
 312         my ($file, $full) = get_command_and_cmdline(handle_line_first($remaining, $mod_file, %opts));
 313         $mods[0]{command}  = $file;
 314         $mods[0]{cmdline}  = $full;
 315         next;
 316       } elsif ($type eq 'default-sigma0') {
 317         my ($file, $full) = get_command_and_cmdline(handle_line_first($remaining, $mod_file, %opts));
 318         $mods[1]{command}  = $file;
 319         $mods[1]{cmdline}  = $full;
 320         next;
 321       } elsif ($type eq 'default-roottask') {
 322         my ($file, $full) = get_command_and_cmdline(handle_line_first($remaining, $mod_file, %opts));
 323         $mods[2]{command}  = $file;
 324         $mods[2]{cmdline}  = $full;
 325         next;
 326       }
 327
 328       next unless $process_mode;
 329
 330       my @params = handle_line($remaining, $mod_file, %opts);
 331
 332       my @valid_types = ( 'bin', 'data', 'bin-nostrip', 'data-nostrip',
 333                           'bootstrap', 'roottask', 'kernel', 'sigma0',
 334                           'module-group', 'moe', 'initrd', 'set');
 335       error "$mod_file_db{id_to_file}{$$fileentry[0]}:$$fileentry[1]: Invalid type \"$type\"\n"
 336         unless grep(/^$type$/, @valid_types);
 337
 338
 339       if ($type eq 'set') {
 340         my ($varname, $value) = split /\s+/, $params[0], 2;
 341         $is_mode_linux = 1 if $varname eq 'mode' and lc($value) eq 'linux';
 342       }
 343
 344       if ($type eq 'module-group') {
 345         my @m = ();
 346         foreach (split /\s+/, join(' ', @params)) {
 347           error "$mod_file_db{id_to_file}{$$fileentry[0]}:$$fileentry[1]: Unknown group '$_'\n" unless defined $groups{$_};
 348           push @m, @{$groups{$_}};
 349         }
 350         @params = @m;
 351         $type = 'bin';
 352       } elsif ($type eq 'moe') {
 353         $mods[2]{command}  = 'moe';
 354         $mods[2]{cmdline}  = "moe rom/$params[0]";
 355         $type = 'bin';
 356         @m = ($params[0]);
 357       }
 358       next if not defined $params[0] or $params[0] eq '';
 359
 360       if ($process_mode eq 'entry') {
 361         foreach my $m (@params) {
 362
 363           my ($file, $full) = get_command_and_cmdline($m);
 364
 365           # special cases
 366           if ($type eq 'bootstrap') {
 367             $bootstrap_command = $file;
 368             $bootstrap_cmdline = $full;
 369           } elsif ($type =~ /(rmgr|roottask)/i) {
 370             $mods[2]{command}  = $file;
 371             $mods[2]{cmdline}  = $full;
 372           } elsif ($type eq 'kernel') {
 373             $mods[0]{command}  = $file;
 374             $mods[0]{cmdline}  = $full;
 375           } elsif ($type eq 'sigma0') {
 376             $mods[1]{command}  = $file;
 377             $mods[1]{cmdline}  = $full;
 378           } elsif ($type eq 'initrd') {
 379             $linux_initrd      = $file;
 380             $is_mode_linux     = 1;
 381           } else {
 382             push @mods, {
 383                           type    => $type,
 384                           command => $file,
 385                           cmdline => $full,
 386                         };
 387           }
 388         }
 389       } elsif ($process_mode eq 'group') {
 390         push @{$groups{$current_group_name}}, @params;
 391       } else {
 392         error "$mod_file_db{id_to_file}{$$fileentry[0]}:$$fileentry[1]: Invalid mode '$process_mode'\n";
 393       }
 394     }
 395
 396   error "$mod_file: Unknown entry \"$entry_to_pick\"!\n" unless $found_entry;
 397
 398   if (defined $is_mode_linux)
 399     {
 400       error "No Linux kernel image defined\n" unless defined $mods[0]{cmdline};
 401       print STDERR "Entry '$entry_to_pick' is a Linux type entry\n";
 402       my @files;
 403       # @files is actually redundant but eases file selection for entry
 404       # generators
 405       push @files, $mods[0]{command};
 406       push @files, $linux_initrd if defined $linux_initrd;
 407       my %r;
 408       %r = (
 409              # actually bootstrap is always the kernel in this
 410              # environment, for convenience we use $mods[0] because that
 411              # are the contents of 'kernel xxx' which sounds more
 412              # reasonable
 413              bootstrap => { command => $mods[0]{command},
 414                             cmdline => $mods[0]{cmdline}},
 415              type      => 'Linux',
 416              files     => [ @files ],
 417            );
 418       $r{initrd} = { cmdline => $linux_initrd } if defined $linux_initrd;
 419       return %r;
 420     }
 421
 422   # now some implicit stuff
 423   my $m = $modaddr_title || $modaddr_global;
 424   if (defined $m)
 425     {
 426       if ($bootstrap_cmdline =~ /-modaddr\s+/)
 427         {
 428           $bootstrap_cmdline =~ s/(-modaddr\s+)%modaddr%/$1$m/;
 429         }
 430       else
 431         {
 432           $bootstrap_cmdline .= " -modaddr $m";
 433         }
 434     }
 435
 436   my @files; # again, this is redundant but helps generator functions
 437   push @files, $bootstrap_command;
 438   push @files, $_->{command} foreach @mods;
 439
 440   return (
 441            bootstrap => { command => $bootstrap_command,
 442                           cmdline => $bootstrap_cmdline },
 443            mods    => [ @mods ],
 444            modaddr => $modaddr_title || $modaddr_global,
 445            type    => 'MB',
 446            files   => [ @files ],
 447          );
 448 }
 449
 450 sub entry_is_linux(%)
 451 {
 452   my %e = @_;
 453   return defined $e{type} && $e{type} eq 'Linux';
 454 }
 455
 456 sub entry_is_mb(%)
 457 {
 458   my %e = @_;
 459   return defined $e{type} && $e{type} eq 'MB';
 460 }
 461
 462 sub get_entries($)
 463 {
 464   my ($mod_file) = @_;
 465   my @entry_list;
 466
 467   my %mod_file_db = readin_config($mod_file);
 468
 469   foreach my $fileentry (@{$mod_file_db{contents}})
 470     {
 471       push @entry_list, $2 if $$fileentry[2] =~ /^(entry|title)\s+(.+)\s*$/;
 472     }
 473
 474   return @entry_list;
 475 }
 476
 477 # Search for a file by using a path list (single string, split with colons
 478 # or spaces, see the split)
 479 # return undef if it could not be found, the complete path otherwise
 480 sub search_file($$)
 481 {
 482   my $file = shift;
 483   my $paths = shift;
 484
 485   foreach my $p (split(/[:\s]+/, $paths), @internal_searchpaths) {
 486     return "$p/$file" if -e "$p/$file" and ! -d "$p/$file";
 487   }
 488
 489   return $file if $file =~ /^\// && -e $file;
 490
 491   undef;
 492 }
 493
 494 sub search_file_or_die($$)
 495 {
 496   my $file = shift;
 497   my $paths = shift;
 498   my $f = search_file($file, $paths);
 499   error "Could not find '$file' with path '$paths'\n" unless defined $f;
 500   $f;
 501 }
 502
 503 sub get_or_copy_file_uncompressed_or_die($$$$)
 504 {
 505   my $command   = shift;
 506   my $paths     = shift;
 507   my $targetdir = shift;
 508   my $copy      = shift;
 509
 510   my $fp = L4::ModList::search_file_or_die($command, $paths);
 511
 512   open F, $fp || error "Cannot open '$fp': $!\n";
 513   my $buf;
 514   read F, $buf, 2;
 515   close F;
 516
 517   (my $tf = $fp) =~ s|.*/||;
 518   $tf = $targetdir.'/'.$tf;
 519
 520   if (length($buf) >= 2 && unpack("n", $buf) == 0x1f8b) {
 521     print STDERR "'$fp' is a zipped file, uncompressing to '$tf'\n";
 522     system("zcat $fp >$tf");
 523     $fp = $tf;
 524   } elsif ($copy) {
 525     print("cp $fp $tf\n");
 526     system("cp $fp $tf");
 527     $fp = $tf;
 528   }
 529
 530   $fp;
 531 }
 532
 533 sub get_file_uncompressed_or_die($$$)
 534 {
 535   return get_or_copy_file_uncompressed_or_die(shift, shift, shift, 0);
 536 }
 537
 538 sub copy_file_uncompressed_or_die($$$)
 539 {
 540   return get_or_copy_file_uncompressed_or_die(shift, shift, shift, 1);
 541 }
 542
 543
 544 sub generate_grub1_entry($$%)
 545 {
 546   my $entryname = shift;
 547   my $prefix = shift;
 548   $prefix = '' unless defined $prefix;
 549   $prefix = "/$prefix" if $prefix ne '' and $prefix !~ /^\//;
 550   my %entry = @_;
 551   my $s = "title $entryname\n";
 552   my $c = $entry{bootstrap}{cmdline};
 553   $c =~ s/^\S*\/([^\/]+\s*)/$1/;
 554   $s .= "kernel $prefix/$c\n";
 555
 556   if (entry_is_linux(%entry) and defined $entry{initrd})
 557     {
 558       $c = $entry{initrd}{cmdline};
 559       $c =~ s/^\S*\/([^\/]+\s*)/$1/;
 560       $s .= "initrd $prefix/$c\n";
 561       return $s;
 562     }
 563
 564   foreach my $m (@{$entry{mods}})
 565     {
 566       $c = $m->{cmdline};
 567       $c =~ s/^\S*\/([^\/]+\s*)/$1/;
 568       $s .= "module $prefix/$c\n";
 569     }
 570   $s;
 571 }
 572
 573 sub generate_grub2_entry($$%)
 574 {
 575   my $entryname = shift;
 576   my $prefix = shift;
 577   $prefix = '' unless defined $prefix;
 578   $prefix = "/$prefix" if $prefix ne '' and $prefix !~ /^\//;
 579   my %entry = @_;
 580   # basename of first path
 581   my ($c, $args) = split(/\s+/, $entry{bootstrap}{cmdline}, 2);
 582   my $bn = (reverse split(/\/+/, $c))[0];
 583   my $s = "menuentry \"$entryname\" {\n";
 584
 585   if (entry_is_linux(%entry))
 586     {
 587       $s .= "  echo Loading '$prefix/$bn $args'\n";
 588       $s .= "  linux $prefix/$bn $args\n";
 589       if (defined $entry{initrd})
 590         {
 591           $bn = (reverse split(/\/+/, $entry{initrd}{cmdline}))[0];
 592           my $c = $entry{initrd}{cmdline};
 593           $c =~ s/^\S*(\/[^\/]+\s*)/$1/;
 594           $s .= "  initrd $prefix$c\n";
 595         }
 596     }
 597   else
 598     {
 599       $s .= "  echo Loading '$prefix/$bn $prefix/$bn $args'\n";
 600       $s .= "  multiboot $prefix/$bn $prefix/$bn $args\n";
 601       foreach my $m (@{$entry{mods}})
 602         {
 603           # basename
 604           $bn = (reverse split(/\/+/, $m->{command}))[0];
 605           my $c = $m->{cmdline};
 606           $c =~ s/^\S*(\/[^\/]+\s*)/$1/;
 607           $s .= "  echo Loading '$prefix/$bn $c'\n";
 608           $s .= "  module $prefix/$bn $c\n";
 609         }
 610     }
 611   $s .= "  echo Done, booting...\n";
 612   $s .= "}\n";
 613 }
 614
 615 return 1;