#!/usr/bin/perl
# Filename:	perlc
# Author:	David Ljung Madison <DaveSource.com>
# See License:	http://MarginalHacks.com/License/
# Description:	Create a perl executable by embedding the script in C code
use strict;
use ExtUtils::Embed;

##################################################
# Setup the variables
##################################################
my $PROGNAME = $0; $PROGNAME =~ s|.*/||;

my $LIBPERL = '/usr/lib/libperl.a';	# For static linking hack

##################################################
# Filters
##################################################
sub attempt_use {
	my $save = $SIG{__DIE__};
	$SIG{__DIE__} = 'ignore';
	### could replace this with: eval("use $_[0]") so we can 'use' instead of require
	### could also add "; import $_[0]"
	eval("use $_[0]");
	my $ret = $@ ? 0 : 1;
	$SIG{__DIE__} = $save;
	$ret;
}

sub bleach {
	my ($scriptP) = @_;
	usage("Can't -bleach, PAR::Filter::Bleach not installed")
		unless attempt_use "PAR::Filter::Bleach";
	PAR::Filter::Bleach->apply($scriptP); 
}

##################################################
# Usage
##################################################
sub fatal {
	foreach my $msg (@_) { print STDERR "[$PROGNAME] ERROR:  $msg\n"; }
	exit(-1);
}

sub usage {
	foreach my $msg (@_) { print STDERR "ERROR:  $msg\n"; }
	print STDERR <<USAGE;

Usage:\t$PROGNAME [-d] <script>
  Convert a perl script to (embedded) C code

  -key <str>         Specify key for encode/decode of embedded script
  -exe <exec>        Compile the code into an executable
  -block <name>      Just print out C code that contains script as a block
                     - Out is the block <name> and decode(block,key)
  -o <file>          Save output to specified file.
  -bleach            Also bleach code using PAR::Filter::Bleach (if avail)
  -d                 Debug mode (show actions)
  -pre <code>        Code to insert at the top of the perl script
  -mac <addr>        Required mac address for the script to run
  -static            Kludge for statically linking libperl (likely to break!)
                       You will likely need to set \@INC or else include modules.
                       Uses:  $LIBPERL

USAGE
	exit -1;
}

sub parse_args {
	my $opt = {
		key => 'somekey',
	};
	while (my $arg=shift(@ARGV)) {
		if ($arg =~ /^-h$/) { usage(); }
		if ($arg =~ /^-d$/) { $MAIN::DEBUG=1; next; }
		if ($arg =~ /^-o$/) { $opt->{out} = shift @ARGV; next; }
		if ($arg =~ /^-exe$/) { $opt->{exe} = shift @ARGV; next; }
		if ($arg =~ /^-key$/) { $opt->{key} = shift @ARGV; next; }
		if ($arg =~ /^-block$/) { $opt->{block} = shift @ARGV; next; }
		if ($arg =~ /^-bleach$/) { $opt->{bleach} = 1; next; }
		if ($arg =~ /^-static$/) { $opt->{static} = 1; next; }
		if ($arg =~ /^-pre$/) { push(@{$opt->{pre}}, shift @ARGV); next; }
		if ($arg =~ /^-mac$/) { push(@{$opt->{mac}}, shift @ARGV); next; }
		if ($arg =~ /^-./) { usage("Unknown option: $arg"); }
		usage("Too many scripts specified [$arg and $opt->{script}]") if $opt->{script};
		$opt->{script}=$arg;
	}
	usage("No script defined") unless $opt->{script};

	$opt;
}

sub debug {
	return unless $MAIN::DEBUG;
	foreach my $msg (@_) { print STDERR "[$PROGNAME] $msg\n"; }
}

