pintos-os.org Git - pintos-anon/blob - src/utils/pintos

   1 #! /usr/bin/perl -w
   2
   3 use strict;
   4 use POSIX;
   5 use Fcntl;
   6 use File::Temp 'tempfile';
   7 use Getopt::Long qw(:config bundling);
   8
   9 # Command-line options.
  10 our ($start_time) = time ();
  11 our ($sim) = $ENV{PINTOSSIM};   # Simulator: bochs, qemu, or gsx.
  12 our ($debug) = "none";          # Debugger: none, monitor, or gdb.
  13 our ($mem) = 4;                 # Physical RAM in MB.
  14 our ($serial_out) = 1;          # Send output to serial port?
  15 our ($vga);                     # VGA output: window, terminal, or none.
  16 our ($jitter);                  # Seed for random timer interrupts, if set.
  17 our ($realtime);                # Synchronize timer interrupts with real time?
  18 our ($timeout);                 # Maximum runtime in seconds, if set.
  19 our (@puts);                    # Files to copy into the VM.
  20 our (@gets);                    # Files to copy out of the VM.
  21 our ($as_ref);                  # Reference to last addition to @gets or @puts.
  22 our (@kernel_args);             # Arguments to pass to kernel.
  23 our (%disks) = (OS => {DEF_FN => 'os.dsk'},             # Disks to give VM.
  24                 FS => {DEF_FN => 'fs.dsk'},
  25                 SCRATCH => {DEF_FN => 'scratch.dsk'},
  26                 SWAP => {DEF_FN => 'swap.dsk'});
  27 our (@disks_by_iface) = @disks{qw (OS FS SCRATCH SWAP)};
  28
  29 parse_command_line ();
  30 find_disks ();
  31 prepare_scratch_disk ();
  32 prepare_arguments ();
  33 run_vm ();
  34 finish_scratch_disk ();
  35
  36 exit 0;
  37 \f
  38 # Parses the command line.
  39 sub parse_command_line {
  40     usage (0) if @ARGV == 0 || (@ARGV == 1 && $ARGV[0] eq '--help');
  41
  42     @kernel_args = @ARGV;
  43     if (grep ($_ eq '--', @kernel_args)) {
  44         @ARGV = ();
  45         while ((my $arg = shift (@kernel_args)) ne '--') {
  46             push (@ARGV, $arg);
  47         }
  48         GetOptions ("sim=s" => sub { set_sim (@_) },
  49                     "bochs" => sub { set_sim ("bochs") },
  50                     "qemu" => sub { set_sim ("qemu") },
  51                     "gsx" => sub { set_sim ("gsx") },
  52
  53                     "debug=s" => sub { set_debug (@_) },
  54                     "no-debug" => sub { set_debug ("none") },
  55                     "monitor" => sub { set_debug ("monitor") },
  56                     "gdb" => sub { set_debug ("gdb") },
  57
  58                     "m|memory=i" => \$mem,
  59                     "j|jitter=i" => sub { set_jitter (@_) },
  60                     "r|realtime" => sub { set_realtime () },
  61                     "T|timeout=i" => \$timeout,
  62
  63                     "v|no-vga" => sub { set_vga ('none'); },
  64                     "s|no-serial" => sub { $serial_out = 0; },
  65                     "t|terminal" => sub { set_vga ('terminal'); },
  66
  67                     "p|put-file=s" => sub { add_file (\@puts, $_[1]); },
  68                     "g|get-file=s" => sub { add_file (\@gets, $_[1]); },
  69                     "a|as=s" => sub { set_as ($_[1]); },
  70
  71                     "h|help" => sub { usage (0); },
  72
  73                     "os-disk=s" => \$disks{OS}{FILE_NAME},
  74                     "fs-disk=s" => \$disks{FS}{FILE_NAME},
  75                     "scratch-disk=s" => \$disks{SCRATCH}{FILE_NAME},
  76                     "swap-disk=s" => \$disks{SWAP}{FILE_NAME},
  77
  78                     "0|disk-0|hda=s" => \$disks_by_iface[0]{FILE_NAME},
  79                     "1|disk-1|hdb=s" => \$disks_by_iface[1]{FILE_NAME},
  80                     "2|disk-2|hdc=s" => \$disks_by_iface[2]{FILE_NAME},
  81                     "3|disk-3|hdd=s" => \$disks_by_iface[3]{FILE_NAME})
  82           or exit 1;
  83     }
  84
  85     $sim = "bochs" if !defined $sim;
  86     $debug = "none" if !defined $debug;
  87     $vga = "window" if !defined $vga;
  88
  89     print "warning: -T or --timeout should not be used with --$debug\n"
  90       if defined ($timeout) && $debug ne 'none';
  91 }
  92
  93 # usage($exitcode).
  94 # Prints a usage message and exits with $exitcode.
  95 sub usage {
  96     my ($exitcode) = @_;
  97     $exitcode = 1 unless defined $exitcode;
  98     print <<'EOF';
  99 pintos, a utility for running Pintos in a simulator
 100 Usage: pintos [OPTION...] -- [ARGUMENT...]
 101 where each OPTION is one of the following options
 102   and each ARGUMENT is passed to Pintos kernel verbatim.
 103 Simulator selection:
 104   --bochs                  (default) Use Bochs as simulator
 105   --qemu                   Use qemu as simulator
 106   --gsx                    Use VMware GSX Server 3.x as simulator
 107 Debugger selection:
 108   --no-debug               (default) No debugger
 109   --monitor                Debug with simulator's monitor
 110   --gdb                    Debug with gdb
 111 Display options: (default is both VGA and serial)
 112   -v, --no-vga             No VGA display
 113   -s, --no-serial          No serial output
 114   -t, --terminal           Display VGA in terminal (Bochs only)
 115 Timing options: (Bochs only)
 116   -j SEED                  Randomize timer interrupts
 117   -r, --realtime           Use realistic, not reproducible, timings
 118   -T, --timeout=N          Kill Pintos after N seconds CPU time or N*load_avg
 119                            seconds wall-clock time (whichever comes first)
 120 Configuration options:
 121   -m, --mem=N              Give Pintos N MB physical RAM (default: 4)
 122 File system commands (for `run' command):
 123   -p, --put-file=HOSTFN    Copy HOSTFN into VM, by default under same name
 124   -g, --get-file=GUESTFN   Copy GUESTFN out of VM, by default under same name
 125   -a, --as=FILENAME        Specifies guest (for -p) or host (for -g) file name
 126 Disk options: (name an existing FILE or specify SIZE in MB for a temp disk)
 127   --os-disk=FILE           Set OS disk file (default: os.dsk)
 128   --fs-disk=FILE|SIZE      Set FS disk file (default: fs.dsk)
 129   --scratch-disk=FILE|SIZE Set scratch disk (default: scratch.dsk)
 130   --swap-disk=FILE|SIZE    Set swap disk file (default: swap.dsk)
 131 Other options:
 132   -h, --help               Display this help message.
 133 Environment variables:
 134   PINTOSSIM                Select default simulator.
 135 EOF
 136     exit $exitcode;
 137 }
 138
 139 # Sets the simulator.
 140 sub set_sim {
 141     my ($new_sim) = @_;
 142     die "--$new_sim conflicts with --$sim\n"
 143         if defined ($sim) && $sim ne $new_sim;
 144     $sim = $new_sim;
 145 }
 146
 147 # Sets the debugger.
 148 sub set_debug {
 149     my ($new_debug) = @_;
 150     die "--$new_debug conflicts with --$debug\n"
 151         if $debug ne 'none' && $new_debug ne 'none' && $debug ne $new_debug;
 152     $debug = $new_debug;
 153 }
 154
 155 # Sets VGA output destination.
 156 sub set_vga {
 157     my ($new_vga) = @_;
 158     if (defined ($vga) && $vga ne $new_vga) {
 159         print "warning: conflicting vga display options\n";
 160     }
 161     $vga = $new_vga;
 162 }
 163
 164 # Sets randomized timer interrupts.
 165 sub set_jitter {
 166     my ($new_jitter) = @_;
 167     die "--realtime conflicts with --jitter\n" if defined $realtime;
 168     die "different --jitter already defined\n"
 169         if defined $jitter && $jitter != $new_jitter;
 170     $jitter = $new_jitter;
 171 }
 172
 173 # Sets real-time timer interrupts.
 174 sub set_realtime {
 175     die "--realtime conflicts with --jitter\n" if defined $jitter;
 176     $realtime = 1;
 177 }
 178
 179 # add_file(\@list, $file)
 180 #
 181 # Adds [$file] to @list, which should be @puts or @gets.
 182 # Sets $as_ref to point to the added element.
 183 sub add_file {
 184     my ($list, $file) = @_;
 185     $as_ref = [$file];
 186     push (@$list, $as_ref);
 187 }
 188
 189 # Sets the guest/host name for the previous put/get.
 190 sub set_as {
 191     my ($as) = @_;
 192     die "-a (or --as) is only allowed after -p or -g\n" if !defined $as_ref;
 193     die "Only one -a (or --as) is allowed after -p or -g\n"
 194       if defined $as_ref->[1];
 195     $as_ref->[1] = $as;
 196 }
 197 \f
 198 # Locates the files used to back each of the virtual disks,
 199 # and creates temporary disks.
 200 sub find_disks {
 201     for my $disk (values %disks) {
 202         # If there's no assigned file name but the default file exists,
 203         # try to assign a default file name.
 204         if (!defined ($disk->{FILE_NAME})) {
 205             for my $try_fn ($disk->{DEF_FN}, "build/" . $disk->{DEF_FN}) {
 206                 $disk->{FILE_NAME} = $try_fn, last
 207                   if -e $try_fn;
 208             }
 209         }
 210
 211         # If there's no file name, we're done.
 212         next if !defined ($disk->{FILE_NAME});
 213
 214         if ($disk->{FILE_NAME} =~ /^\d+(\.\d+)?|\.\d+$/) {
 215             # Create a temporary disk of approximately the specified
 216             # size in megabytes.
 217             die "OS disk can't be temporary\n" if $disk == $disks{OS};
 218
 219             my ($mb) = $disk->{FILE_NAME};
 220             undef $disk->{FILE_NAME};
 221
 222             my ($cyl_size) = 512 * 16 * 63;
 223             extend_disk ($disk, ceil ($mb * 2) * $cyl_size);
 224         } else {
 225             # The file must exist and have nonzero size.
 226             -e $disk->{FILE_NAME} or die "$disk->{FILE_NAME}: stat: $!\n";
 227             -s _ or die "$disk->{FILE_NAME}: disk has zero size\n";
 228         }
 229     }
 230
 231     # Warn about (potentially) missing disks.
 232     die "Cannot find OS disk\n" if !defined $disks{OS}{FILE_NAME};
 233     if (my ($project) = `pwd` =~ /\b(threads|userprog|vm|filesys)\b/) {
 234         if ((grep ($project eq $_, qw (userprog vm filesys)))
 235             && !defined ($disks{FS}{FILE_NAME})) {
 236             print STDERR "warning: it looks like you're running the $project ";
 237             print STDERR "project, but no file system disk is present\n";
 238         }
 239         if ($project eq 'vm' && !defined $disks{SWAP}{FILE_NAME}) {
 240             print STDERR "warning: it looks like you're running the $project ";
 241             print STDERR "project, but no swap disk is present\n";
 242         }
 243     }
 244 }
 245 \f
 246 # Prepare the scratch disk for gets and puts.
 247 sub prepare_scratch_disk {
 248     # Copy the files to put onto the scratch disk.
 249     put_scratch_file ($_->[0]) foreach @puts;
 250
 251     # Make sure the scratch disk is big enough to get big files.
 252     extend_disk ($disks{SCRATCH}, @gets * 1024 * 1024) if @gets;
 253 }
 254
 255 # Read "get" files from the scratch disk.
 256 sub finish_scratch_disk {
 257     # We need to start reading the scratch disk from the beginning again.
 258     if (@gets) {
 259         close ($disks{SCRATCH}{HANDLE});
 260         undef ($disks{SCRATCH}{HANDLE});
 261     }
 262
 263     # Read each file.
 264     get_scratch_file (defined ($_->[1]) ? $_->[1] : $_->[0]) foreach @gets;
 265 }
 266
 267 # put_scratch_file($file).
 268 #
 269 # Copies $file into the scratch disk.
 270 sub put_scratch_file {
 271     my ($put_file_name) = @_;
 272     my ($disk_handle, $disk_file_name) = open_disk ($disks{SCRATCH});
 273
 274     print "Copying $put_file_name into $disk_file_name...\n";
 275
 276     # Write metadata sector, which consists of a 4-byte signature
 277     # followed by the file size.
 278     stat $put_file_name or die "$put_file_name: stat: $!\n";
 279     my ($size) = -s _;
 280     my ($metadata) = pack ("a4 V x504", "PUT\0", $size);
 281     write_fully ($disk_handle, $disk_file_name, $metadata);
 282
 283     # Copy file data.
 284     my ($put_handle);
 285     sysopen ($put_handle, $put_file_name, O_RDONLY)
 286       or die "$put_file_name: open: $!\n";
 287     copy_file ($put_handle, $put_file_name, $disk_handle, $disk_file_name,
 288                $size);
 289     close ($put_handle);
 290
 291     # Round up disk data to beginning of next sector.
 292     write_fully ($disk_handle, $disk_file_name, "\0" x (512 - $size % 512))
 293       if $size % 512;
 294 }
 295
 296 # get_scratch_file($file).
 297 #
 298 # Copies from the scratch disk to $file.
 299 sub get_scratch_file {
 300     my ($get_file_name) = @_;
 301     my ($disk_handle, $disk_file_name) = open_disk ($disks{SCRATCH});
 302
 303     print "Copying $get_file_name out of $disk_file_name...\n";
 304
 305     # Read metadata sector, which has a 4-byte signature followed by
 306     # the file size.
 307     my ($metadata) = read_fully ($disk_handle, $disk_file_name, 512);
 308     my ($signature, $size) = unpack ("a4 V", $metadata);
 309     die "bad signature reading scratch disk--did Pintos run correctly?\n"
 310       if $signature ne "GET\0";
 311
 312     # Copy file data.
 313     my ($get_handle);
 314     sysopen ($get_handle, $get_file_name, O_WRONLY | O_CREAT | O_EXCL, 0666)
 315       or die "$get_file_name: create: $!\n";
 316     copy_file ($disk_handle, $disk_file_name, $get_handle, $get_file_name,
 317                $size);
 318     close ($get_handle);
 319
 320     # Skip forward in disk up to beginning of next sector.
 321     read_fully ($disk_handle, $disk_file_name, 512 - $size % 512)
 322       if $size % 512;
 323 }
 324 \f
 325 # Prepares the arguments to pass to the Pintos kernel,
 326 # and then write them into Pintos bootloader.
 327 sub prepare_arguments {
 328     my (@args);
 329     push (@args, shift (@kernel_args))
 330       while @kernel_args && $kernel_args[0] =~ /^-/;
 331     push (@args, 'put', defined $_->[1] ? $_->[1] : $_->[0]) foreach @puts;
 332     push (@args, @kernel_args);
 333     push (@args, 'get', $_->[0]) foreach @gets;
 334     write_cmd_line ($disks{OS}, @args);
 335 }
 336
 337 # Writes @args into the Pintos bootloader at the beginning of $disk.
 338 sub write_cmd_line {
 339     my ($disk, @args) = @_;
 340
 341     # Figure out command line to write.
 342     my ($arg_cnt) = pack ("V", scalar (@args));
 343     my ($args) = join ('', map ("$_\0", @args));
 344     die "command line exceeds 128 bytes" if length ($args) > 128;
 345     $args .= "\0" x (128 - length ($args));
 346
 347     # Write command line.
 348     my ($handle, $file_name) = open_disk_copy ($disk);
 349     print "Writing command line to $file_name...\n";
 350     sysseek ($handle, 0x17a, 0) == 0x17a or die "$file_name: seek: $!\n";
 351     syswrite ($handle, "$arg_cnt$args") or die "$file_name: write: $!\n";
 352 }
 353 \f
 354 # Running simulators.
 355
 356 # Runs the selected simulator.
 357 sub run_vm {
 358     if ($sim eq 'bochs') {
 359         run_bochs ();
 360     } elsif ($sim eq 'qemu') {
 361         run_qemu ();
 362     } elsif ($sim eq 'gsx') {
 363         run_gsx ();
 364     } else {
 365         die "unknown simulator `$sim'\n";
 366     }
 367 }
 368
 369 # Runs Bochs.
 370 sub run_bochs {
 371     # Select Bochs binary based on the chosen debugger.
 372     my ($bin) = $debug eq 'monitor' ? 'bochs-dbg' : 'bochs';
 373
 374     # Write bochsrc.txt configuration file.
 375     open (BOCHSRC, ">", "bochsrc.txt") or die "bochsrc.txt: create: $!\n";
 376     print BOCHSRC <<EOF;
 377 romimage: file=\$BXSHARE/BIOS-bochs-latest, address=0xf0000
 378 vgaromimage: file=\$BXSHARE/VGABIOS-lgpl-latest
 379 boot: disk
 380 cpu: ips=1000000
 381 megs: $mem
 382 log: bochsout.txt
 383 panic: action=fatal
 384 EOF
 385     print BOCHSRC "gdbstub: enabled=1\n" if $debug eq 'gdb';
 386     print BOCHSRC "clock: sync=", $realtime ? 'realtime' : 'none',
 387       " time0=0\n";
 388     print_bochs_disk_line ("ata0-master", 0);
 389     print_bochs_disk_line ("ata0-slave", 1);
 390     if (defined ($disks_by_iface[2]{FILE_NAME})
 391         || defined ($disks_by_iface[3]{FILE_NAME})) {
 392         print BOCHSRC "ata1: enabled=1, ioaddr1=0x170, ",
 393           "ioaddr2=0x370, irq=15\n";
 394         print_bochs_disk_line ("ata1-master", 2);
 395         print_bochs_disk_line ("ata1-slave", 3);
 396     }
 397     if ($vga ne 'terminal') {
 398         print BOCHSRC "com1: enabled=1, mode=file, dev=/dev/stdout\n"
 399           if $serial_out;
 400         print BOCHSRC "display_library: nogui\n" if $vga eq 'none';
 401     } else {
 402         print BOCHSRC "display_library: term\n";
 403     }
 404     close (BOCHSRC);
 405
 406     # Compose Bochs command line.
 407     my (@cmd) = ($bin, '-q');
 408     push (@cmd, '-j', $jitter) if defined $jitter;
 409
 410     # Run Bochs.
 411     print join (' ', @cmd), "\n";
 412     my ($exit) = xsystem (@cmd);
 413     if (WIFEXITED ($exit)) {
 414         # Bochs exited normally.
 415         # Ignore the exit code; Bochs normally exits with status 1,
 416         # which is weird.
 417     } elsif (WIFSIGNALED ($exit)) {
 418         die "Bochs died with signal ", WTERMSIG ($exit), "\n";
 419     } else {
 420         die "Bochs died: code $exit\n";
 421     }
 422 }
 423
 424 # print_bochs_disk_line($device, $iface)
 425 #
 426 # If IDE interface $iface has a disk attached, prints a bochsrc.txt
 427 # line for attaching it to $device.
 428 sub print_bochs_disk_line {
 429     my ($device, $iface) = @_;
 430     my ($disk) = $disks_by_iface[$iface];
 431     my ($file) = $disk->{FILE_NAME};
 432     if (defined $file) {
 433         my (%geom) = disk_geometry ($disk);
 434         print BOCHSRC "$device: type=disk, path=$file, mode=flat, ";
 435         print BOCHSRC "cylinders=$geom{C}, heads=$geom{H}, spt=$geom{S}, ";
 436         print BOCHSRC "translation=none\n";
 437     }
 438 }
 439
 440 # Runs qemu.
 441 sub run_qemu {
 442     print "warning: qemu doesn't support --terminal\n"
 443       if $vga eq 'terminal';
 444     print "warning: qemu doesn't support jitter\n"
 445       if defined $jitter;
 446     my (@cmd) = ('qemu');
 447     for my $iface (0...3) {
 448         my ($option) = ('-hda', '-hdb', '-hdc', '-hdd')[$iface];
 449         push (@cmd, $option, $disks_by_iface[$iface]{FILE_NAME})
 450           if defined $disks_by_iface[$iface]{FILE_NAME};
 451     }
 452     push (@cmd, '-m', $mem);
 453     push (@cmd, '-nographic') if $vga eq 'none';
 454     push (@cmd, '-serial', 'stdio') if $serial_out && $vga ne 'none';
 455     push (@cmd, '-S') if $debug eq 'monitor';
 456     push (@cmd, '-s', '-S') if $debug eq 'gdb';
 457     push (@cmd, '-monitor', 'null') if $vga eq 'none' && $debug eq 'none';
 458     run_command (@cmd);
 459 }
 460
 461 # gsx_unsup($flag)
 462 #
 463 # Prints a message that $flag is unsupported by GSX Server.
 464 sub gsx_unsup {
 465     my ($flag) = @_;
 466     print "warning: no support for $flag with VMware GSX Server\n";
 467 }
 468
 469 # Runs VMware GSX Server.
 470 sub run_gsx {
 471     gsx_unsup ("--$debug") if $debug ne 'none';
 472     gsx_unsup ("--no-vga") if $vga eq 'none';
 473     gsx_unsup ("--terminal") if $vga eq 'terminal';
 474     gsx_unsup ("--jitter") if defined $jitter;
 475
 476     unlink ("pintos.out");
 477
 478     open (VMX, ">", "pintos.vmx") or die "pintos.vmx: create: $!\n";
 479     chmod 0777 & ~umask, "pintos.vmx";
 480     print VMX <<EOF;
 481 #! /usr/bin/vmware -G
 482 config.version = 6
 483 guestOS = "linux"
 484 floppy0.present = FALSE
 485 memsize = $mem
 486
 487 serial0.present = TRUE
 488 serial0.fileType = "file"
 489 serial0.fileName = "pintos.out"
 490 EOF
 491
 492     for (my ($i) = 0; $i < 4; $i++) {
 493         my ($disk) = $disks_by_iface[$i];
 494         my ($dsk) = $disk->{FILE_NAME};
 495         next if !defined $dsk;
 496
 497         my ($pln) = $dsk;
 498         $pln =~ s/\.dsk//;
 499         $pln .= ".pln";
 500
 501         my ($device) = "ide" . int ($i / 2) . ":" . ($i % 2);
 502         print VMX <<EOF;
 503
 504 $device.present = TRUE
 505 $device.deviceType = "plainDisk"
 506 $device.fileName = "$pln"
 507 EOF
 508
 509         my (%geom) = disk_geometry ($disk);
 510         open (PLN, ">", $pln) or die "$pln: create: $!\n";
 511         print PLN <<EOF;
 512 DRIVETYPE       ide
 513 #vm|VERSION     2
 514 #vm|TOOLSVERSION        2
 515 CYLINDERS       $geom{C}
 516 HEADS           $geom{H}
 517 SECTORS         $geom{S}
 518 #vm|CAPACITY    $geom{CAPACITY}
 519 ACCESS "$dsk" 0 $geom{CAPACITY}
 520 EOF
 521         close (PLN);
 522     }
 523     close (VMX);
 524
 525     my ($vmx) = getcwd () . "/pintos.vmx";
 526     system ("vmware-cmd -s register $vmx >&/dev/null");
 527     system ("vmware-cmd $vmx stop hard >&/dev/null");
 528     system ("vmware -l -G -x -q $vmx");
 529     system ("vmware-cmd $vmx stop hard >&/dev/null");
 530     system ("vmware-cmd -s unregister $vmx >&/dev/null");
 531 }
 532 \f
 533 # Disk utilities.
 534
 535 # open_disk($disk)
 536 #
 537 # Opens $disk, if it is not already open, and returns its file handle
 538 # and file name.
 539 sub open_disk {
 540     my ($disk) = @_;
 541     if (!defined ($disk->{HANDLE})) {
 542         if ($disk->{FILE_NAME}) {
 543             sysopen ($disk->{HANDLE}, $disk->{FILE_NAME}, O_RDWR)
 544               or die "$disk->{FILE_NAME}: open: $!\n";
 545         } else {
 546             ($disk->{HANDLE}, $disk->{FILE_NAME}) = tempfile (UNLINK => 1,
 547                                                              SUFFIX => '.dsk');
 548         }
 549     }
 550     return ($disk->{HANDLE}, $disk->{FILE_NAME});
 551 }
 552
 553 # open_disk_copy($disk)
 554 #
 555 # Makes a temporary copy of $disk and returns its file handle and file name.
 556 sub open_disk_copy {
 557     my ($disk) = @_;
 558     die if !$disk->{FILE_NAME};
 559
 560     my ($orig_handle, $orig_file_name) = open_disk ($disk);
 561     my ($cp_handle, $cp_file_name) = tempfile (UNLINK => 1, SUFFIX => '.dsk');
 562     copy_file ($orig_handle, $orig_file_name, $cp_handle, $cp_file_name,
 563                -s $orig_handle);
 564     return ($disk->{HANDLE}, $disk->{FILE_NAME}) = ($cp_handle, $cp_file_name);
 565 }
 566
 567 # extend_disk($disk, $size)
 568 #
 569 # Extends $disk, if necessary, so that it is at least $size bytes
 570 # long.
 571 sub extend_disk {
 572     my ($disk, $size) = @_;
 573     my ($handle, $file_name) = open_disk ($disk);
 574     if (-s ($handle) < $size) {
 575         sysseek ($handle, $size - 1, 0) == $size - 1
 576           or die "$file_name: seek: $!\n";
 577         syswrite ($handle, "\0") == 1
 578           or die "$file_name: write: $!\n";
 579     }
 580 }
 581
 582 # disk_geometry($file)
 583 #
 584 # Examines $file and returns a valid IDE disk geometry for it, as a
 585 # hash.
 586 sub disk_geometry {
 587     my ($disk) = @_;
 588     my ($file) = $disk->{FILE_NAME};
 589     my ($size) = -s $file;
 590     die "$file: stat: $!\n" if !defined $size;
 591     die "$file: size not a multiple of 512 bytes\n" if $size % 512;
 592     my ($cyl_size) = 512 * 16 * 63;
 593     my ($cylinders) = ceil ($size / $cyl_size);
 594     extend_disk ($disk, $cylinders * $cyl_size) if $size % $cyl_size;
 595
 596     return (CAPACITY => $size / 512,
 597             C => $cylinders,
 598             H => 16,
 599             S => 63);
 600 }
 601
 602 # copy_file($from_handle, $from_file_name, $to_handle, $to_file_name, $size)
 603 #
 604 # Copies $size bytes from $from_handle to $to_handle.
 605 # $from_file_name and $to_file_name are used in error messages.
 606 sub copy_file {
 607     my ($from_handle, $from_file_name, $to_handle, $to_file_name, $size) = @_;
 608
 609     while ($size > 0) {
 610         my ($chunk_size) = 4096;
 611         $chunk_size = $size if $chunk_size > $size;
 612         $size -= $chunk_size;
 613
 614         my ($data) = read_fully ($from_handle, $from_file_name, $chunk_size);
 615         write_fully ($to_handle, $to_file_name, $data);
 616     }
 617 }
 618
 619 # read_fully($handle, $file_name, $bytes)
 620 #
 621 # Reads exactly $bytes bytes from $handle and returns the data read.
 622 # $file_name is used in error messages.
 623 sub read_fully {
 624     my ($handle, $file_name, $bytes) = @_;
 625     my ($data);
 626     my ($read_bytes) = sysread ($handle, $data, $bytes);
 627     die "$file_name: read: $!\n" if !defined $read_bytes;
 628     die "$file_name: unexpected end of file\n" if $read_bytes != $bytes;
 629     return $data;
 630 }
 631
 632 # write_fully($handle, $file_name, $data)
 633 #
 634 # Write $data to $handle.
 635 # $file_name is used in error messages.
 636 sub write_fully {
 637     my ($handle, $file_name, $data) = @_;
 638     my ($written_bytes) = syswrite ($handle, $data);
 639     die "$file_name: write: $!\n" if !defined $written_bytes;
 640     die "$file_name: short write\n" if $written_bytes != length $data;
 641 }
 642 \f
 643 # Subprocess utilities.
 644
 645 # run_command(@args)
 646 #
 647 # Runs xsystem(@args).
 648 # Also prints the command it's running and checks that it succeeded.
 649 sub run_command {
 650     print join (' ', @_), "\n";
 651     die "command failed\n" if xsystem (@_);
 652 }
 653
 654 # xsystem(@args)
 655 #
 656 # Creates a subprocess via exec(@args) and waits for it to complete.
 657 # Relays common signals to the subprocess.
 658 # If $timeout is set then the subprocess will be killed after that long.
 659 sub xsystem {
 660     my ($pid) = fork;
 661     if (!defined ($pid)) {
 662         # Fork failed.
 663         die "fork: $!\n";
 664     } elsif (!$pid) {
 665         # Running in child process.
 666         exec_setitimer (@_);
 667     } else {
 668         # Running in parent process.
 669         local $SIG{ALRM} = sub { timeout ($pid); };
 670         local $SIG{INT} = sub { relay_signal ($pid, "INT"); };
 671         local $SIG{TERM} = sub { relay_signal ($pid, "TERM"); };
 672         alarm ($timeout * get_load_average () + 1) if defined ($timeout);
 673         waitpid ($pid, 0);
 674         alarm (0);
 675
 676         if (WIFSIGNALED ($?) && WTERMSIG ($?) == SIGVTALRM ()) {
 677             seek (STDOUT, 0, 2);
 678             print "\nTIMEOUT after $timeout seconds of host CPU time\n";
 679             exit 0;
 680         }
 681
 682         return $?;
 683     }
 684 }
 685
 686 # relay_signal($pid, $signal)
 687 #
 688 # Relays $signal to $pid and then reinvokes it for us with the default
 689 # handler.  Also cleans up temporary files.
 690 sub relay_signal {
 691     my ($pid, $signal) = @_;
 692     kill $signal, $pid;
 693     File::Temp::cleanup();
 694     $SIG{$signal} = 'DEFAULT';
 695     kill $signal, getpid ();
 696 }
 697
 698 # timeout($pid)
 699 #
 700 # Interrupts $pid and dies with a timeout error message.
 701 sub timeout {
 702     my ($pid) = @_;
 703     kill "INT", $pid;
 704     waitpid ($pid, 0);
 705     seek (STDOUT, 0, 2);
 706     my ($load_avg) = `uptime` =~ /(load average:.*)$/i;
 707     print "\nTIMEOUT after ", time () - $start_time,
 708       " seconds of wall-clock time";
 709     print  " - $load_avg" if defined $load_avg;
 710     print "\n";
 711     exit 0;
 712 }
 713
 714 # Returns the system load average over the last minute.
 715 # If the load average is less than 1.0 or cannot be determined, returns 1.0.
 716 sub get_load_average {
 717     my ($avg) = `uptime` =~ /load average:\s*([^,]+),/;
 718     return $avg >= 1.0 ? $avg : 1.0;
 719 }
 720
 721 # Calls setitimer to set a timeout, then execs what was passed to us.
 722 sub exec_setitimer {
 723     if (defined $timeout) {
 724         if ($\16 ge 5.8.0) {
 725             eval "
 726               use Time::HiRes qw(setitimer ITIMER_VIRTUAL);
 727               setitimer (ITIMER_VIRTUAL, $timeout, 0);
 728             ";
 729         } else {
 730             { exec ("setitimer-helper", $timeout, @_); };
 731             exit 1 if !$!{ENOENT};
 732             print STDERR "warning: setitimer-helper is not installed, so ",
 733               "CPU time limit will not be enforced\n";
 734         }
 735     }
 736     exec (@_);
 737     exit (1);
 738 }
 739
 740 sub SIGVTALRM {
 741     use Config;
 742     my $i = 0;
 743     foreach my $name (split(' ', $Config{sig_name})) {
 744         return $i if $name eq 'VTALRM';
 745         $i++;
 746     }
 747     return 0;
 748 }