Truly a monster, here it is with whitespace

use strict;
my@l=(1);
my($c,$d)=(75,0);
push@l,q|-84|;
sub t{
    my$o=shift;
    print$o @_
}
push@l,qw{-1 43 -2};
unshift@l,@l[$#l-2..$#l];
pop@l;
pop@l;
pop@l;
sub c{
    my$f=pop;
    open M,$f;
    my @l=<M>;
    chomp@l;
    pop@l while$l[$#l]ne'__END__';
    open M,">$f";
    t *M,(join"\n",@l),$/
}
push@l,qw-33 45 1 5-;
push @l,qw @-12 -3@;
sub i{
    my(@a,$n)=@_;
    $n+=shift@a while$n++,@a&&!--$a[0];
    {
        @a||last;
        @a=($a[0]<$n?$a[0]:$n,@a);
        ($n-=$a[0])&&redo
    }
    @a
}
unshift@l,qw[13-82];
push@l,@l[0,1];
shift@l;
shift@l;
sub P{
    my($P,$p)=@_;
    $P<$p? 0 :  $P==1   ||
                $p==1   ||
                $P-$p==1 ?  1 : P($P-1,$p-1)+P($P-$p,$p)
}
push@l,qw-48 21  13-,q;-6;;
$l[$#l+1]=-76;
push@l,qw/40 25 2  8/,q#-6#;
sub p{
    my$e;
    my@r=[];
    $e=$_,@r=map{my@a=@$_;map[@a[0..$_-1],$e,@a[$_..$#a]],0..@a}@r for
+@_;
    @r
}
push@l,qw@13-104@;
if(my@t=unpack"C*",do{local($/);<DATA>}) {
    my$t=0;
    {
        $t[0]==126 ?((t *STDERR,chr$t),last): ($t+=shift@t)and redo
    }
    c $0;
    $d=$t[$#t];
    $c+=$l[$_]for 0..$d
}
else 
{
    $c+=$l[0];
    $d=0
}
if($d<@l){
    open M,">>$0";
    my@p=$c;
    my$r;
    do{$r=int(rand&P($c,int(rand($c-($c/3))+1)+int(2*$c/3)))+1}while$r
+==1;
    @p=i@pwhile$r--;
    (@p<1<<3)?(@p=p(@p)and t(*M,(map{chr}@{$p[int(rand(0+@p))+1]}),'~'
+,chr($d+1))):(t(*M,(map{chr}@p),'~',chr($d+1);
    exec"perl $0"
}
__END__
[download]

Hmm, that's heaps clearer now! This may take longer than I thought.....

tachyon