http://www.perlmonks.org?node_id=123783

#!/usr/bin/perl -w # Bugs In My Code? use strict; $/ =chr ( (($= << 1) /((1<<1 )* (int$]))). "\62" ); my@ sg=map{$_++;;my@l;; while($_){ my$z=1<<1; my$i= substr($_,0,$z);if($i>(int($])** $z)){$l[@l]="$|".$i ;}else{$l[@l]= $i.substr$_,$z,1;$z++}$_=substr$ _,$z,length$_;}@l=map chr,@ l;$_=join'',@l;}map{ my@y= split ''; map{$_ ='' if/[a-z]/}@ y;; join '', @y ;}map ( ( ( join'',split)) ,<DATA>);% _=() ;@_=(2401, 2414,2414, 2423,1264,1322, 1413,1483,1904 ,1940,265,299);;; ; ; $_=$|;while($_<@_){$ _{chr$_/(1<<1)}=[$_[$_ ],$_[ $_+1]];$_+=(1<<1)} my$ bug=3;$_=qq!seek$"DATA,$"$[,$" int($]-($=/($=/int($]))))!;my@b=qw |; _ $ @ ) { % =|;my%u=();my$t;my$s= $|;while (){undef $/;eval;my$m= <DATA>;$/= "\n" ;;while(){$t= int rand @_/(1<<1);last if !exists ($u{$t})}my $d =substr ($m,$_{ chr$ t}-> [$|] ,$_ { chr$t}->[ ++ $| ]-$_ { chr $t}->[--$|]) ;;; ;;; $d=~s+\s{2,2} ++gx ;$d=~ tr=\n==d;my$b;while(){ $b=$b [int rand@b];last if$d=~/\Q$b\E/};my$u=$d; my@z=split//,$u;;my@p;;foreach my$z($|..$#z){$p[@p]=$z if$z[$z] eq$b}substr($u,$p[int(rand@p)],$= >>int$])="";;;print qq+$sg[1<<1]$"$ b$"$sg[3]\n$u\n$sg[$[]$"$sg[$= >> int$]]:$"+;$u=<>;chomp$u;;;if($u eq$d){$s++;print "$sg[$|]! ";}print "$sg[1<<1**1<<1]: $s\n\n";;$bug--;; last if!$bug;$u{$t}=$t}print qq!$sg[int($ ])]$":)!if$s==(3+$bug);print"$sg[6]\n"__DATA__ 6711dh 11141g 141019 9115z11 g610410 1321h 08105 g h11 0100 z84104101 e1 14101321 15101101 1c 09 1153 f 21161 11 32h981 01h32973 2g1161 h21 112 11gh 132111101z10h51gh09z8y3 99cx1 1q1 1p1 4d1qd0o0z 6711as1110 103114d971161 1 5 3d3 328 9d111 117321049 7118101d321tyqu1 9111 11032 t116 1041 d013299 104 97108108 101w11010 j3 1 0146 32711 051181013 2jh1 21111 qt11711411 51011 f0810 2329 7321 d12971 163211s 11103211 610d 41013 29 8 979 910 6z 719x 710x 91013 sxc27911 8d10 ds11 f14 3g3 32 841dyf04 ds97dd x1101d t073 2fd1 2l 11fg 111 1732f fd102u1 adf1p 111 4as df3 er2112k10s df89qe7121 tyu1 05 1iry 10103 443211tyu2 1081 01jh 971ty 151uf0 1t32 9911 1i10910t 1a32 971t y039u 7105 11l 032 d jh

