#!/usr/bin/perl

# shroud

# Copyright 2000 Robert Jones, Craic Computing, All rights reserved.

# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

# The software is supplied as is, with absolutely no warranty.

#-----------------------------------------------------------
# POD documentation section
#-----------------------------------------------------------

=head1 NAME

shroud - Make the source code of a perl program unreadable

=head1 SYNOPSIS

shroud [B<--input> perl_script] [B<--noheader>] [B<--nopod>] [B<--nocomments>] [B<--exclude> perl_regexp]

=head1 DESCRIPTION

The distribution of a commercial Perl script poses a problem to developers
in that the source code is, by default, available to anyone using the
code. Even with a strong licensing agreement, developers risk their
intellectual property being taken and used in the development of other
codes. Solutions exist for encrypting Perl code or compiling it to
byte-code prior to distribution but these have their own problems. 
They may not permit POD documentation to be included in the files and
they may remove or obfuscate comments in the code related to 
copyright and licensing issues.

This program provides an alternative approach in that it transforms your 
nicely written and formatted perl code into something that is virtually
unreadable while still retaining all of the functionality of your code.
It does this by replacing variable names, declared with 'my' statements,
with arbitrary names and then by stripping extraneous whitespace and
comments.

After being shrouded your program will operate in exactly the same way
as the original. The logical sense of your code will not have been
changed in any way. It will, however, be extremely difficult to make
sense of the source code. This is an example of 'Security through
Obscurity' but it is a good compromise solution - pretty good protection
of your code at minimal 'cost' in terms of effort or complexity.

If you have had the dubious pleasure of trying to modify or port someone 
else's code then you will realize how difficult it can be to figure
out what a piece of code is doing. After you have applied this
filter to the code then the task becomes much more difficult.

NOTE that only variable names that are declared with a 'my' statement in 
the file are replaced, so as to avoid problems with libraries or perl special
variables like $0, $@, etc. This is an important restriction ! If you use
the 'strict' pragma then you'll be fine. If you don't use a single 'my' 
statement then no variables will be replaced.

The default operation is to leave in all comments and POD documentation
but to replace all local declared variables, delete all blank lines 
and strip out all leading whitespace from other lines.

Program options allow the user to strip out POD documentation, header
comments and all other comments. Header comments are defined as those at
the beginning of a file before any real code or POD documentation.
Typically these comments include the name of the program, the author and
any copyright and/or licensing information. It is often critical to
include this set of comments even though comments within the real code
can be eliminated. The 'nocomments' option does not strip the header comments.

In certain circumstances the user may wish to exclude certain variables
from the renaming step. This can be accomplished by using the 'exclude' option
and supplying a perl regular expression that matches that subset of variables.

=head1 OPTIONS

=item B<--input> input file

Specify the input perl script file

=item B<--noheader>

Strip out any header block of comments

=item B<--nopod>

Strip out any embedded POD documentation

=item B<--nocomments>

Strip out all comments

=item B<--exclude> Perl regexp

Exclude variables that match the pattern from the renaming process

=head1 EXAMPLES

shroud --nocomments --input mycode.pl

Strip all code comments and whitespace from 'mycode.pl' and replace all the
local variable names. Leave in the POD documentation and header comments.

shroud --nocomments --input mycode.pl --exclude '^foo_'

As above, but exclude variable names beginning with 'foo_' from being renamed.

shroud --nocomments --nopod --noheader --input mycode.pl

Remove all comments and documentation, strip whitespace and replace all
local variable names.


=head1 BUGS

Variable names where the '$' etc is escaped by a backslash in a 
print statement will be replaced, which may not be the right thing
to do. For example, in the statement :

print "variable \$foo";

$foo will be replaced even though the user wanted '$foo' to appear in
the program output.

=head1 AUTHOR

Copyright 2000 Robert Jones, Craic Computing (jones@craic.com). All Rights Reserved.

This program is free software. You can redistribute it and/or modify it
under the same terms as Perl itself. The software is supplied as is, with 
absolutely no warranty.

=head1 SCRIPT CATEGORIES

Unix/System_administration

=head1 OSNAMES

any

=head1 README

'shroud' is a script that will transform perl code into
virtually unreadable text, while retaining the full 
functionality of that code. It is used to shroud the
source code of commercial perl programs. More information 
is available from the POD documentation within the script 
and from this URL: http://www.craic.com/resources/tech_notes/tech_note_2.html

=cut

#-----------------------------------------------------------
# End of POD documentation
#-----------------------------------------------------------

use strict;

use FindBin;
use lib "$FindBin::Bin";

