#!/usr/bin/perl

use strict;
use warnings;

use Config;

use ExtUtils::Embed;

my %opt = (
'src' => 0,
'obj' => 0,
'out' => '',
);

my($target,$source,$srclen) = ('','',0);

for(my $i=0;$i<@ARGV;$i++){
  if($ARGV[$i] =~ /^[\-\/]c$/){
    $opt{src} = 1;
  } elsif($ARGV[$i] =~ /^[\-\/]o$/ && $i < @ARGV){
    $i++; $opt{out} = $ARGV[$i];
  } elsif($ARGV[$i] =~ /^\[-\/]o\:(.+)$/){
    $i++; $opt{out} = $1;
  } elsif($ARGV[$i] =~ /^[\-\/](Fo|O)$/){
    $opt{obj} = 1;
  } elsif(-f $ARGV[$i]){
    $target = $ARGV[$i];
  }
}

$opt{src} = 1 if $opt{out} =~ /\.c$/;
$opt{obj} = 1 if $opt{out} =~ /$Config{_o}$/;

exit unless open SRC,$target;
sysread SRC,$source,(-s SRC);
close SRC;

if(! eval{$target} && $@){
  print STDERR $@; exit;
} else{
  print STDOUT "perlpv-lint: passed $target\n";
}

$source =~ s/^\#\![^\r\n]+\s*//;
$srclen = length $source;

my($pkgnam) = $source =~ /^package\x20(((::)?\w+)+)/;
$pkgnam = 'main' if ! $pkgnam;

my $tmpsrc = $opt{out} ? $opt{out}.($opt{out} =~ s/(\.c|$Config{_exe}|$Config{_o})$//i ? '' : '') : ($target =~ s/\.pl$//i ? $target : $target);
my $outobj = $opt{out} ? $opt{out}.($opt{out} =~ /$Config{_o}$/ ? '' : $Config{_o}) : $tmpsrc.$Config{_o};
my $output = $opt{out} ? $opt{out}.($opt{out} =~ /$Config{_exe}$/ ? '' : $Config{_exe}) : $tmpsrc.$Config{_exe};
$tmpsrc .= '.c';

exit unless open TMP,">$tmpsrc";
flock(TMP,2);
{
  my(@mods,%seen);
  my $xsinit_proto = "pTHX";
  my $std = 1 unless scalar @mods;
  push(@mods, ExtUtils::Embed::static_ext()) if defined $std;
  @mods = grep(!$seen{$_}++, @mods);
  print TMP ExtUtils::Embed::xsi_header();
  print TMP "EXTERN_C void xs_init ($xsinit_proto);\n\n";
  print TMP ExtUtils::Embed::xsi_protos(@mods);
  print TMP "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n";
  print TMP ExtUtils::Embed::xsi_body(@mods);
  print TMP "}\n\n";
}
print TMP "static char SOURCE[] = {\n  ";
for(my $i=0;$i<$srclen;$i++){
  print TMP '0x'.unpack("H2",substr($source,$i,1));
  print TMP ((($i+1)%16) == 0)? ",\n  " : ', ';
}
print TMP "0x00\n};\n\n";
print TMP <<__END_OF_FUNCTION__;

int main(int argc,char **argv,char **envp){

  PerlInterpreter *my_perl;
  STRLEN n_a;
  char *embedding[] = {argv[0],"-e\\0","0\\0"};
  int exitstatus = 0;

  PERL_SYS_INIT3(&argc,&argv,&envp);
  if((my_perl = perl_alloc()) == NULL){
    fprintf(stderr,"no memory!");
    exit(1);
  }
  perl_construct(my_perl);
  PL_origalen = 1;
  exitstatus = perl_parse(my_perl,xs_init,3,embedding,(char**)NULL);
  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  exitstatus = perl_run(my_perl);
  eval_pv(SOURCE,TRUE);
  call_argv("$pkgnam\:\:main",G_DISCARD|G_EVAL,++argv);
  if(SvTRUE(ERRSV)){
    fprintf(stderr,"%s\\n",SvPV(ERRSV,n_a));
  }
  PL_perl_destruct_level = 0;
  perl_destruct(my_perl);
  perl_free(my_perl);
  PERL_SYS_TERM();
  exit(exitstatus);

}
__END_OF_FUNCTION__
close TMP;

exit if $opt{src};

my $OPTIMIZ = $Config{optimize};
my $CCFLAGS = ExtUtils::Embed::ccopts;
my $LDFLAGS = ExtUtils::Embed::ldopts;

if($^O =~ /cygwin/i){
  $CCFLAGS =~ s/\-fstack\-protector//g;
  $LDFLAGS =~ s/\-fstack\-protector//g;
}

if($Config{cc} eq 'cl'){
  `$Config{cc} $tmpsrc $CCFLAGS`;
  if(! $opt{obj}){
    `$Config{ld} $OPTIMIZ $outobj $LDFLAGS`;
    unlink $outobj;
    unlink glob '*.pdb';
  }
} elsif($opt{obj}){
  `$Config{cc} -c -o $outobj $tmpsrc $CCFLAGS`;
} else{
  `$Config{cc} $OPTIMIZ -o $output $tmpsrc $CCFLAGS $LDFLAGS`;
}

unlink $tmpsrc;
