summaryrefslogtreecommitdiffstats
path: root/perl-install
diff options
context:
space:
mode:
authorChmouel Boudjnah <chmouel@mandriva.org>1999-07-01 12:29:54 +0000
committerChmouel Boudjnah <chmouel@mandriva.org>1999-07-01 12:29:54 +0000
commite1729dfdb9c341fe0b9fed7d7b0a80691a547d82 (patch)
treeb72fd8f59af166fe944ebcf114d648ed5644f752 /perl-install
parentb50e655e352e2524fb3fb84b2bb4bc96e6a04cf0 (diff)
downloaddrakx-backup-do-not-use-e1729dfdb9c341fe0b9fed7d7b0a80691a547d82.tar
drakx-backup-do-not-use-e1729dfdb9c341fe0b9fed7d7b0a80691a547d82.tar.gz
drakx-backup-do-not-use-e1729dfdb9c341fe0b9fed7d7b0a80691a547d82.tar.bz2
drakx-backup-do-not-use-e1729dfdb9c341fe0b9fed7d7b0a80691a547d82.tar.xz
drakx-backup-do-not-use-e1729dfdb9c341fe0b9fed7d7b0a80691a547d82.zip
"See_The_Changelog"
Diffstat (limited to 'perl-install')
-rw-r--r--perl-install/Makefile114
-rw-r--r--perl-install/c.pm25
-rw-r--r--perl-install/c/Makefile.PL11
-rwxr-xr-xperl-install/commands15
-rw-r--r--perl-install/commands.pm381
-rw-r--r--perl-install/common.pm84
-rw-r--r--perl-install/detect_devices.pm151
-rw-r--r--perl-install/devices.pm107
-rw-r--r--perl-install/fs.pm245
-rw-r--r--perl-install/fsedit.pm187
-rw-r--r--perl-install/install2.pm469
-rw-r--r--perl-install/install_steps.pm220
-rw-r--r--perl-install/keyboard.pm128
-rw-r--r--perl-install/lang.pm72
-rw-r--r--perl-install/log.pm34
-rw-r--r--perl-install/modules.pm330
-rw-r--r--perl-install/my_gtk.pm261
-rw-r--r--perl-install/partition_table.pm333
-rw-r--r--perl-install/partition_table_raw.pm101
-rw-r--r--perl-install/pkgs.pm211
-rw-r--r--perl-install/resize_fat/Makefile12
-rw-r--r--perl-install/resize_fat/README6
-rw-r--r--perl-install/resize_fat/any.pm82
-rw-r--r--perl-install/resize_fat/boot_sector.pm106
-rw-r--r--perl-install/resize_fat/dir_entry.pm72
-rw-r--r--perl-install/resize_fat/directory.pm78
-rw-r--r--perl-install/resize_fat/fat.pm167
-rw-r--r--perl-install/resize_fat/info_sector.pm36
-rw-r--r--perl-install/resize_fat/io.pm74
-rw-r--r--perl-install/resize_fat/main.pm152
-rw-r--r--perl-install/run_program.pm30
-rw-r--r--perl-install/share/diskdrake.rc39
-rw-r--r--perl-install/swap.pm136
-rw-r--r--perl-install/unused/cdrom.pm41
-rw-r--r--perl-install/unused/dns.pm64
-rw-r--r--perl-install/unused/otherinsmod.pm26
-rw-r--r--perl-install/unused/scsi.pm104
-rwxr-xr-xperl-install/verify_c14
38 files changed, 4718 insertions, 0 deletions
diff --git a/perl-install/Makefile b/perl-install/Makefile
new file mode 100644
index 000000000..68fe70782
--- /dev/null
+++ b/perl-install/Makefile
@@ -0,0 +1,114 @@
+SO_FILES = c/blib/arch/auto/c/c.so
+PMS = *.pm resize_fat/*.pm commands diskdrake
+DEST = /tmp/t
+DESTREP4PMS = $(DEST)/usr/bin/perl-install
+PERL = ./perl
+BINS = /bin/ash /sbin/mke2fs $(PERL)
+
+.PHONY: all tags install clean verify_c
+
+all: $(SO_FILES)
+
+tags:
+ etags -o - $(PMS) | perl2etags > TAGS
+
+clean:
+ test ! -e c/Makefile || $(MAKE) -C c clean
+ find . -name "*~" -name "TAGS" -name "*.old" | xargs rm -f
+
+tar: clean
+ cd .. ; tar cfy perl-install.tar.bz2 --exclude perl-install/perl perl-install
+
+c/c.xs: c/c.xs.pm
+ chmod u+w $@
+ perl $< > $@
+ chmod a-w $@
+
+$(SO_FILES): c/c.xs
+ test -e c/Makefile || (cd c; perl Makefile.PL)
+ $(MAKE) -C c
+
+test_pms: verify_c
+ perl2fcalls -excludec install2.pm
+ (for i in $(PMS); do perl -cw -I. -Ic -Ic/blib/arch $$i || exit 1 ; done)
+
+verify_c:
+ ./verify_c $(PMS)
+
+install_pms: $(SO_FILES)
+ for i in `perl -ne 's/sub (\w+?)_? {.*/$$1/ and print' commands.pm`; do ln -sf commands $(DEST)/usr/bin/$$i; done
+
+ install -d $(DESTREP4PMS)
+ for i in $(PMS); do \
+ dest=$(DESTREP4PMS)/`dirname $$i`; \
+ install -d $$dest; \
+ perl -ne 'print #unless /^use (diagnostics|vars|strict)/' $$i > $(DESTREP4PMS)/$$i; \
+ done
+ @# cp -f $$i $$dest; \
+ cp diskdrake.rc $(DESTREP4PMS)
+ ln -sf perl-install/install2.pm $(DEST)/usr/bin/install2
+ ln -sf perl-install/commands $(DEST)/usr/bin/commands
+ chmod a+x $(DESTREP4PMS)/install2.pm
+ chmod a+x $(DESTREP4PMS)/commands
+
+ cp -af */blib/arch/auto $(DESTREP4PMS)
+ find $(DESTREP4PMS) -name "*.so" | xargs strip
+
+full_tar:
+ cp -af /usr/lib/perl5/site_perl/5.005/i386-linux/Gtk* $(DESTREP4PMS)
+ cp -af /usr/lib/perl5/site_perl/5.005/i386-linux/auto/Gtk $(DESTREP4PMS)/auto
+ find $(DESTREP4PMS) -name "*.so" | xargs strip
+ cd $(DESTREP4PMS)/.. ; tar cfz /tmp/perl-install.tgz perl-install
+
+get_needed_files: $(SO_FILES)
+ export PERL_INSTALL_TEST=1 ; strace -f -e trace=file -o '| grep -v "(No such file or directory)" | sed -e "s/[^\"]*\"//" -e "s/\".*//" | grep "^/" | grep -v -e "^/tmp" -e "^/home" -e "^/proc" -e "^/var" -e "^/dev" -e "^/etc" -e "^/usr/lib/rpm" > /tmp/list ' $(PERL) -d install2.pm < /dev/null
+
+ install -d $(DEST)/bin
+ install -d $(DEST)/usr/bin
+ for i in $(BINS) `grep "\.so" /tmp/list`; do \
+ install -s $$i $(DEST)/usr/bin; \
+ ldd $$i | sed -e 's/.*=> //' -e 's/ .*//' >> /tmp/list; \
+ done
+ for i in `sort /tmp/list | uniq`; do \
+ install -d $(DEST)/`dirname $$i` && \
+ if (echo $$i | grep "\.pm"); then \
+ perl -pe '$$_ eq "__END__" and exit(0);' $$i > $(DEST)/$$i; \
+ else \
+ cp -f $$i $(DEST)/$$i; \
+ fi && \
+ strip $(DEST)/$$i 2>/dev/null || true; \
+ done
+ mv $(DEST)/usr/lib/*.so* $(DEST)/lib
+
+ ln -sf ../usr/bin/sh $(DEST)/bin/sh
+ ln -sf ../usr/bin/tr $(DEST)/bin/tr
+ ln -sf sh $(DEST)/bin/bash
+ ln -sf ash $(DEST)/usr/bin/sh
+
+ echo -e "#!/usr/bin/perl\n\nsymlink '/tmp/rhimage/usr/lib/perl5', '/usr/lib/perl5';\nexec '/bin/sh'" > $(DEST)/usr/bin/runinstall2
+ chmod a+x $(DEST)/usr/bin/runinstall2
+
+as_root:
+ /bin/dd if=/dev/zero of=/tmp/initrd bs=1k count=4000
+ echo y | /sbin/mke2fs /tmp/initrd
+ losetup /dev/loop0 /tmp/initrd
+ mount /dev/loop0 /mnt/initrd
+ chmod a+w /mnt/initrd
+
+full_stage2:
+ rm -rf $(DEST)/[^M]*
+ @#mkdir -p $(DEST)/Mandrake/base
+ @#ln -s .. $(DEST)/Mandrake/instimage
+ $(MAKE) get_needed_files
+ $(MAKE) stage2
+
+stage2:
+ $(MAKE) install_pms
+
+ @#rm -rf /mnt/initrd/*
+ @#cp -a $(DEST)/* /mnt/initrd
+ @#sync
+ @#dd if=/dev/loop0 | gzip -9 > /tmp/t/Mandrake/base/stage2.img
+
+
+# function f() { grep "$*" /usr/include/*.h /usr/include/*/*.h; }
diff --git a/perl-install/c.pm b/perl-install/c.pm
new file mode 100644
index 000000000..d1da19f2d
--- /dev/null
+++ b/perl-install/c.pm
@@ -0,0 +1,25 @@
+package c;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+require DynaLoader;
+
+@ISA = qw(DynaLoader);
+$VERSION = '0.01';
+
+bootstrap c $VERSION;
+
+1;
+
+sub headerGetEntry {
+ my ($h, $q) = @_;
+
+ $q eq 'name' and return headerGetEntry_string($h, RPMTAG_NAME());
+ $q eq 'group' and return headerGetEntry_string($h, RPMTAG_GROUP());
+ $q eq 'version' and return headerGetEntry_string($h, RPMTAG_VERSION());
+ $q eq 'release' and return headerGetEntry_string($h, RPMTAG_RELEASE());
+ $q eq 'arch' and return headerGetEntry_string($h, RPMTAG_ARCH());
+ $q eq 'size' and return headerGetEntry_int($h, RPMTAG_SIZE());
+}
+
diff --git a/perl-install/c/Makefile.PL b/perl-install/c/Makefile.PL
new file mode 100644
index 000000000..bb7eed0d1
--- /dev/null
+++ b/perl-install/c/Makefile.PL
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'c',
+ 'VERSION_FROM' => 'c.pm', # finds $VERSION
+ 'LIBS' => ['-ldb1 -lz'], # e.g., '-lm'
+# 'OBJECT' => 'c.o librpm.a',
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ 'INC' => '-Wall', # e.g., '-I/usr/include/other'
+);
diff --git a/perl-install/commands b/perl-install/commands
new file mode 100755
index 000000000..66574c7dc
--- /dev/null
+++ b/perl-install/commands
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+
+use diagnostics;
+use strict;
+
+use lib qw(/usr/bin/perl-install /home/pixel/perl-install . c c/blib/arch);
+use common qw(:file);
+use commands;
+
+my $progname = basename($0);
+
+# hack as some functions are defined by perl... so chmod -> chmod_
+&{$commands::{$progname} || $commands::{$progname . "_"} || \&err}(@ARGV), exit 0;
+
+sub err { die "$0: unknown program (unimplemented)\n"; }
diff --git a/perl-install/commands.pm b/perl-install/commands.pm
new file mode 100644
index 000000000..8448a9f24
--- /dev/null
+++ b/perl-install/commands.pm
@@ -0,0 +1,381 @@
+package commands;
+
+use diagnostics;
+use strict;
+use vars qw($printable_chars);
+
+use common qw(:common :file :system :constant);
+
+my $BUFFER_SIZE = 1024;
+
+1;
+
+
+sub getopts {
+ my $o = shift;
+ my @r = map { '' } (@_ = split //, $_[0]);
+ while (1) {
+ local $_ = $o->[0];
+ $_ && /^-/ or return @r;
+ for (my $i = 0; $i < @_; $i++) { /$_[$i]/ and $r[$i] = $_[$i]; }
+ shift @$o;
+ }
+ @r;
+}
+
+sub cat { @ARGV = @_; print while <> }
+sub which { ARG: foreach (@_) { foreach my $c (split /:/, $ENV{PATH}) { -x "$c/$_" and print("$c/$_\n"), next ARG; }}}
+sub dirname_ { print dirname(@_), "\n" }
+sub basename_ { print basename(@_), "\n" }
+sub rmdir_ { foreach (@_) { rmdir $_ or die "rmdir: can't remove $_\n" } }
+sub lsmod { print "Module Size Used by\n"; cat("/proc/modules"); }
+
+sub grep_ {
+ my ($h, $v) = getopts(\@_, qw(hv));
+ my $r = shift and !$h or die "usage: grep <regexp> [files...]\n";
+ @ARGV = @_; (/$r/ ? $v || print : $v && print) while <>
+}
+
+sub tr_ {
+ my ($s, $c, $d) = getopts(\@_, qw(s c d));
+ @_ >= 1 + (!$d || $s) or die "usage: tr [-c] [-s [-d]] <set1> <set2> [files...]\n or tr [-c] -d <set1> [files...]\n";
+ my $set1 = shift;
+ my $set2; !$d || $s and $set2 = shift;
+ @ARGV = @_;
+ eval "(tr/$set1/$set2/$s$d$c, print) while <>";
+}
+
+sub mount {
+ @_ or return cat("/proc/mounts");
+ my ($t) = getopts(\@_, qw(t));
+ my $fs = $t ? shift : $_[0] =~ /:/ ? "nfs" : "ext2";
+
+ @_ == 2 or die "usage: mount [-t <fs>] <device> <dir>\n",
+ " (if /dev/ is left off the device name, a temporary node will be created)\n";
+
+ require 'fs.pm';
+ fs::mount(@_, $fs, 0, 1);
+}
+
+sub umount {
+ @_ == 1 or die "umount expects a single argument\n";
+
+ require 'fs.pm';
+ fs::umount($_[0]);
+}
+
+sub mkdir_ {
+ my $rec; $_[0] eq '-p' and $rec = shift;
+
+ my $mkdir; $mkdir = sub {
+ my $root = dirname $_[0];
+ if (-e $root) {
+ -d $root or die "mkdir: error creating directory $_[0]: $root is a file and i won't delete it\n";
+ } else {
+ $rec or die "mkdir: $root does not exist (try option -p)\n";
+ &$mkdir($root);
+ }
+ mkdir $_[0], 0755 or die "mkdir: error creating directory $_: $!\n";
+ };
+ foreach (@_) { &$mkdir($_); }
+}
+
+
+sub mknod {
+ if (@_ == 1) {
+ require 'devices.pm';
+ eval { devices::make($_[0]) }; $@ and die "mknod: failed to create $_[0]\n";
+ } elsif (@_ == 4) {
+ require 'c.pm';
+ my $mode = $ {{"b" => c::S_IFBLK(), "c" => c::S_IFCHR()}}{$_[1]} or die "unknown node type $_[1]\n";
+ syscall_('mknod', my $a = $_[0], $mode | 0600, makedev($_[2], $_[3])) or die "mknod failed: $!\n";
+ } else { die "usage: mknod <path> [b|c] <major> <minor> or mknod <path>\n"; }
+}
+
+sub ln {
+ my ($force, $soft, $i);
+
+ while ($i = shift) {
+ if ($i eq '-f') { $force = 1; }
+ elsif ($i eq '-s') { $soft = 1; }
+ elsif ($i eq '-fs' || $i eq '-sf') { $force = $soft = 1; }
+ else { last }
+ }
+
+ my $source = $i or die "usage: ln [-s] [-f] <source> [<dest>]\n";
+ my $dest = shift || basename($source);
+
+ $force and unlink $dest;
+
+
+ ($soft ? symlink($source, $dest) : link($source, $dest)) or die "ln failed: $!\n";
+}
+
+sub rm {
+ my $rec; $_[0] eq '-r' and $rec = shift;
+
+ my $rm; $rm = sub {
+ foreach (@_) {
+ if (-d $_) {
+ $rec or die "$_ is a directory\n";
+ &$rm(glob_($_));
+ rmdir $_ or die "can't remove directory $_: $!\n";
+ } else { unlink $_ or die "rm of $_ failed: $!\n" }
+ }
+ };
+ &$rm(@_);
+}
+
+sub chmod_ {
+ @_ >= 2 or die "usage: chmod <mode> <files>\n";
+
+ my $mode = shift;
+ $mode =~ /^[0-7]+$/ or die "illegal mode $mode\n";
+
+ foreach (@_) { chmod oct($mode), $_ or die "chmod failed $_: $!\n" }
+}
+
+sub chown_ {
+ my $rec; $_[0] eq '-r' and $rec = shift;
+ local $_ = shift or die "usage: chown [-r] name[.group] <files>\n";
+
+ my ($name, $group) = (split('\.'), $_);
+
+ my ($uid, $gid) = (getpwnam($name) || $name, getgrnam($group) || $group);
+
+ my $chown; $chown = sub {
+ foreach (@_) {
+ chown $uid, $gid, $_ or die "chown of file $_ failed: $!\n";
+ -d $_ && $rec and &$chown(glob_($_));
+ }
+ };
+ &$chown(@_);
+}
+
+sub mkswap {
+ @_ == 1 or die "mkswap <device>\n";
+
+ require 'swap.pm';
+ swap::enable($_[0], 0);
+}
+
+sub swapon {
+ @_ == 1 or die "swapon <file>\n";
+
+ require 'swap.pm';
+ swap::swapon($_[0]);
+}
+sub swapoff {
+ @_ == 1 or die "swapoff <file>\n";
+ require 'swap.pm';
+ swap::swapoff($_[0]);
+}
+
+sub uncpio {
+ @_ and die "uncpio reads from stdin\n";
+
+# cpioInstallArchive(gzdopen(0, "r"), NULL, 0, NULL, NULL, &fail);
+}
+
+
+sub rights {
+ my $r = '-' x 9;
+ my @rights = (qw(x w r x w r x w r), ['t', 0], ['s', 3], ['s', 6]);
+ for (my $i = 0; $i < @rights; $i++) {
+ if (vec(pack("S", $_[0]), $i, 1)) {
+ my ($val, $place) = $i >= 9 ? @{$rights[$i]} : ($rights[$i], $i);
+ my $old = \substr($r, 8 - $place, 1);
+ $$old = ($$old eq '-' && $i >= 9) ? uc $val : $val;
+ }
+ }
+ my @types = split //, "_pc_d_b_-_l_s";
+ $types[$_[0] >> 12 & 0xf] . $r;
+}
+
+sub ls {
+ my ($l , $h) = getopts(\@_, qw(lh));
+ $h and die "usage: ls [-l] <files...>\n";
+
+ @_ or @_ = '.';
+ @_ == 1 && -d $_[0] and @_ = glob_($_[0]);
+ foreach (sort @_) {
+ if ($l) {
+ my @s = lstat or warn("can't stat file $_\n"), next;
+ formline(
+"@<<<<<<<<< @<<<<<<< @<<<<<<< @>>>>>>>> @>>>>>>>>>>>>>>> @*\n",
+ rights($s[2]), getpwuid $s[4] || $s[4], getgrgid $s[5] || $s[5],
+ $s[6] ? join ", ", unmakedev($s[6]) : $s[7],
+ scalar localtime $s[9], -l $_ ? "$_ -> " . readlink $_ : $_);
+ print $^A; $^A = '';
+ } else { print "$_\n"; }
+ }
+}
+
+sub cp {
+ my ($force) = getopts(\@_, qw(f));
+ @_ >= 2 or die "usage: cp [-f] <sources> <dest>\n(this cp does -Rl by default)\n";
+
+ my $cp; $cp = sub {
+ my $dest = pop @_;
+
+ @_ or return;
+ @_ == 1 || -d $dest or die "cp: copying multiple files, but last argument ($dest) is not a directory\n";
+
+ foreach my $src (@_) {
+ my $dest = $dest;
+ -d $dest and $dest .= "/" . basename($src);
+
+ if (-e $dest) {
+ $force ? unlink $dest : die "file $dest already exist\n";
+ }
+
+ if (-d $src) {
+ -d $dest or mkdir $dest, mode($src) or die "mkdir: can't create directory $dest: $!\n";
+ &$cp(glob_($src), $dest);
+ } elsif (-l $src) {
+ symlink((readlink($src) || die "readlink failed: $!"), $dest) or die "symlink: can't create symlink $dest: $!\n";
+ } else {
+ local (*F, *G);
+ open F, $src or die "can't open $src for reading: $!\n";
+ open G, "> $dest" or $force or die "can't create $dest : $!\n";
+ foreach (<F>) { print G $_ }
+ chmod mode($src), $dest;
+ }
+ }
+ };
+ &$cp(@_);
+}
+
+sub ps {
+ @_ and die "usage: ps\n";
+ my ($pid, $cmd);
+
+ local (*STDOUT_TOP, *STDOUT);
+ format STDOUT_TOP =
+ PID CMD
+.
+ format =
+@>>>> @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$pid, $cmd
+.
+
+ foreach $pid (sort {$a <=> $b} grep { /\d+/ } all('/proc')) {
+ (($cmd) = cat_("/proc/$pid/cmdline")) =~ s/\0/ /g;
+ $cmd ||= (split ' ', (cat_("/proc/$pid/stat"))[0])[1];
+ write STDOUT
+ }
+}
+
+
+sub dd {
+ my $u = "usage: dd [-h] [if=<file>] [of=<file>] [bs=<number>] [count=<number>]\n";
+ (getopts(\@_, qw(h)))[0] and die $u;
+ my %h = (if => \*STDIN, of => \*STDOUT, bs => 512, count => undef);
+ foreach (@_) {
+ /(.*?)=(.*)/ && exists $h{$1} or die $u;
+ $h{$1} = $2;
+ }
+ local (*IF, *OF); my ($tmp, $nb, $read);
+ ref $h{if} eq 'GLOB' ? *IF = $h{if} : sysopen(IF, $h{if}, 0 ) || die "error: can't open file $h{if}\n";
+ ref $h{of} eq 'GLOB' ? *OF = $h{of} : sysopen(OF, $h{of}, 0x41) || die "error: can't open file $h{of}\n";
+
+ $h{bs} =~ /(\d+)k$/ and $h{bs} = $1 * 1024;
+ $h{bs} =~ /(\d+)M$/ and $h{bs} = $1 * 1024 * 1024;
+ $h{bs} =~ /(\d+)G$/ and $h{bs} = $1 * 1024 * 1024 * 1024;
+
+ for ($nb = 0; !$h{count} || $nb < $h{count}; $nb++) {
+ $read = sysread(IF, $tmp, $h{bs}) or $h{count} ? die "error: can't read block $nb\n" : last;
+ syswrite(OF, $tmp) or die "error: can't write block $nb\n";
+ $read < $h{bs} and $read = 1, last;
+ }
+ print STDERR "$nb+$read records in\n";
+ print STDERR "$nb+$read records out\n";
+}
+
+sub head_tail {
+ my ($h, $n) = getopts(\@_, qw(hn));
+ $h || @_ > 1 + bool($n) and die "usage: $0 [-h] [-n lines] [<file>]\n";
+ $n = $n ? shift : 10;
+ local *F; @_ ? open(F, $_[0]) || die "error: can't open file $_[0]\n" : (*F = \*STDIN);
+
+ if ($0 eq 'head') {
+ foreach (<F>) { $n-- or return; print }
+ } else {
+ @_ = (); foreach (<F>) { push @_, $_; @_ > $n and shift; }
+ print @_;
+ }
+}
+sub head { $0 = 'head'; &head_tail }
+sub tail { $0 = 'tail'; &head_tail }
+
+sub strings {
+ my ($h, $o, $n) = getopts(\@_, qw(hon));
+ $h and die "usage: strings [-o] [-n min-length] [<files>]\n";
+ $n = $n ? shift : 4;
+ $/ = "\0"; @ARGV = @_; my $l = 0; while (<>) {
+ while (/[$printable_chars]\{$n,}/og) {
+ printf "%07d ", ($l + length $') if $o;
+ print "$&\n" ;
+ }
+ $l += length;
+ } continue { $l = 0 if eof }
+}
+
+sub hexdump {
+ my $i = 0; $/ = \16; @ARGV = @_; while (<>) {
+ printf "%08lX ", $i; $i += 16;
+ print join(" ", map({ sprintf "%02X", $_ } unpack("C*", $_)),
+ ($_ =~ s/[^$printable_chars]/./og, $_)[1]), "\n";
+ }
+}
+
+sub more {
+ @ARGV = @_;
+ require 'devices.pm';
+ my $tty = devices::make('tty');
+ local *IN; open IN, "<$tty" or die "can't open $tty\n";
+ my $n = 0; while (<>) {
+ ++$n == 25 and $n = <IN>, $n = 0;
+ print
+ }
+}
+
+sub pack_ {
+ my $t;
+ foreach (@_) {
+ if (-d $_) {
+ pack_(glob_($_));
+ } else {
+ print -s $_, "\n";
+ print $_, "\n";
+
+ local *F;
+ open F, $_ or die "can't read file $_: $!\n";
+ while (read F, $t, $BUFFER_SIZE) { print $t; }
+ }
+ }
+}
+
+sub unpack_ {
+ my $t;
+ @_ == 1 or die "give me one and only one file to unpack\n";
+ local *F;
+ open F, $_[0] or die "can't open file $_: $!\n";
+ while (1) {
+ my ($size) = chop_(scalar <F>);
+ defined $size or last;
+ $size =~ /^\d+$/ or die "bad format (can't find file size)\n";
+ my ($filename) = chop_(scalar <F>) or die "expecting filename\n";
+
+ print "$filename\n";
+ my $dir = dirname($filename);
+ -d $dir or mkdir_('-p', $dir);
+
+ local *G;
+ open G, "> $filename" or die "can't write file $filename: $!\n";
+ while ($size) {
+ $size -= read(F, $t, min($size, $BUFFER_SIZE)) || die "data for file $filename is missing\n";
+ print G $t or die "error writing to file $filename: $!\n";
+ }
+ }
+}
diff --git a/perl-install/common.pm b/perl-install/common.pm
new file mode 100644
index 000000000..6c12961ef
--- /dev/null
+++ b/perl-install/common.pm
@@ -0,0 +1,84 @@
+package common;
+
+use diagnostics;
+use strict;
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $printable_chars $sizeof_int $bitof_int $error $cancel $SECTORSIZE);
+
+@ISA = qw(Exporter);
+%EXPORT_TAGS = (
+ common => [ qw(min max bool member divide error cancel is_empty_array_ref round_up round_down first top) ],
+ file => [ qw(dirname basename all glob_ cat_ chop_ mode) ],
+ system => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ crypt_) ],
+ constant => [ qw($printable_chars $sizeof_int $bitof_int $SECTORSIZE) ],
+);
+@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+
+$printable_chars = "\x20-\x7E";
+$sizeof_int = psizeof("i");
+$bitof_int = $sizeof_int * 8;
+$error = 0;
+$cancel = 0;
+$SECTORSIZE = 512;
+
+1;
+
+sub min { my $min = shift; grep { $_ < $min and $min = $_; } @_; $min }
+sub max { my $max = shift; grep { $_ > $max and $max = $_; } @_; $max }
+sub first { $_[0] }
+sub top { $_[$#_] }
+sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 }
+sub dirname { @_ == 1 or die "usage: dirname <name>\n"; local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' }
+sub basename { @_ == 1 or die "usage: basename <name>\n"; local $_ = shift; s|/*\s*$||; s|.*/||; $_ }
+sub error { $error = 1; 0 }
+sub cancel { $cancel = 1; 0 }
+sub bool { $_[0] ? 1 : 0 }
+sub strcpy { substr($_[0], $_[2] || 0, length $_[1]) = $_[1] }
+sub cat_ { local *F; open F, $_[0] or $_[1] ? die "cat of file $_[0] failed: $!\n" : return; my @l = <F>; @l }
+sub chop_ { map { my $l = $_; chomp $l; $l } @_ }
+sub divide { my $d = int $_[0] / $_[1]; wantarray ? ($d, $_[0] % $_[1]) : $d }
+sub round_up { my ($i, $r) = @_; $i += $r - ($i + $r - 1) % $r - 1; }
+sub round_down { my ($i, $r) = @_; $i -= $i % $r; }
+sub is_empty_array_ref { my $a = shift; !defined $a || @$a == 0 }
+
+sub sync { syscall_('sync') }
+sub gettimeofday { my $t = pack "LL"; syscall_('gettimeofday', $t, 0) or die "gettimeofday: $!\n"; unpack("LL", $t) }
+
+sub remove_spaces { local $_ = shift; s/^ +//; s/ +$//; $_ }
+sub mode { my @l = stat $_[0] or die "unable to get mode of file $_[0]: $!\n"; $l[2] }
+sub psizeof { length pack $_[0] }
+
+sub all {
+ my $d = shift;
+
+ local *F;
+ opendir F, $d or die "all: can't opendir $d: $!\n";
+ grep { $_ ne '.' && $_ ne '..' } readdir F;
+}
+
+sub glob_ {
+ my ($d, $f) = ($_[0] =~ /\*/) ? (dirname($_[0]), basename($_[0])) : ($_[0], '*');
+
+ $d =~ /\*/ and die "glob_: wildcard in directory not handled ($_[0])\n";
+ ($f = quotemeta $f) =~ s/\\\*/.*/g;
+
+ $d =~ m|/$| or $d .= '/';
+ map { $d eq './' ? $_ : "$d$_" } grep { /$f/ } all($d);
+}
+
+
+sub syscall_ {
+ my $f = shift;
+
+ require 'syscall.ph';
+ syscall(&{$common::{"SYS_$f"}}, @_) == 0;
+}
+
+
+sub crypt_ {
+ local $_ = (gettimeofday())[1] % 0x40;
+ tr [\0-\x3f] [0-9a-zA-Z./];
+ crypt($_[0], $_)
+}
+
+sub makedev { ($_[0] << 8) | $_[1] }
+sub unmakedev { $_[0] >> 8, $_[0] & 0xff }
diff --git a/perl-install/detect_devices.pm b/perl-install/detect_devices.pm
new file mode 100644
index 000000000..8f1fac97d
--- /dev/null
+++ b/perl-install/detect_devices.pm
@@ -0,0 +1,151 @@
+package detect_devices;
+
+use diagnostics;
+use strict;
+
+use log;
+use common qw(:common :file);
+use c;
+
+
+my $scsiDeviceAvailable;
+my $CSADeviceAvailable;
+
+1;
+
+sub get {
+ # Detect the default BIOS boot harddrive is kind of tricky. We may have IDE,
+ # SCSI and RAID devices on the same machine. From what I see so far, the default
+ # BIOS boot harddrive will be
+ # 1. The first IDE device if IDE exists. Or
+ # 2. The first SCSI device if SCSI exists. Or
+ # 3. The first RAID device if RAID exists.
+
+ map { &{$_->[0]}() ? &{$_->[1]}() : () }
+ [ \&hasIDE, \&getIDE ],
+ [ \&hasSCSI, \&getSCSI ],
+ [ \&hasDAC960, \&getDAC960 ],
+ [ \&hasCompaqSmartArray, \&getCompaqSmartArray ];
+}
+sub hds() { grep { $_->{type} eq 'hd' } get(); }
+sub cdroms() { grep { $_->{type} eq 'cdrom' } get(); }
+
+sub hasSCSI() {
+ defined $scsiDeviceAvailable and return $scsiDeviceAvailable;
+ local *F;
+ open F, "/proc/scsi/scsi" or log::l("failed to open /proc/scsi/scsi: $!"), return 0;
+ foreach (<F>) {
+ /devices: none/ and log::l("no scsi devices are available"), return $scsiDeviceAvailable = 0;
+ }
+ log::l("scsi devices are available");
+ $scsiDeviceAvailable = 1;
+}
+sub hasIDE() { 1 }
+sub hasDAC960() { 1 }
+
+sub hasCompaqSmartArray() {
+ defined $CSADeviceAvailable and return $CSADeviceAvailable;
+ -r "/proc/array/ida0" or log::l("failed to open /proc/array/ida0: $!"), return $CSADeviceAvailable = 0;
+ log::l("Compaq Smart Array controllers available");
+ $CSADeviceAvailable = 1;
+}
+
+sub getSCSI() {
+ my @drives;
+ my ($driveNum, $cdromNum, $tapeNum) = qw(0 0 0);
+ my $err = sub { chop; log::l("unexpected line in /proc/scsi/scsi: $_"); error() };
+ local $_;
+
+ local *F;
+ open F, "/proc/scsi/scsi" or return &$err();
+ $_ = <F>; /^Attached devices:/ or return &$err();
+ while ($_ = <F>) {
+ my ($id) = /^Host:.*?Id: (\d+)/ or return &$err();
+ $_ = <F>; my ($vendor, $model) = /^\s*Vendor:\s*(.*?)\s+Model:\s*(.*?)\s+Rev:/ or return &$err();
+ $_ = <F>; my ($type) = /^\s*Type:\s*(.*)/ or &$err();
+ my $device;
+ if ($type =~ /Direct-Access/) {
+ $type = 'hd';
+ $device = "sd" . chr($driveNum++ + ord('a'));
+ } elsif ($type =~ /Sequential-Access/) {
+ $type = 'tape';
+ $device = "st" . $tapeNum++;
+ } elsif ($type =~ /CD-ROM/) {
+ $type = 'cdrom';
+ $device = "scd" . $cdromNum++;
+ }
+ $device and push @drives, { device => $device, type => $type, info => "$vendor $model", id => $id, bus => 0 };
+ }
+ @drives;
+}
+
+sub getIDE() {
+ my @idi;
+
+ -r "/proc/ide" or die "sorry, /proc/ide not available, seems like you have a pre-2.2 kernel\n => not handled yet :(";
+
+ # Great. 2.2 kernel, things are much easier and less error prone.
+ foreach my $d (glob_('/proc/ide/hd*')) {
+ my ($t) = chop_(cat_("$d/media"));
+ my $type = $ {{disk => 'hd', cdrom => 'cdrom', tape => 'tape', floppy => 'fd'}}{$t} or next;
+ my ($info) = chop_(cat_("$d/model")); $info ||= "(none)";
+
+ my $num = ord (($d =~ /(.)$/)[0]) - ord 'a';
+ push @idi, { type => $type, device => basename($d), info => $info, bus => $num/2, id => $num%2 };
+ }
+ @idi;
+}
+
+
+sub getCompaqSmartArray() {
+ my @idi;
+ my $f;
+
+ for (my $i = 0; -r ($f = "/proc/array/ida$i"); $i++) {
+ local *F;
+ open F, $f or die;
+ local $_ = <F>;
+ my ($name) = m|ida/(.*?):| or next;
+ push @idi, { device => $name, info => "Compaq RAID logical disk", type => 'hd' };
+ }
+ @idi;
+}
+
+sub getDAC960() {
+ my @idi;
+ my $file = "/var/log/dmesg";
+ -r $file or $file = "/tmp/syslog";
+
+ local *F;
+ open F, $file or die "Failed to open $file: $!";
+
+ # We are looking for lines of this format:DAC960#0:
+ # /dev/rd/c0d0: RAID-7, Online, 17928192 blocks, Write Thru0123456790123456789012
+ foreach (<F>) {
+ my ($devicename, $info) = m|/dev/rd/(.*?): (.*?),| or next;
+ push @idi, { info => $info, type => 'hd', devicename => $devicename };
+ log::l("DAC960: $devicename: $info");
+ }
+ @idi;
+}
+
+
+sub getNet() {
+ # I should probably ask which device to use if multiple ones are available -- oh well :-(
+ foreach (qw(eth0 tr0 plip0 plip1 plip2 fddi0)) {
+ hasNetDevice($_) and log::l("$_ is available -- using it for networking"), return $_;
+ }
+ undef;
+}
+sub getPlip() {
+ foreach (0..2) {
+ hasNetDevice("plip$_") and log::l("plip$_ will be used for PLIP"), return "plip$_";
+ }
+ undef;
+}
+
+sub hasNet() { goto &getNet }
+sub hasPlip() { goto &getPlip }
+sub hasEthernet() { hasNetDevice("eth0"); }
+sub hasTokenRing() { hasNetDevice("tr0"); }
+sub hasNetDevice($) { c::hasNetDevice($_[0]) }
diff --git a/perl-install/devices.pm b/perl-install/devices.pm
new file mode 100644
index 000000000..704b3d40d
--- /dev/null
+++ b/perl-install/devices.pm
@@ -0,0 +1,107 @@
+package devices;
+
+use diagnostics;
+use strict;
+
+use common qw(:system :file);
+use run_program;
+use log;
+use c;
+
+1;
+
+
+sub size($) {
+ local *F;
+ sysopen F, $_[0], 0 or log::l("open $_[0]: $!"), return 0;
+
+ my $valid_offset = sub { sysseek(F, $_[0], 0) && sysread(F, my $a, 1) };
+
+ # first try getting the size nicely
+ my $size = 0;
+ ioctl(F, c::BLKGETSIZE(), $size) and return unpack("i", $size) * $common::SECTORSIZE;
+
+ # sad it didn't work, well searching the size using the dichotomy algorithm!
+ my $low = 0;
+ my ($high, $mid);
+
+ # first find n where 2^n < size <= 2^n+1
+ for ($high = 1; $high > 0 && &$valid_offset($high); $high *= 2) { $low = $high; }
+
+ while ($low < $high - 1) {
+ $mid = int ($low + $high) / 2;
+ &$valid_offset($mid) ? $low : $high = $mid;
+ }
+ $low + 1;
+}
+
+sub make($) {
+ local $_ = my $file = $_[0];
+ my ($type, $major, $minor);
+
+ unless (s,^/(dev|tmp)/,,) {
+ $file = -e "/dev/$file" ? "/dev/$file" : "/tmp/$file";
+ }
+
+ -e $file and return $file; # assume nobody takes fun at creating files named as device
+
+ if (/^sd(.)(\d\d)/) {
+ $type = c::S_IFBLK();
+ $major = 8;
+ $minor = ord($1) - ord('a') + $2;
+ } elsif (/^hd(.)(\d{0,2})/) {
+ $type = c::S_IFBLK();
+ ($major, $minor) =
+ @{ $ {{'a' => [3, 0], 'b' => [3, 64],
+ 'c' => [22,0], 'd' => [22,64],
+ 'e' => [33,0], 'f' => [33,64],
+ 'g' => [34,0], 'h' => [34,64],
+ }}{$1} or die "unknown device $_" };
+ $minor += $2 || 0;
+ } elsif (/^ram(.)/) {
+ $type = c::S_IFBLK();
+ $major = 1;
+ $minor = $1 eq '' ? 1 : $1;
+ } elsif (m|^rd/c(\d+)d(\d+)(p(\d+))?|) {
+ # dac 960 "/rd/cXdXXpX"
+ $type = c::S_IFBLK();
+ $major = 48 + $1;
+ $minor = 8 * $2 + $4;
+ } elsif (m|ida/c(\d+)d(\d+)(p(\d+))|) {
+ # Compaq Smart Array "ida/c0d0{p1}"
+ $type = c::S_IFBLK();
+ $major = 72 + $1;
+ $minor = 16 * $2 + $4;
+ } else {
+ ($type, $major, $minor) =
+ @{ $ {{"aztcd" => [ c::S_IFBLK(), 29, 0 ],
+ "bpcd" => [ c::S_IFBLK(), 41, 0 ],
+ "cdu31a" => [ c::S_IFBLK(), 15, 0 ],
+ "cdu535" => [ c::S_IFBLK(), 24, 0 ],
+ "cm206cd" => [ c::S_IFBLK(), 32, 0 ],
+ "tty" => [ c::S_IFCHR(), 5, 0 ],
+ "fd0" => [ c::S_IFBLK(), 2, 0 ],
+ "fd1" => [ c::S_IFBLK(), 2, 1 ],
+ "gscd" => [ c::S_IFBLK(), 16, 0 ],
+ "lp0" => [ c::S_IFCHR(), 6, 0 ],
+ "lp1" => [ c::S_IFCHR(), 6, 1 ],
+ "lp2" => [ c::S_IFCHR(), 6, 2 ],
+ "mcd" => [ c::S_IFBLK(), 23, 0 ],
+ "mcdx" => [ c::S_IFBLK(), 20, 0 ],
+ "nst0" => [ c::S_IFCHR(), 9, 128 ],
+ "optcd" => [ c::S_IFBLK(), 17, 0 ],
+ "sbpcd" => [ c::S_IFBLK(), 25, 0 ],
+ "scd0" => [ c::S_IFBLK(), 11, 0 ],
+ "scd1" => [ c::S_IFBLK(), 11, 1 ],
+ "sjcd" => [ c::S_IFBLK(), 18, 0 ],
+ }}{$_} or die "unknown device $type" };
+ }
+
+ # make a directory for this inode if needed.
+ mkdir dirname($file), 0755;
+
+ syscall_('mknod', $file, $type | 0600, makedev($major, $minor)) or die "mknod failed (dev:$_): $!";
+
+ $file;
+}
+
diff --git a/perl-install/fs.pm b/perl-install/fs.pm
new file mode 100644
index 000000000..cf29fe014
--- /dev/null
+++ b/perl-install/fs.pm
@@ -0,0 +1,245 @@
+package fs;
+
+use diagnostics;
+use strict;
+
+use common qw(:common :file :system);
+use log;
+use devices;
+use partition_table qw(:types);
+use run_program;
+use nfs;
+use swap;
+use detect_devices;
+use commands;
+
+1;
+
+
+sub read_fstab($) {
+ my ($file) = @_;
+
+ local *F;
+ open F, $file or return;
+
+ map {
+ my ($dev, $mntpoint, @l) = split ' ';
+ $dev =~ s,/(tmp|dev)/,,;
+ while (@l > 4) { $mntpoint .= " " . shift @l; }
+ { device => $dev, mntpoint => $mntpoint, type => $l[0], options => $l[1] }
+ } <F>;
+}
+
+sub check_mounted($) {
+ my ($fstab) = @_;
+
+ local (*F, *G, *H);
+ open F, "/etc/mtab";
+ open G, "/proc/mounts";
+ open H, "/proc/swaps";
+ foreach (<F>, <G>, <H>) {
+ foreach my $p (@$fstab) {
+ /$p->{device}\s/ and $p->{isMounted} = 1;
+ }
+ }
+}
+
+sub get_mntpoints_from_fstab($) {
+ my ($fstab) = @_;
+
+ foreach (read_fstab('/etc/fstab')) {
+ foreach my $p (@$fstab) {
+ $p->{device} eq $_->{device} or next;
+ $p->{mntpoint} ||= $_->{mntpoint};
+ $p->{options} ||= $_->{options};
+ $_->{type} ne 'auto' && $_->{type} ne type2fs($p->{type}) and
+ log::l("err, fstab and partition table do not agree for $_->{device} type: " . (type2fs($p->{type}) || type2name($p->{type})) . " vs $_->{type}");
+ }
+ }
+}
+
+sub format_ext2($;$) {
+ my ($dev, $bad_blocks) = @_;
+ my @options;
+
+ $dev =~ m,(rd|ida)/, and push @options, qw(-b 4096 -R stride=16); # For RAID only.
+ $bad_blocks and push @options, "-c";
+
+ run_program::run("mke2fs", devices::make($dev), @options) or die "ext2 formatting of $dev failed";
+}
+
+sub format_dos($;$) {
+ my ($dev, $bad_blocks) = @_;
+
+ run_program::run("mkdosfs", devices::make($dev), $bad_blocks ? "-c" : ()) or die "dos formatting of $dev failed";
+}
+
+sub format_part($;$) {
+ my ($part, $bad_blocks) = @_;
+
+ $part->{isFormatted} and return;
+
+ if (isExt2($part)) {
+ format_ext2($part->{device}, $bad_blocks);
+ } elsif (isDos($part)) {
+ format_dos($part->{device}, $bad_blocks);
+ } elsif (isSwap($part)) {
+ swap::make($part->{device}, $bad_blocks);
+ } else {
+ die "don't know how to format $_->{device} in type " . type2name($_->{type});
+ }
+ $part->{isFormatted} = 1;
+}
+
+sub mount($$$;$) {
+ my ($dev, $where, $fs, $rdonly) = @_;
+ log::l("mounting $dev on $where as type $fs");
+
+ $::testing and return;
+
+ -d $where or commands::mkdir_('-p', $where);
+
+ if ($fs eq 'nfs') {
+ log::l("calling nfs::mount($dev, $where)");
+ nfs::mount($dev, $where) or die "nfs mount failed";
+ } elsif ($fs eq 'smb') {
+ die "no smb yet...";
+ }
+ $dev = devices::make($dev);
+
+ my $flag = 0;#c::MS_MGC_VAL();
+ $flag |= c::MS_RDONLY() if $rdonly;
+ my $mount_opt = $fs eq 'vfat' ? "check=relaxed" : "";
+
+ log::l("calling mount($dev, $where, $fs, $flag, $mount_opt)");
+ syscall_('mount', $dev, $where, $fs, $flag, $mount_opt) or die "mount failed: $!";
+
+ local *F;
+ open F, ">>/etc/mtab" or return; # fail silently, must be read-only /etc
+ print F "$dev $where $fs defaults 0 0\n";
+}
+
+# takes the mount point to umount (can also be the device)
+sub umount($) {
+ my ($mntpoint) = @_;
+ syscall_('umount', $mntpoint) or die "error unmounting $mntpoint: $!";;
+
+ my @mtab = cat_('/etc/mtab'); # don't care about error, if we can't read, we won't manage to write... (and mess mtab)
+ local *F;
+ open F, ">/etc/mtab" or return;
+ foreach (@mtab) { print F $_ unless /(^|\s)$mntpoint\s/; }
+}
+
+sub mount_part($;$) {
+ my ($part, $prefix) = @_;
+
+ $part->{isMounted} and return;
+ $part->{mntpoint} or die "missing mount point";
+
+ isSwap($part) ?
+ swap::swapon($part->{device}) :
+ mount(devices::make($part->{device}), ($prefix || '') . $part->{mntpoint}, type2fs($part->{type}), 0);
+ $part->{isMounted} = 1;
+}
+
+sub umount_part($;$) {
+ my ($part, $prefix) = @_;
+
+ $part->{isMounted} or return;
+
+ isSwap($part) ?
+ swap::swapoff($part->{device}) :
+ umount(($prefix || '') . ($part->{mntpoint} || "/dev/$part->{device}"));
+ $part->{isMounted} = 0;
+}
+
+sub mount_all($;$) {
+ my ($fstab, $prefix) = @_;
+
+ log::l("mounting all filesystems");
+
+ # order mount by alphabetical ordre, that way / < /home < /home/httpd...
+ foreach (sort { $a->{mntpoint} cmp $b->{mntpoint} } @$fstab) {
+ $_->{mntpoint} and mount_part($_, $prefix);
+ }
+}
+
+sub umount_all($;$) {
+ my ($fstab, $prefix) = @_;
+
+ log::l("unmounting all filesystems");
+
+ foreach (sort { $b->{mntpoint} cmp $a->{mntpoint} } @$fstab) {
+ $_->{mntpoint} and umount_part($_, $prefix);
+ }
+}
+
+# do some stuff before calling write_fstab
+sub write($$) {
+ my ($prefix, $fstab) = @_;
+ my @cd_drives = detect_devices::cdroms();
+
+ log::l("scanning /proc/mounts for iso9660 filesystems");
+ unshift @cd_drives, grep { $_->{type} eq 'iso9660' } read_fstab("/proc/mounts");
+ log::l("found cdrom drive(s) " . join(', ', map { $_->{device} } @cd_drives));
+
+ # cd-rom rooted installs have the cdrom mounted on /dev/root which
+ # is not what we want to symlink to /dev/cdrom.
+ my $cddev = first(grep { $_ ne 'root' } map { $_->{device} } @cd_drives);
+
+ $::testing and return 1;
+
+ log::l("resetting /etc/mtab");
+ local *F;
+ open F, "> $prefix/etc/mtab" or die "error resetting $prefix/etc/mtab";
+
+ if ($cddev) {
+ mkdir "$prefix/mnt/cdrom", 0755 or log::l("failed to mkdir $prefix/mnt/cdrom: $!");
+ symlink $cddev, "$prefix/dev/cdrom" or log::l("failed to symlink $prefix/dev/cdrom: $!");
+ }
+ write_fstab($fstab, $prefix, $cddev);
+}
+
+
+sub write_fstab($;$$) {
+ my ($fstab, $prefix, $cddev) = @_;
+ $prefix ||= '';
+
+ my @to_add =
+ map {
+ my ($dir, $options, $freq, $passno) = qw(/dev/ defaults 0 0);
+ $options ||= $_->{options};
+
+ isExt2($_) and ($freq, $passno) = (1, ($_->{mntpoint} eq '/') ? 1 : 2);
+ isNfs($_) and ($dir, $options) = ('', 'ro');
+
+ [ "$dir$_->{device}", $_->{mntpoint}, type2fs($_->{type}), $options, $freq, $passno ];
+
+ } grep { $_->{mntpoint} && type2fs($_->{type}) } @$fstab;
+
+ {
+ push @to_add, [ split ' ', '/dev/fd0 /mnt/floppy auto sync,user,noauto,nosuid,nodev,unhide 0 0' ];
+ push @to_add, [ split ' ', '/dev/cdrom /mnt/cdrom auto user,noauto,nosuid,exec,nodev,ro 0 0' ] if $cddev;
+ push @to_add, [ split ' ', 'none /proc proc defaults 0 0' ];
+ push @to_add, [ split ' ', 'none /dev/pts devpts mode=0620 0 0' ];
+ }
+
+ # get the list of devices and mntpoint
+ my @new = grep { $_ ne 'none' } map { @$_[0,1] } @to_add;
+ my %new; @new{@new} = undef;
+
+ my @current = cat_("$prefix/etc/fstab");
+
+ log::l("writing $prefix/etc/fstab");
+ local *F;
+ open F, "> $prefix/etc/fstab" or die "error writing $prefix/etc/fstab";
+ foreach (@current) {
+ my ($a, $b) = split;
+ # if we find one line of fstab containing either the same device or mntpoint, do not write it
+ exists $new{$a} || exists $new{$b} and next;
+ print F $_;
+ }
+ foreach (@to_add) {
+ print F join(" ", @$_), "\n";
+ }
+}
diff --git a/perl-install/fsedit.pm b/perl-install/fsedit.pm
new file mode 100644
index 000000000..fb2703e8f
--- /dev/null
+++ b/perl-install/fsedit.pm
@@ -0,0 +1,187 @@
+package fsedit;
+
+use diagnostics;
+use strict;
+
+use common qw(:common);
+use partition_table qw(:types);
+use partition_table_raw;
+use devices;
+use log;
+
+1;
+
+my @suggestions = (
+ { mntpoint => "/boot", minsize => 10 << 11, size => 16 << 11, type => 0x83 },
+ { mntpoint => "/", minsize => 50 << 11, size => 100 << 11, type => 0x83 },
+ { mntpoint => "swap", minsize => 30 << 11, size => 60 << 11, type => 0x82 },
+ { mntpoint => "/usr", minsize => 200 << 11, size => 500 << 11, type => 0x83 },
+ { mntpoint => "/home", minsize => 50 << 11, size => 200 << 11, type => 0x83 },
+ { mntpoint => "/var", minsize => 200 << 11, size => 250 << 11, type => 0x83 },
+ { mntpoint => "/tmp", minsize => 50 << 11, size => 100 << 11, type => 0x83 },
+ { mntpoint => "/mnt/iso", minsize => 700 << 11, size => 800 << 11, type => 0x83 },
+);
+
+
+1;
+
+sub hds($$) {
+ my ($drives, $flags) = @_;
+ my @hds;
+ my $rc;
+
+ foreach (@$drives) {
+ my $file = devices::make($_->{device});
+
+ my $hd = partition_table_raw::get_geometry($file) or die "An error occurred while getting the geometry of block device $file: $!";
+ $hd->{file} = $file;
+ $hd->{prefix} = $hd->{device} = $_->{device};
+ # for RAID arrays of format c0d0p1
+ $hd->{prefix} .= "p" if $hd->{prefix} =~ m,(rd|ida)/,;
+
+ eval { $rc = partition_table::read($hd, $flags->{clearall}) };
+ if ($@) {
+ $@ =~ /bad magic number/ or die;
+ $flags->{forcezero} && !$::testing ? partition_table_raw::zero_MBR($hd) : die;
+ }
+ $rc ? push @hds, $hd : log::l("An error occurred reading the partition table for the block device $_->{device}");
+ }
+ [ @hds ];
+}
+
+sub get_fstab(@) {
+ map { partition_table::get_normal_parts($_) } @_;
+}
+
+sub suggest_part($$$;$) {
+ my ($hd, $part, $hds, $suggestions) = @_;
+ $suggestions ||= \@suggestions;
+ foreach (@$suggestions) { $_->{minsize} ||= $_->{size} }
+
+ my $has_swap;
+ my @mntpoints = map { $has_swap ||= isSwap($_); $_->{mntpoint} } get_fstab(@$hds);
+ my %mntpoints; @mntpoints{@mntpoints} = undef;
+
+ my ($best, $second) =
+ grep { $part->{size} >= $_->{minsize} }
+ grep { !exists $mntpoints{$_->{mntpoint}} || isSwap($_) && !$has_swap }
+ @$suggestions or return;
+
+ $best = $second if
+ $best->{mntpoint} eq '/boot' &&
+ $part->{start} + $best->{minsize} > 1024 * partition_table::cylinder_size($hd); # if the empty slot is beyond the 1024th cylinder, no use having /boot
+
+ defined $best or return; # sorry no suggestion :(
+
+ $part->{mntpoint} = $best->{mntpoint};
+ $part->{type} = $best->{type};
+ $part->{size} = min($part->{size}, $best->{size});
+ 1;
+}
+
+
+#sub partitionDrives {
+#
+# my $cmd = "/sbin/fdisk";
+# -x $cmd or $cmd = "/usr/bin/fdisk";
+#
+# my $drives = findDrivesPresent() or die "You don't have any hard drives available! You probably forgot to configure a SCSI controller.";
+#
+# foreach (@$drives) {
+# my $text = "/dev/" . $_->{device};
+# $text .= " - SCSI ID " . $_->{id} if $_->{device} =~ /^sd/;
+# $text .= " - Model " . $_->{info};
+# $text .= " array" if $_->{device} =~ /^c.d/;
+#
+# # truncate at 50 columns for now
+# $text = substr $text, 0, 50;
+# }
+# #TODO TODO
+#}
+
+
+
+sub checkMountPoint($$) {
+# my $type = shift;
+# local $_ = shift;
+#
+# m|^/| or die "The mount point $_ is illegal.\nMount points must begin with a leading /";
+# m|(.)/$| and die "The mount point $_ is illegal.\nMount points may not end with a /";
+# c::isprint($_) or die "The mount point $_ is illegal.\nMount points must be made of printable characters (no accents...)";
+#
+# foreach my $dev (qw(/dev /bin /sbin /etc /lib)) {
+# /^$dev/ and die "The $_ directory must be on the root filesystem.",
+# }
+#
+# if ($type eq 'linux_native') {
+# $_ eq '/'; and return 1;
+# foreach my $r (qw(/var /tmp /boot /root)) {
+# /^$r/ and return 1;
+# }
+# die "The mount point $_ is illegal.\nSystem partitions must be on Linux Native partitions";
+# }
+# 1;
+}
+
+sub removeFromList($$$) {
+ my ($start, $end, $list) = @_;
+ my $err = "error in removeFromList: removing an non-free block";
+
+ for (my $i = 0; $i < @$list; $i += 2) {
+ $start < $list->[$i] and die $err;
+ $start > $list->[$i + 1] and next;
+
+ if ($start == $list->[$i]) {
+ $end > $list->[$i + 1] and die $err;
+ if ($end == $list->[$i + 1]) {
+ # the free block is just the same size, removing it
+ splice(@$list, 0, 2);
+ } else {
+ # the free block now start just after this block
+ $list->[$i] = $end;
+ }
+ } else {
+ $end <= $list->[$i + 1] or die $err;
+ if ($end < $list->[$i + 1]) {
+ splice(@$list, $i + 2, 0, $end, $list->[$i + 1]);
+ }
+ $list->[$i + 1] = $start; # shorten the free block
+ }
+ return;
+ }
+}
+
+
+sub allocatePartitions($$) {
+ my ($hds, $to_add) = @_;
+ my %free_sectors = map { $_->{device} => [1, $_->{totalsectors} ] } @$hds; # first sector is always occupied by the MBR
+ my $remove = sub { removeFromList($_->{start}, $_->{start} + $_->{size}, $free_sectors{$_->{rootDevice}}) };
+ my $success = 0;
+
+ foreach (get_fstab(@$hds)) { &$remove(); }
+
+ FSTAB: foreach (@$to_add) {
+ foreach my $hd (@$hds) {
+ my $v = $free_sectors{$hd->{device}};
+ for (my $i = 0; $i < @$v; $i += 2) {
+ my $size = $v->[$i + 1] - $v->[$i];
+ $_->{size} > $size and next;
+ $_->{start} = $v->[$i];
+ $_->{rootDevice} = $hd->{device};
+ partition_table::adjustStartAndEnd($hd, $_);
+ &$remove();
+ partition_table::add($hd, $_);
+ $success++;
+ next FSTAB;
+ }
+ }
+ log::ld("can't allocate partition $_->{mntpoint} of size $_->{size}, not enough room");
+ }
+ $success;
+}
+
+sub auto_allocate($;$) {
+ my ($hds, $suggestions) = @_;
+ allocatePartitions($hds, $suggestions || \@suggestions);
+ map { partition_table::assign_device_numbers($_) } @$hds;
+}
diff --git a/perl-install/install2.pm b/perl-install/install2.pm
new file mode 100644
index 000000000..5d2bd900b
--- /dev/null
+++ b/perl-install/install2.pm
@@ -0,0 +1,469 @@
+#!/usr/bin/perl
+
+# $o->{hints}->{component} *was* 'Workstation' or 'Server' or NULL
+
+use diagnostics;
+use strict;
+use vars qw($testing $error $cancel $INSTALL_VERSION);
+
+use lib qw(/usr/bin/perl-install . c/blib/arch);
+use c;
+use common qw(:common :file :system);
+use devices;
+use log;
+use net;
+use keyboard;
+use pkgs;
+use smp;
+use fs;
+use setup;
+use fsedit;
+use install_methods;
+use lilo;
+use swap;
+use install_steps_graphical;
+use modules;
+use partition_table qw(:types);
+use detect_devices;
+use commands;
+
+$error = 0;
+$cancel = 0;
+$testing = $ENV{PERL_INSTALL_TEST};
+$INSTALL_VERSION = 0;
+
+my @installStepsFields = qw(text skipOnCancel skipOnLocal prev next);
+my @installSteps = (
+ selectPath => [ "Select installation path", 0, 0, 'none' ],
+ selectInstallClass => [ "Select installation class", 0, 0 ],
+ setupSCSI => [ "Setup SCSI", 0, 1 ],
+ partitionDisks => [ "Setup filesystems", 0, 1 ],
+ findInstallFiles => [ "Find installation files", 1, 0 ],
+ choosePackages => [ "Choose packages to install", 0, 0 ],
+ doInstallStep => [ "Install system", 0, 0 ],
+# configureMouse => [ "Configure mouse", 0, 0 ],
+ finishNetworking => [ "Configure networking", 0, 0 ],
+# configureTimezone => [ "Configure timezone", 0, 0 ],
+# configureServices => [ "Configure services", 0, 0 ],
+# configurePrinter => [ "Configure printer", 0, 0 ],
+ setRootPassword => [ "Set root password", 0, 0 ],
+ addUser => [ "Add a user", 0, 0 ],
+ configureAuth => [ "Configure authentication", 0, 0 ],
+ createBootdisk => [ "Create bootdisk", 0, 1 ],
+ setupBootloader => [ "Install bootloader", 0, 1 ],
+# configureX => [ "Configure X", 0, 0 ],
+ exitInstall => [ "Exit install", 0, 0, undef, 'done' ],
+);
+
+# this table is translated at run time
+my %upgradeSteps = (
+ selectPath => [ "Select installation path", 0, 0 , 'none' ],
+ setupSCSI => [ "Setup SCSI", 0, 0 ],
+ upgrFindInstall => [ "Find current installation", 0, 0 ],
+ findInstallFiles => [ "Find installation files", 1, 0 ],
+ upgrChoosePackages => [ "Choose packages to upgrade", 0, 0 ],
+ doInstallStep => [ "Upgrade system", 0, 0 ],
+ createBootdisk => [ "Create bootdisk", 0, 0 , 'none' ],
+ setupBootloader => [ "Install bootloader", 0, 0 ],
+ exitInstall => [ "Exit install", 0, 0 , undef, 'done' ],
+);
+
+for (my $i = 0; $i < @installSteps; $i += 2) {
+ my %h; @h{@installStepsFields} = @{ $installSteps[$i + 1] };
+ $h{prev} ||= $installSteps[$i - 2];
+ $h{next} ||= $installSteps[$i + 2];
+ $installSteps{ $installSteps[$i] } = \%h;
+}
+$installSteps{first} = $installSteps[0];
+for (my $i = 0; $i < @upgradeSteps; $i += 2) {
+ my %h; @h{@installStepsFields} = @{ $upgradeSteps[$i + 1] };
+ $h{prev} ||= $upgradeSteps[$i - 2];
+ $h{next} ||= $upgradeSteps[$i + 2];
+ $upgradeSteps{ $upgradeSteps[$i] } = \%h;
+}
+$upgradeSteps{first} = $upgradeSteps[0];
+
+
+# partition layout for a server
+my @serverPartitioning = (
+ { mntpoint => "/boot", size => 16 << 11, type => 0x83 },
+ { mntpoint => "/", size => 256 << 11, type => 0x83 },
+ { mntpoint => "/usr", size => 512 << 11, type => 0x83, growable => 1 },
+ { mntpoint => "/var", size => 256 << 11, type => 0x83 },
+ { mntpoint => "/home", size => 512 << 11, type => 0x83, growable => 1 },
+ { mntpoint => "swap", size => 64 << 11, type => 0x82 }
+);
+
+my $o = {};
+my $default = {
+ display => "129.104.42.9:0",
+ user => { name => 'foo', password => 'foo', shell => '/bin/bash', realname => 'really, it is foo' },
+ rootPassword => 'toto',
+ keyboard => 'us',
+ isUpgrade => 0,
+ installClass => 'Server',
+ bootloader => { onmbr => 1,
+ linear => 1,
+ },
+ mkbootdisk => 0,
+ comps => [ qw() ],
+ packages => [ qw() ],
+ partitions => [
+ { mntpoint => "/boot", size => 16 << 11, type => 0x83 },
+ { mntpoint => "/", size => 300 << 11, type => 0x83 },
+ { mntpoint => "/usr", size => 400 << 11, type => 0x83, growable => 1 },
+ { mntpoint => "swap", size => 64 << 11, type => 0x82 }
+ ],
+};
+
+
+
+sub selectPath {
+ $o->{steps} = $o->{isUpgrade} ? \%upgradeSteps : \%installSteps;
+}
+
+sub selectInstallClass {
+# my @choices = qw(Workstation Server Custom);
+
+ $o->{installClass} eq 'Custom' and return;
+
+ $o->{bootloader}->{onmbr} = 1;
+ $o->{bootloader}->{uselinear} = 1;
+
+ foreach (qw(skipntsysv autoformat nologmessage auth autoswap skipbootloader forceddruid)) {
+ $o->{hints}->{flags}->{$_} = 1;
+ }
+ $o->{hints}->{auth}->{shadow} = 1;
+ $o->{hints}->{auth}->{md5} = 1;
+
+ if ($o->{installClass} eq 'Server') {
+ $o->{hints}->{flags}->{skipprinter} = 1;
+ $o->{hints}->{flags}->{skipresize} = 1;
+ $o->{hints}->{partitioning}->{flags}->{clearall} = 1;
+ $o->{hints}->{partitioning}->{attempts} = 'serverPartitioning';
+ } else { # workstation
+ $o->{hints}->{flags}->{autoscsi} = 1;
+ $o->{hints}->{partitioning}->{flags}->{clearlinux} = 1;
+ }
+}
+
+sub setupSCSI {
+ $o->{direction} < 0 && detect_devices::hasSCSI() and return cancel();
+
+ # If we have any scsi adapters configured from earlier, then don't bother asking again
+ while (my ($k, $v) = each %modules::loaded) {
+ $v->{type} eq 'scsi' and return;
+ }
+ #setupSCSIInterfaces(0, \%modules::loaded, $o->{hints}->{flags}->{autoscsi}, $o->{direction});
+}
+
+sub partitionDisks {
+ $o->{drives} = [ detect_devices::hds() ];
+ $o->{hds} = fsedit::hds($o->{drives}, $o->{hints}->{partitioning}->{flags});
+ @{$o->{hds}} > 0 or die "An error has occurred - no valid devices were found on which to create new filesystems. Please check your hardware for the cause of this problem";
+
+ unless ($o->{isUpgrade}) {
+ $o->{install}->doPartitionDisks($o->{hds}, $o->{fstab_wanted});
+
+ # Write partitions to disk
+ foreach (@{$o->{hds}}) { partition_table::write($_); }
+ }
+
+ $o->{fstab} = [ fsedit::get_fstab(@{$o->{hds}}) ];
+
+ my $root_fs; map { $_->{mntpoint} eq '/' and $root_fs = $_ } @{$o->{fstab}};
+ $root_fs or die "partitionning failed: no root filesystem";
+
+ if ($o->{hints}->{flags}->{autoformat}) {
+ log::l("formatting all filesystems");
+
+ foreach (@{$o->{fstab}}) {
+ fs::format_part($_) if $_->{mntpoint} && isExt2($_) || isSwap($_);
+ }
+ }
+ fs::mount_all($o->{fstab}, '/mnt');
+}
+
+sub findInstallFiles {
+ $o->{packages} = $o->{method}->getPackageSet() and
+ $o->{comps} = $o->{method}->getComponentSet($o->{packages});
+}
+
+sub choosePackages {
+# $o->{hints}->{component} && $o->{direction} < 0 and return cancel();
+
+ $o->{install}->choosePackages($o->{packages}, $o->{comps}, $o->{isUpgrade});
+}
+
+sub doInstallStep {
+ $testing and return 0;
+
+ $o->{install}->beforeInstallPackages($o->{method}, $o->{fstab});
+ $o->{install}->installPackages($o->{rootPath}, $o->{method}, $o->{packages}, $o->{isUpgrade});
+ $o->{install}->afterInstallPackages($o->{rootPath}, $o->{keyboard}, $o->{isUpgrade});
+}
+
+sub configureMouse { setup::mouseConfig($o->{rootPath}); }
+
+sub finishNetworking {
+#
+# rc = checkNetConfig(&$o->{intf}, &$o->{netc}, &$o->{intfFinal},
+# &$o->{netcFinal}, &$o->{driversLoaded}, $o->{direction});
+#
+# if (rc) return rc;
+#
+# sprintf(path, "%s/etc/sysconfig", $o->{rootPath});
+# writeNetConfig(path, &$o->{netcFinal},
+# &$o->{intfFinal}, 0);
+# strcat(path, "/network-scripts");
+# writeNetInterfaceConfig(path, &$o->{intfFinal});
+# sprintf(path, "%s/etc", $o->{rootPath});
+# writeResolvConf(path, &$o->{netcFinal});
+#
+# # this is a bit of a hack
+# writeHosts(path, &$o->{netcFinal},
+# &$o->{intfFinal}, !$o->{isUpgrade});
+#
+# return 0;
+}
+
+sub configureTimezone { setup::timeConfig($o->{rootPath}) }
+sub configureServices { setup::servicesConfig($o->{rootPath}) }
+
+sub setRootPassword {
+ $testing and return 0;
+
+ $o->{install}->setRootPassword($o->{rootPath});
+}
+
+sub addUser {
+ $o->{install}->addUser($o->{rootPath});
+}
+
+sub createBootdisk {
+ $o->{isUpgrade} or fs::write('mnt', $o->{fstab});
+ modules::write_conf("/mnt/etc/conf.modules", 'append');
+
+ $o->{mkbootdisk} and lilo::mkbootdisk("/mnt", versionString());
+}
+
+sub setupBootloader {
+ my $versionString = versionString();
+ log::l("installed kernel version $versionString");
+
+ $o->{isUpgrade} or modules::read_conf("/mnt/etc/conf.modules");
+
+ lilo::install("/mnt", $o->{hds}, $o->{fstab}, $versionString, $o->{bootloader});
+}
+
+sub configureX { $o->{install}->setupXfree($o->{method}, $o->{rootPath}, $o->{packages}); }
+
+sub exitInstall { 1 }
+
+sub upgrFindInstall {
+# int rc;
+#
+# if (!$o->{table}.parts) {
+# rc = findAllPartitions(NULL, &$o->{table});
+# if (rc) return rc;
+# }
+#
+# umountFilesystems(&$o->{fstab});
+#
+# # rootpath upgrade support
+# if (strcmp($o->{rootPath} ,"/mnt"))
+# return INST_OKAY;
+#
+# # this also turns on swap for us
+# rc = readMountTable($o->{table}, &$o->{fstab});
+# if (rc) return rc;
+#
+# if (!testing) {
+# mountFilesystems(&$o->{fstab});
+#
+# if ($o->{method}->prepareMedia) {
+# rc = $o->{method}->prepareMedia($o->{method}, &$o->{fstab});
+# if (rc) {
+# umountFilesystems(&$o->{fstab});
+# return rc;
+# }
+# }
+# }
+#
+# return 0;
+}
+
+sub upgrChoosePackages {
+# static int firstTime = 1;
+# char * rpmconvertbin;
+# int rc;
+# char * path;
+# char * argv[] = { NULL, NULL };
+# char buf[128];
+#
+# if (testing)
+# path = "/";
+# else
+# path = $o->{rootPath};
+#
+# if (firstTime) {
+# snprintf(buf, sizeof(buf), "%s%s", $o->{rootPath},
+# "/var/lib/rpm/packages.rpm");
+# if (access(buf, R_OK)) {
+# snprintf(buf, sizeof(buf), "%s%s", $o->{rootPath},
+# "/var/lib/rpm/packages");
+# if (access(buf, R_OK)) {
+# errorWindow("No RPM database exists!");
+# return INST_ERROR;
+# }
+#
+# if ($o->{method}->getFile($o->{method}, "rpmconvert",
+# &rpmconvertbin)) {
+# return INST_ERROR;
+# }
+#
+# symlink("/mnt/var", "/var");
+# winStatus(35, 3, _("Upgrade"), _("Converting RPM database..."));
+# chmod(rpmconvertbin, 0755);
+# argv[0] = rpmconvertbin;
+# rc = runProgram(RUN_LOG, rpmconvertbin, argv);
+# if ($o->{method}->rmFiles)
+# unlink(rpmconvertbin);
+#
+# newtPopWindow();
+# if (rc) return INST_ERROR;
+# }
+# winStatus(35, 3, "Upgrade", _("Finding packages to upgrade..."));
+# rc = ugFindUpgradePackages(&$o->{packages}, path);
+# newtPopWindow();
+# if (rc) return rc;
+# firstTime = 0;
+# psVerifyDependencies(&$o->{packages}, 1);
+# }
+#
+# return psSelectPackages(&$o->{packages}, &$o->{comps}, NULL, 0, 1);
+}
+
+
+sub versionString {
+ my $kernel = $o->{packages}->{kernel} or die "I couldn't find the kernel package!";
+
+ c::headerGetEntry($kernel->{header}, 'version') . "-" .
+ c::headerGetEntry($kernel->{header}, 'release');
+}
+
+sub getNextStep {
+ my ($lastStep) = @_;
+
+ $error and die "an error occured in step $lastStep";
+ $cancel and die "cancel called in step $lastStep";
+
+ $o->{direction} = 1;
+
+ return $o->{lastChoice} = $o->{steps}->{$lastStep}->{next};
+}
+
+sub doSuspend {
+ $o->{exitOnSuspend} and exit(1);
+
+ if (my $pid = fork) {
+ waitpid $pid, 0;
+ } else {
+ print "\n\nType <exit> to return to the install program.\n\n";
+ exec {"/bin/sh"} "-/bin/sh";
+ warn "error execing /bin/sh";
+ sleep 5;
+ exit 1;
+ }
+}
+
+
+sub spawnShell {
+ $testing and return;
+
+ -x "/bin/sh" or log::l("cannot open shell - /usr/bin/sh doesn't exist"), return;
+
+ fork and return;
+
+ local *F;
+ sysopen F, "/dev/tty2", 2 or log::l("cannot open /dev/tty2 -- no shell will be provided"), return;
+
+ open STDIN, "<&F" or die;
+ open STDOUT, ">&F" or die;
+ open STDERR, ">&F" or die;
+ close F;
+
+ c::setsid();
+
+ ioctl(STDIN, c::TIOCSCTTY(), 0) or warn "could not set new controlling tty: $!";
+
+ exec {"/bin/sh"} "-/bin/sh" or log::l("exec of /bin/sh failed: $!");
+}
+
+sub main {
+
+ # if this fails, it's okay -- it might help with free space though
+ unlink "/sbin/install";
+
+ print STDERR "in second stage install\n";
+
+ $o->{rootPath} = "/mnt";
+
+ $o->{method} = install_methods->new('cdrom');
+ $o->{install} = install_steps_graphical->new($o);
+
+ unless ($testing || $o->{localInstall}) {
+ if (fork == 0) {
+ while (1) { sleep(30); sync(); }
+ }
+ }
+ $o->{exitOnSuspend} = $o->{localInstall} || $testing;
+
+ log::openLog(($testing || $o->{localInstall}) && 'debug.log');
+
+ log::l("second stage install running (version $INSTALL_VERSION)");
+
+ log::ld("extra log messages are enabled");
+
+ $o->{rootPath} eq '/mnt' and spawnShell();
+
+# chooseLanguage('fr');
+
+ $o->{netc} = net::readNetConfig("/tmp");
+
+ if (my ($file) = glob_('/tmp/ifcfg-*')) {
+ log::l("found network config file $file");
+ $o->{intf} = net::readNetInterfaceConfig($file);
+ }
+
+ log::l("reading /usr/lib/rpm/rpmrc");
+ c::rpmReadConfigFiles_();
+ log::l("\tdone");
+
+ modules::load_deps("/modules/modules.dep");
+ modules::read_conf("/tmp/conf.modules");
+
+ # make sure we don't pick up any gunk from the outside world
+ $ENV{PATH} = "/usr/bin:/bin:/sbin:/usr/sbin";
+ $ENV{LD_LIBRARY_PATH} = "";
+
+ $o->{keyboard} = keyboard::read("/tmp/keyboard") || $default->{keyboard};
+
+ for (my $step = $o->{steps}->{first}; $step ne 'done'; $step = getNextStep($step)) {
+ log::l("entering step $step");
+ &{$main::{$step}}() and $o->{steps}->{completed} = 1;
+ log::l("step $step finished");
+ }
+ killCardServices();
+
+ log::l("installation complete, leaving");
+
+ <STDIN> unless $testing;
+}
+
+sub killCardServices {
+ my $pid = cat_("/tmp/cardmgr.pid");
+ $pid and kill(15, chop_($pid)); # send SIGTERM
+}
+
+main(@ARGV);
diff --git a/perl-install/install_steps.pm b/perl-install/install_steps.pm
new file mode 100644
index 000000000..123507929
--- /dev/null
+++ b/perl-install/install_steps.pm
@@ -0,0 +1,220 @@
+package install_steps;
+
+use diagnostics;
+use strict;
+
+use lang;
+use keyboard;
+use pkgs;
+use cpio;
+use log;
+use fsedit;
+
+
+
+1;
+
+
+sub new($) {
+ my ($type, $I) = @_;
+
+ bless $I, ref $type || $type;
+}
+
+
+sub doPartitionDisks($$$) {
+ my ($I, $hds) = @_;
+ fsedit::auto_allocate($hds, $I->{partitions});
+}
+
+sub choosePackages($$$$) {
+ my ($I, $packages, $comps, $isUpgrade) = @_;
+
+ foreach ('base', @{$I->{comps}}) {
+ $comps->{$_}->{selected} = 1;
+ foreach (@{$_->{packages}}) { $_->{selected} = 1; }
+ }
+ foreach (@{$I->{packages}}) { $_->{selected} = 1; }
+
+ smp::detect() and $packages->{"kernel-smp"}->{selected} = 1;
+}
+
+sub beforeInstallPackages($$$) {
+ my ($I, $method, $fstab, $isUpgrade) = @_;
+
+ $method->prepareMedia($fstab);
+
+ foreach (qw(dev etc home mnt tmp var var/tmp var/lib var/lib/rpm)) {
+ mkdir "$prefix/$_", 0755;
+ }
+
+ unless ($isUpgrade) {
+ local *F;
+ open F, "> $prefix/etc/hosts" or die "Failed to create etc/hosts: $!";
+ print F "127.0.0.1 localhost localhost.localdomain\n";
+ }
+}
+
+sub installPackages($$$$$) {
+ my ($I, $prefix, $method, $packages, $isUpgrade) = @_;
+
+ pkgs::install($prefix, $method, $packages, $isUpgrade, 0);
+}
+
+sub afterInstallPackages($$$$) {
+ my ($prefix, $keymap, $isUpgrade) = @_;
+
+ unless ($isUpgrade) {
+ keyboard::write($prefix, $keymap);
+ lang::write($prefix);
+ }
+ # why not?
+ sync(); sync();
+
+# configPCMCIA($o->{rootPath}, $o->{pcmcia});
+}
+
+sub addUser($$) {
+ my ($I, $prefix) = @_;
+
+ my $new_uid;
+ #my @uids = map { (split)[2] } cat__("$prefix/etc/passwd");
+ #for ($new_uid = 500; member($new_uid, @uids); $new_uid++) {}
+ for ($new_uid = 500; getpwuid($new_uid); $new_uid++) {}
+
+ my $new_gid;
+ #my @gids = map { (split)[2] } cat__("$prefix/etc/group");
+ #for ($new_gid = 500; member($new_gid, @gids); $new_gid++) {}
+ for ($new_gid = 500; getgrgid($new_gid); $new_gid++) {}
+
+ my $homedir = "$prefix/home/$default->{user}->{name}";
+
+ my $pw = crypt_($default->{user}->{password});
+
+ unless ($testing) {
+ {
+ local *F;
+ open F, ">> $prefix/etc/passwd" or die "can't append to passwd file: $!";
+ print F "$default->{user}->{name}:$pw:$new_uid:$new_gid:$default->{user}->{realname}:/home/$default->{user}->{name}:$default->{user}->{shell}\n";
+
+ open F, ">> $prefix/etc/group" or die "can't append to group file: $!";
+ print F "$default->{user}->{name}::$new_gid:\n";
+ }
+ eval { commands::cp("-f", "$prefix/etc/skel", $homedir) }; $@ and log::l("copying of skel failed: $@"), mkdir($homedir, 0750);
+ commands::chown_("-r", "$new_uid.$new_gid", $homedir);
+ }
+}
+
+sub setRootPassword($$) {
+ my ($I, $prefix) = @_;
+
+ my $pw = $default->{rootPassword};
+ $pw = crypt_($pw);
+
+ my @lines = cat_("$prefix/etc/passwd", 'die');
+ local *F;
+ open F, "> $prefix/etc/passwd" or die "can't write in passwd: $!\n";
+ foreach (@lines) {
+ s/^root:.*?:/root:$pw:/;
+ print F $_;
+ }
+}
+
+
+sub setupXfree {
+# my ($method, $prefix, $psp) = @_;
+# int fd, i;
+# char buf[200], * chptr;
+# char server[50];
+# int rc;
+# char * path;
+# char * procPath;
+# rpmdb db;
+# rpmTransactionSet trans;
+# struct callbackInfo cbi;
+# rpmProblemSet probs;
+#
+# if (rpmdbOpen(prefix, &db, O_RDWR | O_CREAT, 0644)) {
+# errorWindow(_("Fatal error reopening RPM database"));
+# return INST_ERROR;
+# }
+# log::l("reopened rpm database");
+#
+# path = alloca(strlen(prefix) + 200);
+# procPath = alloca(strlen(prefix) + 50);
+# sprintf(path, "%s/usr/X11R6/bin/Xconfigurator", prefix);
+#
+# # This is a cheap trick to see if our X component was installed
+# if (access(path, X_OK)) {
+# log::l("%s cannot be run", path);
+# return INST_OKAY;
+# }
+#
+# # need proc to do pci probing
+# sprintf(procPath, "%s/proc", prefix);
+# umount(procPath);
+# if ((rc = doMount("/proc", procPath, "proc", 0, 0))) {
+# return INST_ERROR;
+# }
+#
+# # this handles kickstart and normal/expert modes
+# if ((rc=xfree86Config(prefix, "--pick")))
+# return INST_ERROR;
+#
+# sprintf(path, "%s/tmp/SERVER", prefix);
+# if ((fd = open(path, O_RDONLY)) < 0) {
+# log::l("failed to open %s: %s", path, strerror(errno));
+# return INST_ERROR;
+# }
+#
+# buf[0] = '\0';
+# read(fd, buf, sizeof(buf));
+# close(fd);
+# chptr = buf;
+# while (chptr < (buf + sizeof(buf) - 1) && *chptr && *chptr != ' ')
+# chptr++;
+#
+# if (chptr >= (buf + sizeof(buf) - 1) || *chptr != ' ') {
+# log::l("couldn't find ' ' in %s", path);
+# return INST_ERROR;
+# }
+#
+# *chptr = '\0';
+# strcpy(server, "XFree86-");
+# strcat(server, buf);
+#
+# log::l("I will install the %s package", server);
+#
+# for (i = 0; i < psp->numPackages; i++) {
+# if (!strcmp(psp->packages[i]->name, server)) {
+# log::l("\tfound package: %s", psp->packages[i]->name);
+# swOpen(1, psp->packages[i]->size);
+# trans = rpmtransCreateSet(db, prefix);
+# rpmtransAddPackage(trans, psp->packages[i]->h, NULL,
+# psp->packages[i], 0, NULL);
+#
+# cbi.method = method;
+# cbi.upgrade = 0;
+#
+# rpmRunTransactions(trans, swCallback, &cbi, NULL, &probs, 0,
+# 0xffffffff);
+#
+# swClose();
+# break;
+# }
+# }
+#
+# # this handles kickstart and normal/expert modes
+# if ((rc=xfree86Config(prefix, "--continue")))
+# return INST_ERROR;
+#
+# # done with proc now
+# umount(procPath);
+#
+# rpmdbClose(db);
+#
+# log::l("rpm database closed");
+#
+# return INST_OKAY;
+}
+
diff --git a/perl-install/keyboard.pm b/perl-install/keyboard.pm
new file mode 100644
index 000000000..233aafda1
--- /dev/null
+++ b/perl-install/keyboard.pm
@@ -0,0 +1,128 @@
+package keyboard;
+
+use diagnostics;
+use strict;
+use vars qw($KMAP_MAGIC %defaultKeyboards %loadKeymap);
+
+use common qw(:system :file);
+use log;
+
+
+$KMAP_MAGIC = 0x8B39C07F;
+
+%defaultKeyboards = (
+ "de" => "de-latin1",
+ "fi" => "fi-latin1",
+ "se" => "se-latin1",
+ "no" => "no-latin1",
+ "cs" => "cz-lat2",
+ "tr" => "trq",
+);
+
+1;
+
+
+sub load($) {
+ my ($keymap_raw) = @_;
+
+ my ($magic, @keymaps) = unpack "i i" . c::MAX_NR_KEYMAPS() . "a*", $keymap_raw;
+ $keymap_raw = pop @keymaps;
+
+ $magic != $KMAP_MAGIC and die "failed to read kmap magic: $!";
+
+ local *F;
+ sysopen F, "/dev/console", 2 or die "failed to open /dev/console: $!";
+
+ my $count = 0;
+ foreach (0 .. c::MAX_NR_KEYMAPS() - 1) {
+ $keymaps[$_] or next;
+
+ my @keymap = unpack "s" . c::NR_KEYS() . "a*", $keymap_raw;
+ $keymap_raw = pop @keymap;
+
+ my $key = 0;
+ foreach my $value (@keymap) {
+ c::KTYP($value) != c::KT_SPEC() or next;
+ ioctl(F, c::KDSKBENT(), pack("CCS", $_, $key++, $value)) or log::l("keymap ioctl failed: $!");
+ $key++;
+ }
+ $count++;
+ }
+ log::l("loaded $count keymap tables");
+ 1;
+}
+
+sub setup($) {
+ my ($defkbd) = @_;
+ my $t;
+
+ #$::testing and return 1;
+
+ $defkbd ||= $defaultKeyboards{$ENV{LANG}} || "us";
+
+ local *F;
+ open F, "/etc/keymaps" or die "cannot open /etc/keymaps: $!";
+
+ my $format = "i2";
+ read F, $t, psizeof($format) or die "failed to read keymaps header: $!";
+ my ($magic, $numEntries) = unpack $format, $t;
+
+ log::l("%d keymaps are available", $numEntries);
+
+ my @infoTable;
+ my $format2 = "i Z40";
+ foreach (1..$numEntries) {
+ read F, $t, psizeof($format2) or die "failed to read keymap information: $!";
+ push @infoTable, [ unpack $format2, $t ];
+ }
+
+ foreach (@infoTable) {
+ read F, $t, $_->[0] or log::l("error reading $_->[0] bytes from file: $!"), return;
+
+ if ($defkbd eq $_->[1]) {
+ log::l("using keymap $_->[1]");
+ load($t) or return;
+ &write("/tmp", $_->[1]) or log::l("write keyboard config failed");
+ return $_->[1];
+ }
+ }
+ undef;
+}
+
+sub write($$) {
+ my ($prefix, $keymap) = @_;
+
+ $keymap or return 1;
+ $::testing and return 1;
+
+ local *F;
+ open F, ">$prefix/etc/sysconfig/keyboard" or die "failed to create keyboard configuration: $!";
+ print F "KEYTABLE=$keymap\n" or die "failed to write keyboard configuration: $!";
+
+ # write default keymap
+ if (fork) {
+ wait;
+ $? == 0 or log::l('dumpkeys failed');
+ } else {
+ chroot $prefix;
+ CORE::system("/usr/bin/dumpkeys > /etc/sysconfig/console/default.kmap 2>/dev/null");
+ exit($?);
+ }
+}
+
+sub read($) {
+ my ($file) = @_;
+
+ local *F;
+ open F, "$file" or # fail silently -- old bootdisks won't create this
+ log::l("failed to read keyboard configuration (probably ok)"), return;
+
+ foreach (<F>) {
+ ($_) = /^KEYTABLE=(.*)/ or die "unrecognized entry in keyboard configuration file";
+ s/\"//g;
+ s/\.[^.]*//; # remove extension
+ return basename($_);
+ }
+ log::l("empty keyboard configuration file");
+ undef;
+}
diff --git a/perl-install/lang.pm b/perl-install/lang.pm
new file mode 100644
index 000000000..708a6b5da
--- /dev/null
+++ b/perl-install/lang.pm
@@ -0,0 +1,72 @@
+package lang;
+
+use diagnostics;
+use strict;
+
+use common qw(:file);
+use commands;
+use cpio;
+use log;
+
+my %languages = (
+ "en" => [ "English", undef, undef, "en_US" ],
+ "fr" => [ "French", "lat0-sun16", "iso15", "fr_FR" ],
+ "de" => [ "German", "lat0-sun16", "iso15", "de_DE" ],
+ "hu" => [ "Hungarian", "lat2-sun16", "iso02", "hu_HU" ],
+ "is" => [ "Icelandic", "lat0-sun16", "iso15", "is_IS" ],
+ "it" => [ "Italian", "lat0-sun16", "iso15", "it_IT" ],
+ "no" => [ "Norwegian", "lat0-sun16", "iso15", "no_NO" ],
+ "ro" => [ "Romanian", "lat2-sun16", "iso02", "ro_RO" ],
+ "sk" => [ "Slovak", "lat2-sun16", "iso02", "sk_SK" ],
+ "ru" => [ "Russian", "Cyr_a8x16", "koi2alt", "ru_SU" ],
+"uk_UA"=> [ "Ukrainian", "RUSCII_8x16", "koi2alt", "uk_UA" ],
+);
+
+1;
+
+sub set {
+ my $lang = shift;
+
+ if ($lang) {
+ $ENV{LANG} = $ENV{LINGUAS} = $lang;
+ $ENV{LC_ALL} = $languages{$lang}->[3];
+ my $f = $languages{$lang}->[1]; $f and load_font($f);
+ } else {
+ # stick with the default (English) */
+ delete $ENV{LANG};
+ delete $ENV{LC_ALL};
+ delete $ENV{LINGUAS};
+ }
+}
+
+sub write {
+ my ($prefix) = @_;
+ my $lang = $ENV{LANG};
+
+ $::testing || !$lang and return 0;
+ local *F;
+ open F, "> $prefix/etc/sysconfig/i18n";
+
+ my $f = sub { $_[1] and print F "$_[0]=$_[1]\n"; };
+ &$f("LANG", $lang);
+ &$f("LINGUAS", $lang);
+ if (my $l = $languages{$lang}) {
+ &$f("LC_ALL", $l->{lc_all});
+ &$f("SYSFONT", $l->{font});
+ &$f("SYSFONTACM", $l->{map});
+
+ my $p = "$prefix/usr/lib/kbd";
+ commands::cp("-f",
+ "$p/consolefonts/$l->{font}.psf.gz",
+ glob_("$p/consoletrans/$l->{map}*"),
+ "$prefix/etc/sysconfig/console");
+ }
+ 1;
+}
+
+sub load_font {
+ my ($fontFile) = @_;
+ cpio::installCpioFile("/etc/fonts.cgz", $fontFile, "/tmp/font", 1) or die "error extracting $fontFile from /etc/fonts.cfz";
+ c::loadFont('/tmp/font') or log::l("error in loadFont: one of PIO_FONT PIO_UNIMAPCLR PIO_UNIMAP PIO_UNISCRNMAP failed: $!");
+ print STDERR "\033(K";
+}
diff --git a/perl-install/log.pm b/perl-install/log.pm
new file mode 100644
index 000000000..0fe696f07
--- /dev/null
+++ b/perl-install/log.pm
@@ -0,0 +1,34 @@
+use diagnostics;
+use strict;
+
+package log;
+
+my $logOpen = 0;
+my $logDebugMessages = 0;
+
+1;
+
+sub fd() { fileno LOG }
+
+sub l {
+ $logOpen or openLog();
+ print LOG "* ", @_, "\n";
+ print LOG2 "* ", @_, "\n";
+}
+sub ld { $logDebugMessages and &l }
+sub w { &l }
+
+sub openLog(;$) {
+ if ($_[0]) { # useLocal
+ open LOG, "> $_[0]" or die "no log possible :(";
+ } else {
+ open LOG, "> /dev/tty3" or open LOG, ">> /tmp/install.log" or die "no log possible :(";
+ }
+ open LOG2, ">> /tmp/ddebug.log" or die "no log possible :(";
+ select((select(LOG), $| = 1)[0]);
+ select((select(LOG2), $| = 1)[0]);
+ exists $ENV{DEBUG} and $logDebugMessages = 1;
+ $logOpen = 1;
+}
+
+sub closeLog() { close LOG; close LOG2; }
diff --git a/perl-install/modules.pm b/perl-install/modules.pm
new file mode 100644
index 000000000..b6e2ebd9b
--- /dev/null
+++ b/perl-install/modules.pm
@@ -0,0 +1,330 @@
+package modules;
+
+use diagnostics;
+use strict;
+use vars qw(%loaded);
+
+use common qw(:file);
+use log;
+use detect_devices;
+use run_program;
+use pci;
+
+%loaded = ();
+
+my %deps = ();
+
+
+my @neOptions = (
+ [ "io=", "Base IO port:", "0x300:0x280:0x320:0x340:0x360" ],
+ [ "irq=", "IRQ level:", "" ],
+);
+
+my @de4x5Options = (
+ [ "io=", "Base IO port:", "0x0b" ],
+);
+
+my @cdu31aOptions = (
+ [ "cdu31a_port=", "Base IO port:", "" ],
+ [ "cdu31a_irq=", "IRQ level:", "" ],
+);
+
+my @cm206Options = (
+ [ "cm206=", "IO base, IRQ:", "" ],
+);
+
+my @mcdOptions = (
+ [ "mcd=", "Base IO port:", "" ],
+);
+
+my @optcdOptions = (
+ [ "optcd=", "Base IO port:", "" ],
+);
+
+my @fdomainOptions = (
+ [ "setup_called=", "Use other options", "1" ],
+ [ "port_base=", "Base IO port:", "0xd800" ],
+ [ "interrupt_level=", "Interrupt level (IRQ):", "10" ],
+);
+
+my @sbpcdOptions = (
+ [ "sbpcd=", "IO base, IRQ, label:", "" ],
+);
+
+my @parportPcOptions = (
+ [ "io=", "Base IO port:", "0x378" ],
+ [ "irq=", "IRQ level:", "7" ],
+);
+
+my %modules = (
+ "8390" => [ 1, undef, 0, '' ],
+ "cdu31a" => [ 0, \@cdu31aOptions, 0, '' ],
+ "cm206" => [ 0, \@cm206Options, 0, '' ],
+ "de4x5" => [ 1, \@de4x5Options, 'AUTOPROBE', "io=0" ],
+ "ds" => [ 1, undef, 0, '' ],
+ "fdomain" => [ 1, \@fdomainOptions, 0, '' ],
+ "i82365" => [ 1, undef, 0, '' ],
+ "isofs" => [ 1, undef, 0, '' ],
+ "loop" => [ 1, undef, 0, '' ],
+ "lp" => [ 1, undef, 0, '' ],
+ "parport" => [ 1, undef, 0, '' ],
+ "parport_pc" => [ 1, \@parportPcOptions, 0, "irq=7" ],
+ "mcd" => [ 0, \@mcdOptions, 0, '' ],
+ "ne" => [ 0, \@neOptions, 'FAKEAUTOPROBE', "io=0x300" ],
+ "nfs" => [ 1, undef, 0, '' ],
+ "optcd" => [ 0, \@optcdOptions, 0, '' ],
+ "pcmcia_core" => [ 1, undef, 0, '' ],
+ "sbpcd" => [ 1, \@sbpcdOptions, 0, '' ],
+ "smbfs" => [ 1, undef, 0, '' ],
+ "tcic" => [ 1, undef, 0, '' ],
+ "vfat" => [ 1, undef, 0, '' ],
+);
+
+my @drivers_by_category = (
+[ 0, \&detect_devices::hasEthernet, 'net', 'ethernet', {
+ "3c509" => "3com 3c509",
+ "3c501" => "3com 3c501",
+ "3c503" => "3com 3c503",
+ "3c505" => "3com 3c505",
+ "3c507" => "3com 3c507",
+ "3c515" => "3com 3c515",
+ "3c59x" => "3com 3c59x (Vortex)",
+ "3c59x" => "3com 3c90x (Boomerang)",
+ "at1700" => "Allied Telesis AT1700",
+ "ac3200" => "Ansel Communication AC3200",
+ "pcnet32" => "AMD PC/Net 32",
+ "apricot" => "Apricot 82596",
+ "atp" => "ATP",
+ "e2100" => "Cabletron E2100",
+ "tlan" => "Compaq Netelligent",
+ "de4x5" => "Digital 425,434,435,450,500",
+ "depca" => "Digital DEPCA and EtherWORKS",
+ "ewrk3" => "Digital EtherWORKS 3",
+ "tulip" => "Digital 21040 (Tulip)",
+ "de600" => "D-Link DE-600 pocket adapter",
+ "de620" => "D-Link DE-620 pocket adapter",
+ "epic100" => "EPIC 100",
+ "hp100" => "HP10/100VG any LAN ",
+ "hp" => "HP LAN/AnyLan",
+ "hp-plus" => "HP PCLAN/plus",
+ "eth16i" => "ICL EtherTeam 16i",
+ "eexpress" => "Intel EtherExpress",
+ "eepro" => "Intel EtherExpress Pro",
+ "eepro100" => "Intel EtherExpress Pro 100",
+ "lance" => "Lance",
+ "lne390" => "Mylex LNE390",
+ "ne" => "NE2000 and compatible",
+ "ne2k-pci" => "NE2000 PCI",
+ "ne3210" => "NE3210",
+ "ni5010" => "NI 5010",
+ "ni52" => "NI 5210",
+ "ni65" => "NI 6510",
+ "rtl8139" => "RealTek RTL8129/8139",
+ "es3210" => "Racal-Interlan ES3210",
+ "rcpci45" => "RedCreek PCI45 LAN",
+ "epic100" => "SMC 83c170 EPIC/100",
+ "smc9194" => "SMC 9000 series",
+ "smc-ultra" => "SMC Ultra",
+ "smc-ultra32" => "SMC Ultra 32",
+ "via-rhine" => "VIA Rhine",
+ "wd" => "WD8003, WD8013 and compatible",
+}],
+[ 0, \&detect_devices::hasSCSI, 'scsi', undef, {
+ "aha152x" => "Adaptec 152x",
+ "aha1542" => "Adaptec 1542",
+ "aha1740" => "Adaptec 1740",
+ "aic7xxx" => "Adaptec 2740, 2840, 2940",
+ "advansys" => "AdvanSys Adapters",
+ "in2000" => "Always IN2000",
+ "AM53C974" => "AMD SCSI",
+ "megaraid" => "AMI MegaRAID",
+ "BusLogic" => "BusLogic Adapters",
+ "dtc" => "DTC 3180/3280",
+ "eata_dma" => "EATA DMA Adapters",
+ "eata_pio" => "EATA PIO Adapters",
+ "seagate" => "Future Domain TMC-885, TMC-950",
+ "fdomain" => "Future Domain TMC-16x0",
+ "gdth" => "ICP Disk Array Controller",
+ "ppa" => "Iomega PPA3 (parallel port Zip)",
+ "g_NCR5380" => "NCR 5380",
+ "NCR53c406a" => "NCR 53c406a",
+ "53c7,8xx" => "NCR 53c7xx",
+ "ncr53c8xx" => "NCR 53C8xx PCI",
+ "pci2000" => "Perceptive Solutions PCI-2000",
+ "pas16" => "Pro Audio Spectrum/Studio 16",
+ "qlogicfas" => "Qlogic FAS",
+ "qlogicisp" => "Qlogic ISP",
+ "seagate" => "Seagate ST01/02",
+ "t128" => "Trantor T128/T128F/T228",
+ "u14-34f" => "UltraStor 14F/34F",
+ "ultrastor" => "UltraStor 14F/24F/34F",
+ "wd7000" => "Western Digital wd7000",
+}],
+[ 0, undef, 'cdrom', 'none', {
+ "sbpcd" => "SoundBlaster/Panasonic",
+ "aztcd" => "Aztech CD",
+ "bpcd" => "Backpack CDROM",
+ "gscd" => "Goldstar R420",
+ "mcd" => "Mitsumi",
+ "mcdx" => "Mitsumi (alternate)",
+ "optcd" => "Optics Storage 8000",
+ "cm206" => "Phillips CM206/CM260",
+ "sjcd" => "Sanyo",
+ "cdu31a" => "Sony CDU-31A",
+ "sonycd535" => "Sony CDU-5xx",
+}]
+);
+
+my %drivers = (
+ "plip" => [ "PLIP (parallel port)", 0, \&detect_devices::hasPlip, 'net', 'plip' ],
+ "ibmtr" => [ "Token Ring", 0, \&detect_devices::hasTokenRing, 'net', 'tr' ],
+ "DAC960" => [ "Mylex DAC960", 0, undef, 'scsi', undef ],
+ "pcmcia_core" => [ "PCMCIA core support", 0, undef, 'pcmcia', undef ],
+ "ds" => [ "PCMCIA card support", 0, undef, 'pcmcia', undef ],
+ "i82365" => [ "PCMCIA i82365 controller", 0, undef, 'pcmcia', undef ],
+ "tcic" => [ "PCMCIA tcic controller", 0, undef, 'pcmcia', undef ],
+ "isofs" => [ "iso9660", 0, undef, 'fs', undef ],
+ "nfs" => [ "Network File System (nfs)", 0, undef, 'fs', undef ],
+ "smbfs" => [ "Windows SMB", 0, undef, 'fs', undef ],
+ "loop" => [ "Loopback device", 0, undef, 'other', undef ],
+ "lp" => [ "Parallel Printer", 0, undef, 'other', undef ],
+);
+foreach (@drivers_by_category) {
+ my @l = @$_;
+ my $l = pop @l;
+ foreach (keys %$l) { $drivers{$_} = [ $l->{$_}, @l ]; }
+}
+
+
+1;
+
+
+sub load($;$$) {
+ my ($name, $type, $minor) = @_;
+
+ $loaded{$name} and return;
+
+ $type or ($type, $minor) = @{$drivers{$name}}[3,4];
+
+ foreach (@{$deps{$name}}) { load($_, 'prereq', $minor) }
+ load_raw($name, $type, $minor);
+}
+
+sub unload($) { run_program::run("/bin/rmmod", $_[0]); }
+
+sub load_raw($$$@) {
+ my ($name, $type, $minor, @options) = @_;
+
+# @options or @options = guiGetModuleOptions($name);
+
+ run_program::run("/usr/bin/insmod", "/modules/$name.o", @options) or die("insmod module $name");
+
+ # this is a hack to make plip go
+ if ($name eq "parport_pc") {
+ foreach (@options) {
+ /^irq=(\d+)/ or next;
+ log::l("writing to /proc/parport/0/irq");
+ local *F;
+ open F, "> /proc/parport/0/irq" or last;
+ print F $1;
+ }
+ }
+ $loaded{$name} = { type => $type, minor => $minor, options => \@options };
+}
+
+sub load_deps($) {
+ my ($file) = @_;
+
+ local *F;
+ open F, $file or log::l("error opening $file: $!"), return 0;
+ foreach (<F>) {
+ my ($f, $deps) = split ':';
+ push @{$deps{$f}}, split ' ', $deps;
+ }
+ 1;
+}
+
+sub read_conf {
+ my ($file) = @_;
+
+ local *F;
+ open F, $file or log::l("failed to open $file for module information"), return 0;
+
+ foreach (<F>) {
+ /^alias\s+eth0\s+(\S+)/ and $loaded{$1} = { type => 'net', minor => 'ethernet' };
+ /^alias\s+scsi_hostadapter\s+(\S+)/ and $loaded{$1} = { type => 'scsi' };
+ /^option\s+(\S+)\s+(.*)/ and $loaded{$1} = { type => 'other', options => [ split ' ', $2 ] };
+ }
+ 1;
+}
+
+sub write_conf {
+ my ($file, $append) = @_;
+ my ($tr, $eth, $scsi) = (0, 0, 0);
+
+ $::testing and return 1;
+
+ $append or rename($file, "$file.orig"), log::l("backing up old conf.modules");
+
+ local *F;
+ open F, ($append ? ">" : "") . "> $file" or die("cannot write module config file $file: $!\n");
+
+ while (my ($k, $v) = each %loaded) {
+ unless ($append && $v->{persistFlags}->{alias}) {
+ if ($v->{type} eq 'net') {
+ $v->{minor} eq 'tr' and print F "alias tr", $tr++, " $k\n";
+ $v->{minor} eq 'ethernet' and print F "alias eth", $eth++, " $k\n";
+ } elsif ($v->{type} eq 'scsi') {
+ print F "alias scsi_hostadapter", $scsi++, " $k\n";
+ }
+ }
+ unless ($append && $v->{persistFlags}->{options} || !$v->{options}) {
+ print F "options $k ", join(' ', @{$v->{options}}), "\n";
+ }
+ }
+
+ print F "alias parport_lowlevel parport_pc\n";
+ print F "pre-install pcmcia_core /etc/rc.d/init.d/pcmcia start\n";
+ 1;
+}
+
+
+
+sub load_thiskind($) {
+ my ($type) = @_;
+ my @devs;
+ my $found;
+
+ log::l("in load_thiskind, type = $type");
+
+ unless ($type eq 'scsi' || $type eq 'net') {
+ log::l("pci probing for $type devices");
+ @devs = pci::probe($type);
+ log::l("pci probe found " . scalar @devs . "$type devices");
+ }
+
+ my %devs;
+ foreach (@devs) {
+ my $m = $_->{module};
+ $devs{$m}++ and log::l("multiple $m devices found"), next;
+ $drivers{$m} or log::l("module $m not in install table"), next;
+ log::l("found driver for $m");
+ load($m);
+ $found = 1;
+ }
+ pci::free(@devs);
+ $found;
+}
+
+# This assumes only one of each driver type is loaded
+sub removeDeviceDriver {
+# my ($type) = @_;
+#
+# my @m = grep { $loaded{$_}->{type} eq $type } keys %loaded;
+# @m or return 0;
+# @m > 1 and log::l("removeDeviceDriver assume only one of each driver type is loaded, which is not the case (" . join(' ', @m) . ")");
+# removeModule($m[0]);
+# 1;
+}
+
+
diff --git a/perl-install/my_gtk.pm b/perl-install/my_gtk.pm
new file mode 100644
index 000000000..a6f1101d5
--- /dev/null
+++ b/perl-install/my_gtk.pm
@@ -0,0 +1,261 @@
+package my_gtk;
+
+use diagnostics;
+use strict;
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+
+@ISA = qw(Exporter);
+%EXPORT_TAGS = (
+ all => [ qw(create_window create_yesorno createScrolledWindow create_menu create_notebook create_packtable create_hbox create_adjustment mymain my_signal_connect mypack mypack_ myappend myadd label_align myset_usize myset_justify myshow mysync myflush mydestroy) ],
+);
+@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+
+use Gtk;
+
+1;
+
+
+sub new {
+ my ($type, $title, @opts) = @_;
+
+ Gtk->init;
+ parse Gtk::Rc "$ENV{HOME}/etc/any/Gtkrc";
+ my $o = bless { @opts }, $type;
+ $o->{window} = $o->create_window($title);
+ $o;
+}
+sub destroy($) {
+ my ($o) = @_;
+ $o->{window}->destroy;
+ myflush();
+}
+
+sub ask_from_entry($$@) {
+ my ($o, @msgs) = @_;
+ my $entry = new Gtk::Entry;
+ my $f = sub { $o->{retval} = $entry->get_text; Gtk->main_quit };
+
+ myadd($o->{window},
+ mypack($o->create_box_with_title(@msgs),
+ my_signal_connect($entry, 'activate' => $f),
+ ($o->{hide_buttons} ? () : mypack(new Gtk::HBox(0,0),
+ my_signal_connect(new Gtk::Button('Ok'), 'clicked' => $f),
+ my_signal_connect(new Gtk::Button('Cancel'), 'clicked' => sub { $o->{retval} = undef; Gtk->main_quit }),
+ )),
+ ),
+ );
+ $entry->grab_focus();
+ mymain($o);
+}
+
+
+sub ask_from_list($\@$@) {
+ my ($o, $l, @msgs) = @_;
+ my $f = sub { $o->{retval} = $_[1]; Gtk->main_quit };
+ my @l = map { my_signal_connect(new Gtk::Button($_), "clicked" => $f, $_) } @$l;
+
+# myadd($o->{window},
+# mypack_(myset_usize(new Gtk::VBox(0,0), 0, 200),
+# 0, $o->create_box_with_title(@msgs),
+# 1, createScrolledWindow(mypack(new Gtk::VBox(0,0), @l))));
+ myadd($o->{window},
+ mypack($o->create_box_with_title(@msgs), @l));
+ $l[0]->grab_focus();
+ mymain($o)
+}
+
+
+sub ask_warn($@) {
+ my ($o, @msgs) = @_;
+
+ myadd($o->{window},
+ mypack($o->create_box_with_title(@msgs),
+ my_signal_connect(my $w = new Gtk::Button("Ok"), "clicked" => sub { Gtk->main_quit }),
+ ),
+ );
+ $w->grab_focus();
+ mymain($o)
+}
+
+sub ask_yesorno($@) {
+ my ($o, @msgs) = @_;
+
+ myadd($o->{window},
+ mypack(create_box_with_title($o, @msgs),
+ create_yesorno($o),
+ )
+ );
+ $o->{ok}->grab_focus();
+ mymain($o)
+}
+
+sub create_window($$) {
+ my ($o, $title) = @_;
+ $o->{window} = new Gtk::Window;
+ $o->{window}->set_title($title);
+ $o->{window}->signal_connect("delete_event" => sub { $o->{retval} = undef; Gtk->main_quit });
+ $o->{window}
+}
+
+sub create_yesorno($) {
+ my ($w) = @_;
+
+ myadd(create_hbox(),
+ my_signal_connect($w->{ok} = new Gtk::Button("Ok"), "clicked" => sub { $w->{retval} = 1; Gtk->main_quit }),
+ my_signal_connect(new Gtk::Button("Cancel"), "clicked" => sub { $w->{retval} = 0; Gtk->main_quit }),
+ );
+}
+
+sub create_box_with_title($@) {
+ my $o = shift;
+ $o->{box} = mypack(new Gtk::VBox(0,0),
+ map({ new Gtk::Label(" $_ ") } @_),
+ new Gtk::HSeparator,
+ )
+}
+
+sub createScrolledWindow($) {
+ my $w = new Gtk::ScrolledWindow(undef, undef);
+ $w->set_policy('automatic', 'automatic');
+ $w->add_with_viewport($_[0]);
+ $_[0]->show;
+ $w
+}
+
+sub create_menu($@) {
+ my $title = shift;
+ my $w = new Gtk::MenuItem($title);
+ $w->set_submenu(myshow(myappend(new Gtk::Menu, @_)));
+ $w
+}
+
+sub create_notebook(@) {
+ my $n = new Gtk::Notebook;
+ while (@_) {
+ my $title = shift;
+ my $book = shift;
+
+ my ($w1, $w2) = map { new Gtk::Label($_) } $title, $title;
+ $n->append_page_menu($book, $w1, $w2);
+ $book->show;
+ $w1->show;
+ $w2->show;
+ }
+ $n
+}
+
+sub create_adjustment($$$) {
+ my ($val, $min, $max) = @_;
+ new Gtk::Adjustment($val, $min, $max + 1, 1, ($max - $min + 1) / 10, 1);
+}
+
+sub create_packtable($@) {
+ my $options = shift;
+ my $w = new Gtk::Table(0, 0, $options->{homogeneous} || 0);
+ my $i = 0; foreach (@_) {
+ for (my $j = 0; $j < @$_; $j++) {
+ if (defined $_->[$j]) {
+ my $l = $_->[$j];
+ ref $l or $l = new Gtk::Label($l);
+ $w->attach_defaults($l, $j, $j + 1, $i, $i + 1);
+ $l->show;
+ }
+ }
+ $i++;
+ }
+ $w->set_col_spacings($options->{col_spacings} || 0);
+ $w->set_row_spacings($options->{row_spacings} || 0);
+ $w
+}
+
+sub create_hbox {
+ my $w = new Gtk::HButtonBox;
+ $w->set_layout(-spread);
+ $w;
+}
+
+sub mymain($) {
+ my $o = shift;
+
+ $o->{window}->show;
+ Gtk->main;
+ $o->{window}->destroy;
+ myflush();
+ $o->{retval}
+}
+
+sub my_signal_connect($@) {
+ my $w = shift;
+ $w->signal_connect(@_);
+ $w
+}
+
+sub mypack($@) {
+ my $box = shift;
+ foreach (@_) {
+ my $l = $_;
+ ref $l or $l = new Gtk::Label($l);
+ $box->pack_start($l, 1, 1, 0);
+ $l->show;
+ }
+ $box
+}
+
+sub mypack_($@) {
+ my $box = shift;
+ for (my $i = 0; $i < @_; $i += 2) {
+ my $l = $_[$i + 1];
+ ref $l or $l = new Gtk::Label($l);
+ $box->pack_start($l, $_[$i], 1, 0);
+ $_[$i + 1]->show;
+ }
+ $box
+}
+
+sub myappend($@) {
+ my $w = shift;
+ foreach (@_) {
+ my $l = $_;
+ ref $l or $l = new Gtk::Label($l);
+ $w->append($l);
+ $l->show;
+ }
+ $w
+}
+sub myadd($@) {
+ my $w = shift;
+ foreach (@_) {
+ my $l = $_;
+ ref $l or $l = new Gtk::Label($l);
+ $w->add($l);
+ $l->show;
+ }
+ $w
+}
+sub myshow($) { $_[0]->show; $_[0] }
+
+sub mysync(;$) {
+ my ($o) = @_;
+ $o and $o->{window}->show;
+
+ my $h = Gtk->idle_add(sub { Gtk->main_quit; 1 });
+ map { Gtk->main } (1..4);
+ Gtk->idle_remove($h);
+}
+sub myflush(;$) {
+ Gtk->main_iteration while Gtk::Gdk->events_pending;
+}
+
+
+
+sub bigsize($) { $_[0]->{window}->set_usize(600,400); }
+sub myset_usize($$$) { $_[0]->set_usize($_[1],$_[2]); $_[0] }
+sub myset_justify($$) { $_[0]->set_justify($_[1]); $_[0] }
+sub mydestroy($) { $_[0] and $_[0]->destroy }
+
+sub label_align($$) {
+ my $w = shift;
+ local $_ = shift;
+ $w->set_alignment(!/W/i, !/N/i);
+ $w
+}
diff --git a/perl-install/partition_table.pm b/perl-install/partition_table.pm
new file mode 100644
index 000000000..a7d06fb21
--- /dev/null
+++ b/perl-install/partition_table.pm
@@ -0,0 +1,333 @@
+package partition_table;
+
+use diagnostics;
+use strict;
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK @important_types);
+
+@ISA = qw(Exporter);
+%EXPORT_TAGS = (
+ types => [ qw(type2name type2fs name2type fs2type isExtended isExt2 isSwap isDos isWin isPrimary isNfs) ],
+);
+@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+
+
+use common qw(:common :system);
+use partition_table_raw;
+
+
+@important_types = ("Linux native", "Linux swap", "DOS FAT16");
+
+my %types = (
+ 0 => "Empty",
+ 1 => "DOS 12-bit FAT",
+ 2 => "XENIX root",
+ 3 => "XENIX usr",
+ 4 => "DOS 16-bit <32M",
+ 5 => "Extended",
+ 6 => "DOS FAT16",
+ 7 => "OS/2 HPFS", # or QNX?
+ 8 => "AIX",
+ 9 => "AIX bootable",
+ 10 => "OS/2 Boot Manager",
+ 0xb => "Win98 FAT32",
+ 0xc => "Win98 FAT32 0xb",
+ 0xe => "Win98 FAT32 0xc",
+ 0x12 => "Compaq setup",
+ 0x40 => "Venix 80286",
+ 0x51 => "Novell?",
+ 0x52 => "Microport", # or CPM?
+ 0x63 => "GNU HURD", # or System V/386?
+ 0x64 => "Novell Netware 286",
+ 0x65 => "Novell Netware 386",
+ 0x75 => "PC/IX",
+ 0x80 => "Old MINIX", # Minix 1.4a and earlier
+
+ 0x81 => "Linux/MINIX", # Minix 1.4b and later
+ 0x82 => "Linux swap",
+ 0x83 => "Linux native",
+
+ 0x93 => "Amoeba",
+ 0x94 => "Amoeba BBT", # (bad block table)
+ 0xa5 => "BSD/386",
+ 0xb7 => "BSDI fs",
+ 0xb8 => "BSDI swap",
+ 0xc7 => "Syrinx",
+ 0xdb => "CP/M", # or Concurrent DOS?
+ 0xe1 => "DOS access",
+ 0xe3 => "DOS R/O",
+ 0xf2 => "DOS secondary",
+ 0xff => "BBT" # (bad track table)
+);
+
+my %type2fs = (
+ 0x01 => 'vfat',
+ 0x04 => 'vfat',
+ 0x05 => 'ignore',
+ 0x06 => 'vfat',
+ 0x07 => 'hpfs',
+ 0x0b => 'vfat',
+ 0x0c => 'vfat',
+ 0x0e => 'vfat',
+ 0x82 => 'swap',
+ 0x83 => 'ext2',
+ nfs => 'nfs', # hack
+);
+my %types_rev = reverse %types;
+my %fs2type = reverse %type2fs;
+
+
+1;
+
+sub type2name($) { $types{$_[0]} }
+sub type2fs($) { $type2fs{$_[0]} }
+sub name2type($) { $types_rev{$_[0]} }
+sub fs2type($) { $fs2type{$_[0]} }
+
+sub isExtended($) { $_[0]->{type} == 5 }
+sub isSwap($) { $type2fs{$_[0]->{type}} eq 'swap' }
+sub isExt2($) { $type2fs{$_[0]->{type}} eq 'ext2' }
+sub isDos($) { $ {{ 1=>1, 4=>1, 6=>1 }}{$_[0]->{type}} }
+sub isWin($) { $ {{ 0xb=>1, 0xc=>1, 0xe=>1 }}{$_[0]->{type}} }
+sub isNfs($) { $_[0]->{type} eq 'nfs' } # small hack
+
+sub isPrimary($$) {
+ my ($part, $hd) = @_;
+ foreach (@{$hd->{primary}->{raw}}) { $part eq $_ and return 1; }
+ 0;
+}
+
+sub cylinder_size($) {
+ my ($hd) = @_;
+ $hd->{geom}->{sectors} * $hd->{geom}->{heads};
+}
+
+sub adjustStart($$) {
+ my ($hd, $part) = @_;
+ my $end = $part->{start} + $part->{size};
+
+ $part->{start} = round_up($part->{start},
+ $part->{start} % cylinder_size($hd) < 2 * $hd->{geom}->{sectors} ?
+ $hd->{geom}->{sectors} : cylinder_size($hd));
+ $part->{size} = $end - $part->{start};
+}
+sub adjustEnd($$) {
+ my ($hd, $part) = @_;
+ my $end = $part->{start} + $part->{size};
+
+ $end = round_down($end, cylinder_size($hd));
+ $part->{size} = $end - $part->{start};
+}
+sub adjustStartAndEnd($$) {
+ &adjustStart;
+ &adjustEnd;
+}
+
+sub verifyNotOverlap($$) {
+ my ($a, $b) = @_;
+ $a->{start} + $a->{size} <= $b->{start} || $b->{start} + $b->{size} <= $a->{start};
+}
+sub verifyInside($$) {
+ my ($a, $b) = @_;
+ $b->{start} <= $a->{start} && $a->{start} + $a->{size} <= $b->{start} + $b->{size};
+}
+
+sub assign_device_numbers($) {
+ my ($hd) = @_;
+
+ my $i = 1; foreach (@{$hd->{primary}->{raw}}, map { $_->{normal} } @{$hd->{extended}}) {
+ $_->{device} = $hd->{prefix} . $i++;
+ }
+}
+
+sub get_normal_parts($) {
+ my ($hd) = @_;
+
+ @{$hd->{primary}->{normal} || []}, map { $_->{normal} } @{$hd->{extended} || []}
+}
+
+
+sub read_one($$) {
+ my ($hd, $sector) = @_;
+
+ my $pt = partition_table_raw::read($hd, $sector) or return;
+
+ my @extended = grep { isExtended($_) } @$pt;
+ my @normal = grep { $_->{size} && $_->{type} && !isExtended($_) } @$pt;
+
+ @extended > 1 and die "more than one extended partition";
+
+ foreach (@normal, @extended) {
+ $_->{rootDevice} = $hd->{device};
+ }
+ { raw => $pt, extended => $extended[0], normal => \@normal };
+}
+
+sub read($;$) {
+ my ($hd, $clearall) = @_;
+ my $pt = $clearall ? { raw => [ {}, {}, {}, {} ] } : read_one($hd, 0) || return 0;
+
+ $hd->{primary} = $pt;
+ $hd->{extended} = undef;
+ $clearall and return $hd->{isDirty} = 1;
+
+ my @l = (@{$pt->{normal}}, $pt->{extended});
+ foreach my $i (@l) { foreach (@l) {
+ $i != $_ and verifyNotOverlap($i, $_) || die "partitions $i->{device} and $_->{device} are overlapping!";
+ }}
+
+ eval {
+ $pt->{extended} and read_extended($hd, $pt->{extended}) || return 0;
+ }; die "extended partition: $@" if $@;
+ assign_device_numbers($hd);
+ 1;
+}
+
+sub read_extended($$) {
+ my ($hd, $extended) = @_;
+
+ my $pt = read_one($hd, $extended->{start}) or return 0;
+ $pt = { %$extended, %$pt };
+
+ push @{$hd->{extended}}, $pt;
+ @{$hd->{extended}} > 100 and die "oops, seems like we're looping here :( (or you have more than 100 extended partitions!)";
+
+ @{$pt->{normal}} <= 1 or die "more than one normal partition in extended partition";
+ @{$pt->{normal}} >= 1 or die "no normal partition in extended partition";
+ $pt->{normal} = $pt->{normal}->[0];
+ # in case of extended partitions, the start sector is local to the partition or to the first extended_part!
+ $pt->{normal}->{start} += $pt->{start};
+
+ verifyInside($pt->{normal}, $extended) or die "partition $pt->{normal}->{device} is not inside its extended partition";
+
+ if ($pt->{extended}) {
+ $pt->{extended}->{start} += $hd->{primary}->{extended}->{start};
+ read_extended($hd, $pt->{extended}) or return 0;
+ }
+ 1;
+}
+
+# give a hard drive hd, write the partition data
+sub write($) {
+ my ($hd) = @_;
+
+ # set first primary partition active if no primary partitions are marked as active.
+ for ($hd->{primary}->{raw}) {
+ (grep { $_->{local_start} = $_->{start}; $_->{active} ||= 0 } @$_) or $_->[0]->{active} = 0x80;
+ }
+ partition_table_raw::write($hd, 0, $hd->{primary}->{raw}) or die "writing of partition table failed";
+
+ foreach (@{$hd->{extended}}) {
+ # in case of extended partitions, the start sector must be local to the partition
+ $_->{normal}->{local_start} = $_->{normal}->{start} - $_->{start};
+ $_->{extended} and $_->{extended}->{local_start} = $_->{extended}->{start} - $hd->{primary}->{extended}->{start};
+
+ partition_table_raw::write($hd, $_->{start}, $_->{raw}) or die "writing of partition table failed";
+ }
+ $hd->{isDirty} = 0;
+
+ # now sync disk and re-read the partition table
+ sync();
+ partition_table_raw::kernel_read($hd);
+}
+
+sub active($$) {
+ my ($hd, $part) = @_;
+
+ foreach (@{$hd->{primary}->{normal}}) { $_->{active} = 0; }
+ $part->{active} = 0x80;
+}
+
+
+# remove a normal partition from hard drive hd
+sub remove($$) {
+ my ($hd, $part) = @_;
+ my $i;
+
+ # first search it in the primary partitions
+ $i = 0; foreach (@{$hd->{primary}->{normal}}) {
+ if ($_ eq $part) {
+ splice(@{$hd->{primary}->{normal}}, $i, 1);
+ %$_ = ();
+
+ return $hd->{isDirty} = 1;
+ }
+ $i++;
+ }
+ # otherwise search it in extended partitions
+ my $last = $hd->{primary}->{extended};
+ $i = 0; foreach (@{$hd->{extended}}) {
+ if ($_->{normal} eq $part) {
+ %{$last->{extended}} = $_->{extended} ? %{$_->{extended}} : ();
+ splice(@{$hd->{extended}}, $i, 1);
+
+ return $hd->{isDirty} = 1;
+ }
+ $last = $_;
+ $i++;
+ }
+ 0;
+}
+
+# create of partition at starting at `start', of size `size' and of type `type' (nice comment, uh?)
+# !be carefull!, no verification is done (start -> start+size must be free)
+sub add($$) {
+ my ($hd, $part) = @_;
+
+ $part->{notFormatted} = 1;
+ $part->{isFormatted} = 0;
+ $part->{rootDevice} = $hd->{device};
+ $hd->{isDirty} = 1;
+ adjustStartAndEnd($hd, $part);
+
+ if (is_empty_array_ref($hd->{primary}->{normal})) {
+ raw_add($hd->{primary}->{raw}, $part);
+ @{$hd->{primary}->{normal}} = $part;
+ } else {
+ foreach (@{$hd->{extended}}) {
+ $_->{normal} and next;
+ raw_add($_->{raw}, $part);
+ $_->{normal} = $part;
+ return;
+ }
+ my ($ext, $ext_size) = is_empty_array_ref($hd->{extended}) ?
+ ($hd->{primary}, $hd->{totalsectors} - $part->{start}) :
+ (top(@{$hd->{extended}}), $part->{size});
+ my %ext = ( type => 5, start => $part->{start}, size => $ext_size );
+
+ raw_add($ext->{raw}, \%ext);
+ $ext->{extended} = \%ext;
+ push @{$hd->{extended}}, { %ext, raw => [ $part, {}, {}, {} ], normal => $part };
+
+ $part->{start}++; $part->{size}--; # let it start after the extended partition sector
+ adjustStartAndEnd($hd, $part);
+ }
+}
+
+# search for the next partition
+sub next($$) {
+ my ($hd, $part) = @_;
+
+ first(
+ sort { $a->{start} <=> $b->{start} }
+ grep { $_->{start} >= $part->{start} + $part->{size} }
+ get_normal_parts($hd)
+ );
+}
+sub next_start($$) {
+ my ($hd, $part) = @_;
+ my $next = &next($hd, $part);
+ $next ? $next->{start} : $hd->{totalsectors};
+}
+
+
+sub raw_add($$) {
+ my ($raw, $part) = @_;
+
+ foreach (@$raw) {
+ $_->{size} || $_->{type} and next;
+ $_ = $part;
+ return;
+ }
+ die "raw_add: partition table already full";
+}
+
diff --git a/perl-install/partition_table_raw.pm b/perl-install/partition_table_raw.pm
new file mode 100644
index 000000000..d85789a50
--- /dev/null
+++ b/perl-install/partition_table_raw.pm
@@ -0,0 +1,101 @@
+package partition_table_raw;
+
+use diagnostics;
+use strict;
+
+use common qw(:common :system);
+use c;
+
+my @fields = qw(active start_head start_sec start_cyl type end_head end_sec end_cyl start size);
+my $format = "C8 I2";
+my $magic = "\x55\xAA";
+my $nb_primary = 4;
+
+my $offset = $common::SECTORSIZE - length($magic) - $nb_primary * common::psizeof($format);
+
+1;
+
+
+sub compute_CHS($$) {
+ my ($hd, $e) = @_;
+ my @l = qw(cyl head sec);
+ @$e{map { "start_$_" } @l} = $e->{start} || $e->{type} ? CHS2rawCHS(sector2CHS($hd, $e->{start})) : (0,0,0);
+ @$e{map { "end_$_" } @l} = $e->{start} || $e->{type} ? CHS2rawCHS(sector2CHS($hd, $e->{start} + $e->{size} - 1)) : (0,0,0);
+ 1;
+}
+
+sub CHS2rawCHS($$$) {
+ my ($c, $h, $s) = @_;
+ $c = min($c, 1023); # no way to have a #cylinder >= 1024
+ ($c & 0xff, $h, $s | ($c >> 2 & 0xc0));
+}
+
+# returns (cylinder, head, sector)
+sub sector2CHS($$) {
+ my ($hd, $start) = @_;
+ my ($s, $h);
+ ($start, $s) = divide($start, $hd->{geom}->{sectors});
+ ($start, $h) = divide($start, $hd->{geom}->{heads});
+ ($start, $h, $s + 1);
+}
+
+sub get_geometry($) {
+ my ($dev) = @_;
+ my $g = "";
+
+ local *F; sysopen F, $dev, 0 or return;
+ ioctl(F, c::HDIO_GETGEO(), $g) or return;
+
+ my %geom; @geom{qw(heads sectors cylinders start)} = unpack "CCSL", $g;
+
+ { geom => \%geom, totalsectors => $geom{heads} * $geom{sectors} * $geom{cylinders} };
+}
+
+sub openit($$;$) { sysopen $_[1], $_[0]->{file}, $_[2] || 0; }
+
+# cause kernel to re-read partition table
+sub kernel_read($) {
+ my ($hd) = @_;
+ local *F; openit($hd, \*F) or return 0;
+ ioctl(F, c::BLKRRPART(), 0) or die "kernel_read failed: need to reboot";
+}
+
+sub read($$) {
+ my ($hd, $sector) = @_;
+ my $tmp;
+
+ local *F; openit($hd, \*F) or return;
+ c::lseek_sector(fileno(F), $sector, $offset) or die "reading of partition in sector $sector failed";
+
+ my @pt = map {
+ sysread F, $tmp, psizeof($format) or return "error while reading partition table in sector $sector";
+ my %h; @h{@fields} = unpack $format, $tmp;
+ \%h;
+ } (1..$nb_primary);
+
+ # check magic number
+ sysread F, $tmp, length $magic or die "error reading magic number";
+ $tmp eq $magic or die "bad magic number";
+
+ [ @pt ];
+}
+
+# write the partition table (and extended ones)
+# for each entry, it uses fields: start, size, type, active
+sub write($$$) {
+ my ($hd, $sector, $pt) = @_;
+
+ local *F; openit($hd, \*F, 2) or die "error opening device $hd->{device} for writing";
+ c::lseek_sector(fileno(F), $sector, $offset) or return 0;
+
+ @$pt == $nb_primary or die "partition table does not have $nb_primary entries";
+ foreach (@$pt) {
+ compute_CHS($hd, $_);
+ local $_->{start} = $_->{local_start} || 0;
+ $_->{active} ||= 0; $_->{type} ||= 0; $_->{size} ||= 0; # for no warning
+ syswrite F, pack($format, @$_{@fields}) or return 0;
+ }
+ syswrite F, $magic or return 0;
+ 1;
+}
+sub zero_MBR($) { &write($_[0], 0, [ {} x $nb_primary ]); }
diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm
new file mode 100644
index 000000000..1f4764d22
--- /dev/null
+++ b/perl-install/pkgs.pm
@@ -0,0 +1,211 @@
+package pkgs;
+
+use diagnostics;
+use strict;
+
+use common qw(:common :file);
+use log;
+use smp;
+use fs;
+
+my @skipList = qw(XFree86-8514 XFree86-AGX XFree86-Mach32 XFree86-Mach64 XFree86-Mach8 XFree86-Mono
+ XFree86-P9000 XFree86-S3 XFree86-S3V XFree86-SVGA XFree86-W32 XFree86-I128
+ XFree86-Sun XFree86-SunMono XFree86-Sun24 XFree86-3DLabs kernel-boot
+ metroess metrotmpl);
+
+1;
+
+
+sub psUsingDirectory {
+ my ($dirname) = @_;
+ my %packages;
+
+ log::l("scanning $dirname for packages");
+ foreach (glob_("$dirname/*.rpm")) {
+ my $basename = basename($_);
+ local *F;
+ open F, $_ or log::l("failed to open package $_: $!");
+ my $header = c::rpmReadPackageHeader($_) or log::l("failed to rpmReadPackageHeader $basename: $!");
+ my $name = c::headerGetEntry($header, 'name');
+
+ $packages{lc $name} = {
+ header => $header, selected => 0, manuallySelected => 0, name => $name,
+ size => c::headerGetEntry($header, 'size'),
+ group => c::headerGetEntry($header, 'group') || "(unknown group)",
+ inmenu => skipPackage($name),
+ };
+ }
+ \%packages;
+}
+
+sub psReadComponentsFile {
+ my ($compsfile, $packages) = @_;
+ my (%comps, %current);
+
+ local *F;
+ open F, $compsfile or die "Cannot open components file: $!";
+
+ <F> =~ /^0(\.1)?$/ or die "Comps file is not version 0.1 as expected";
+
+ my $inComp = 0;
+ my $n = 0;
+ foreach (<F>) { $n++;
+ chomp;
+ s/^ +//;
+ /^#/ and next;
+ /^$/ and next;
+
+ if ($inComp) { if (/^end$/) {
+ $inComp = 0;
+ $comps{lc $current{name}} = { %current };
+ } else {
+ push @{$current{packages}}, $packages->{lc $_} || log::w "package $_ does not exist (line $n of comps file)";
+ }
+ } else {
+ my ($selected, $hidden, $name) = /^([01])\s*(--hide)?\s*(.*)/ or die "bad comps file at line $n";
+ %current = (selected => $selected, inmenu => !$hidden, name => $name);
+ $inComp = 1;
+ }
+ }
+ log::l("read " . (scalar keys %comps) . " comps");
+ \%comps;
+}
+
+
+
+sub psVerifyDependencies {
+# my ($packages, $fixup) = @_;
+#
+# -r "/mnt/var/lib/rpm/packages.rpm" or die "can't find packages.rpm";
+#
+# my $db = rpmdbOpenRWCreate("/mnt");
+# my $rpmdeps = rpmtransCreateSet($db, undef);
+#
+# foreach (values %$packages) {
+# $_->{selected} ?
+# c::rpmtransAddPackage($rpmdeps, $_->{header}, undef, $_, 0, undef) :
+# c::rpmtransAvailablePackage($rpmdeps, $_->{header}, $_);
+# }
+# my @conflicts = c::rpmdepCheck($rpmdeps);
+#
+# rpmtransFree($rpmdeps);
+# rpmdbClose($db);
+#
+# if ($fixup) {
+# foreach (@conflicts) {
+# $_->{suggestedPackage}->{selected} = 1;
+# }
+# rpmdepFreeConflicts(@conflicts);
+# }
+#
+# 1;
+}
+
+sub selectComponents {
+ my ($csp, $psp, $doIndividual) = @_;
+
+ return 0;
+}
+
+sub psFromHeaderListDesc {
+ my ($fd, $noSeek) = @_;
+ my %packages;
+ my $end;
+
+ unless ($noSeek) {
+ my $current = sysseek $fd, 0, 1 or die "seek failed";
+ $end = sysseek $fd, 0, 2 or die "seek failed";
+ sysseek $fd, $current, 0 or die "seek failed";
+ }
+
+ while (1) {
+ my $header = c::headerRead(fileno($fd), 1);
+ unless ($header) {
+ $noSeek and last;
+ die "error reading header at offset ", sysseek($fd, 0, 1);
+ }
+
+ my $name = c::headerGetEntry($header, 'name');
+
+ $packages{lc $name} = {
+ header => $header, size => c::headerGetEntry($header, 'size'),
+ inmenu => skipPackage($name), name => $name,
+ group => c::headerGetEntry($header, 'group') || "(unknown group)",
+ };
+
+ $noSeek or $end <= sysseek($fd, 0, 1) and last;
+ }
+
+ log::l("psFromHeaderListDesc read " . scalar keys(%packages) . " headers");
+
+ \%packages;
+}
+
+sub psFromHeaderListFile {
+ my ($file) = @_;
+ local *F;
+ sysopen F, $file, 0 or die "error opening header file: $!";
+ psFromHeaderListDesc(\*F, 0);
+}
+
+sub skipPackage { member($_[0], @skipList) }
+
+sub printSize { }
+sub printGroup { }
+sub printPkg { }
+sub selectPackagesByGroup { }
+sub showPackageInfo { }
+sub queryIndividual { }
+
+
+sub install {
+ my ($rootPath, $method, $packages, $isUpgrade, $force) = @_;
+
+ my $f = "$rootPath/tmp/" . ($isUpgrade ? "upgrade" : "install") . ".log";
+ local *F;
+ open(F, "> $f") ? log::l("opened $f") : log::l("Failed to open $f. No upgrade log will be kept.");
+ my $fd = fileno(F) || log::fd() || 2;
+ c::rpmErrorSetCallback($fd);
+# c::rpmSetVeryVerbose();
+
+ # FIXME: we ought to read /mnt/us/lib/rpmrc if we're in the midst of an upgrade, but it's not obvious how to get RPM to do that.
+ # if we set netshared path to "" then we get no files installed
+ # addMacro(&globalMacroContext, "_netsharedpath", NULL, netSharedPath ? netSharedPath : "" , RMIL_RPMRC);
+
+ $isUpgrade ? c::rpmdbRebuild($rootPath) : c::rpmdbInit($rootPath, 0644) or die "creation/rebuilding of rpm database failed: ", c::rpmErrorString();
+
+ my $db = c::rpmdbOpen($rootPath) or die "error opening RPM database: ", c::rpmErrorString();
+ log::l("opened rpm database");
+
+ my $trans = c::rpmtransCreateSet($db, $rootPath);
+
+ my ($total, $nb);
+
+ foreach my $p ($packages->{basesystem},
+ grep { $_->{selected} && $_->{name} ne "basesystem" } values %$packages) {
+ my $fullname = sprintf "%s-%s-%s.%s.rpm",
+ $p->{name},
+ map { c::headerGetEntry($p->{header}, $_) } qw(version release arch);
+ c::rpmtransAddPackage($trans, $p->{header}, $method->getFile($fullname) , $isUpgrade);
+ $nb++;
+ $total += $p->{size};
+ }
+
+ c::rpmdepOrder($trans) or c::rpmdbClose($db), c::rpmtransFree($trans), die "error ordering package list: ", c::rpmErrorString();
+ c::rpmtransSetScriptFd($trans, $fd);
+
+ eval { fs::mount("/proc", "$rootPath/proc", "proc", 0) };
+
+ log::ld("starting installation: ", $nb, " packages, ", $total, " bytes");
+
+ # !! do not translate these messages, they are used when catched (cf install_steps_graphical)
+ my $callbackStart = sub { log::ld("starting installing package ", $_[0]) };
+ my $callbackProgress = sub { log::ld("progressing installation ", $_[0], "/", $_[1]) };
+
+ if (my @probs = c::rpmRunTransactions($trans, $callbackStart, $callbackProgress, $force)) {
+ die "installation of rpms failed:\n ", join("\n ", @probs);
+ }
+ c::rpmtransFree($trans);
+ c::rpmdbClose($db);
+ log::l("rpm database closed");
+}
diff --git a/perl-install/resize_fat/Makefile b/perl-install/resize_fat/Makefile
new file mode 100644
index 000000000..34c257a4e
--- /dev/null
+++ b/perl-install/resize_fat/Makefile
@@ -0,0 +1,12 @@
+PRODUCT = libresize
+TARSOURCE = $(PRODUCT).tar.bz2
+
+.PHONY: clean tar
+
+clean:
+ rm -f *~ TAGS $(TARSOURCE)
+
+tar: clean
+ cp -f ../common.pm .
+ cd .. ; tar cfy $(TARSOURCE) $(PRODUCT) ; mv $(TARSOURCE) $(PRODUCT)
+ rm -f common.pm
diff --git a/perl-install/resize_fat/README b/perl-install/resize_fat/README
new file mode 100644
index 000000000..2910c06c3
--- /dev/null
+++ b/perl-install/resize_fat/README
@@ -0,0 +1,6 @@
+just do ./resize.pm and look at usage.
+
+
+BUGS:
+no known bugs :)
+if you found one, please mail pixel@linux-mandrake.com !!
diff --git a/perl-install/resize_fat/any.pm b/perl-install/resize_fat/any.pm
new file mode 100644
index 000000000..d78a342be
--- /dev/null
+++ b/perl-install/resize_fat/any.pm
@@ -0,0 +1,82 @@
+package resize_fat::any;
+
+use diagnostics;
+use strict;
+use vars qw($FREE $FILE $DIRECTORY);
+
+use common qw(:common :constant);
+use resize_fat::fat;
+use resize_fat::directory;
+use resize_fat::dir_entry;
+
+
+$FREE = 0;
+$FILE = 1;
+$DIRECTORY = 2;
+
+
+1;
+
+
+# returns the number of clusters for a given filesystem type
+sub min_cluster_count($) {
+ my ($fs) = @_;
+ (1 << $ {{ FAT16 => 12, FAT32 => 16 }}{$fs->{fs_type}}) - 12;
+}
+sub max_cluster_count($) {
+ my ($fs) = @_;
+ $resize_fat::bad_cluster_value - 2;
+}
+
+
+
+# calculates the minimum size of a partition, in physical sectors
+sub min_size($) {
+ my ($fs) = @_;
+ my $count = $fs->{clusters}->{count};
+
+ # directories are both in `used' and `dirs', so are counted twice
+ # It's done on purpose since we're moving all directories. So at the worse
+ # moment, 2 directories are there, but that way nothing wrong can happen :)
+ my $min_cluster_count = max(2 + $count->{used} + $count->{bad} + $count->{dirs}, min_cluster_count($fs));
+
+ $min_cluster_count * divide($fs->{cluster_size}, $SECTORSIZE) +
+ divide($fs->{cluster_offset}, $SECTORSIZE);
+}
+# calculates the maximum size of a partition, in physical sectors
+sub max_size($) {
+ my ($fs) = @_;
+
+ my $max_cluster_count = min($fs->{nb_fat_entries} - 2, max_cluster_count($fs));
+
+ $max_cluster_count * divide($fs->{cluster_size}, $SECTORSIZE) +
+ divide($fs->{cluster_offset}, $SECTORSIZE);
+}
+
+# fills in $fs->{fat_flag_map}.
+# Each FAT entry is flagged as either FREE, FILE or DIRECTORY.
+sub flag_clusters {
+ my ($fs) = @_;
+ my ($cluster, $entry, $type);
+
+ my $f = sub {
+ ($entry) = @_;
+ $cluster = resize_fat::dir_entry::get_cluster($entry);
+
+ if (resize_fat::dir_entry::is_file($entry)) {
+ $type = $FILE;
+ } elsif (resize_fat::dir_entry::is_directory($entry)) {
+ $type = $DIRECTORY;
+ } else { return }
+
+ for (; !resize_fat::fat::is_eof($cluster); $cluster = resize_fat::fat::next($fs, $cluster)) {
+ $cluster == 0 and die "Bad FAT: unterminated chain for $entry->{name}\n";
+ $fs->{fat_flag_map}->[$cluster] and die "Bad FAT: cluster $cluster is cross-linked for $entry->{name}\n";
+ $fs->{fat_flag_map}->[$cluster] = $type;
+ $fs->{clusters}->{count}->{dirs}++ if $type == $DIRECTORY;
+ }
+ };
+ $fs->{fat_flag_map} = [ ($FREE) x ($fs->{nb_clusters} + 2) ];
+ $fs->{clusters}->{count}->{dirs} = 0;
+ resize_fat::directory::traverse_all($fs, $f);
+}
diff --git a/perl-install/resize_fat/boot_sector.pm b/perl-install/resize_fat/boot_sector.pm
new file mode 100644
index 000000000..c236b1617
--- /dev/null
+++ b/perl-install/resize_fat/boot_sector.pm
@@ -0,0 +1,106 @@
+package resize_fat::boot_sector;
+
+use diagnostics;
+use strict;
+
+use common qw(:common :system :constant);
+use resize_fat::io;
+use resize_fat::any;
+use resize_fat::directory;
+
+
+my $format = "a3 a8 S C S C S S C S S S I I I S S I S S a458 S";
+my @fields = (
+ 'boot_jump', # boot strap short or near jump
+ 'system_id', # Name - can be used to special case partition manager volumes
+ 'sector_size', # bytes per logical sector
+ 'cluster_size_in_sectors', # sectors/cluster
+ 'nb_reserved', # reserved sectors
+ 'nb_fats', # number of FATs
+ 'nb_root_dir_entries', # number of root directory entries
+ 'small_nb_sectors', # number of sectors: big_nb_sectors supersedes
+ 'media', # media code
+ 'fat16_fat_length', # sectors/FAT for FAT12/16
+ 'sectors_per_track',
+ 'nb_heads',
+ 'nb_hidden', # (unused)
+ 'big_nb_sectors', # number of sectors (if small_nb_sectors == 0)
+
+# FAT32-only entries
+ 'fat32_fat_length', # size of FAT in sectors
+ 'fat32_flags', # bit8: fat mirroring,
+ # low4: active fat
+ 'fat32_version', # minor * 256 + major
+ 'fat32_root_dir_cluster',
+ 'info_offset_in_sectors',
+ 'fat32_backup_sector',
+
+# Common again...
+ 'boot_code', # Boot code (or message)
+ 'boot_sign', # 0xAA55
+);
+
+1;
+
+
+# trimfs_init_boot_sector() - reads in the boot sector - gets important info out
+# of boot sector, and puts in main structure - performs sanity checks - returns 1
+# on success, 0 on failureparameters: filesystem an empty structure to fill.
+sub read($) {
+ my ($fs) = @_;
+
+ my $boot = eval { resize_fat::io::read($fs, 0, $SECTORSIZE) }; $@ and die "reading boot sector failed on device $fs->{fs_name}";
+ @{$fs}{@fields} = unpack $format, $boot;
+
+ $fs->{nb_sectors} = $fs->{small_nb_sectors} || $fs->{big_nb_sectors};
+ $fs->{cluster_size} = $fs->{cluster_size_in_sectors} * $fs->{sector_size};
+
+ $fs->{boot_sign} == 0xAA55 or die "Invalid signature for a MS-based filesystem.";
+ $fs->{nb_fats} == 2 or die "Weird number of FATs: $fs->{nb_fats}, not 2.",
+ $fs->{nb_sectors} < 32 and die "Too few sectors for viable file system\n";
+
+ if ($fs->{fat16_fat_length}) {
+ # asserting FAT16, will be verified later on
+ $fs->{fs_type} = 'FAT16';
+ $fs->{fs_type_size} = 16;
+ $fs->{fat_length} = $fs->{fat16_fat_length};
+ } else {
+ $resize_fat::isFAT32 = 1;
+ $fs->{fs_type} = 'FAT32';
+ $fs->{fs_type_size} = 32;
+ $fs->{fat_length} = $fs->{fat32_fat_length};
+
+ $fs->{nb_root_dir_entries} = 0;
+ $fs->{info_offset} = $fs->{info_offset_in_sectors} * $fs->{sector_size};
+ }
+ $resize_fat::bad_cluster_value = (1 << $fs->{fs_type_size}) - 9;
+
+ $fs->{fat_offset} = $fs->{nb_reserved} * $fs->{sector_size};
+ $fs->{fat_size} = $fs->{fat_length} * $fs->{sector_size};
+ $fs->{root_dir_offset} = $fs->{fat_offset} + $fs->{fat_size} * $fs->{nb_fats};
+ $fs->{root_dir_size} = $fs->{nb_root_dir_entries} * resize_fat::directory::entry_size();
+ $fs->{cluster_offset} = $fs->{root_dir_offset} + $fs->{root_dir_size} - 2 * $fs->{cluster_size};
+
+ $fs->{nb_fat_entries} = divide($fs->{fat_size}, $fs->{fs_type_size} / 8);
+
+ # - 2 because clusters 0 & 1 doesn't exist
+ $fs->{nb_clusters} = divide($fs->{nb_sectors} * $fs->{sector_size} - $fs->{cluster_offset}, $fs->{cluster_size}) - 2;
+
+ $fs->{dir_entries_per_cluster} = divide($fs->{cluster_size}, psizeof($format));
+
+ $fs->{nb_clusters} >= resize_fat::any::min_cluster_count($fs) or die "error: not enough sectors for a $fs->{fs_type}\n";
+ $fs->{nb_clusters} < resize_fat::any::max_cluster_count($fs) or die "error: too many sectors for a $fs->{fs_type}\n";
+}
+
+sub write($) {
+ my ($fs) = @_;
+ my $boot = pack($format, @{$fs}{@fields});
+
+ eval { resize_fat::io::write($fs, 0, $SECTORSIZE, $boot) }; $@ and die "writing the boot sector failed on device $fs->{fs_name}";
+
+ if ($resize_fat::isFAT32) {
+ # write backup
+ eval { resize_fat::io::write($fs, $fs->{fat32_backup_sector} * $SECTORSIZE, $SECTORSIZE, $boot) };
+ $@ and die "writing the backup boot sector (#$fs->{fat32_backup_sector}) failed on device $fs->{fs_name}";
+ }
+}
diff --git a/perl-install/resize_fat/dir_entry.pm b/perl-install/resize_fat/dir_entry.pm
new file mode 100644
index 000000000..fa5ebb344
--- /dev/null
+++ b/perl-install/resize_fat/dir_entry.pm
@@ -0,0 +1,72 @@
+package resize_fat::dir_entry;
+
+use diagnostics;
+use strict;
+
+
+my $DELETED_FLAG = 0xe5;
+my $VOLUME_LABEL_ATTR = 0x08;
+my $VFAT_ATTR = 0x0f;
+my $DIRECTORY_ATTR = 0x10;
+
+1;
+
+sub get_cluster($) {
+ my ($entry) = @_;
+ $entry->{first_cluster} + ($resize_fat::isFAT32 ? $entry->{first_cluster_high} * 65536 : 0);
+}
+sub set_cluster($$) {
+ my ($entry, $val) = @_;
+ $entry->{first_cluster} = $val & (1 << 16) - 1;
+ $entry->{first_cluster_high} = $val >> 16 if $resize_fat::isFAT32;
+}
+
+sub is_directory_raw($) {
+ my ($entry) = @_;
+ !is_special_entry($entry) && $entry->{attributes} & $DIRECTORY_ATTR;
+}
+
+sub is_directory($) {
+ my ($entry) = @_;
+ is_directory_raw($entry) && $entry->{name} !~ /^\.\.? /;
+}
+
+sub is_volume($) {
+ my ($entry) = @_;
+ !is_special_entry($entry) && $entry->{attributes} & $VOLUME_LABEL_ATTR;
+}
+
+sub is_file($) {
+ my ($entry) = @_;
+ !is_special_entry($entry) && !is_directory($entry) && !is_volume($entry) && $entry->{length};
+}
+
+
+sub is_special_entry($) {
+ my ($entry) = @_;
+ my ($c) = unpack "C", $entry->{name};
+
+ # skip empty slots, deleted files, and 0xF6?? (taken from kernel)
+ $c == 0 || $c == $DELETED_FLAG || $c == 0xF6 and return 1;
+
+ $entry->{attributes} == $VFAT_ATTR and return 1;
+ 0;
+}
+
+
+# return true if entry has been modified
+sub remap {
+ my ($fat_remap, $entry) = @_;
+
+ is_special_entry($entry) and return;
+
+ my $cluster = get_cluster($entry);
+ my $new_cluster = $fat_remap->[$cluster];
+
+ #print "remapping cluster ", get_first_cluster($fs, $entry), " to $new_cluster";
+
+ $new_cluster == $cluster and return; # no need to modify
+
+ set_cluster($entry, $new_cluster);
+ 1;
+}
diff --git a/perl-install/resize_fat/directory.pm b/perl-install/resize_fat/directory.pm
new file mode 100644
index 000000000..ab8ec5328
--- /dev/null
+++ b/perl-install/resize_fat/directory.pm
@@ -0,0 +1,78 @@
+package resize_fat::directory;
+
+use diagnostics;
+use strict;
+
+use common qw(:system);
+use resize_fat::dir_entry;
+use resize_fat::io;
+
+
+my $format = "a8 a3 C C C S7 I";
+my @fields = (
+ 'name',
+ 'extension',
+ 'attributes',
+ 'is_upper_case_name',
+ 'creation_time_low', # milliseconds
+ 'creation_time_high',
+ 'creation_date',
+ 'access_date',
+ 'first_cluster_high', # for FAT32
+ 'time',
+ 'date',
+ 'first_cluster',
+ 'length',
+);
+
+1;
+
+sub entry_size { psizeof($format) }
+
+# call `f' for each entry of the directory
+# if f return true, then modification in the entry are taken back
+sub traverse($$$) {
+ my ($fs, $directory, $f) = @_;
+
+ for (my $i = 0; 1; $i++) {
+ my $raw = \substr($directory, $i * psizeof($format), psizeof($format));
+
+ # empty entry means end of directory
+ $$raw =~ /^\0*$/ and return $directory;
+
+ my $entry; @{$entry}{@fields} = unpack $format, $$raw;
+
+ &$f($entry)
+ and $$raw = pack $format, @{$entry}{@fields};
+ }
+ $directory;
+}
+
+sub traverse_all($$) {
+ my ($fs, $f) = @_;
+
+ my $traverse_all; $traverse_all = sub {
+ my ($entry) = @_;
+
+ &$f($entry);
+
+ resize_fat::dir_entry::is_directory($entry)
+ and traverse($fs, resize_fat::io::read_file($fs, resize_fat::dir_entry::get_cluster($entry)), $traverse_all);
+
+ undef; # no need to write back (cf traverse)
+ };
+
+ my $directory = $resize_fat::isFAT32 ?
+ resize_fat::io::read_file($fs, $fs->{fat32_root_dir_cluster}) :
+ resize_fat::io::read($fs, $fs->{root_dir_offset}, $fs->{root_dir_size});
+ traverse($fs, $directory, $traverse_all);
+}
+
+
+# function used by construct_dir_tree to translate the `cluster' fields in each
+# directory entry
+sub remap {
+ my ($fs, $directory) = @_;
+
+ traverse($fs->{fat_remap}, $directory, sub { resize_fat::dir_entry::remap($fs->{fat_remap}, $_[0]) });
+}
diff --git a/perl-install/resize_fat/fat.pm b/perl-install/resize_fat/fat.pm
new file mode 100644
index 000000000..2b64bd6f7
--- /dev/null
+++ b/perl-install/resize_fat/fat.pm
@@ -0,0 +1,167 @@
+package resize_fat::fat;
+
+use diagnostics;
+use strict;
+
+use resize_fat::any;
+use resize_fat::io;
+
+1;
+
+sub read($) {
+ my ($fs) = @_;
+
+ @{$fs->{fats}} = map {
+ my $fat = eval { resize_fat::io::read($fs, $fs->{fat_offset} + $_ * $fs->{fat_size}, $fs->{fat_size}) };
+ $@ and die "reading fat #$_ failed";
+ vec($fat, 0, 8) == $fs->{media} or die "FAT $_ has invalid signature";
+ $fat;
+ } (0 .. $fs->{nb_fats} - 1);
+
+ $fs->{fat} = $fs->{fats}->[0];
+
+ my ($free, $bad, $used) = (0, 0, 0);
+
+ for (my $i = 2; $i < $fs->{nb_clusters} + 2; $i++) {
+ my $cluster = &next($fs, $i);
+ if ($cluster == 0) { $free++; }
+ elsif ($cluster == $resize_fat::bad_cluster_value) { $bad++; }
+ else { $used++; }
+ }
+ @{$fs->{clusters}->{count}}{qw(free bad used)} = ($free, $bad, $used);
+}
+
+sub write($) {
+ my ($fs) = @_;
+
+ sysseek $fs->{fd}, $fs->{fat_offset}, 0 or die "write_fat: seek failed";
+ foreach (1..$fs->{nb_fats}) {
+ syswrite $fs->{fd}, $fs->{fat}, $fs->{fat_size} or die "write_fat: write failed";
+ }
+}
+
+
+
+# allocates where all the clusters will be moved to. Clusters before cut_point
+# remain in the same position, however cluster that are part of a directory are
+# moved regardless (this is a mechanism to prevent data loss) (cut_point is the
+# first cluster that won't occur in the new fs)
+sub allocate_remap {
+ my ($fs, $cut_point) = @_;
+ my ($cluster, $new_cluster);
+ my $remap = sub { $fs->{fat_remap}->[$cluster] = $new_cluster; };
+ my $get_new = sub {
+ $new_cluster = get_free($fs);
+ 0 < $new_cluster && $new_cluster < $cut_point or die "no free clusters";
+ set_eof($fs, $new_cluster); # mark as used
+ #log::ld("resize_fat: [$cluster,", &next($fs, $cluster), "...]->$new_cluster...");
+ };
+
+ $fs->{fat_remap}->[0] = 0;
+ $fs->{last_free_cluster} = 2;
+ for ($cluster = 2; $cluster < $fs->{nb_clusters} + 2; $cluster++) {
+ if ($cluster < $cut_point) {
+ if ($fs->{fat_flag_map}->[$cluster] == $resize_fat::any::DIRECTORY) {
+ &$get_new();
+ } else {
+ $new_cluster = $cluster;
+ }
+ &$remap();
+ } elsif (!is_empty(&next($fs, $cluster))) {
+ &$get_new();
+ &$remap();
+ }
+ }
+}
+
+
+# updates the fat for the resized filesystem
+sub update {
+ my ($fs) = @_;
+
+ for (my $cluster = 2; $cluster < $fs->{nb_clusters} + 2; $cluster++) {
+ if ($fs->{fat_flag_map}->[$cluster]) {
+ my $old_next = &next($fs, $cluster);
+ my $new = $fs->{fat_remap}->[$cluster];
+ my $new_next = $fs->{fat_remap}->[$old_next];
+
+ set_available($fs, $cluster);
+
+ is_eof($old_next) ?
+ set_eof($fs, $new) :
+ set_next($fs, $new, $new_next);
+ }
+ }
+}
+
+
+# - compares the two FATs (one's a backup that should match) - skips first entry
+# - its just a signature (already checked above) NOTE: checks for cross-linking
+# are done in count.c
+sub check($) {
+ my ($fs) = @_;
+ foreach (@{$fs->{fats}}) {
+ $_ eq $fs->{fats}->[0] or die "FAT tables do not match";
+ }
+}
+
+sub endianness16($) { (($_[0] & 0xff) << 8) + ($_[0] >> 8); }
+sub endianness($$) {
+ my ($val, $nb_bits) = @_;
+ my $r = 0;
+ for (; $nb_bits > 0; $nb_bits -= 8) {
+ $r <<= 8;
+ $r += $val & 0xff;
+ $val >>= 8;
+ }
+ $nb_bits < 0 and die "error: endianness only handle numbers divisible by 8";
+ $r;
+}
+
+sub next($$) {
+ my ($fs, $cluster) = @_;
+ $cluster > $fs->{nb_clusters} + 2 and die "fat::next: cluster $cluster outside filesystem";
+ endianness(vec($fs->{fat}, $cluster, $fs->{fs_type_size}), $fs->{fs_type_size});
+
+}
+sub set_next($$$) {
+ my ($fs, $cluster, $new_v) = @_;
+ $cluster > $fs->{nb_clusters} + 2 and die "fat::set_next: cluster $cluster outside filesystem";
+ vec($fs->{fat}, $cluster, $fs->{fs_type_size}) = endianness($new_v, $fs->{fs_type_size});
+}
+
+
+sub get_free($) {
+ my ($fs) = @_;
+ foreach (my $i = 0; $i < $fs->{nb_clusters}; $i++) {
+ my $cluster = ($i + $fs->{last_free_cluster} - 2) % $fs->{nb_clusters} + 2;
+ is_available(&next($fs, $cluster)) and return $fs->{last_free_cluster} = $cluster;
+ }
+ die "no free clusters";
+}
+
+# returns true if <cluster> represents an EOF marker
+sub is_eof($) {
+ my ($cluster) = @_;
+ $cluster >= $resize_fat::bad_cluster_value;
+}
+sub set_eof($$) {
+ my ($fs, $cluster) = @_;
+ set_next($fs, $cluster, $resize_fat::bad_cluster_value + 1);
+}
+
+# returns true if <cluster> is empty. Note that this includes bad clusters.
+sub is_empty($) {
+ my ($cluster) = @_;
+ $cluster == 0 || $cluster == $resize_fat::bad_cluster_value;
+}
+
+# returns true if <cluster> is available.
+sub is_available($) {
+ my ($cluster) = @_;
+ $cluster == 0;
+}
+sub set_available($$) {
+ my ($fs, $cluster) = @_;
+ set_next($fs, $cluster, 0);
+}
diff --git a/perl-install/resize_fat/info_sector.pm b/perl-install/resize_fat/info_sector.pm
new file mode 100644
index 000000000..c46ae15fc
--- /dev/null
+++ b/perl-install/resize_fat/info_sector.pm
@@ -0,0 +1,36 @@
+package resize_fat::info_sector;
+
+use diagnostics;
+use strict;
+
+use common qw(:system);
+use resize_fat::io;
+
+my $format = "a484 I I I a16";
+my @fields = (
+ 'unused',
+ 'signature', # should be 0x61417272
+ 'free_clusters', # -1 for unknown
+ 'next_cluster', # most recently allocated cluster
+ 'unused2',
+);
+
+1;
+
+
+sub read($) {
+ my ($fs) = @_;
+ my $info = resize_fat::io::read($fs, $fs->{offset}, psizeof($format));
+ @{$fs->{info_sector}}{@fields} = unpack $format, $info;
+ $fs->{info_sector}->{signature} == 0x61417272 or die "Invalid information sector signature\n";
+}
+
+sub write($) {
+ my ($fs) = @_;
+ $fs->{info_sector}->{free_clusters} = $fs->{clusters}->{count}->{free};
+ $fs->{info_sector}->{next_cluster} = 2;
+
+ my $info = pack $format, @{$fs->{info_sector}}{@fields};
+
+ resize_fat::io::write($fs, $fs->{info_offset}, psizeof($format), $info);
+}
diff --git a/perl-install/resize_fat/io.pm b/perl-install/resize_fat/io.pm
new file mode 100644
index 000000000..8ffaa8355
--- /dev/null
+++ b/perl-install/resize_fat/io.pm
@@ -0,0 +1,74 @@
+package resize_fat::io;
+
+use diagnostics;
+use strict;
+
+use resize_fat::fat;
+
+1;
+
+
+sub read($$$) {
+ my ($fs, $pos, $size) = @_;
+ my $buf;
+ sysseek $fs->{fd}, $pos, 0 or die "seeking to byte #$pos failed on device $fs->{fs_name}";
+ sysread $fs->{fd}, $buf, $size or die "reading at byte #$pos failed on device $fs->{fs_name}";
+ $buf;
+}
+sub write($$$$) {
+ my ($fs, $pos, $size, $buf) = @_;
+ sysseek $fs->{fd}, $pos, 0 or die "seeking to byte #$pos failed on device $fs->{fs_name}";
+ syswrite $fs->{fd}, $buf, $size or die "writing at byte #$pos failed on device $fs->{fs_name}";
+}
+
+sub read_cluster($$) {
+ my ($fs, $cluster) = @_;
+ my $buf;
+
+ eval {
+ $buf = &read($fs,
+ $fs->{cluster_offset} + $cluster * $fs->{cluster_size},
+ $fs->{cluster_size});
+ }; @$ and die "reading cluster #$cluster failed on device $fs->{fs_name}";
+ $buf;
+}
+sub write_cluster($$$) {
+ my ($fs, $cluster, $buf) = @_;
+
+ eval {
+ &write($fs,
+ $fs->{cluster_offset} + $cluster * $fs->{cluster_size},
+ $fs->{cluster_size},
+ $buf);
+ }; @$ and die "writing cluster #$cluster failed on device $fs->{fs_name}";
+}
+
+sub read_file($$) {
+ my ($fs, $cluster) = @_;
+ my $buf = '';
+
+ for (; !resize_fat::fat::is_eof($cluster); $cluster = resize_fat::fat::next($fs, $cluster)) {
+ $cluster == 0 and die "Bad FAT: unterminated chain\n";
+ $buf .= read_cluster($fs, $cluster);
+ }
+ $buf;
+}
+
+sub check_mounted($) {
+ my ($f) = @_;
+
+ local *F;
+ open F, "/proc/mounts" or die "error opening /proc/mounts\n";
+ foreach (<F>) {
+ /^$f\s/ and die "device is mounted";
+ }
+}
+
+sub open($) {
+ my ($fs) = @_;
+
+ check_mounted($fs->{device});
+
+ sysopen F, $fs->{fs_name}, 2 or sysopen F, $fs->{fs_name}, 0 or die "error opening device $fs->{fs_name} for writing\n";
+ $fs->{fd} = \*F;
+}
diff --git a/perl-install/resize_fat/main.pm b/perl-install/resize_fat/main.pm
new file mode 100644
index 000000000..2d5f4f969
--- /dev/null
+++ b/perl-install/resize_fat/main.pm
@@ -0,0 +1,152 @@
+#!/usr/bin/perl
+
+package resize_fat::main;
+
+use diagnostics;
+use strict;
+
+use log;
+use common qw(:common :system :constant);
+use resize_fat::boot_sector;
+use resize_fat::info_sector;
+use resize_fat::directory;
+use resize_fat::io;
+use resize_fat::fat;
+use resize_fat::any;
+
+
+#@ARGV == 2 or die "usage: fatresize <device> <size>\n <size> = 100 means `resize to 100Mb'\n <size> = +10 means `keep 10Mb of free space'\n";
+#
+#my $fs = init($ARGV[0]);
+#resize($fs, $ARGV[1]);
+
+1;
+
+# - reads in the boot sector/partition info., and tries to make some sense of it
+sub new($$$) {
+ my ($type, $device, $fs_name) = @_;
+ my $fs = { device => $device, fs_name => $fs_name } ;
+
+ resize_fat::io::open($fs);
+ resize_fat::boot_sector::read($fs);
+ $resize_fat::isFAT32 and eval { resize_fat::info_sector::read($fs) };
+ resize_fat::fat::read($fs);
+ resize_fat::fat::check($fs);
+ resize_fat::any::flag_clusters($fs);
+
+ bless $fs, $type;
+}
+
+# copy all clusters >= <start_cluster> to a new place on the partition, less
+# than <start_cluster>. Only copies files, not directories.
+# (use of buffer needed because the seeks slow like hell the hard drive)
+sub copy_clusters {
+ my ($fs, $cluster) = @_;
+ my @buffer;
+ my $flush = sub {
+ while (@buffer) {
+ my $cluster = shift @buffer;
+ resize_fat::io::write_cluster($fs, $cluster, shift @buffer);
+ }
+ };
+ for (; $cluster < $fs->{nb_clusters} + 2; $cluster++) {
+ $fs->{fat_flag_map}->[$cluster] == $resize_fat::any::FILE or next;
+ push @buffer, $fs->{fat_remap}->[$cluster], resize_fat::io::read_cluster($fs, $cluster);
+ @buffer > 50 and &$flush();
+ }
+ &$flush();
+}
+
+# Constructs the new directory tree to match the new file locations.
+sub construct_dir_tree {
+ my ($fs) = @_;
+
+ if ($resize_fat::isFAT32) {
+ # fat32's root must remain in the first 64k clusters
+ # so don't set it as DIRECTORY, it will be specially handled
+ $fs->{fat_flag_map}->[$fs->{fat32_root_dir_cluster}] = $resize_fat::any::FREE;
+ }
+
+ for (my $cluster = 2; $cluster < $fs->{nb_clusters} + 2; $cluster++) {
+ $fs->{fat_flag_map}->[$cluster] == $resize_fat::any::DIRECTORY or next;
+
+ resize_fat::io::write_cluster($fs,
+ $fs->{fat_remap}->[$cluster],
+ resize_fat::directory::remap($fs, resize_fat::io::read_cluster($fs, $cluster)));
+ }
+
+ sync();
+
+ # until now, only free clusters have been written. it's a null operation if we stop here.
+ # it means no corruption :)
+ #
+ # now we must be as fast as possible!
+
+ # remapping non movable root directory
+ if ($resize_fat::isFAT32) {
+ my $cluster = $fs->{fat32_root_dir_cluster};
+
+ resize_fat::io::write_cluster($fs,
+ $fs->{fat_remap}->[$cluster],
+ resize_fat::directory::remap($fs, resize_fat::io::read_cluster($fs, $cluster)));
+ } else {
+ resize_fat::io::write($fs, $fs->{root_dir_offset}, $fs->{root_dir_size},
+ resize_fat::directory::remap($fs, resize_fat::io::read($fs, $fs->{root_dir_offset}, $fs->{root_dir_size})));
+ }
+}
+
+sub min_size($) { &resize_fat::any::min_size }
+sub max_size($) { &resize_fat::any::max_size }
+
+# resize
+# - size is in sectors
+# - checks boundaries before starting
+# - copies all data beyond new_cluster_count behind the frontier
+sub resize {
+ my ($fs, $size) = @_;
+
+ my ($min, $max) = (min_size($fs), max_size($fs));
+
+
+ $size += $min if $size =~ /^\+/;
+
+ $size >= $min or die "Minimum filesystem size is $min sectors";
+ $size <= $max or die "Maximum filesystem size is $max sectors";
+
+ log::l("resize_fat: Partition size fill be ", $size * $SECTORSIZE >> 20, "Mb (well exactly ${size} sectors)");
+
+ my $new_data_size = $size * $SECTORSIZE - $fs->{cluster_offset};
+ my $new_nb_clusters = divide($new_data_size, $fs->{cluster_size});
+
+ log::l("resize_fat: Allocating new clusters");
+ resize_fat::fat::allocate_remap($fs, $new_nb_clusters);
+
+ log::l("resize_fat: Copying files");
+ copy_clusters($fs, $new_nb_clusters);
+
+ log::l("resize_fat: Copying directories");
+ construct_dir_tree($fs);
+
+ log::l("Writing new FAT...");
+ resize_fat::fat::update($fs);
+ resize_fat::fat::write($fs);
+
+ $fs->{nb_sectors} = $size;
+ $fs->{nb_clusters} = $new_nb_clusters;
+ $fs->{clusters}->{count}->{free} =
+ $fs->{nb_clusters} - $fs->{clusters}->{count}->{used} - $fs->{clusters}->{count}->{bad};
+
+ $fs->{system_id} = 'was here!';
+ $fs->{small_nb_sectors} = 0;
+ $fs->{big_nb_sectors} = $size;
+
+ log::l("resize_fat: Writing new boot sector...");
+
+ resize_fat::boot_sector::write($fs);
+
+ $resize_fat::isFAT32 and eval { resize_fat::info_sector::write($fs) }; # doesn't matter if this fails - its pretty useless!
+
+ sync();
+ log::l("resize_fat: done");
+}
+
diff --git a/perl-install/run_program.pm b/perl-install/run_program.pm
new file mode 100644
index 000000000..e4f2a7ef8
--- /dev/null
+++ b/perl-install/run_program.pm
@@ -0,0 +1,30 @@
+package run_program;
+
+use diagnostics;
+use strict;
+
+use log;
+
+1;
+
+sub run($@) { rooted('', @_) }
+
+sub rooted($$@) {
+ my ($root, $name, @args) = @_;
+
+ log::l("running: $name @args" . ($root ? " with root $root" : ""));
+ $root ? $root .= '/' : ($root = '');
+
+ fork and wait, return $? == 0;
+ {
+ open STDIN, "/dev/null" or die "can't open /dev/null as stdin";
+
+ open STDERR, ">> /dev/tty5" or open STDERR, ">> /tmp/exec.log" or die "runProgramRoot can't log :(";
+ open STDOUT, ">> /dev/tty5" or open STDOUT, ">> /tmp/exec.log" or die "runProgramRoot can't log :(";
+
+ $root and chroot $root;
+ chdir "/";
+
+ exec $name, @args or log::l("exec of $name failed: $!"), exit(-1);
+ }
+}
diff --git a/perl-install/share/diskdrake.rc b/perl-install/share/diskdrake.rc
new file mode 100644
index 000000000..ffbf762b1
--- /dev/null
+++ b/perl-install/share/diskdrake.rc
@@ -0,0 +1,39 @@
+binding "bind"
+{
+ bind "m" {
+ "clicked" ("Mount")
+ }
+}
+
+style "font"
+{
+ font = "-adobe-helvetica-medium-r-normal--*-80-*-*-*-*-*-*"
+}
+
+
+
+style "red" = "font"
+{
+ bg[NORMAL] = { 1.0, 0, 0 }
+ bg[PRELIGHT] = { 0.9, 0, 0 }
+}
+style "green" = "font"
+{
+ bg[NORMAL] = { 0, 1.0, 0 }
+ bg[PRELIGHT] = { 0, 0.9, 0 }
+}
+style "blue" = "font"
+{
+ bg[NORMAL] = { 0, 0, 1.0 }
+ bg[PRELIGHT] = { 0, 0, 0.9 }
+}
+style "white" = "font"
+{
+ bg[NORMAL] = { 1.0, 1.0, 1.0 }
+}
+
+widget "*PART_*" binding "bind"
+widget "*Linux*" style "red"
+widget "*Linux swap" style "green"
+widget "*DOS*" style "blue"
+widget "*Empty*" style "white"
diff --git a/perl-install/swap.pm b/perl-install/swap.pm
new file mode 100644
index 000000000..675c521a7
--- /dev/null
+++ b/perl-install/swap.pm
@@ -0,0 +1,136 @@
+package swap;
+
+use diagnostics;
+use strict;
+
+use common qw(:common :system :constant);
+use log;
+use devices;
+use c;
+
+
+my $pagesize = c::getpagesize();
+my $signature_page = "\0" x $pagesize;
+
+# Maximum allowable number of pages in one swap.
+# From 2.2.0 onwards, this depends on how many offset bits
+# the architectures can actually store into the page tables
+# and on 32bit architectures it is limited to 2GB at the
+# same time.
+# Old swap format keeps the limit of 8*pagesize*(pagesize - 10)
+
+my $V0_MAX_PAGES = 8 * $pagesize - 10;
+my $V1_OLD_MAX_PAGES = int 0x7fffffff / $pagesize - 1;
+my $V1_MAX_PAGES = $V1_OLD_MAX_PAGES; # (1 << 24) - 1;
+my $MAX_BADPAGES = int ($pagesize - 1024 - 128 * $common::sizeof_int - 10) / $common::sizeof_int;
+my $signature_format_v1 = "x1024 I I I I125"; # bootbits, version, last_page, nr_badpages, padding
+
+1;
+
+sub kernel_greater_or_equal($$$) {
+ c::kernel_version() =~ /(\d*)\.(\d*)\.(\d*)/;
+ ($1 <=> $_[0] || $2 <=> $_[1] || $3 <=> $_[2]) >= 0;
+}
+
+sub check_blocks {
+ my ($fd, $version, $nbpages) = @_;
+ my ($last_read_ok, $badpages) = (0, 0);
+ my ($buffer);
+ my $badpages_field_v1 = \substr($signature_page, psizeof($signature_format_v1));
+
+ for (my $i = 0; $i < $nbpages; $i++) {
+
+ $last_read_ok || sysseek($fd, $i * $pagesize, 0) or die "seek failed";
+
+ unless ($last_read_ok = sysread($fd, $buffer, $pagesize)) {
+ if ($version == 1) {
+ $badpages == $MAX_BADPAGES and die "too many bad pages";
+ vec($$badpages_field_v1, $badpages, $bitof_int) = $i;
+ }
+ $badpages++;
+ }
+ vec($signature_page, $i, 1) = bool($last_read_ok) if $version == 0;
+ }
+
+ # TODO: add interface
+
+ $badpages and log::l("$badpages bad pages\n");
+ return $badpages;
+}
+
+sub make($;$) {
+ my ($devicename, $checkBlocks) = @_;
+ my $tmpdev = 0;
+ my $badpages = 0;
+ my ($version, $maxpages);
+
+ $devicename or die "nowhere to set up swap on?";
+ $::testing and return;
+
+ $devicename = devices::make($devicename);
+
+ my $nbpages = divide(devices::size($devicename), $pagesize);
+
+ if ($nbpages <= $V0_MAX_PAGES || kernel_greater_or_equal(2,1,117) || $pagesize < 2048) {
+ $version = 0;
+ } else {
+ $version = 1;
+ }
+
+ $nbpages >= 10 or die "swap area needs to be at least " . 10 * $pagesize >> 10 . "kB";
+
+ -b $devicename or $checkBlocks = 0;
+ my $rdev = (stat $devicename)[6];# or log::l("stat of $devicename failed: $!");
+ $rdev == 0x300 || $rdev == 0x340 and die "$devicename is not a good device for swap";
+
+ sysopen F, $devicename, 2 or die "opening $devicename for writing failed: $!";
+
+ if ($version == 0) { $maxpages = $V0_MAX_PAGES; }
+ elsif (kernel_greater_or_equal(2,2,1)) { $maxpages = $V1_MAX_PAGES; }
+ else { $maxpages = min($V1_OLD_MAX_PAGES, $V1_MAX_PAGES); }
+
+ if ($nbpages > $maxpages) {
+ $nbpages = $maxpages;
+ log::l("warning: truncating swap area to " . ($nbpages * $pagesize >> 10) . "kB");
+ }
+
+ if ($checkBlocks) {
+ $badpages = check_blocks(\*F, $version, $nbpages);
+ } elsif ($version == 0) {
+ for (my $i = 0; $i < $nbpages; $i++) { vec($signature_page, $i, 1) = 1; }
+ }
+
+ $version == 0 and !vec($signature_page, 0, 1) and die "bad block on first page";
+ vec($signature_page, 0, 1) = 0;
+
+ $version == 1 and strcpy($signature_page, pack($signature_format_v1, $version, $nbpages - 1, $badpages));
+
+ my $goodpages = $nbpages - $badpages - 1;
+ $goodpages > 0 or die "all blocks are bad";
+
+ log::l("Setting up swapspace on $devicename version $version, size = " . $goodpages * $pagesize . " bytes");
+
+ strcpy($signature_page, $version == 0 ? "SWAP-SPACE" : "SWAPSPACE2", $pagesize - 10);
+
+ my $offset = ($version == 0) ? 0 : 1024;
+ sysseek(F, $offset, 0) or die "unable to rewind swap-device: $!";
+
+ syswrite(F, substr($signature_page, $offset)) or die "unable to write signature page: $!";
+
+ # A subsequent swapon() will fail if the signature is not actually on disk. (This is a kernel bug.)
+ syscall_('fsync', fileno(F)) or die "fsync failed: $!";
+ close F;
+}
+
+sub enable($;$) {
+ my ($devicename, $checkBlocks) = @_;
+ make($devicename, $checkBlocks);
+ swapon($devicename);
+}
+
+sub swapon($) {
+ syscall_('swapon', devices::make($_[0]), 0) or die "swapon($_[0]) failed: $!";
+}
+sub swapoff($) {
+ syscall_('swapoff', devices::make($_[0])) or die "swapoff($_[0]) failed: $!";
+}
diff --git a/perl-install/unused/cdrom.pm b/perl-install/unused/cdrom.pm
new file mode 100644
index 000000000..46bb4fc3f
--- /dev/null
+++ b/perl-install/unused/cdrom.pm
@@ -0,0 +1,41 @@
+package cdrom;
+
+use diagnostics;
+use strict;
+
+use detect_devices;
+
+
+my %transTable = ( cm206 => 'cm206cd', sonycd535 => 'cdu535');
+
+1;
+
+
+sub setupCDdevicePanel {
+ my ($type) = @_;
+}
+
+sub findAtapi {
+ my $ide = ideGetDevices();
+ foreach (@$ide) { $_->{type} eq 'cdrom' and return $_->{device} }
+ error();
+}
+
+sub findSCSIcdrom {
+ detect_devices::isSCSI() or return error();
+ my $scsi = detect_devices::getSCSI();
+ foreach (@$scsi) { $_->{type} eq 'cdrom' and return $_->{device} }
+ error();
+}
+
+sub setupCDdevice {
+ my ($cddev, $dl) = @_;
+ #TODO
+}
+
+sub removeCDmodule {
+ # this wil fail silently if no CD module has been loaded
+ removeDeviceDriver('cdrom');
+ 1;
+}
+
diff --git a/perl-install/unused/dns.pm b/perl-install/unused/dns.pm
new file mode 100644
index 000000000..baad57f9e
--- /dev/null
+++ b/perl-install/unused/dns.pm
@@ -0,0 +1,64 @@
+use diagnostics;
+use strict;
+
+# This is dumb, but glibc doesn't like to do hostname lookups w/o libc.so
+
+
+#TODO TODO
+sub doQuery {
+# my ($query, $queryType, $domainName, $ipNum) = @_;
+#
+# _res.retry = 2;
+#
+# len = res_search(query, C_IN, queryType, (void *) &response,
+# sizeof(response));
+# if (len <= 0) return -1;
+#
+# if (ntohs(response.hdr.rcode) != NOERROR) return -1;
+# ancount = ntohs(response.hdr.ancount);
+# if (ancount < 1) return -1;
+#
+# data = response.buf + sizeof(HEADER);
+# end = response.buf + len;
+#
+# # skip the question
+# data += dn_skipname(data, end) + QFIXEDSZ;
+#
+# # parse the answer(s)
+# while (--ancount >= 0 && data < end) {
+#
+# # skip the domain name portion of the RR record
+# data += dn_skipname(data, end);
+#
+# # get RR information
+# GETSHORT(type, data);
+# data += INT16SZ; # skipp class
+# data += INT32SZ; # skipp TTL
+# GETSHORT(len, data);
+#
+# if (type == T_PTR) {
+# # we got a pointer
+# len = dn_expand(response.buf, end, data, name, sizeof(name));
+# if (len <= 0) return -1;
+# if (queryType == T_PTR && domainName) {
+# # we wanted a pointer
+# *domainName = malloc(strlen(name) + 1);
+# strcpy(*domainName, name);
+# return 0;
+# }
+# } else if (type == T_A) {
+# # we got an address
+# if (queryType == T_A && ipNum) {
+# # we wanted an address
+# memcpy(ipNum, data, sizeof(*ipNum));
+# return 0;
+# }
+# }
+#
+# # move ahead to next RR
+# data += len;
+# }
+#
+# return -1;
+}
+
diff --git a/perl-install/unused/otherinsmod.pm b/perl-install/unused/otherinsmod.pm
new file mode 100644
index 000000000..fb62ff945
--- /dev/null
+++ b/perl-install/unused/otherinsmod.pm
@@ -0,0 +1,26 @@
+use diagnostics;
+use strict;
+
+sub insmod {
+
+ @_ or die "usage: insmod <module>.o [params]\n";
+
+ my $file = shift;
+ my $tmpname;
+
+ unless (-r $file) {
+ local *F;
+ open F, "/modules/modules.cgz" or die "error opening /modules/modules.cgz";
+
+ $tmpname = "/tmp/" . basename($file);
+
+ installCpioFile(\*F, $file, $tmpname, 0) or die "error extracting file";
+ }
+
+ my $rc = insmod_main($tmpname || $file, @_);
+
+ unlink($tmpname);
+
+ return $rc;
+}
+sub modprobe { &insmod }
diff --git a/perl-install/unused/scsi.pm b/perl-install/unused/scsi.pm
new file mode 100644
index 000000000..77fe8fe44
--- /dev/null
+++ b/perl-install/unused/scsi.pm
@@ -0,0 +1,104 @@
+use diagnostics;
+use strict;
+
+my $scsiDeviceAvailable;
+my $CSADeviceAvailable;
+
+1;
+
+sub scsiDeviceAvailable {
+ defined $scsiDeviceAvailable and return $scsiDeviceAvailable;
+ local *F;
+ open F, "/proc/scsi/scsi" or log::l("failed to open /proc/scsi/scsi: $!"), return 0;
+ foreach (<F>) {
+ /devices: none/ and log::l("no scsi devices are available"), return $scsiDeviceAvailable = 0;
+ }
+ log::l("scsi devices are available");
+ $scsiDeviceAvailable = 1;
+}
+
+sub CompaqSmartArrayDeviceAvailable {
+ defined $CSADeviceAvailable and return $CSADeviceAvailable;
+ -r "/proc/array/ida0" or log::l("failed to open /proc/array/ida0: $!"), return $CSADeviceAvailable = 0;
+ log::l("Compaq Smart Array controllers available");
+ $CSADeviceAvailable = 1;
+}
+
+sub scsiGetDevices {
+ my @drives;
+ my ($driveNum, $cdromNum, $tapeNum) = qw(0 0 0);
+ my $err = sub { chop; log::l("unexpected line in /proc/scsi/scsi: $_"); error() };
+ local $_;
+
+ local *F;
+ open F, "/proc/scsi/scsi" or return &$err();
+ $_ = <F>; /^Attached devices:/ or return &$err();
+ while ($_ = <F>) {
+ my ($id) = /^Host:.*?Id: (\d+)/ or return &$err();
+ $_ = <F>; my ($vendor, $model) = /^\s*Vendor:\s*(.*?)\s+Model:\s*(.*?)\s+Rev:/ or return &$err();
+ $_ = <F>; my ($type) = /^\s*Type:\s*(.*)/ or &$err();
+ my $device;
+ if ($type =~ /Direct-Access/) {
+ $type = 'hd';
+ $device = "sd" . chr($driveNum++ + ord('a'));
+ } elsif ($type =~ /Sequential-Access/) {
+ $type = 'tape';
+ $device = "st" . $tapeNum++;
+ } elsif ($type =~ /CD-ROM/) {
+ $type = 'cdrom';
+ $device = "scd" . $cdromNum++;
+ }
+ $device and push @drives, { device => $device, type => $type, info => "$vendor $model", id => $id, bus => 0 };
+ }
+ [ @drives ];
+}
+
+sub ideGetDevices {
+ my @idi;
+
+ -r "/proc/ide" or die "sorry, /proc/ide not available, seems like you have a pre-2.2 kernel\n => not handled yet :(";
+
+ # Great. 2.2 kernel, things are much easier and less error prone.
+ foreach my $d (glob_('/proc/ide/hd*')) {
+ my ($t) = chop_(cat_("$d/media"));
+ my $type = $ {{disk => 'hd', cdrom => 'cdrom', tape => 'tape', floppy => 'fd'}}{$t} or next;
+ my ($info) = chop_(cat_("$d/model")); $info ||= "(none)";
+
+ my $num = ord (($d =~ /(.)$/)[0]) - ord 'a';
+ push @idi, { type => $type, device => basename($d), info => $info, bus => $num/2, id => $num%2 };
+ }
+ [ @idi ];
+}
+
+
+sub CompaqSmartArrayGetDevices {
+ my @idi;
+ my $f;
+
+ for (my $i = 0; -r ($f = "/proc/array/ida$i"); $i++) {
+ local *F;
+ open F, $f or die;
+ local $_ = <F>;
+ my ($name) = m|ida/(.*?):| or next;
+ push @idi, { device => $name, info => "Compaq RAID logical disk", type => 'hd' };
+ }
+ [ @idi ];
+}
+
+sub dac960GetDevices {
+ my @idi;
+ my $file = "/var/log/dmesg";
+ -r $file or $file = "/tmp/syslog";
+
+ local *F;
+ open F, $file or die "Failed to open $file: $!";
+
+ # We are looking for lines of this format:DAC960#0:
+ # /dev/rd/c0d0: RAID-7, Online, 17928192 blocks, Write Thru0123456790123456789012
+ foreach (<F>) {
+ my ($devicename, $info) = m|/dev/rd/(.*?): (.*?),| or next;
+ push @idi, { info => $info, type => 'hd', devicename => $devicename };
+ log::l("DAC960: $devicename: $info");
+ }
+ [ @idi ];
+}
diff --git a/perl-install/verify_c b/perl-install/verify_c
new file mode 100755
index 000000000..a306348dd
--- /dev/null
+++ b/perl-install/verify_c
@@ -0,0 +1,14 @@
+#!/usr/bin/perl -n
+
+/^#/ and next;
+/c::(\w+)/ and push @c, [ $1, $ARGV, $. ] ;
+
+eof && close ARGV;
+
+END {
+ $_ = join '', `cat c/c.xs.pm`;
+ foreach $c (@c) {
+ /$c->[0]/ or $err = print "$c->[1]:$c->[2]: $c->[0] not in c.xs\n";
+ }
+ exit $err;
+}