##################################################
# C code
##################################################
sub Cheader {
	my ($opt) = @_;

	my @inc;
	push(@inc, qw (EXTERN.h perl.h XSUB.h)) unless $opt->{block};
	push(@inc, qw (stdlib.h string.h sys/ioctl.h net/if.h));

	print C <<TOP;
/* **************************************************
 * C wrapper for perl, created by $PROGNAME
 *   http://MarginalHacks.com/Hacks/perlc/
 *
 * To compile (on this system):
 * % $opt->{compile}
 *
 * ************************************************** */
TOP

	foreach my $inc ( @inc ) {
		print C "#include <$inc>\n";
	}

 	return if $opt->{block};

	# Dynaloader time
	my $dyna = `perl -MExtUtils::Embed -e xsinit -- -o -`;
	print C $dyna;
}

sub Cmain {
	my ($opt) = @_;

	my $block = $opt->{block} || "block";
	my ($hostcheck,$hostcheckvars) = ("","");

	if ($opt->{mac}) {
		$hostcheckvars = <<HOSTCHECKVARS;
	char *macAddr = getMac();
	int foundMac = 0;
HOSTCHECKVARS

		$hostcheck = "\tsetenv(\"MACADDR\",macAddr,1);\n";

		foreach my $mac ( @{$opt->{mac}} ) {
			$hostcheck .= <<MACCHECK;
	if (!foundMac && !strcmp(macAddr,"$mac")) foundMac = 1;
MACCHECK
		}
		$hostcheck .= <<HOSTCHECK;
	if (!foundMac) {
		fprintf(stderr,"Host mac address [%s] did not match\\n",macAddr);
		exit(-2);
	}
HOSTCHECK
	}

	print C <<"ENDDECODE";

#define MAX_IFS 64
char * getMac() {
	struct ifreq *ifr, *ifend;
	struct ifreq ifreq;
	struct ifconf ifc;
	struct ifreq ifs[MAX_IFS];
	char *data = malloc(18*sizeof(char));
	int SockFD;

	if (data==NULL) return "ERROR: malloc";
	SockFD = socket(AF_INET, SOCK_DGRAM, 0);

	ifc.ifc_len = sizeof(ifs);
	ifc.ifc_req = ifs;
	if (ioctl(SockFD, SIOCGIFCONF, &ifc) < 0) return "ERROR: No configs?";

	ifend = ifs + (ifc.ifc_len / sizeof(struct ifreq));
	for (ifr = ifc.ifc_req; ifr < ifend; ifr++) {
		if (ifr->ifr_addr.sa_family == AF_INET) {
			strncpy(ifreq.ifr_name, ifr->ifr_name,sizeof(ifreq.ifr_name));
			if (ioctl (SockFD, SIOCGIFHWADDR, &ifreq) < 0) continue;
			// Found one for interface: ifreq.ifr_name
	  	sprintf(data,"%02x:%02x:%02x:%02x:%02x:%02x",
				(int) ((unsigned char *) &ifreq.ifr_hwaddr.sa_data)[0],
				(int) ((unsigned char *) &ifreq.ifr_hwaddr.sa_data)[1],
				(int) ((unsigned char *) &ifreq.ifr_hwaddr.sa_data)[2],
				(int) ((unsigned char *) &ifreq.ifr_hwaddr.sa_data)[3],
				(int) ((unsigned char *) &ifreq.ifr_hwaddr.sa_data)[4],
				(int) ((unsigned char *) &ifreq.ifr_hwaddr.sa_data)[5]);
			if (strcmp(data,"00:00:00:00:00:00")) return data;
 		}
	}

	free(data);
	return "ERROR: No interfaces found";
}

void
decode(char *block, char *key, int len) {
	int keylen = strlen(key);
	int i;

	if (keylen==0) return;

	for (i=0; i<len; i++) {
		block[i] -= key[i%keylen];
		block[i] %= 0xff;
	}
}
ENDDECODE

	print C <<"ENDMAIN" unless $opt->{block};

int
main(int argc, char **argv, char **env) {
$hostcheckvars
	PerlInterpreter *my_perl;

$hostcheck

	// Args  ['','-e','','--',@ARGV]
	int pargc = 3+argc;
	char **parg = calloc(pargc+2, (sizeof(char*)));
	parg[0] = ""; parg[1] = "-e"; parg[2] = "";  parg[3] = "--";
	for(pargc=4;pargc<3+argc;pargc++) {
		parg[pargc] = argv[pargc-3];
	}

	// Modify this code to put the key somewhere external for more protection
	char *key = "$opt->{key}";

	decode($block,key,$opt->{len});
	//printf("BLOCK: [%c%c%c%c%c%c%c%c]\\n",block[0],block[1],block[2],block[3],block[4],block[5],block[6],block[7]);

	my_perl = perl_alloc();
	perl_construct(my_perl);
	if (perl_parse(my_perl, xs_init, pargc, parg, (char **)NULL)) {
		fprintf(stderr,"Trouble opening perl parser\\n");
		return -1;
	}

	eval_pv($block, G_VOID);


	perl_destruct(my_perl);
	perl_free(my_perl);
	return 0;
}
ENDMAIN
}

