home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-2 / Inter.Net 55-2.iso / Mandrake / mdkinst / usr / bin / perl-install / commands.pm < prev    next >
Encoding:
Perl POD Document  |  2000-01-12  |  14.5 KB  |  558 lines
  1. package commands;
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10. use common qw(:common :file :system :constant);
  11.  
  12.  
  13.  
  14.  
  15. my $BUFFER_SIZE = 1024;
  16.  
  17.  
  18.  
  19.  
  20. sub getopts {
  21.     my $o = shift;
  22.     my @r = map { '' } (@_ = split //, $_[0]);
  23.     while (1) {
  24.     local $_ = $o->[0];
  25.     $_ && /^-/ or return @r;
  26.     for (my $i = 0; $i < @_; $i++) { /$_[$i]/ and $r[$i] = $_[$i]; }
  27.     shift @$o;
  28.     }
  29.     @r;
  30. }
  31.  
  32. sub true { exit 0 }
  33. sub false { exit 1 }
  34. sub cat { @ARGV = @_; print while <> }
  35. sub which { ARG: foreach (@_) { foreach my $c (split /:/, $ENV{PATH}) { -x "$c/$_" and print("$c/$_\n"), next ARG; }}}
  36. sub dirname_ { print dirname(@_), "\n" }
  37. sub basename_ { print basename(@_), "\n" }
  38. sub rmdir_ { foreach (@_) { rmdir $_ or die "rmdir: can't remove $_\n" } }
  39. sub lsmod { print "Module                  Size  Used by\n"; cat("/proc/modules"); }
  40.  
  41. sub grep_ {
  42.     my ($h, $v, $i) = getopts(\@_, qw(hvi));
  43.     @_ == 0 || $h and die "usage: grep <regexp> [files...]\n";
  44.     my $r = shift;
  45.     $r = qr/$r/i if $i;
  46.     @ARGV = @_; (/$r/ ? $v || print : $v && print) while <>
  47. }
  48.  
  49. sub tr_ {
  50.     my ($s, $c, $d) = getopts(\@_, qw(s c d));
  51.     @_ >= 1 + (!$d || $s) or die "usage: tr [-c] [-s [-d]] <set1> <set2> [files...]\n    or tr [-c] -d <set1> [files...]\n";
  52.     my $set1 = shift;
  53.     my $set2; !$d || $s and $set2 = shift;
  54.     @ARGV = @_;
  55.     eval "(tr/$set1/$set2/$s$d$c, print) while <>";
  56. }
  57.  
  58. sub mount {
  59.     @_ or return cat("/proc/mounts");
  60.     my ($t) = getopts(\@_, qw(t));
  61.     my $fs = $t && shift;
  62.  
  63.     @_ == 2 or die "usage: mount [-t <fs>] <device> <dir>\n",
  64.     "       (if /dev/ is left off the device name, a temporary node will be created)\n";
  65.  
  66.     my ($dev, $where) = @_;
  67.     $fs ||= $where =~ /:/ ? "nfs" :
  68.             $dev =~ /fd/ ? "vfat" : "ext2";
  69.  
  70.     require 'fs.pm';
  71.     fs::mount($dev, $where, $fs, 0, 1);
  72. }
  73.  
  74. sub umount {
  75.     @_ == 1 or die "umount expects a single argument\n";
  76.  
  77.     require 'fs.pm';
  78.     fs::umount($_[0]);
  79. }
  80.  
  81. sub mkdir_ {
  82.     my ($rec) = getopts(\@_, qw(p));
  83.  
  84.     my $mkdir; $mkdir = sub {
  85.     my $root = dirname $_[0];
  86.     if (-e $root) {
  87.         -d $root or die "mkdir: error creating directory $_[0]: $root is a file and i won't delete it\n";
  88.     } else {
  89.         $rec or die "mkdir: $root does not exist (try option -p)\n";
  90.         &$mkdir($root);
  91.     }
  92.     mkdir $_[0], 0755 or die "mkdir: error creating directory $_: $!\n";
  93.     };
  94.     &$mkdir($_) foreach @_;
  95. }
  96.  
  97.  
  98. sub mknod {
  99.     if (@_ == 1) {
  100.     require 'devices.pm';
  101.     eval { devices::make($_[0]) }; $@ and die "mknod: failed to create $_[0]\n";
  102.     } elsif (@_ == 4) {
  103.     require 'c.pm';
  104.     my $mode = $ {{"b" => c::S_IFBLK(), "c" => c::S_IFCHR()}}{$_[1]} or die "unknown node type $_[1]\n";
  105.     syscall_('mknod', my $a = $_[0], $mode | 0600, makedev($_[2], $_[3])) or die "mknod failed: $!\n";
  106.     } else { die "usage: mknod <path> [b|c] <major> <minor> or mknod <path>\n"; }
  107. }
  108.  
  109. sub ln {
  110.     my ($force, $soft) = getopts(\@_, qw(fs));
  111.     @_ >= 1 or die "usage: ln [-s] [-f] <source> [<dest>]\n";
  112.  
  113.     my ($source, $dest) = @_;
  114.     $dest ||= basename($source);
  115.  
  116.     $force and unlink $dest;
  117.  
  118.     ($soft ? symlink($source, $dest) : link($source, $dest)) or die "ln failed: $!\n";
  119. }
  120.  
  121. sub rm {
  122.     my ($rec, undef) = getopts(\@_, qw(rf));
  123.  
  124.     my $rm; $rm = sub {
  125.     foreach (@_) {
  126.         if (!-l $_ && -d $_) {
  127.         $rec or die "$_ is a directory\n";
  128.         &$rm(glob_($_));
  129.         rmdir $_ or die "can't remove directory $_: $!\n";
  130.         } else { unlink $_ or die "rm of $_ failed: $!\n" }
  131.     }
  132.     };
  133.     &$rm(@_);
  134. }
  135.  
  136. sub chmod_ {
  137.     @_ >= 2 or die "usage: chmod <mode> <files>\n";
  138.  
  139.     my $mode = shift;
  140.     $mode =~ /^[0-7]+$/ or die "illegal mode $mode\n";
  141.  
  142.     foreach (@_) { chmod oct($mode), $_ or die "chmod failed $_: $!\n" }
  143. }
  144.  
  145. sub chown_ {
  146.     my ($rec, undef) = getopts(\@_, qw(r));
  147.     local $_ = shift or die "usage: chown [-r] name[.group] <files>\n";
  148.  
  149.     my ($name, $group) = (split('\.'), $_);
  150.  
  151.     my ($uid, $gid) = (getpwnam($name) || $name, getgrnam($group) || $group);
  152.  
  153.     my $chown; $chown = sub {
  154.     foreach (@_) {
  155.         chown $uid, $gid, $_ or die "chown of file $_ failed: $!\n";
  156.         -d $_ && $rec and &$chown(glob_($_));
  157.     }
  158.     };
  159.     &$chown(@_);
  160. }
  161.  
  162. sub mkswap {
  163.     @_ == 1 or die "mkswap <device>\n";
  164.  
  165.     require 'swap.pm';
  166.     swap::enable($_[0], 0);
  167. }
  168.  
  169. sub swapon {
  170.     @_ == 1 or die "swapon <file>\n";
  171.  
  172.     require 'swap.pm';
  173.     swap::swapon($_[0]);
  174. }
  175. sub swapoff {
  176.     @_ == 1 or die "swapoff <file>\n";
  177.     require 'swap.pm';
  178.     swap::swapoff($_[0]);
  179. }
  180.  
  181. sub uncpio {
  182.     @_ and die "uncpio reads from stdin\n";
  183.  
  184. #    cpioInstallArchive(gzdopen(0, "r"), NULL, 0, NULL, NULL, &fail);
  185. }
  186.  
  187.  
  188. sub rights {
  189.     my $r = '-' x 9;
  190.     my @rights = (qw(x w r x w r x w r), ['t', 0], ['s', 3], ['s', 6]);
  191.     for (my $i = 0; $i < @rights; $i++) {
  192.     if (vec(pack("S", $_[0]), $i, 1)) {
  193.         my ($val, $place) = $i >= 9 ? @{$rights[$i]} : ($rights[$i], $i);
  194.         my $old = \substr($r, 8 - $place, 1);
  195.         $$old = ($$old eq '-' && $i >= 9) ? uc $val : $val;
  196.     }
  197.     }
  198.     my @types = split //, "_pc_d_b_-_l_s";
  199.     $types[$_[0] >> 12 & 0xf] . $r;
  200. }
  201.  
  202. sub displaySize {
  203.     my $m = $_[0] >> 12;
  204.     $m == 4 || $m == 8 || $m == 10;
  205. }
  206.  
  207. sub ls {
  208.     my ($l , $h) = getopts(\@_, qw(lh));
  209.     $h and die "usage: ls [-l] <files...>\n";
  210.  
  211.     @_ or @_ = '.';
  212.     @_ == 1 && -d $_[0] and @_ = glob_($_[0]);
  213.     foreach (sort @_) {
  214.     if ($l) {
  215.         my @s = lstat or warn("can't stat file $_\n"), next;
  216.         formline(
  217. "@<<<<<<<<< @<<<<<<< @<<<<<<< @>>>>>>>> @>>>>>>>>>>>>>>> @*\n",
  218.              rights($s[2]), getpwuid $s[4] || $s[4], getgrgid $s[5] || $s[5],
  219.              displaySize($s[2]) ? $s[7] : join(", ", unmakedev($s[6])),
  220.              scalar localtime $s[9], -l $_ ? "$_ -> " . readlink $_ : $_);
  221.         print $^A; $^A = '';
  222.     } else { print "$_\n"; }
  223.     }
  224. }
  225. sub cp {
  226.     my ($force) = getopts(\@_, qw(f));
  227.     @_ >= 2 or die "usage: cp [-f] <sources> <dest>\n(this cp does -Rl by default)\n";
  228.  
  229.     my $cp; $cp = sub {
  230.     my $dest = pop @_;
  231.  
  232.     @_ or return;
  233.     @_ == 1 || -d $dest or die "cp: copying multiple files, but last argument ($dest) is not a directory\n";
  234.  
  235.     foreach my $src (@_) {
  236.         my $dest = $dest;
  237.         -d $dest and $dest .= "/" . basename($src);
  238.  
  239.         if (-e $dest) {
  240.         $force ? unlink $dest : die "file $dest already exist\n";
  241.         }
  242.  
  243.         if (-d $src) {
  244.         -d $dest or mkdir $dest, mode($src) or die "mkdir: can't create directory $dest: $!\n";
  245.         &$cp(glob_($src), $dest);
  246.         } elsif (-l $src) {
  247.         symlink((readlink($src) || die "readlink failed: $!"), $dest) or die "symlink: can't create symlink $dest: $!\n";
  248.         } else {
  249.         local (*F, *G);
  250.         open F, $src or die "can't open $src for reading: $!\n";
  251.         open G, "> $dest" or $force or die "can't create $dest : $!\n";
  252.         foreach (<F>) { print G $_ }
  253.         chmod mode($src), $dest;
  254.         }
  255.     }
  256.     };
  257.     &$cp(@_);
  258. }
  259.  
  260. sub ps {
  261.     @_ and die "usage: ps\n";
  262.     my ($pid, $cpu, $cmd);
  263.     my ($uptime) = split ' ', first(cat_("/proc/uptime"));
  264.     my $hertz = 100;
  265.  
  266.     open PS, ">&STDOUT";
  267.     format PS_TOP =
  268.   PID  %CPU CMD
  269. .
  270.     format PS =
  271. @>>>>  @>>> @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  272. $pid, $cpu, $cmd
  273. .
  274.     foreach $pid (sort {$a <=> $b} grep { /\d+/ } all('/proc')) {
  275.      my @l = split(' ', cat_("/proc/$pid/stat"));
  276.      $cpu = sprintf "%2.1f", max(0, min(99, ($l[13] + $l[14]) * 100 / $hertz / ($uptime - $l[21] / $hertz)));
  277.      (($cmd) = cat_("/proc/$pid/cmdline")) =~ s/\0/ /g;
  278.      $cmd ||= (split ' ', (cat_("/proc/$pid/stat"))[0])[1];
  279.      write PS;
  280.     }
  281. }
  282.  
  283.  
  284. sub dd {
  285.     my $u = "usage: dd [-h] [-p] [if=<file>] [of=<file>] [bs=<number>] [count=<number>]\n";
  286.     my ($help, $percent) = getopts(\@_, qw(hp));
  287.     die $u if $help;
  288.     my %h = (if => *STDIN, of => *STDOUT, bs => 512, count => undef);
  289.     foreach (@_) {
  290.     /(.*?)=(.*)/ && exists $h{$1} or die $u;
  291.     $h{$1} = $2;
  292.     }
  293.     local (*IF, *OF); my ($tmp, $nb, $read);
  294.     ref $h{if} eq 'GLOB' ? *IF = $h{if} : sysopen(IF, $h{if}, 0   ) || die "error: can't open file $h{if}\n";
  295.     ref $h{of} eq 'GLOB' ? *OF = $h{of} : sysopen(OF, $h{of}, 0x41) || die "error: can't open file $h{of}\n";
  296.  
  297.     $h{bs} = removeXiBSuffix($h{bs});
  298.  
  299.     for ($nb = 0; !$h{count} || $nb < $h{count}; $nb++) {
  300.     printf "\r%02.1d%%", 100 * $nb / $h{count} if $h{count} && $percent;
  301.     $read = sysread(IF, $tmp, $h{bs}) or $h{count} ? die "error: can't read block $nb\n" : last;
  302.     syswrite(OF, $tmp) or die "error: can't write block $nb\n";
  303.     $read < $h{bs} and $read = 1, last;
  304.     }
  305.     print STDERR "\r$nb+$read records in\n";
  306.     print STDERR   "$nb+$read records out\n";
  307. }
  308.  
  309. sub head_tail {
  310.     my ($h, $n) = getopts(\@_, qw(hn));
  311.     $h || @_ > 1 + bool($n) and die "usage: $0 [-h] [-n lines] [<file>]\n";
  312.     $n = $n ? shift : 10;
  313.     local *F; @_ ? open(F, $_[0]) || die "error: can't open file $_[0]\n" : (*F = *STDIN);
  314.  
  315.     if ($0 eq 'head') {
  316.     foreach (<F>) { $n-- or return; print }
  317.     } else {
  318.     @_ = (); foreach (<F>) { push @_, $_; @_ > $n and shift; }
  319.     print @_;
  320.     }
  321. }
  322. sub head { $0 = 'head'; &head_tail }
  323. sub tail { $0 = 'tail'; &head_tail }
  324.  
  325. sub strings {
  326.     my ($h, $o, $n) = getopts(\@_, qw(hon));
  327.     $h and die "usage: strings [-o] [-n min-length] [<files>]\n";
  328.     $n = $n ? shift : 4;
  329.     $/ = "\0"; @ARGV = @_; my $l = 0; while (<>) {
  330.     while (/[$printable_chars]\{$n,}/og) {
  331.         printf "%07d ", ($l + length $') if $o;
  332.         print "$&\n" ;
  333.     }
  334.     $l += length;
  335.     } continue { $l = 0 if eof }
  336. }
  337.  
  338. sub hexdump {
  339.     my $i = 0; $/ = \16; @ARGV = @_; while (<>) {
  340.     printf "%08lX  ", $i; $i += 16;
  341.     print join(" ", (map { sprintf "%02X", $_ } unpack("C*", $_)),
  342.            ($_ =~ s/[^$printable_chars]/./og, $_)[1]), "\n";
  343.     }
  344. }
  345.  
  346. sub more {
  347.     @ARGV = @_;
  348.     require 'devices.pm';
  349.     my $tty = devices::make('tty');
  350.     local *IN; open IN, "<$tty" or die "can't open $tty\n";
  351.     my $n = 0; while (<>) {
  352.     ++$n == 25 and $n = <IN>, $n = 0;
  353.     print
  354.     }
  355. }
  356.  
  357. sub pack_ {
  358.     my $t;
  359.     foreach (@_) {
  360.     if (-d $_) {
  361.         pack_(glob_($_));
  362.     } else {
  363.         print -s $_, "\n";
  364.         print $_, "\n";
  365.  
  366.         local *F;
  367.         open F, $_ or die "can't read file $_: $!\n";
  368.         while (read F, $t, $BUFFER_SIZE) { print $t; }
  369.     }
  370.     }
  371. }
  372.  
  373. sub unpack_ {
  374.     my $t;
  375.     @_ == 1 or die "give me one and only one file to unpack\n";
  376.     local *F;
  377.     open F, $_[0] or die "can't open file $_: $!\n";
  378.     while (1) {
  379.     my ($size) = chop_(scalar <F>);
  380.     defined $size or last;
  381.     $size =~ /^\d+$/ or die "bad format (can't find file size)\n";
  382.     my ($filename) = chop_(scalar <F>) or die "expecting filename\n";
  383.  
  384.     print "$filename\n";
  385.     my $dir = dirname($filename);
  386.     -d $dir or mkdir_('-p', $dir);
  387.  
  388.     local *G;
  389.     open G, "> $filename" or die "can't write file $filename: $!\n";
  390.     while ($size) {
  391.         $size -= read(F, $t, min($size, $BUFFER_SIZE)) || die "data for file $filename is missing\n";
  392.         print G $t or die "error writing to file $filename: $!\n";
  393.     }
  394.     }
  395. }
  396.  
  397. sub insmod {
  398.     my ($h) = getopts(\@_, qw(h));
  399.     $h || @_ == 0 and die "usage: insmod <module> [options]\n";
  400.     my $f = local $_ = shift;
  401.  
  402.     require 'run_program.pm';
  403.  
  404.     
  405.     
  406.     unless (-r $f) {
  407.     $_ = $1 if m@.*/([^/]*)\.o@;
  408.     unless (-r ($f = "/lib/modules/$_.o")) {
  409.         $f = "/tmp/$_.o";
  410.         if (-e "/lib/modules.cz2") {
  411.         run_program::run("extract_archive /lib/modules /tmp $_.o");
  412.         } elsif (-e "/lib/modules.cpio.bz2") {
  413.         run_program::run("cd /tmp ; bzip2 -cd /lib/modules.cpio.bz2 | cpio -i $_.o");
  414.         } else {
  415.         die "unable to find an archive for modules";
  416.         }
  417.     }
  418.     }
  419.     -r $f or die "can't find module $_";
  420.     run_program::run(["insmod_", "insmod"], $f, @_) or die("insmod $_ failed");
  421.     unlink $f;
  422. }
  423.  
  424. sub modprobe {
  425.     my ($h) = getopts(\@_, qw(h));
  426.     $h || @_ == 0 and die "usage: modprobe <module> [options]\n";
  427.     my $name = shift;
  428.     require 'modules.pm';
  429.     modules::load_deps("/modules/modules.dep");
  430.     modules::load($name, '', @_);
  431. }
  432.  
  433. sub route {
  434.     @_ == 0 or die "usage: route\nsorry, no modification handled\n";
  435.     my ($titles, @l) = cat_("/proc/net/route");
  436.     my @titles = split ' ', $titles;
  437.     my %l;
  438.     open ROUTE, ">&STDOUT";
  439.     format ROUTE_TOP =
  440. Destination    Gateway        Mask           Iface
  441. .
  442.     format ROUTE =
  443. @<<<<<<<<<<<<  @<<<<<<<<<<<<  @<<<<<<<<<<<<  @<<<<<<<
  444. $l{Destination}, $l{Gateway}, $l{Mask}, $l{Iface}
  445. .
  446.     foreach (@l) {
  447.     /^\s*$/ and next;
  448.     @l{@titles} = split;
  449.     $_ = join ".", reverse map { hex } unpack "a2a2a2a2", $_ foreach @l{qw(Destination Gateway Mask)};
  450.     $l{Destination} = 'default' if $l{Destination} eq "0.0.0.0";
  451.     $l{Gateway}     = '*'       if $l{Gateway}     eq "0.0.0.0";
  452.     write ROUTE;
  453.     }
  454. }
  455.  
  456. sub df {
  457.     my ($h) = getopts(\@_, qw(h));
  458.     my ($dev, $blocksize, $size, $free, $used, $use, $mntpoint);
  459.     open DF, ">&STDOUT";
  460.     format DF_TOP =
  461. Filesystem          Size      Used    Avail     Use  Mounted on
  462. .
  463.     format DF =
  464. @<<<<<<<<<<<<<<<< @>>>>>>> @>>>>>>> @>>>>>>> @>>>>>% @<<<<<<<<<<<<<<<<<<<<<<<<<
  465. $dev, $size, $used, $free, $use, $mntpoint
  466. .
  467.     my %h;
  468.     foreach (cat_("/proc/mounts"), cat_("/etc/mtab")) {
  469.     ($dev, $mntpoint) = split;
  470.     $h{$dev} = $mntpoint;
  471.     }
  472.     foreach $dev (sort keys %h) {
  473.     $mntpoint = $h{$dev};
  474.     my $buf = ' ' x 20000;
  475.     syscall_('statfs', $mntpoint, $buf) or next;
  476.     (undef, $blocksize, $size, undef, $free, undef) = unpack "L2L4", $buf;
  477.     $_ *= $blocksize / 1024 foreach $size, $free;
  478.  
  479.     $size or next;
  480.  
  481.     $use = int (100 * ($size - $free) / $size);
  482.     $used = $size - $free;
  483.     if ($h) {
  484.         $used = int ($used / 1024) . "M";
  485.         $size = int ($size / 1024) . "M";
  486.         $free = int ($free / 1024) . "M";
  487.     }
  488.     write DF if $size;
  489.     }
  490. }
  491.  
  492. sub kill {
  493.     my $signal = 15;
  494.     @_ or die "usage: kill [-<signal>] pids\n";
  495.     $signal = (shift, $1)[1] if $_[0] =~ /^-(.*)/;
  496.     kill $signal, @_ or die "kill failed: $!\n";
  497. }
  498.  
  499. sub lspci {
  500.     require 'pci_probing/main.pm';
  501.     print join "\n", pci_probing::main::list (), '';
  502. }
  503. sub dmesg { print cat_("/tmp/syslog"); }
  504.  
  505. sub sort {
  506.     my ($n, $h) = getopts(\@_, qw(nh));
  507.     $h and die "usage: sort [-n] [<file>]\n";
  508.     local *F; @_ ? open(F, $_[0]) || die "error: can't open file $_[0]\n" : (*F = *STDIN);
  509.     if ($n) {
  510.     print sort { $a <=> $b } <F>;
  511.     } else {
  512.     print sort <F>;
  513.     }
  514. }
  515.  
  516. sub du {
  517.     my ($s, $h) = getopts(\@_, qw(sh));
  518.     $h || !$s and die "usage: du -s [<directories>]\n";
  519.  
  520.     my $f; $f = sub {
  521.     my ($e) = @_;
  522.     my $s = (lstat($e))[12];
  523.     $s += sum map { &$f($_) } glob_("$e/*") if !-l $e && -d $e;
  524.     $s;
  525.     };
  526.     print &$f($_) >> 1, "\t$_\n" foreach @_ ? @_ : glob_("*");
  527. }
  528.  
  529. #my %cached_failed_install_cpio;
  530.  
  531. sub  install_cpio($$;@) {
  532.     my ($dir, $name, @more) = @_; 
  533.  
  534. #    return if $cached_failed_install_cpio{"$dir $name"};
  535.     return "$dir/$name" if -e "$dir/$name";
  536.  
  537.     my $cpio = "$dir.cpio.bz2";
  538.     -e $cpio or return;
  539.  
  540.     eval { rm("-r", $dir) };
  541.     mkdir $dir, 0755;
  542.     require 'run_program.pm';
  543.     
  544.     my $more = join " ", map { $_ && "$_ $_/*" } @more;
  545.     run_program::run("cd $dir ; bzip2 -cd $cpio | cpio -id $name $name/* $more");
  546.  
  547.     
  548. #    return if $cached_failed_install_cpio{"$dir $name"} = ! -e "$dir/$name";
  549.     "$dir/$name";
  550. }
  551.  
  552.  
  553.  
  554.  
  555.  
  556. 1; #
  557.  
  558.