mirror of
https://github.com/MidnightCommander/mc
synced 2024-12-23 12:56:51 +03:00
326 lines
8.6 KiB
Perl
326 lines
8.6 KiB
Perl
#! /usr/bin/perl
|
|
#
|
|
# 1999 (c) Piotr Roszatycki <dexter@debian.org>
|
|
# This software is under GNU license
|
|
# last modification: 1999-12-08
|
|
#
|
|
# dpkg
|
|
|
|
sub bt
|
|
{
|
|
my ($dt) = @_;
|
|
my (@time);
|
|
@time = localtime($dt);
|
|
$bt = sprintf "%02d-%02d-%02d %02d:%02d", $time[4], $time[3], $time[5], $time[2], $time[1];
|
|
return $bt;
|
|
}
|
|
|
|
|
|
sub ft
|
|
{
|
|
my ($f) = @_;
|
|
return "d" if -d $f;
|
|
return "l" if -l $f;
|
|
return "p" if -p $f;
|
|
return "S" if -S $f;
|
|
return "b" if -b $f;
|
|
return "c" if -c $f;
|
|
return "-";
|
|
}
|
|
|
|
sub fm
|
|
{
|
|
my ($n) = @_;
|
|
my ($m);
|
|
|
|
if( $n & 0400 ) {
|
|
$m .= "r";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
if( $n & 0200 ) {
|
|
$m .= "w";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
if( $n & 04000 ) {
|
|
$m .= "s";
|
|
} elsif( $n & 0100 ) {
|
|
$m .= "x";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
|
|
if( $n & 0040 ) {
|
|
$m .= "r";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
if( $n & 0020 ) {
|
|
$m .= "w";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
if( $n & 02000 ) {
|
|
$m .= "s";
|
|
} elsif( $n & 0010 ) {
|
|
$m .= "x";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
|
|
if( $n & 0004 ) {
|
|
$m .= "r";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
if( $n & 0002 ) {
|
|
$m .= "w";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
if( $n & 01000 ) {
|
|
$m .= "t";
|
|
} elsif( $n & 0001 ) {
|
|
$m .= "x";
|
|
} else {
|
|
$m .= "-";
|
|
}
|
|
|
|
return $m;
|
|
}
|
|
|
|
sub ls {
|
|
my ($file,$path,$mode) = @_;
|
|
my @stat = stat($file);
|
|
# mode, nlink, uid, gid, size, mtime, filename
|
|
printf "%s %d %d %d %d %s %s\n", $mode || ft($file).fm($stat[2] & 07777),
|
|
$stat[3], $stat[4], $stat[5], $stat[7], bt($stat[9]), $path;
|
|
}
|
|
|
|
$DATE=bt(time());
|
|
|
|
sub list
|
|
{
|
|
my ($pkg, $fn, $dn, $sz, $bt);
|
|
my %debs = ();
|
|
my %sects = ();
|
|
|
|
my($diversions,$architecture);
|
|
chop($diversions = `dpkg-divert --list 2>/dev/null`);
|
|
chop($architecture = `dpkg-architecture 2>/dev/null`);
|
|
chop($list = `dpkg -l '*' 2>/dev/null`);
|
|
chop($getselections = `dpkg --get-selections 2>/dev/null`);
|
|
chop($audit = `dpkg --audit 2>/dev/null`);
|
|
$sz = length($diversions);
|
|
print "-r--r--r-- 1 root root $sz $DATE DIVERSIONS\n";
|
|
$sz = length($architecture);
|
|
print "-r--r--r-- 1 root root $sz $DATE ARCHITECTURE\n";
|
|
$sz = length($list);
|
|
print "-r--r--r-- 1 root root $sz $DATE LIST\n";
|
|
$sz = length($getselections);
|
|
print "-r--r--r-- 1 root root $sz $DATE GET-SELECTIONS\n";
|
|
$sz = length($audit);
|
|
print "-r--r--r-- 1 root root $sz $DATE AUDIT\n";
|
|
$sz = length($pressconfigure);
|
|
print "-r-xr--r-- 1 root root $sz $DATE CONFIGURE\n";
|
|
$sz = length($pressremove);
|
|
print "-r-xr--r-- 1 root root $sz $DATE REMOVE\n";
|
|
$sz = length($pressclearavail);
|
|
print "-r-xr--r-- 1 root root $sz $DATE CLEAR-AVAIL\n";
|
|
$sz = length($pressforgetoldunavail);
|
|
print "-r-xr--r-- 1 root root $sz $DATE FORGET-OLD-UNAVAIL\n";
|
|
ls("/var/lib/dpkg/status","STATUS","-r--r--r--");
|
|
# ls("/var/lib/dpkg/available","AVAILABLE","-r--r--r--");
|
|
|
|
print "drwxr-xr-x 1 root root 0 $DATE all\n";
|
|
|
|
open STAT, "/var/lib/dpkg/status"
|
|
or exit 1;
|
|
while( <STAT> ) {
|
|
chop;
|
|
if( /^([\w-]*): (.*)/ ) {
|
|
$pkg = $2 if( lc($1) eq 'package' );
|
|
$debs{$pkg}{lc($1)} = $2;
|
|
}
|
|
}
|
|
close STAT;
|
|
|
|
foreach $pkg (sort keys %debs) {
|
|
next if $debs{$pkg}{status} =~ /not-installed/;
|
|
$fn = $debs{$pkg}{package}. "_". $debs{$pkg}{version};
|
|
$dn = $debs{$pkg}{section};
|
|
if( ! $dn ) {
|
|
$dn = "unknown";
|
|
} elsif( $dn =~ /^(non-us)$/i ) {
|
|
$dn .= "/main";
|
|
} elsif( $dn !~ /\// ) {
|
|
$dn = "main/". $dn;
|
|
}
|
|
unless( $sects{$dn} ) {
|
|
my $sub = $dn;
|
|
while( $sub =~ s!^(.*)/[^/]*$!$1! ) {
|
|
unless( $sects{$sub} ) {
|
|
print "drwxr-xr-x 1 root root 0 $DATE $sub/\n";
|
|
$sects{$sub} = 1;
|
|
}
|
|
}
|
|
print "drwxr-xr-x 1 root root 0 $DATE $dn/\n";
|
|
$sects{$dn} = 1;
|
|
}
|
|
$sz = $debs{$pkg}{'status'} =~ /config-files/ ? 0 : $debs{$pkg}{'installed-size'} * 1024;
|
|
@stat = stat("/var/lib/dpkg/info/".$debs{$pkg}{package}.".list");
|
|
$bt = bt($stat[9]);
|
|
print "-rw-r--r-- 1 root root $sz $bt $dn/$fn.debd\n";
|
|
print "lrwxrwxrwx 1 root root $sz $bt all/$fn.debd -> ../$dn/$fn.debd\n";
|
|
}
|
|
}
|
|
|
|
sub copyout
|
|
{
|
|
my($archive,$filename) = @_;
|
|
if( $archive eq 'DIVERSIONS' ) {
|
|
system("dpkg-divert --list > $filename 2>/dev/null");
|
|
} elsif( $archive eq 'ARCHITECTURE' ) {
|
|
system("dpkg-architecture > $filename 2>/dev/null");
|
|
} elsif( $archive eq 'LIST' ) {
|
|
system("dpkg -l '*' > $filename 2>/dev/null");
|
|
} elsif( $archive eq 'AUDIT' ) {
|
|
system("dpkg --audit > $filename 2>/dev/null");
|
|
} elsif( $archive eq 'GET-SELECTIONS' ) {
|
|
system("dpkg --get-selections > $filename 2>/dev/null");
|
|
} elsif( $archive eq 'STATUS' ) {
|
|
system("cp /var/lib/dpkg/status $filename");
|
|
} elsif( $archive eq 'AVAILABLE' ) {
|
|
system("cp /var/lib/dpkg/available $filename");
|
|
} elsif( $archive eq 'CONFIGURE' ) {
|
|
open O, ">$filename";
|
|
print O $pressconfigure;
|
|
close O;
|
|
} elsif( $archive eq 'REMOVE' ) {
|
|
open O, ">$filename";
|
|
print O $pressremove;
|
|
close O;
|
|
} elsif( $archive eq 'CLEAR-AVAIL' ) {
|
|
open O, ">$filename";
|
|
print O $pressclearavail;
|
|
close O;
|
|
} elsif( $archive eq 'FORGET-OLD-UNAVAIL' ) {
|
|
open O, ">$filename";
|
|
print O $pressforgetoldunavail;
|
|
close O;
|
|
} else {
|
|
open O, ">$filename";
|
|
print O $archive, "\n";
|
|
close O;
|
|
}
|
|
}
|
|
|
|
# too noisy but less dangerouse
|
|
sub copyin
|
|
{
|
|
my($archive,$filename) = @_;
|
|
if( $archive =~ /\.deb$/ ) {
|
|
system("dpkg -i $filename>/dev/null");
|
|
} else {
|
|
die "extfs: cannot create regular file \`$archive\': Permission denied\n";
|
|
}
|
|
}
|
|
|
|
sub run
|
|
{
|
|
my($archive,$filename) = @_;
|
|
if( $archive eq 'CONFIGURE' ) {
|
|
system("dpkg --pending --configure");
|
|
} elsif( $archive eq 'REMOVE' ) {
|
|
system("dpkg --pending --remove");
|
|
} elsif( $archive eq 'CLEAR-AVAIL' ) {
|
|
system("dpkg --clear-avail");
|
|
} elsif( $archive eq 'FORGET-OLD-UNAVAIL' ) {
|
|
system("dpkg --forget-old-unavail");
|
|
} else {
|
|
die "extfs: $filename: command not found\n";
|
|
}
|
|
}
|
|
|
|
# Disabled - too dangerous and too noisy
|
|
sub rm_disabled
|
|
{
|
|
my($archive) = @_;
|
|
if( $archive =~ /\.debd?$/ ) {
|
|
my $name = $archive;
|
|
$name =~ s%.*/%%g;
|
|
$name =~ s%_.*%%g;
|
|
system("if dpkg -s $name | grep ^Status | grep -qs config-files; \
|
|
then dpkg --purge $name>/dev/null; \
|
|
else dpkg --remove $name>/dev/null; fi");
|
|
die("extfs: $archive: Operation not permitted\n") if $? != 0;
|
|
} else {
|
|
die "extfs: $archive: Operation not permitted\n";
|
|
}
|
|
}
|
|
|
|
|
|
$pressconfigure=<<EOInstall;
|
|
|
|
WARNING
|
|
Don\'t use this method if you are not willing to configure all
|
|
non configured packages.
|
|
|
|
This is not a real file. It is a way to configure all non configured packages.
|
|
|
|
To configure packages go back to the panel and press Enter on this file.
|
|
|
|
EOInstall
|
|
|
|
$pressremove=<<EOInstall;
|
|
|
|
WARNING
|
|
Don\'t use this method if you are not willing to remove all
|
|
unselected packages.
|
|
|
|
This is not a real file. It is a way to remove all unselected packages.
|
|
|
|
To remove packages go back to the panel and press Enter on this file.
|
|
|
|
EOInstall
|
|
|
|
$pressforgetoldunavail=<<EOInstall;
|
|
|
|
WARNING
|
|
Don\'t use this method if you are not willing to forget about
|
|
uninstalled unavailable packages.
|
|
|
|
This is not a real file. It is a way to forget about uninstalled
|
|
unavailable packages.
|
|
|
|
To forget this information go back to the panel and press Enter on this file.
|
|
|
|
EOInstall
|
|
|
|
$pressclearavail=<<EOInstall;
|
|
|
|
WARNING
|
|
Don\'t use this method if you are not willing to erase the existing
|
|
information about what packages are available.
|
|
|
|
This is not a real file. It is a way to erase the existing information
|
|
about what packages are available.
|
|
|
|
To clear this information go back to the panel and press Enter on this file.
|
|
|
|
EOInstall
|
|
|
|
|
|
|
|
# override any locale for dates
|
|
$ENV{"LC_ALL"}="C";
|
|
|
|
if ($ARGV[0] eq "list") { list(); exit(0); }
|
|
elsif ($ARGV[0] eq "copyout") { copyout($ARGV[2], $ARGV[3]); exit(0); }
|
|
elsif ($ARGV[0] eq "copyin") { copyin($ARGV[2], $ARGV[3]); exit(0); }
|
|
elsif ($ARGV[0] eq "run") { run($ARGV[2],$ARGV[3]); exit(0); }
|
|
#elsif ($ARGV[0] eq "rm") { rm($ARGV[2]); exit(0); }
|
|
exit(1);
|
|
|