JezK
Edit File: dpkg+
#! /usr/bin/perl # # 1999 (c) Piotr Roszatycki <dexter@debian.org> # This software is under GNU license # last modification: 1999-12-08 # # dpkg sub quote { $_ = shift(@_); s/([^\w\/.+-])/\\$1/g; return($_); } sub bt { my ($dt) = @_; my (@time); @time = localtime($dt); $bt = sprintf "%02d-%02d-%d %02d:%02d", $time[4] + 1, $time[3], $time[5] + 1900, $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) = @_; if (-f $file) { my @stat = stat(_); # 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) = @_; my $qfilename = quote($filename); if( $archive eq 'DIVERSIONS' ) { system("dpkg-divert --list > $qfilename 2>/dev/null"); } elsif( $archive eq 'ARCHITECTURE' ) { system("dpkg-architecture > $qfilename 2>/dev/null"); } elsif( $archive eq 'LIST' ) { system("dpkg -l '*' > $qfilename 2>/dev/null"); } elsif( $archive eq 'AUDIT' ) { system("dpkg --audit > $qfilename 2>/dev/null"); } elsif( $archive eq 'GET-SELECTIONS' ) { system("dpkg --get-selections > $qfilename 2>/dev/null"); } elsif( $archive eq 'STATUS' ) { system("cp /var/lib/dpkg/status $qfilename"); } elsif( $archive eq 'AVAILABLE' ) { system("cp /var/lib/dpkg/available $qfilename"); } 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) = @_; my $qfilename = quote($filename); if( $archive =~ /\.deb$/ ) { system("dpkg -i $qfilename>/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 $qname = quote($archive); $qname =~ s%.*/%%g; $qname =~ s%_.*%%g; system("if dpkg -s $qname | grep ^Status | grep -qs config-files; \ then dpkg --purge $qname>/dev/null; \ else dpkg --remove $qname>/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);