Sur la page $a++ Vous trouverez un florilège de programmes écrits en Perl obscurci.
Le but du jeu étant d'incrémenter une variable sans que ça se sache.


En voici quelques uns que j'ai écrit.

    
@x=(4,2,1);
eval('$'.pack"c3",sprintf("0%o"x4,@x[2..2*2,2]),($x[0]*10+$x[1]+1)x2);
    
    
    
$x=sub{$b.=!length($b)?'$':'A'if (length($b)<2);($b.='+')
if (length($b)>=2);++$i<3 and &$x;return($b)};
eval(&$x);
    
    
    
map {if ($A){$i=$_ eq (pack
"C",(1<<5)+(1<<1)+1)?$i+int(log($A)/log(0xA))+1:$i+1;($_ eq (pack
"C",(1<<5)+(1<<1)+1)) and $A=$i/(int(log($A)/log(1+(1<<3)+1))+1)}
else{$A=1}}split(//,("$A"x$A).pack "C",(1<<5)+(1<<1)+1);
    
    
    
$A= $i.reverse(join("",map {!$b and $b=$i=!$b!=$i;$i=!!int(($_+=($i
or ""))/0xA);$_%=012} split(//,reverse($A))));
    
    
    
$A+=(split//,(localtime)[(gmtime)-(1<<2)])[$today];
    
    
    
pipe(LIT_P,ECRIT_F);
pipe(LIT_F,ECRIT_P);
local($fh)=select ECRIT_F; $|=1;select $fh;
local($fh)=select ECRIT_P; $|=1;select $fh;
if ($pid = fork) {
    close LIT_P;close ECRIT_P;
    print ECRIT_F "$A\n";
    chomp($A=<LIT_F>);
    close LIT_F;close ECRIT_F;
    waitpid($pid,0);
}
else {
    die "Pas moyen : $!" unless defined $pid;
    close LIT_F;close ECRIT_F;;
    chomp($B=<LIT_P>);
    $B+=int(log(2.718282));
    print ECRIT_P "$B\n";
    close LIT_P;close ECRIT_P;
    exit;
}
    
    
    
for (@b=split(//,unpack ("B32", pack("N",$A))) and $i=@b;$b[--$i] or 
!($b[$i]=1) or !($A=unpack("N",pack("B32",join("",@b))));$b[$i]=0) {};
    
    
    
sub A {$A[$A]=$A;(!$A and $A=!$A) or (($A-=$A/$A) and A and $A=@A)};A;
    
    
    
$x=sub{if (wantarray()){(pack "c",${($_=&$x)}+5)}else{pack "c",$=+1}};
$A =${($_=&$x)}/$=+${(@_=&$x)[0]};
    
    
    
while (1) {
  pipe(LIT_P,ECRIT_F);pipe(LIT_F,ECRIT_P);
  local($fh)=select ECRIT_F; $|=1;select $fh;
  local($fh)=select ECRIT_P; $|=1;select $fh;
  if ($pid = fork){
    close LIT_P;close ECRIT_P;
    print ECRIT_F ($A--,"\n");
    chomp($I=<LIT_F>);
    $X+=!!$I;
    close LIT_F;close ECRIT_F;
    waitpid($pid,0);
    ($I<0) and $A=$X and last;
  } else {
    die "Pas moyen : $!" unless defined $pid;
    close LIT_F;close ECRIT_F;;
    chomp($B=<LIT_P>);
    (print ECRIT_P ($B,"\n"));
    close LIT_P;close ECRIT_P;
    exit;
  }
}
    
    
    
$_=sub{$~=$|++?$|:${chr($=+=5)}};${chr($=)}=&$_+&$_;
    
    
    
$_=sub {$| or ($|=1 and @_=(1,1,0,0,4,2,3,5));return (substr("000001",5-shift(@_)))};
${eval(pack "B24",eval(substr('.&$_'x8,1)))}++;
    
    
    
for ($adn = "ATCACAACATTGATTG";($i<length($adn)) or !($_=(pack "B32",$y))
or !eval();$y.=substr(unpack("B8",substr($adn,$i++,1)),5,2)) {}
    
    
    
$B = !$B;
while (($A ^= $B) and !($A & $B)) {
 $B <<= 1;
}
    
    
    
sub s {
  my $n = @_[0];
  ($n)?($n + &s($n-1)):0
}
$A = $A?(&s($A)<<1)/$A:1;
    
    
    
   AUTOLOAD    {ASSEMBLEUR}
   set         ($B = $A);
   if          ($B == 0) {goto ZERO};
EMPILE:
   push        (@l, $B);
   subs        ($B = $B - 1);
   if          ($B!=0) {goto EMPILE}
DEPILE:
   set         ($x = pop(@l));
   if          (!$x) {goto CALCULE}
   add         ($B = $B + $x);
   goto         DEPILE;
CALCULE:
   shft        ($B = $B << 1);
   div         ($A = $B / $A);
   goto         TERMINE;
ZERO:
   exor        ($A = $A ^ 1);
TERMINE:
    
    
    
   AUTOLOAD    {ASSEMBLEUR}
   sub         sum {#Type : RECURSIVE }
   my          $n;
   set         (@PerlArray = @_);
   set         ($n = $PerlArray[0]);
   if          ($n) {goto NZ }
   goto        Z;
NZ:
   gosub       (sum($n - 1));
Z:
   set         ($x = $x + $n);
   return      ($x)}
   if          ($A) {goto M }
   exor        ($A = $A ^ 1);
   goto        FIN;
M:
   gosub       (sum($A));
   shft        ($x = $x << 1);
   div         ($A = $x / $A);
FIN:
    
    
    
sub add {
 my ($x,$y,$re) = @_;
 $s = $x ^ $y ^ $re;
 $rs = (($x and $y) or ($x and $re) or ($y and $re));
 return ($s, $rs)
}
$l = $A?int(log($A)/log(2))+2:2;
$x = substr(unpack ("B32", pack("N",$A)),-$l);
$y = substr(unpack ("B32", pack("N",1)),-$l);

foreach $i (1..length($x)) {
   ($s,$rs) = add(0+substr($x,-$i,1),0+substr($y,-$i,1),0+$re);
   $R = $s.$R;
   $re = $rs;
}

$A = unpack ("N", pack("B32" ,substr("0"x32 . $R,-32))); 
    
    
    
$x = sub {
($m,$n) = (0,$_[0]);
($m,$n) = ($n, $n?((($n%2)*($n*5+2)+$n)/2):// ) until ($m==//+$n);
};
$A +=&$x($A);
    
    
    

sub x {
   my $s = shift();
   return sub{return (shift() + $s);}
}
$A = x(s--> -) -> ($A);