#!/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 also do "require $_[0]; 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(es) 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


To compile you will likely need to install the perl library for C.
Ubuntu/debian systems:  sudo apt-get install libperl-dev

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,@solarisinc);
	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));
	push(@solarisinc, qw (sys/socket.h sys/sockio.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"; }

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

	return if $opt->{block};

	# Dynaloader time
	my $xsinit = "perl -MExtUtils::Embed -e xsinit -- -o STDOUT";
	my $dyna = `$xsinit`;
	fatal("Error running perl xsinit command [$?]:\n%  $xsinit\n") unless $dyna && $?==0;
	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 <<"ENDGETMAC";

#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);
	if (SockFD<0) return "ERROR: Couldn't create socket";

	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";
}

ENDGETMAC
	}

	print C <<"ENDDECODE";

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;
	}
}

SV* my_eval_sv(SV *sv, I32 croak_on_error)
{
	dSP;
	SV* retval;


	PUSHMARK(SP);
	eval_sv(sv, G_SCALAR);

	SPAGAIN;
	retval = POPs;
	PUTBACK;

	if (croak_on_error && SvTRUE(ERRSV))
		croak_sv(ERRSV);

	return retval;
}

// This exit magic figured out by 'prdev 53' (2023/05/22)
IV get_exit_status() {
	SV *command = newSV(0);
	sv_setpvf(command, "defined \$!? \$! : (\$? >> 8 || 255)");
	return SvIV(my_eval_sv(command, TRUE));
}
ENDDECODE

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

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

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

	// Args  ['','-e','','--',@ARGV]
	int pargc = 3+argc;
	char **parg = calloc(pargc+2, (sizeof(char*)));
	// Need to strdup (at least parg[1]) so that we can modify $0
	parg[0] = strdup(""); parg[1] = strdup("-e"); parg[2] = strdup("");  parg[3] = strdup("--");
	for(pargc=4;pargc<3+argc;pargc++) {
		parg[pargc] = argv[pargc-3];
	}

$hostcheck

	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]);

	PERL_SYS_INIT3(&pargc, &parg, &env);
	if (!(my_perl = perl_alloc())) {
		fprintf(stderr,"Couldn't allocate memory\\n");
		exit(-1);
	}
	perl_construct(my_perl);
	if (perl_parse(my_perl, xs_init, pargc, parg, (char **)NULL)) {
		fprintf(stderr,"Trouble opening perl parser\\n");
		exit(-1);
	}

	PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
	eval_pv($block, G_VOID);
	int exitstatus = get_exit_status();

	perl_destruct(my_perl);
	perl_free(my_perl);
	PERL_SYS_TERM();

	fflush(stdout);

	exit(exitstatus);
}
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 -std=gnu89 -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 (so it's not '-e')
	# Caused a segfault until I found out that $0 couldn't be 'const char'
	# https://rt.perl.org/Public/Bug/Display.html?id=44129
	my $header = "BEGIN {\$0=\$^X;}\n";

	# Also fix exit() in perl causing exit to happen in C
	# Also also - flush at least STDOUT/STDERR since we'll surprise kill perl
	$header .= <<'EXIT_EVAL_FIX';
#my $____EXIT0__ = 0;
BEGIN {
	*CORE::GLOBAL::exit = sub(;$) {
		$! = $_[0];
		goto EXIT_PROGRAM;
		#$____EXIT0__ = 1 unless $_[0];
		#die("exit($_[0]) with error");
	}
}
EXIT_EVAL_FIX

	# Flush outputs since we might suddenly die, and check for exit()
	my $footer = <<'FOOTER';
EXIT_PROGRAM:
FOOTER

	# Deal with -pre
	$header .= "#line 1 \"-pre code\"\n".join("\n",@{$opt->{pre}}) if $opt->{pre};

	# Fix line numbers for errors
	my $prog = $opt->{exe} || $opt->{script};
	$header .= "\n#line 1 \"$prog\"\n";

	$script = $header.$script.$footer;

	# 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;
	}

	#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();