use Getopt::Long;

my $filename = "";
my %varHash = ();
my $var = "";
my $i = 0;
my $line = "";

# Default is not to exclude the header comments or the POD documentation

my $excludePod = 0;
my $excludeHeader = 0;
my $excludeComments = 0;

my $headerFlag = 1;
my $podFlag = 0;
my $firstLine = 1;

my $excludeVarPattern = "";

#-----------------------------------------------------------
# Option handling
#-----------------------------------------------------------

my %options = ();

GetOptions(\%options, "input=s",
                      "exclude=s",
  	              "nopod",
  	              "noheader",
  	              "nocomments",
                      );

if(defined $options{"input"}) {
    $filename = $options{"input"};
} else {
    die "You must specify an input file using the --input option\n";
}

if(defined $options{"nopod"}) {
    $excludePod = 1;
}

if(defined $options{"noheader"}) {
    $excludeHeader = 1;
}

if(defined $options{"nocomments"}) {
    $excludeComments = 1;
}

if(defined $options{"exclude"}) {
    $excludeVarPattern = $options{"exclude"};;
}



open INPUT, "< $filename" or die "Unable to open file $filename\n";

# Go through the code once extracting the names of all the
# variables ($xxx @xxx %xxx etc)

while(<INPUT>) {

   if(/(^|\s)my\s+\((.*?)\)/) {
      # get lines like my ($a, $b, $c);
      $line = $2;
   } elsif(/(^|\s)my\s+(.*?)[\=\;]/) {
      # get lines like my $a = 1;
      $line = $2;
   }

   while($line =~ /[\$\@\%]\{?\s*(\w+)\s*\}?/g) {
      $var = $1;
      if($var =~ /$excludeVarPattern/) {
         next;
      }

      $varHash{$var} = 1;
   }

}


# Give each variable an alternate name

$i = 0;
foreach $var (sort keys %varHash) {
   $varHash{$var} = newVariableName($i);
   $i++;
}

# Second Pass - replace the variables

seek INPUT, 0, 0;

while(<INPUT>) {

    if($firstLine) {
	print $_;
	$firstLine = 0;
	next;
    }

    if($headerFlag) {
        if(/^\s*[^\s#]/ or $podFlag) {
	   $headerFlag = 0;
        } else {
	    if(not $excludeHeader) {
	       print $_;
      	    }
	    next;
        }
    }

    if($podFlag == 0) {
       if(/^\s*\=\w+/) {
	   $podFlag = 1;
	   next if $excludePod;
       }
    } else {
       if(/^\s*\=cut/) {
	   $podFlag = 0;
       }
       next if $excludePod;
    }

    $line = $_;

    if(not $podFlag) {
      $line = replaceVariables($line);
      $line = stripLeadingWhitespace($line);
      if($excludeComments) {
         $line = stripComments($line);
      }
   }

   print $line;
}

close INPUT;


#------------------------------------------------------

sub stripLeadingWhitespace {

# Strip leading whitespace from lines
# and strips blank lines at the same time...

    my $line = $_[0];

    $line =~ s/^\s+//;
    $line;
}

#------------------------------------------------------

sub stripComments {

# Strips comments from lines

    my $line = $_[0];

    if($line =~ /^\s*\#/) {
	$line = "";
    } elsif($line =~ /\s\#[^\'\"\$\@\%]+$/) {
	$line =~ s/\s\#.*$//;
    }

    $line;
}


#------------------------------------------------------

sub replaceVariables {

    my $line = $_[0];
    my $var = "";
    my $var1 = "";
    my $newvar1 = "";

   # Replace the variables

   while(/(([\$\@\%]|\$\#)\{?\s*\w+\s*\}?)/g) {
      $var = $1;

      if($var =~ /([\$\@\%]|\$\#)\{?\s*(\w+)\s*\}?/) {
          $var1 = $2;

          if(exists $varHash{$var1}) {
              $newvar1 = $varHash{$var1};
              eval($line =~ s/([\$\@\%]|\$\#)(\{?\s*)$var1/$1$2$newvar1/);
          }
      }
   }

   $line;
}

#------------------------------------------------------

sub newVariableName {

# Replace a supplied INTEGER with an octal-based
# character string - eight characters

   my $oldvar = $_[0];
   my $newvar = "";
   my @charlist = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h');
   my $str = sprintf "%08lo", $oldvar;
   my $i = 0;
   foreach($i=0; $i<8; $i++) {
      $newvar .= $charlist[substr($str, $i, 1)];
   }

   $newvar;
}

#------------------------------------------------------