diff options
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; +} |