Replies are listed 'Best First'.
(maverick) Re: Bugs In My Code? (explained)
by maverick (Curate) on Nov 08, 2001 at 08:12 UTC
    I've parsed by hand, and explained it's actions (more or less) line by line in code comments. If there are any errors, or parts that are unclear. Please /msg me.

    Excellent obfu jryan! If anyone wants to preserve the magic, stop reading now :)

    #!/usr/bin/perl -w # Bugs In My Code? use strict; # set the input record separator to 'z' $/=chr((($= << 1)/((1<<1)*(int$])))."\62"); my @sg= map { $_++; # increment the last character my @l; while($_){ my $z=1<<1; # 2 my $i=substr($_,0,$z); # $i is two characters of $_ if ($i>(int($])**$z)){ # $] is the version number, int($]) == + 5, so if ($i > 25) { $l[@l]="$|".$i; # push(@l,"0".$i); } else { # otherwise take the number and the next digits and push i +nto @l; $l[@l]=$i.substr $_,$z,1; $z++ # 3 } $_=substr $_,$z,length$_; # remove those characters from $_ } @l = map chr,@l; # translate to character the elements +of @l (ascii values) $_ = join'',@l; # compress back into a line. } map { my @y=split''; # 1 character per array map { $_ = '' if/[a-z]/ # remove all lower a-z } @y; join '',@y; # join back together into one line # This could be translated as $_ =~ s/[a-z]//g; } map (((join'',split)),<DATA>); # remove all white space from _DATA_ # this is what's burried in __DATA__ # # @sg = ( "Correct", # "the line", # "There seems to be a type of", # "in", # "Score", # "Congrats! you have won the challenge. Give yourself a pa +t on the back", # "Game Over! Thank you for playing, please come again!" # ); %_=(); @_= (2401,2414,2414,2423,1264,1322,1413,1483,1904,1940,265,299); $_=$|; # turn the array into a hash of arrays with 2 elements each while ($_<@_){ $_{ chr $_/(1<<1) } = [ $_[$_], $_[$_+1] ]; $_+=(1<<1) } # gives you # # $VAR1 = { # '' => [ # ascii 0 # 2401, # 2414 # ], # '' => [ # ascii 1 # 2414, # 2423 # ], # '' => [ # ascii 2 # 1264, # 1322 # ], # '' => [ # ascii 3 # 1413, # 1483 # ], # '' => [ # ascii 4 # 1904, # 1940 # ], # '' => [ # ascii 5 # 265, # 299 # ] # }; # # these are the offset to yank out of $m for the questions my $bug=3; # number of bugs to quiz you about $_=qq!seek $" DATA, $" $[, $" int($]-($=/($=/int($]))))!; # $" = "", $[ == 0, $] == 5.6.0, $= == 60 # so we have, seek DATA, 0, int(5.6.0-(60 / (60/int("5.6.0")))); # or seek DATA, 0, 0; my @b = qw |; _ $ @ ) { % =|; # @b = (';','_','$','@',')','{','%','='); my %u=(); my $t; my $s=$|; while (){ undef $/; eval; # here is what makes Dparse toss it's cookies # seek DATA 0, 0 # here is what is being excuted. This resets DAT +A for the next question my $m = <DATA>; $/="\n"; while(){ $t = int rand @_/(1<<1); last if !exists ($u{$t}) } # this picks a random value for $t that doesn't exist in $u # (so you don't get the same question twice?) my $d = substr($m, # $_{ ascii $t}->[0] $_{chr $t}->[$|], # $_{ ascii $t}->[1] - $_{ascii $t}->[0] (differenc +e of [1]-[0] in %_; $_{chr $t}->[++$|] - $_{chr $t}->[--$|] ); # remove two consecutive white space characters $d =~ s/\s{2,2}//gx; # remove all the newlines $d =~ tr/\n//d; my $b; while () { # pick a random character to remove from the code fragment $b=$b[int rand @b]; last if $d =~ /\Q$b\E/ } my $u = $d; # $u now contains the character that was removed from $d # one char per element in @z of the code fragment my @z = split //,$u; my @p; print "$|\n"; # iterate across @z. $| == 0 foreach my $z ($|..$#z) { # push into @p the indexes where $b (the character to be remov +ed) are found $p[@p] = $z if $z[$z] eq $b } substr ($u, $p[int(rand @p)], $= >> int $] ) = ""; # substr as an lvalue *shudder* ($= >> int $] == 1) btw # now $u has had a randomly positioned instance of $b removed # $u now contains the 'quiz code' #print qq+$sg[1<<1]$"$b$"$sg[3]\n$u\n$sg[$[]$"$sg[$= >> int$]]:$"+ +; # de-jryan-ed # print $sg[2] , $b, $sg[3], "\n"; # "There seems to be a ty +po of" $b "in" # print $u, "\n"; # the code fragment # print $sg[0], $sg[1], ":"; # "Correct" "the line" ": +" # get your answer $u = <>; chomp $u; if ($u eq $d) { # you got it right $s (score) ++ $s++; # the message saying so $sg[0] "Correct!" print "$sg[$|]!"; } # print "$sg[4]: $s\n\n"; or print "Score: $s\n\n"; print "$sg[1<<1**1<<1]: $s\n\n"; $bug--; last if !$bug; # break out of the infinite loop # mark $t as used, so we don't get the same question twice $u{$t} = $t; } # print the congrats message if you got them all right. print qq!$sg[int($])]$":)! if $s == (3+$bug); # de-jryan-ed # print $sg[5] if $s == 3; # $bug == 0 print "$sg[6]\n" # Game Over! Thank you for playing... __DATA__ 6711dh 11141g 141019 9115z11 g610410 1321h 08105 g h11 0100 z84104101 e1 14101321 15101101 1c 09 1153 f 21161 11 32h981 01h32973 2g1161 h21 112 11gh 132111101z10h51gh09z8y3 99cx1 1q1 1p1 4d1qd0o0z 6711as1110 103114d971161 1 5 3d3 328 9d111 117321049 7118101d321tyqu1 9111 11032 t116 1041 d013299 104 97108108 101w11010 j3 1 0146 32711 051181013 2jh1 21111 qt11711411 51011 f0810 2329 7321 d12971 163211s 11103211 610d 41013 29 8 979 910 6z 719x 710x 91013 sxc27911 8d10 ds11 f14 3g3 32 841dyf04 ds97dd x1101d t073 2fd1 2l 11fg 111 1732f fd102u1 adf1p 111 4as df3 er2112k10s df89qe7121 tyu1 05 1iry 10103 443211tyu2 1081 01jh 971ty 151uf0 1t32 9911 1i10910t 1a32 971t y039u 7105 11l 032 d jh
    *WHEW!* :-)
    Update: minor typos corrected, and first pass mistaken notes to myself removed.

    Update 2:

    Corrections via CB conversation with jryan

    1. # remove two consecutive white space characters $d =~ s/\s{2,2}//gx;
      should really be
      # remove ALL occurances of two consecutive white space characters
      ie. 2, 4, 6, 8 .. This is because the code snippets are often broken by 40+ whitespace characters that need to be compressed out.
    2. while () { # pick a random character to remove from the code fragment $b=$b[int rand @b]; last if $d =~ /\Q$b\E/ }
      Random character *even if you get the same snippet*
    3. quote jryan (with permission)

      "0ne more thing you might wanna point out - one of the things i did intentionally is all of that parsing [of __DATA__]. i can throw all of the garbage in it that i want, but it will still come out correctly"

      ...the "join('',split)" at the tail of the 3 map block combined with the $_ = '' if /[a-z]/ in the middle map removes everything except 0-9 leaving __DATA__ open to be padded/polluted with anything else

    /\/\averick
    perl -l -e "eval pack('h*','072796e6470272f2c5f2c5166756279636b672');"

Re: Bugs in my code?
by jryan (Vicar) on Nov 07, 2001 at 13:06 UTC

    Have fun with this one :) A few things to note: SPACING MATTERS!!! The spacing on this has to be exact; I recommend downloading the code and then removing the trailing spaces at the end, and the leading space at the top.

    Also, a few monks that have tested it for me have told me that that there is an error; all have been running linux. However, other monks under linux have told me it works fine for them. I personally am running Activestate 5.6.1 under Windows 2000. However, there is nothing in the code that should prevent it from being non-cross platform. If you can spot the problem, please inform me so I can update it.

    Also, if the snippits it spits out at you are too hard, run it again. They'll change every time ;)

    Don't even bother with deparse; it'll make the interpreter puke all over your keyboard.

    Finally, don't vote on this comment node right here; I just wanted to make the parent node clean.

    Update:
    I think the problem that some people were having is that they are running versions of perl under 5.6.1; everyone who has msged me with a problem has been below that. So use this as an excuse to update ;)

      It's a DOS-style file, with "\r" on every line, and there is a blank first line before the shebang line. You can run it with `perl ./bugs.pl` or do `perl -i.bak -pe's/\r//' bugs.pl` and remove the first blank line then run with `./bugs.pl`.

      (cool obfu, though :)

Re: Bugs In My Code?
by CubicSpline (Friar) on Nov 07, 2001 at 18:29 UTC
    Very cool, jryan. It took me a while to figure out what I was supposed to do, but I finally did get my score of 3. =) ++ and nice work!

    ~CS

Re: Bugs In My Code?
by Caillte (Friar) on Nov 07, 2001 at 22:13 UTC

    ++ for the fun ;)

    However, there appears to be a bugette when run on perl 5.005_03 on RH linux 7.1 ... it often hangs after the second question, possibly because it picks a question beyond the number of questions asked... but there is no way i'm going to debug and see for myself, my eyesight is bad enough as it is ;)

    $japh->{'Caillte'} = $me;

Re: Bugs In My Code?
by TStanley (Canon) on Nov 08, 2001 at 06:25 UTC
    Ran just fine on Windows 95, ActiveState Perl 5.6.1 (Build 626). And my hat is off to you for an excellent piece of work.

    TStanley
    --------
    There's an infinite number of monkeys outside who want to talk to us
    about this script for Hamlet they've worked out
    -- Douglas Adams/Hitchhiker's Guide to the Galaxy