##################################################
# Building
##################################################
sub mySys {
	my (@cmd) = @_;
	print "@cmd\n" if $MAIN::DEBUG;
	system(@cmd);
	fatal("Error running [@cmd]") if $?;
}

sub compileCommand {
	my ($opt,$c) = @_;

	my $out = $opt->{exe} || 'a.out';

	my $ccopts = ccopts(0);
	my $ldopts = ldopts(0);
	if ($opt->{static}) {
		if (-f $LIBPERL) {
			$ldopts =~ s/ -lperl / $LIBPERL /;
		} else {
			print STDERR "[ERROR] Couldn't find \$LIBPERL [$LIBPERL]\n";
		}
	}
	$opt->{compile} = "gcc -o $out $c $ccopts $ldopts";
}

sub compile {
	my ($opt,$c) = @_;

	return unless $opt->{exe};
	mySys($opt->{compile});
	print "Exe: $opt->{exe}\n";
}

##################################################
# Main code
##################################################
sub main {
	my $opt = parse_args();

	my $c = $opt->{out};
	unless ($c) {
		$c = $opt->{script};
		$c = "stdin" if $c eq '-';
		$c =~ s/\.p.?$//;
		$c .= ".c";
	}

	compileCommand($opt,$c);

	my $script;
	open(FILE,"<$opt->{script}") || usage("Couldn't open script [$opt->{script}]");
	while(<FILE>) { $script .= $_; }
	close FILE;

	# Fix $0 (hopefully this doesn't break anything..)
	##Causes a segfault??##$script = "BEGIN {\$0=\$^X;}\n".$script;
	$script = join("\n",@{$opt->{pre}}).$script if $opt->{pre};

	# Apply filters
	bleach(\$script) if $opt->{bleach};

	open(C,">$c") || usage("Couldn't write C source [$c]");
	
	Cheader($opt);
	
	my $block = $opt->{block} || "block";
	# char block[] = {0x...,0x0};
	print C "char ${block}[] = {\n  ";
	
	my @key = map { ord($_) } split('', $opt->{key});

	my $cnt=0;
	sub chOut {
		my ($ch) = @_;
		my $x = ord($ch);
		$x += $key[$cnt%($#key+1)] if @key;
		$x %= 0xff;
		printf C "0x%0.2x,",$x;
		print C "\n  " unless ++$cnt%14;
	}

	# Hack: Set $0 at the top
	my $zero = "\$0 = \"$opt->{script}\";\n";
	#map { chOut($_) } split('',$zero);

	#while(read(FILE,$ch,1)) { chOut($ch); }	# Old way, read->write w/out filters
	my $ch;
	while(ord($ch = substr($script,0,1,''))) {
		chOut($ch);
		$opt->{len}++;
	}

	print C "0};\n";

	Cmain($opt);

	close(C);
	print STDERR "Out: $c\n" unless $opt->{exe} && $opt->{script} eq '-';

	compile($opt,$c);
	unlink($c) if $opt->{exe} && $opt->{script} eq '-';
}
main();