Обфускатор скриптов на Perl

   1    #!/usr/bin/perl
   2    # RJ's Perl Obfuscator
   3    # fairly ALPHA danger keep your pants on.
   4    #$Id: obfuscator.pl,v 1.8 2000/02/25 17:10:09 rj Exp rj $
   5    
   6            my ($v)='v 1.8 2000/02/25 17:10:09';
   7    
   8    #*************************************
   9    # Internal configurable options
  10    #
  11    # Perl invocation line
  12    my ($invoke)="#!/usr/bin/perl";
  13    
  14    # bareword to quote delimiter
  15    my ($bwqd)=chr(151);
  16    
  17    # Debug mode flag
  18    my ($debug)=0;
  19    #*************************************
  20    
  21            use strict;
  22    
  23            my ($specialflag,$bareword);  # Parse state, bareword quote text
  24            my (@perldoc); # Array of perldoc'ed lines
  25            my (@goop);    # Array of parsed/quote-parsable lines
  26    
  27            # read the file
  28            open FI, $ARGV[0];
  29            while (my $x=<FI>)  {
  30                    # specialflag == 0 when parsing commands
  31                    # specialflag == 1 when parsing a perldoc entry
  32                    # specialflag == 2 when parsing a bareword quote translation
  33    
  34                    if (!$specialflag and ($x =~ /^\=head/))  {
  35                            $specialflag=1;
  36                    }
  37                    if (!$specialflag and ($x =~ /<<[\"\']*(\w+)[\"\']*;/)) {
  38                            $bareword=$1;
  39                            $x =~ s/\<\<$1\;$/\nqq$bwqd/;
  40                            $specialflag=2;
  41                    }
  42                    if (!$specialflag)  {
  43                            push @goop,$x;
  44                    }
  45                    if ($specialflag==1)  {
  46                            push @perldoc,$x;
  47                            if ($x =~ /^\=cut/)  {
  48                                    $specialflag=0;
  49                            }
  50                    }
  51                    if ($specialflag==2)  {
  52                            if ($x =~ /^$bareword\s*$/)  {
  53                                    $x ="$bwqd;";
  54                            }
  55                            push @goop,$x;
  56                    }
  57            }
  58            close FI;
  59    
  60            # pass 1 look for all vars/subs
  61            my(%subroutines);
  62            my(%variables);
  63    
  64            # A short list of the most popular special variables and one
  65            # I needed (%FORM) exported for a cgi implementation.
  66            my(@evilvars)=("ISA","ARGV","_","0","1","2","3","4","5","6","7","8","9","INC","ENV","F","SIG","FORM");
  67    
  68            my ($out,$line,$unquoted);
  69    
  70            foreach my $line(@goop)  {
  71                    my(@hits)= ($line =~ /[\$\@\%]\#*\{*([\w:]+)/g);
  72                    foreach (@hits)  {
  73                            $variables{$_}=$_;
  74                    }
  75                    @hits='';
  76                    (@hits)= $line =~ /\s*sub\s+(\w+)\s*/g;
  77                    foreach (@hits) {
  78                            $subroutines{$_}=$_;
  79                    }
  80            }        
  81    
  82            if ($debug==1)  {
  83                    print "\nFound variables:\n";
  84                    foreach (keys(%variables)) {
  85                            print "$_\n";
  86                    }
  87                    print "\nFound subroutines:\n";
  88                    foreach (keys(%subroutines)) {
  89                            print "$_\n";
  90                    }
  91            }
  92    
  93            # Obfuscate variables with simple substitution via a hash
  94            # Variables get base 26'ed starting high enough to have a letter a-k
  95            # I'm still toying with this part.  Seems to work, though.
  96            srand;
  97            my ($code);
  98            foreach (keys(%variables))  {
  99                    alreadyhavethat:
 100                    $code=lc(BaseConvert(int(rand(182780)+1)+182790,10,26));
 101                    if(in($code,values(%variables)))  { goto alreadyhavethat; }
 102                    # local namespace, only.  BTW, not intended for packages yet
 103                    if (!(/::/))  {
 104                            $variables{$_}=$code;
 105                    }
 106            }
 107    
 108            # Subroutines are simply lettered in sequence, sorry.
 109            my($i);
 110            foreach (keys(%subroutines))  {
 111                    $i++;
 112                    $subroutines{$_}=lc(BaseConvert($i+7030,10,26));
 113            }
 114    
 115            # Fix the variables we didn't really want to rename
 116            $i=0;
 117            foreach $i(@evilvars)  {
 118                    $variables{$i}=$i;
 119            }
 120    
 121    
 122            # Toss it over to a scalar, killing comments
 123            # Note the caveat... print " I like #5 "; will get killed here...
 124            foreach $line(@goop)  {
 125                    # Kill comments
 126                    $line=~s/(^|[^\$\\\S])\#.*$/$1/;
 127                    $out .= $line;
 128            }
 129    
 130            @goop = ();
 131    
 132            # Your line was killed by the comment eater just above here.
 133            print "$invoke\n";
 134            print "\# THIS FILE has passed through RJ's Perl Obfuscator $v\n\n";
 135            if ($#perldoc>-1)  {
 136                    print @perldoc;
 137            }
 138            print stringparse($out);
 139            exit;
 140    
 141    #########################################################
 142    
 143    sub stringparse  {
 144            # The string to work on
 145            my($a)=@_;
 146            my($out,$work);
 147            # Length of string
 148            my($l) = length($a);
 149            # The quote characters in all their glory
 150            my(@qc)= ("\"","'","`");
 151            # Running last 5 characters to find quote state change inside
 152            my(@l5,$last5);
 153            # next character
 154            my($cbyte);
 155            # index
 156            my($i);
 157            my($quoteflag);
 158            my($quotechar);
 159            for ($i=0; $i<$l; $i++)  {
 160                    $cbyte=substr($a,$i,1);
 161                    
 162                    # Keep a running 5 last original letters...
 163                    push @l5,$cbyte;
 164                    if (length(@l5>5)) { shift @l5; }
 165    
 166                    if (!$quoteflag)  {
 167    
 168                            # An actual quote-type character
 169                            $last5=join(undef,@l5);
 170                            # Do we have a quote character?
 171                            if (in($cbyte,@qc) and !$quoteflag)  {
 172                                    # Should we interpret it as a quote character?
 173                                    if (($last5 !~/\\$cbyte$/))  {
 174                                            $quotechar=endquotechar($cbyte);
 175                                            unless ($cbyte eq "\'")  {
 176                                                    $out.=chopnonquote($work,$quoteflag);
 177                                                    $quoteflag=1;
 178                                                    $work=undef;
 179                                            } else {
 180                                                    $out.=chopnonquote($work,$quoteflag);
 181                                                    $quoteflag=2;
 182                                                    $work=undef;
 183                                            }
 184                                    }
 185                                    @l5=();
 186                            }
 187    
 188                            $last5=join(undef,@l5);
 189                            # Cheat and use the qX hack
 190                            if ($last5 =~ m/[\b\s=(,.]q([^\s\w]{1})/)  {
 191                                    $quotechar=endquotechar($1);
 192                                    $out.=chopnonquote($work,$quoteflag);
 193                                    $quoteflag=2;
 194                                    $work=undef;
 195                                    @l5=();
 196                            }
 197    
 198                            $last5=join(undef,@l5);
 199                            # Cheat and use the qqX hack
 200                            if ($last5 =~ m/[\b\s=(,.]qq([^\s\w]{1})/)  {
 201                                    $quotechar=endquotechar($1);
 202                                    $out.=chopnonquote($work,$quoteflag);
 203                                    $quoteflag=1;
 204                                    $work=undef;
 205                                    @l5=();
 206                            }
 207    
 208                            $last5=join(undef,@l5);
 209                            if ($last5 =~ m/[\b\s=(,.]qx([^\s\w]{1})/)  {
 210                                    $quotechar=endquotechar($1);
 211                                    $out.=chopnonquote($work,$quoteflag);
 212                                    $quoteflag=1;
 213                                    $work=undef;
 214                                    @l5=();
 215                            }
 216                            # If we are still not in quotes...
 217                            if ($quoteflag<1)  {
 218                                    # Kill pretty formatting
 219                                    # This should really move to chopnonquote...
 220                                    if ($cbyte=~/[\s\n\t]/)  {
 221                                            if (substr($work, length($work)-1,1) eq " ")  {
 222                                                    $cbyte=undef;
 223                                            } else {
 224                                                    $cbyte=" ";
 225                                            }
 226                                    }
 227                            }
 228                    }  else {
 229                            # We are in quotes... can we get out?
 230                            if ($cbyte eq $quotechar)  {
 231                                    # is it escaped?
 232                                    if (!(($l5[($#l5)-1] eq "\\") and ($l5[($#l5)-2] ne "\\")))  {
 233                                            $quotechar=undef;
 234                                            @l5=();
 235                                            $out.=chopnonquote($work,$quoteflag);
 236                                            $work=undef;
 237                                            $quoteflag=0;
 238                                    }
 239                            }
 240                            if ($quoteflag==1)  {
 241                                    if ($cbyte eq "\n")  {
 242                                            $cbyte = '\n';
 243                                    }
 244                                    if ($cbyte eq "\t")  {
 245                                            $cbyte = '\t';
 246                                    }
 247                            }
 248                    }
 249                    
 250                    $work .= $cbyte;
 251            }
 252            $out =~ s/^\s//;
 253            return $out.chopnonquote($work,$quoteflag);
 254    }        
 255    
 256    sub chopnonquote
 257    {
 258            my($work, $mode)=@_;
 259    
 260    
 261            # Replace variables
 262            if ($mode<2)  { # was ([\w:]+)
 263                    $work =~ s/([\$\@\%]\#*\{*)([\w^:]+)/$1$variables{$2}/g;
 264            }
 265    
 266            # Replace subroutines
 267            if ($mode==0  and (lc($ARGV[1]) ne 'p'))  {
 268                    foreach (keys(%subroutines))  {
 269                            unless ($work =~ /\:$_/)  {
 270                                    $work =~ s/\b($_)\b/$subroutines{$1}/g;
 271                            }
 272                    }
 273            }
 274    
 275            if (!$debug) {
 276                    return $work;
 277            } else {
 278                    return "\n"x($mode==0).$work."\n"x($mode==0);
 279                    #print "[".$work."]<".$mode.">\n";
 280                    return undef;
 281            }
 282    }
 283    
 284    
 285    sub endquotechar
 286    {
 287            my ($qc)=@_;
 288            if ($qc eq "{")  {
 289                    $qc="}";
 290            }
 291            if ($qc eq "[")  {
 292                    $qc="]";
 293            }
 294            if ($qc eq "\(") {
 295                    $qc="\)";
 296            }
 297            if ($qc eq "<")  {
 298                    $qc=">";
 299            }
 300            return $qc;
 301    }
 302    
 303    ############### NMX.pm ROUTINES swiped to make it portable ################
 304    ############### WRITTEN BY Nathan Morse ###################################
 305    ############### Thanks, man!  ;^>
 306    
 307    # BaseConvert($number,$FromBase,$ToBase)
 308    # converts a "number" from one base to another
 309    # doesn't deal with "decimal" values yet
 310    sub BaseConvert
 311    {
 312            my(%digit);
 313            my($i,$letter,$from,$to,$n);
 314            
 315            $letter="A";
 316            for$i(0..35)
 317            {        
 318                    if($i<10)
 319                    {
 320                            $digit{$i}="$i";
 321                    }
 322                    else
 323                    {
 324                            $digit{$i}=$letter++;
 325                    }
 326            }
 327            
 328            ($n,$from,$to)=@_;
 329            $n=uc$n;
 330            $n=to10($n,$from,reverse%digit)if($from!=10);
 331            $n=from10($n,$to,%digit)if($to!=10);
 332            $n=~s/^0*//;
 333            if($n)
 334            {
 335                    return$n;
 336            }
 337            else
 338            {
 339                    return"0";
 340            }
 341            
 342            sub from10
 343            {
 344                    my($n,$to,$nout,%digit);
 345                    $nout="";
 346                    ($n,$to,%digit)=@_;
 347                    while($n>0)
 348                    {
 349                            $nout=$digit{$n%$to}.$nout;
 350                            $n=int($n/$to);
 351                    }
 352                    $nout=$n%$to.$nout;
 353                    $n=$n/$to;
 354                    return$nout;
 355            }
 356            
 357            sub to10
 358            {
 359                    my($n,$from,$nout,$p,%digit);
 360                    ($n,$from,%digit)=@_;
 361                    for$p(0..(length$n)-1)
 362                    {
 363                            $nout+=$digit{substr($n,(length$n)-$p-1,1)}*$from**$p;
 364                    }
 365                    return$nout;
 366            }
 367    }
 368    
 369    # in($SearchString,$StartPosition,@ArrayToSearch) searches an array for a value
 370    # returns true if found, or false if not
 371    sub in
 372    {
 373            my($string,@array)=@_;
 374            my($found)=-1;
 375            my($element);
 376            foreach$element(@array)
 377            {
 378                    return 1 if($element eq $string);
 379            }
 380            return 0;
 381    }