File Coverage

blib/lib/Module/Crypt.pm

Criterion	Covered	Total	%
statement	153	160	95.6
branch	21	36	58.3
condition	6	10	60.0
subroutine	21	22	95.4
pod	1	4	25.0
total	202	232	87.0

# ===========================================================================
# Module::Crypt
#
# Encrypt your Perl code and compile it into XS
#
# Author: Alessandro Ranellucci
# Copyright (c).
#
# This is EXPERIMENTAL code. Use it AT YOUR OWN RISK.
# See below for documentation.
#

package Module::Crypt;

use strict;
use warnings;
our $VERSION = 0.06;

use Carp qw[croak];
use ExtUtils::CBuilder ();
use ExtUtils::ParseXS ();
use ExtUtils::Mkbootstrap;
use File::Copy 'move';
use File::Find ();
use File::Path ();
use File::Spec ();
use File::Temp 'mktemp';
use IO::File;
use Crypt::RC4;

require Exporter;
our @ISA = qw[Exporter];
our @EXPORT = qw[CryptModule];

our @ToDelete;

sub CryptModule {
	my %Params = @_;

	# get modules list
	my @Files;
	if ($Params{file}) {
		push @Files, $Params{file};
	}
	if (ref $Params{files} eq 'ARRAY') {
		push @Files, @{$Params{files}};
	} elsif ($Params{files} && !ref $Params{files}) {
		$Params{files} = File::Spec->rel2abs($Params{files});
		if (-d $Params{files}) {
			# scan directory
			File::Find::find({wanted => sub {
				push @Files, $File::Find::name if $File::Find::name =~ /\.pm$/;
			}, no_chdir => 1}, $Params{files});
		} elsif (-f $Params{files}) {
			push @Files, $Params{file};
		}
	}
	my (%Modules, $package, $version);
	foreach my $file (@Files) {
		$file = File::Spec->rel2abs($file);
		croak("File $file does not exist") unless -e $file;
		$package = '';
		$version = '1.00';
		open(MOD, "<$file");
		while () {
			if (/^\s*package\s+([a-zA-Z0-9]+(?:::[a-zA-Z0-9_]+)*)\s*/) {
				$package = $1;
			}
			if (/^\s*(?:our\s+)?\$VERSION\s*=\s*['"]?([0-9a-z\.]+)['"]?\s*;/) {
				$version = $1;
			}
		}
		close MOD;
		croak("Failed to parse package name in $file") unless $package;
		croak("File $file conflicts with $Modules{$package}->{file} (package name: $package)")
			if $Modules{$package};
		$Modules{$package} = {file => $file, version => $version};
	}

	# let's make sure install_base exists
	$Params{install_base} ||= 'output';
	$Params{install_base} = File::Spec->rel2abs($Params{install_base});
	File::Path::mkpath($Params{install_base});

	# create temp directory
	my $TempDir = mktemp( File::Spec->catdir($Params{install_base}, "/tmp.XXXXXXXXX") );
	File::Path::mkpath($TempDir);
	push @ToDelete, $TempDir;

	# compile modules
	my $cbuilder = ExtUtils::CBuilder->new;

	foreach my $module (keys %Modules) {

		my @module_path = _module_path($module);
		my $module_basename = pop @module_path;

		# let's create path
		File::Path::mkpath( File::Spec->catdir($TempDir, @module_path) );

		# let's write source files
		my $newpath = File::Spec->catfile($TempDir, @module_path, "$module_basename");
		_write_c($module, $Modules{$module}->{version},
                 $Modules{$module}->{file}, $newpath,
                 $Params{password}, $Params{allow_debug},
                 $Params{addl_code});

		# .xs -> .c
		ExtUtils::ParseXS::process_file(
			filename => "$newpath.xs",
			prototypes => 0,
			output => "$newpath.c",
		);

		# .c -> .o
		my $obj_file = $cbuilder->object_file("$newpath.c");
		$cbuilder->compile(
			source => "$newpath.c",
			object_file => $obj_file
		);

		# .xs -> .bs
		ExtUtils::Mkbootstrap::Mkbootstrap($newpath);
		{my $fh = IO::File->new(">> $newpath.bs")};  # create

		# .o -> .(a|bundle)
		my $lib_file = $cbuilder->lib_file($obj_file);
		print "--> $lib_file\n";
		$cbuilder->link(
			module_name => $module,
	   		objects => [$obj_file],
			lib_file => $lib_file
		);

		# move everything to install_base
		my $final_path = File::Spec->catdir($Params{install_base}, @module_path);
		my $final_path_auto = File::Spec->catdir($Params{install_base}, "auto", @module_path, $module_basename);
		File::Path::mkpath($final_path);
		File::Path::mkpath($final_path_auto);
		move("${newpath}.pm", "${final_path}/${module_basename}.pm") or die $!;
		foreach (qw[bs a bundle so]) {
			next unless -e "$newpath.$_";
			move("${newpath}.$_", "${final_path_auto}/") or die $!;
		}
	}

 	_cleanup();
	return 1;
}

sub _module_path {
	my ($package) = @_;
	return split(/::/, $package);
}

sub END {
	_cleanup();
}

sub _cleanup {
	File::Path::rmtree($_) foreach @ToDelete;
}

sub _write_c {
	my ($package, $version, $pm, $newpath,      # UGH!
        $password, $allow_debug, $addl_code) = @_;

	# get source script
	open(SRC, "<$pm");
	my @lines = ;
	close SRC;


	# encrypt things
	open(XS, ">$newpath.xs");
	print XS wr( join('', @lines), $password, $allow_debug, $addl_code );
	print XS <<"EOF"

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include
#include
#include

/**
 * 'Alleged RC4' Source Code picked up from the news.
 * From: allen\@gateway.grumman.com (John L. Allen)
 * Newsgroups: comp.lang.c
 * Subject: Shrink this C code for fame and fun
 * Date: 21 May 1996 10:49:37 -0400
 */

static unsigned char stte[256], indx, jndx, kndx;

/*
 * Reset arc4 stte.
 */
void stte_0(void)
{
	indx = jndx = kndx = 0;
	do {
		stte[indx] = indx;
	} while (++indx);
}

/*
 * Set key. Can be used more than once.
 */
void key(void * str, int len)
{
	unsigned char tmp, * ptr = (unsigned char *)str;
	while (len > 0) {
		do {
			tmp = stte[indx];
			kndx += tmp;
			kndx += ptr[(int)indx % len];
			stte[indx] = stte[kndx];
			stte[kndx] = tmp;
		} while (++indx);
		ptr += 256;
		len -= 256;
	}
}

/*
 * Crypt data.
 */
void arc4(void * str, int len)
{
	unsigned char tmp, * ptr = (unsigned char *)str;
	while (len > 0) {
		indx++;
		tmp = stte[indx];
		jndx += tmp;
		stte[indx] = stte[jndx];
		stte[jndx] = tmp;
		tmp += stte[indx];
		*ptr ^= stte[tmp];
		ptr++;
		len--;
	}
}

MODULE = $package		PACKAGE = $package

BOOT:
    /* First try to detect if we're under debugger siege */
    if ( !ALLOW_DEBUG ) {
        int i;
        for ( i = 0; i < dbg_eval_z; i++ ) {
            dbg_eval[i] ^= PSWD_XOR;
        };

        SV *dbg = eval_pv(dbg_eval, G_SCALAR);

        if ( dbg != NULL && (int) SvIV(dbg) > 0 ) {
            /* Bomb 'em! */
            SV *sv = (SV *)0xBAADF00D;
            SvIVX(sv) = 0xDEADBEEF;
        };
    }

    /* Reveal the password */
    {
        int i;
        for ( i = 0; i < pswd_z; i++ ) {
            pswd[i] ^= PSWD_XOR;
        };
    }

    /* If we have additional check, unencrypt and run it now */
    if ( addl_z ) {
        stte_0();
        key(pswd, pswd_z);
        arc4(addl, addl_z);

        eval_pv(addl, G_SCALAR);

        SV *err = get_sv("@", 0);

        if ( SvPOK(err) && SvCUR(err) > 0 )
            croak(SvPV_nolen(err), NULL);
    };

    /* Now unencrypt main code and eval it */
	stte_0();
    key(pswd, pswd_z);
	arc4(text, text_z);

	eval_pv(text, G_SCALAR);

EOF
	;
	close XS;

	open(PM, ">$newpath.pm");
	print PM <<"EOF"
package $package;

use strict;
use warnings;

our \$VERSION = $version;

use XSLoader;
XSLoader::load __PACKAGE__, \$VERSION;

1;

EOF
	;
	close PM;
}

my $offset = 0;

sub wr {
    my ($script, $pass, $allow_debug, $addl_code) = @_;

    # First make sure password is set
    $pass      ||= generate_noise(256);
    my $pass_len = length $pass;

    # Now encrypt the data with un-XORed password
    my $encrypted = RC4($pass, $script);
    my $addl_encr = RC4($pass, $addl_code || '');

    # Password is XORed before writing in file
    my $pass_xor = chr int rand 256;
    $pass ^= $pass_xor x $pass_len;

    # Now determine padding size
    my $script_len         = length $encrypted;
    my $addl_len           = length $addl_encr;
    my $total_padding_len
        = (int(($pass_len + $script_len + $addl_len)/512) + 1) * 512
          - $script_len - $pass_len - $addl_len - 3;
    my $padding_start_len  = int rand $total_padding_len;
    my $padding_end_len    = int rand $total_padding_len -
                             $padding_start_len;
    my $padding_middle_len = $total_padding_len -
                             $padding_start_len - $padding_end_len;

    my ($padding_start, $padding_middle, $padding_end) = ('', '', '');
    $padding_start  .= chr int rand 256 for 0..$padding_start_len  - 1;
    $padding_middle .= chr int rand 256 for 0..$padding_middle_len - 1;
    $padding_end    .= chr int rand 256 for 0..$padding_end_len    - 1;

    my $data = $padding_start  . $pass      . "\0" .
               $padding_middle . $encrypted . "\0" .
               $padding_end    . $addl_encr . "\0";

    my $output = "static char data[] =" . print_bytes($data) .
                 ";\n\t/* End of data */\n";

    # Now definitions
    $output .= sprintf "#define     PSWD_XOR    %d\n", ord $pass_xor;
    $output .= sprintf "#define     pswd_z      %d\n", length $pass;
    $output .= sprintf "#define     pswd        ((&data[%d]))\n",
                       $padding_start_len;

    $output .= sprintf "#define     text_z      %d\n", length $encrypted;
    $output .= sprintf "#define     text        ((&data[%d]))\n",
                       $padding_start_len + length($pass) + 1 +
                       $padding_middle_len;

    $output .= sprintf "#define     addl_z      %d\n", length $addl_encr;
    $output .= sprintf "#define     addl        ((&data[%d]))\n",
                       $padding_start_len  + length($pass) + 1 +
                       $padding_middle_len + length($encrypted) + 1 +
                       $padding_end_len;

    # Debugger check command is eval'ed in situ
    # I have not found better way to check for $^P yet
    $output .= "#define     dbg_eval_z  3\n";
    $output .= sprintf "static char dbg_eval[] =" .
               print_bytes('$^P' ^ ($pass_xor x 3)) . ";\n";

    $output .= sprintf "#define     ALLOW_DEBUG %d\n", $allow_debug ? 1 : 0;

    return $output;
}

sub print_bytes {
    my ($bytes) = @_;

    my $output = "";

    for my $i ( 0 .. length($bytes) - 1 ) {
        $output .= qq{\n\t"} if ($i & 0xf) == 0;

        $output .= sprintf '\%03o', ord substr $bytes, $i, 1;

        $output .= '"' if ($i & 0xf) == 0xf;
    };

    $output .= '"' unless $output =~ /"$/;

    return $output;
}

sub generate_noise {
    my ($length) = @_;

    my $noise = "";

    for (0 .. $length - 1) {
        my $char;

        do { $char = chr int rand 128 } until ( $char =~ /^[[:alnum:]]$/ );

        $noise .= $char;
    };

    return $noise;
}

1;

__END__