1#! @PERL@
2#
3# Written by Fernando Alegre <alegre@debian.org> 1996
4#
5# Applied patch by Dimitri Maziuk <emaziuk@curtin.edu.au> 1997
6#         (to handle new tar format)
7#
8# Modified by Fernando Alegre <alegre@debian.org> 1997
9#         (to handle both new and old tar formats)
10#
11# Modified by Patrik Rak <prak@post.cz> 1998
12#         (add by Michael Bramer Debian-mc-maintainer <grisu@debian.org>)
13#         (to allow access to package control files)
14#
15# Modified by Martin Bialasinski <martinb@debian.org> 1999
16#         (deal with change in tar format)
17#
18#
19# Copyright (C) 1997 Free Software Foundation
20#
21
22sub quote {
23    $_ = shift(@_);
24    s/([^\w\/.+-])/\\$1/g;
25    return($_);
26}
27
28sub mcdebfs_list
29{
30#
31#	CAVEAT: Hard links are listed as if they were symlinks
32#		Empty directories do not appear at all
33#
34	local($archivename)=@_;
35	local $qarchivename = quote($archivename);
36	chop($date=`LC_ALL=C date "+%b %d %H:%M"`);
37	chop($info_size=`dpkg -I $qarchivename | wc -c`);
38	$install_size=length($pressinstall);
39
40	print "dr-xr-xr-x   1 root     root     0 $date CONTENTS\n";
41	print "dr-xr-xr-x   1 root     root     0 $date DEBIAN\n";
42	print "-r--r--r--   1 root     root     $info_size $date INFO\n";
43	print "-r-xr--r--   1 root     root     $install_size $date INSTALL\n";
44
45        if ( open(PIPEIN, "LC_ALL=C dpkg-deb -c $qarchivename |") )
46	{
47		while(<PIPEIN>)
48		{
49			@_ = split;
50
51			$perm=$_[0]; $owgr=$_[1]; $size=$_[2];
52			if($_[3] =~ /^\d\d\d\d\-/) { # New tar format
53
54				($year,$mon,$day) = split(/-/,$_[3]);
55				$month = ("Gee","Jan","Feb","Mar","Apr","May","Jun",
56						  "Jul","Aug","Sep","Oct","Nov","Dec")[$mon] || "Gee";
57				$time=$_[4];
58				$pathindex=5;
59			}
60			else {
61				$mstring='GeeJanFebMarAprMayJunJulAugSepOctNovDec';
62				$month=$_[3];
63				$mon=index($mstring,$month) / 3;
64				$day=$_[4];
65				$time=$_[5];
66				$year=$_[6];
67				$pathindex=7;
68			}
69
70			$path=$_[$pathindex++];
71			# remove leading ./
72			$path=~s/^\.\///;
73			next if ($path eq '');
74			$arrow=$_[$pathindex++];
75			$link=$_[$pathindex++];
76			$link2=$_[$pathindex++];
77
78			$owgr=~s!/! !;
79			if($arrow eq 'link')
80			{
81# report hard links as soft links
82				$arrow='->'; $link="/$link2";
83				substr($perm, 0, 1) = "l";
84			}
85			if($arrow ne '')
86			{
87				$arrow=' ' . $arrow;
88				$link= ' ' . $link;
89			}
90			$now=`date "+%Y %m"`;
91			($thisyear, $thismon) = split(/ /, $now);
92			# show time for files younger than 6 months
93			# but not for files with dates in the future
94			if ($year * 12 + $mon > $thisyear * 12 + $thismon - 6 &&
95				$year * 12 + $mon <= $thisyear * 12 + $thismon) {
96				print "$perm 1 $owgr $size $month $day $time CONTENTS/$path$arrow$link\n";
97			} else {
98				print "$perm 1 $owgr $size $month $day $year CONTENTS/$path$arrow$link\n";
99			}
100		}
101	}
102        if ( open(PIPEIN, "LC_ALL=C dpkg-deb -I $qarchivename |") )
103        {
104               while(<PIPEIN>)
105               {
106                       @_ = split;
107                       $size=$_[0];
108                       last if $size =~ /:/;
109                       next if $size !~ /\d+/;
110                       if($_[4] eq '*')
111                       {
112                           $perm='-r-xr-xr-x';
113                           $name=$_[5];
114                       }
115                       else
116                       {
117                           $perm='-r--r--r--';
118                           $name=$_[4];
119                       }
120                       print "$perm 1 root root $size $date DEBIAN/$name\n";
121               }
122        }
123}
124
125sub mcdebfs_copyout
126{
127	local($archive,$filename,$destfile)=@_;
128	local $qarchive = quote($archive);
129	local $qfilename = quote($filename);
130	local $qdestfile = quote($destfile);
131
132	if($filename eq "INFO")
133	{
134		system("dpkg-deb -I $qarchive > $qdestfile");
135        }
136        elsif($filename =~ /^DEBIAN/)
137        {
138               $qfilename=~s!^DEBIAN/!!;
139               system("dpkg-deb -I $qarchive $qfilename > $qdestfile");
140	}
141	elsif($filename eq "INSTALL")
142	{
143		if ( open(FILEOUT,">$destfile") )
144		{
145			print FILEOUT $pressinstall;
146			close FILEOUT;
147			system("chmod a+x $qdestfile");
148		}
149	}
150	else
151	{
152	# files can be prepended with ./ or not, depending on the version of tar
153		$qfilename=~s!^CONTENTS/!!;
154		system("dpkg-deb --fsys-tarfile $qarchive | tar xOf - $qfilename ./$qfilename > $qdestfile 2>/dev/null");
155	}
156}
157
158sub mcdebfs_run
159{
160	local($archive,$filename)=@_;
161	local $qarchive = quote($archive);
162	if($filename eq "INSTALL")
163	{
164		print "Installing $archive\n";
165		system("dpkg -i $qarchive");
166	}
167	else
168	{
169		use File::Temp qw(mkdtemp);
170		my $template = "/tmp/mcdebfs.run.XXXXXX";
171		$template="$ENV{MC_TMPDIR}/mcdebfs.XXXXXX" if ($ENV{MC_TMPDIR});
172		$tmpdir = mkdtemp($template);
173		$tmpcmd="$tmpdir/run";
174		&mcdebfs_copyout($archive, $filename, $tmpcmd);
175		system("chmod u+x $tmpcmd");
176		system($tmpcmd);
177		unlink($tmpcmd);
178		rmdir($tmpdir);
179	}
180}
181
182$pressinstall=<<EOInstall;
183
184                              WARNING
185     Don\'t use this method if you are not willing to reinstall everything...
186
187This is not a real file. It is a way to install the package you are browsing.
188
189To install this package go back to the panel and press Enter on this file.
190
191In Debian systems, a package is automatically upgraded when you install a new
192version of it. There is no special upgrade option. Install always works.
193
194EOInstall
195
196umask 077;
197
198if($ARGV[0] eq "list") { shift; &mcdebfs_list(@ARGV); exit 0; }
199elsif($ARGV[0] eq "copyout") { shift; &mcdebfs_copyout(@ARGV); exit 0; }
200elsif($ARGV[0] eq "run") { shift; &mcdebfs_run(@ARGV); exit 0; }
201
202exit 1;
203
204