#!/usr/local/bin/perl

# this script takes in the name of a perl script and spits
# out an obfuscated, but fully functional perl script.
# variable names and subroutine names are changed to
# non-sensical identifiers, comments are stripped out,
# and whitespace is mangled.
#
# this is a one-way conversion. It is impossible to
# get the original source code from the obfuscated code.
# It still functions the same, but it is much more
# difficult for someone to modify your script or cut and
# paste your code into their own programs.
#
# it is NOT iron-clad security.
# 
# This script was written as a proof-of-concept
# it currently has some limitations.
# it cannot handle identifiers inside of double quotes.
#


package Lexer;

# the obfuscator uses the Lexer module written by Damian Conway.
# from Damian Conway's book "Object Oriented Perl", page 206           

# The remainder of the script is written by Greg London

#  Copyright (C) 2002 by Greg London All Rights Reserved.               #

#########################################################################
#                                                                       #
#  Copyright (C) 1999 by Manning Publications Co. All Rights Reserved.  #
#                                                                       #
#  This code is free software. It may be used, redistributed            #
#  and/or modified under the terms of the Perl Artistic License         #
#  (see http://www.perl.com/perl/misc/Artistic.html).                   #
#                                                                       #
#########################################################################


$VERSION = 2.00;
use strict;
use Carp;

sub _croak_cleanly
{
	$_[0] =~ m{/\\A\\s\*\((.*)\)/(.*) at .*}s;
	croak "/$1/$2";
}


sub new
{
	my ($class, @token_defs) = @_;
	my $code = '';
	while (my ($pattern, $token) = splice @token_defs, 0, 2 )
	{
		$code .= '$_[0] =~ s/\A\s*?('.$pattern.')// ';
		$code .= ' and return bless \"$1", '."'$token';\n";
	}
	$code .= '$_[0] =~ s/\A\s*(\S)// and return \"$1"; ';
	$code .= 'return;';

	my $sub = eval "sub { $code }" or _croak_cleanly($@);
	bless $sub, ref($class)||$class;
}

sub extract_next
{
	$_[0]->($_[1]);
}

sub lookahead
{
	my ($self, $str) = @_;
	my @next = $self->($str);
	return wantarray ? @next : $next[0];
}

sub extract_to
{
	my ($self) = @_;
	my @tokens = ();
	while (my @token_and_type = $self->($_[1]))
	{
		push @tokens, @token_and_type;
		last if defined($_[2]) && $token_and_type[1] eq $_[2];
	}
	return @tokens;
}

sub resync_after
{
	$_[0]->extract_to($_[1], $_[2]);
	return;
}

sub extract_all
{
	$_[0]->extract_to($_[1],undef);
}


package main;


my $lexer = Lexer->new 
	(
	'\#.*' => 'COMMENT',
	"\"[^\"]*\"" => 'SINGLEQUOTE',
	"'[^']*'" => 'SINGLEQUOTE',
	'my\s+[\$\@\%]\w{2,}' => 'MYDECLARATION',
	'sub\s+\w+(\:\:\w+)*' => 'SUBDECLARATION',
	'\d' => 'NUMBER',
	'[\$\@\%]\w+(\:\:\w+)*' => 'VARIABLE',
	'\s?\w+(\:\:\w+)*\s?(\s*\=\>)?' => 'IDENTIFIER',
	'\S' => 'UNKNOWN',
	);

@COMMENT::ISA 		= ('Pretty_Token');
@SINGLEQUOTE::ISA 	= ('Pretty_Token');
@MYDECLARATION::ISA 	= ('Pretty_Token');
@SUBDECLARATION::ISA 	= ('Pretty_Token');
@NUMBER::ISA 		= ('Pretty_Token');
@VARIABLE::ISA 		= ('Pretty_Token');
@IDENTIFIER::ISA 	= ('Pretty_Token');
@UNKNOWN::ISA 		= ('Pretty_Token');


sub COMMENT::pretty_print
{

}


sub SINGLEQUOTE::pretty_print
{
	print "${$_[0]}";

}

sub DOUBLEQUOTE::pretty_print
{
	my $var = ${$_[0]};

	$var =~ s/^"//;
	$var =~ s/"$//;

	print '"';
	foreach my $token ($lexer->extract_all($var))
		{	
		$token->pretty_print;
		}
	print '"';
}	


sub NUMBER::pretty_print
{
	print "${$_[0]}";
}


my %var_list;
my $var_counter =100;

my %sub_list;
my $sub_counter =100;

sub MYDECLARATION::pretty_print
{
	my $var = ${$_[0]};

	$var =~ s/^my\s+//;

	#print "my $var \t"; 

	$var =~ s/^(.)//;
	my $sigil = $1;

	my $cloudy;
	if(exists($var_list{$var}))
		{
		$cloudy = $var_list{$var};
		}	
	else
		{
		$cloudy = $var_counter++ . '';
		$cloudy =~ tr/0-9/a-j/;
		$var_list{$var}=$cloudy;
		} 
	print 'my '.$sigil.$cloudy.' ' ;
	#print "\n";
}

sub SUBDECLARATION::pretty_print
{
	my $sub = ${$_[0]};

	$sub =~ s/^sub\s+//;

	#print "my $sub \t"; 

	my $package ='';
	if ($sub =~ /\:\:/)
		{
		my @parts = split(/\:\:/, $sub);
		$sub = pop(@parts);
		$package=join('::', @parts) . '::';
		}

	my $cloudy;
	if(exists($sub_list{$sub}))
		{
		$cloudy = $sub_list{$sub};
		}	
	else
		{
		$cloudy = $sub_counter++ . '';
		$cloudy =~ tr/0-9/a-j/;
		$sub_list{$sub}=$cloudy;
		} 
	print 'sub '.$package.$cloudy.' ' ;
	#print "\n";
}

sub VARIABLE::pretty_print
{
	my $var = ${$_[0]};

	#print "$var ";

	$var =~ s/^(.)//;
	my $sigil = $1;
	if (length($var)==1)
		{
		print $sigil.$var;
		return;
		}

	my $cloudy = $var;
	if(exists($var_list{$var}))
		{
		$cloudy = $var_list{$var};
		}	
	print $sigil.$cloudy;
	#print "\n";
}

sub IDENTIFIER::pretty_print
{
	my $var = ${$_[0]};
	
	if ($var =~ /\=\>/)
		{
		print $var;
		return;
		}

	$var =~ s/^(\s)//;
	my $lead = $1;
	$var =~ s/(\s)$//;
	my $lag = $1;
	$lead=~s/\s/ /;
	$lag=~s/\s/ /;
	my $cloudy = $var;
	if(exists($var_list{$var}))
		{
		$cloudy = $var_list{$var};
		}	
	print $lead.$cloudy.$lag;
}

sub Pretty_Token::pretty_print
{
	my $var = ${$_[0]};
	print "$var";
	print "\n" if($var eq ';');

}


my $input = join '',<>;
foreach my $token ($lexer->extract_all($input))
	{	
	$token->pretty_print;
	}