#!/usr/bin/perl -s

use Data::Dumper;
use IO::All;
our ($init,$install);

use strict;
use Parse::DSLUtils qw{:all};
skimport();

my $base= shift or die("Usage: $0 [options] base
   where options:
     -init     (creates a base initial set of files)
     -install  (install basepp in /usr/local/bin)\n");
$base =~ s/\.def$//;

my $userperl = "#...perl";
my $fproctabinit = "";
my $sproctabinit = "";
my   $pretabinit = "";
my $makefile="";
my $posproc="undef;";

if($init){init($base); exit 0; }

buildit($base);

sub init{ my $base = shift;
  mkdir "$base.plugins";
  if(not -f "$base.def"){
     open(F,">", "$base.def") or die;
     print F q{ 
#comments    (for declarations, usepackages, etc)  \g1=type
#initRE:     qr{ INIT($typespat|$base) }x

#comments                \g1=type  \g2=opts 
#beginRE:    qr{($typespat) }x

#comments                \g1=type
#endRE:      qr{            }x

#comments                \g1=type  \g2=opts \g3=file
#off_includeRE: qr{            }x

#off_inlinecomRE: qr{            }x

#off_perl:

};
     close F;
  }
  for my $plugin(@ARGV){
     next if (-f "$base.plugins/$plugin");
     open(F,">", "$base.plugins/$plugin") or die;
     
     print F "#ext: $plugin\n\n";
     print F "#procfile: \n\nsub{my (\$fbase,\$op)=\@_;\n'';\n};\n\n";
     print F "#off_procstr:\n\nsub{my (\$str,\$op)=\@_;\n'';\n};\n\n";
     print F "#off_preproc:\n\nsub{my (\$s,\$op)=\@_;\n'';\n};\n\n";
     print F "#off_makefile:\n\n%.pdf: %.$plugin\n\t${plugin}2pdf \$*.$plugin > \$*.pdf\n\n";
     print F "#off_perl:\n\n";
     close F;
  }
}

sub buildit{ my $base=shift;
  my %TB=();
  my $def < io "$base.def";
  my $deftab  = parse_hashf($def);
  $posproc    = "\n$deftab->{posproc};\n" if $deftab->{posproc};
  $makefile  .= "\n$deftab->{makefile}\n" if $deftab->{makefile};
  $userperl  .= "\n$deftab->{perl}\n"     if $deftab->{perl};
  my @pls= io->dir("$base.plugins")->all;
  my $typespat = join("|",(map { s!.*plugins/!!r} @pls));
  for my $plug(@pls){
    my $plugintext < io "$plug";
    my $type= ($plug =~ s!$base\.plugins/!!r);
    $TB{$type}=parse_hashf($plugintext);
    $fproctabinit .= "\$fproctab{$type}= $TB{$type}{procfile};\n"
           if $TB{$type}{procfile};
	$sproctabinit .= "\$sproctab{$type}= $TB{$type}{procstr};\n" 
           if $TB{$type}{procstr};
	$pretabinit   .= "\$pretab{$type}= $TB{$type}{preproc};\n" 
           if $TB{$type}{preproc};
	$makefile     .= "\n$TB{$type}{makefile}\n" 
           if $TB{$type}{makefile};
	$userperl     .= "\n$TB{$type}{perl}\n" 
           if $TB{$type}{perl};
  }

  if($install){
     open(F,">","/usr/local/bin/$base-pp") or die("cant create $base-pp\n");
  } else {
     open(F,">","$base-pp") or die("cant create $base-pp\n");
  }
  print F lang_importer_template({
    typespat     => $typespat,
    userperl     => $userperl,
    makefile     => $makefile,
    posproc      => $posproc,
    fproctabinit => $fproctabinit,
    sproctabinit => $sproctabinit,
    pretabinit   => $pretabinit,
    globaldefs   => global_defs($deftab)
  });

  print F "\n__END__\n", Dumper(\%TB);
  close F;
  if($install){ chmod(0755, "/usr/local/bin/$base-pp"); }
  else        { chmod(0755, "$base-pp"); }
}

sub parse_hashf{ my ($s)=@_;
  my %a;
  while($s =~ m!#(\w+):\s*(.*?)\s*(?=\n#|$)!sg){
     $a{$1} = $2;
  }
  \%a;
}

__DATA__

__global_defs__
[% default:{
   initRE=> sub{my %a=@_; "qr{==_undefined_for_this_language}"},
   includeRE=> sub{my %a=@_; "qr{==_undefined_for_this_language}"},
   inlinecomRE=> sub{my %a=@_; "qr{==_undefined_for_this_language}"},
}
%]

   my $beginRE   = [% beginRE %];
   my $endRE     = [% endRE %]; 
   my $initRE    = [% initRE %];
   my $includeRE = [% includeRE %];
   my $inlinecomRE = [% inlinecomRE %];

__lang_importer_template__
#!/usr/bin/perl

## reusable regexp : curly brackets block
my $cbb0 = qr((?:\\[{}]|[^{}])*);
my $cbb1 = qr(\{$cbb0\});
my $cbb2 = qr(\{$cbb0(?:$cbb1*$cbb0)*\});
my $cbb3 = qr(\{$cbb0(?:$cbb2*$cbb0)*\});
my $cbb4 = qr(\{$cbb0(?:$cbb3*$cbb0)*\});
my $cbbm = qr($cbb0(?:$cbb4*$cbb0)*);
my $debug=1;

use strict;
use Data::Dumper;
my %fproctab;          ##procfile
[% fproctabinit %]

my %sproctab;          ##procstr
[% sproctabinit %]

my %pretab;            ##preproc
[% pretabinit %]

my @temporary_files;

my $posproc= [% posproc %];

my $makefilerules= q{
[% makefile %]
};

[% userperl %]

## beginRE endRE    
   my $typespat = '[%typespat%]';
[% globaldefs %]

importer();

sub importer{
  local $/=undef;
  my $t=<>;
  my $chunks = extractor($t);
  processor($chunks);
  my $out= replacer($t,$chunks);
  if(ref($posproc) eq "CODE"){
    return $posproc->($out);
  }
  else{
    return($out); 
  }
}

sub processor{ my($chks)=@_;
  for my $chk (@$chks){
    my ($type,$ch,$op,$cht)=($chk->{type},$chk->{chunk},
                             $chk->{opt}, $chk->{cktype});

    $op //= {};
    if($pretab{$type}){           ## preproc(str) 
      $ch=$pretab{$type}->($ch,$op);
    }
    if($cht eq "init"){                ## INIT
       ## FIXME
    }
    if($fproctab{$type}){         ## procfile(file)
      if($cht eq "include"){                ## inludefile(file)
        my $f=mk_md5file_and_cp($chk->{file},$type);
        $chk->{new}=$fproctab{$chk->{type}}->($f,$op); 
      }
      if($cht eq "inline"){               ## begin(chunk)end
        my $f=mk_md5file_and_save($ch,$type);
        $chk->{new}=$fproctab{$chk->{type}}->($f,$op); 
      }
    }
    if($sproctab{$type}){         ## procstr(str)
      if($cht eq "include"){                ## inludefile(file)
        my $txt= "FIXME slurp($chk->{file})";
        $chk->{new}=$sproctab{$chk->{type}}->($txt,$op); 
      }
      if($cht eq "inline"){               ## begin(chunk)end
        $chk->{new}=$sproctab{$chk->{type}}->($ch,$op); 
      }
    }
  }
}

sub extractor{
  my $f = shift;
  my @chunks;
#  my @types = qw(abc dot gnuplot);
#  my $typespat = join("|",@types);    ## common to all the cases
#  my $extractor   = qr{$beginRE(.*?)$endRE}s;

  ## print STDERR "'/$beginRE(.*?)$endRE/'\n" if $debug; 
  print STDERR "'/$includeRE/'\n" if $debug; 

  while($f =~ m/$includeRE/sg){
     push(@chunks,{begin=>$-[0],
                   end=> $+[0],
                   type=>$1,
                   cktype=>"include",
                   opt=>$2,
                   file=>$3,
                   new=>"FIXME"}); 
  }
  while($f =~ m/$beginRE(.*?)$endRE/sg){
     push(@chunks,{begin=>$-[0],
                   end=> $+[0],
                   type=>$1,
                   cktype=>"inline",
                   opt=>$2,
                   chunk=>$3,
                   new=>"FIXME"}); 
  }
  while($f =~ m/$initRE/sg){
     push(@chunks,{begin=>$-[0],
                   end=> $+[0],
                   type=>$1,
                   cktype=>"init",
                   new=>"FIXME"}); 
  }
  return \@chunks
}

sub replacer{
  my ($p,$chunks)=@_;
  my @chks = sort { $b->{begin} <=> $a->{begin}} @$chunks;
  for my $ch(@chks){
     substr($p,$ch->{begin},$ch->{end}-$ch->{begin}) = $ch->{new} || "FIXME";
  }
  $p
}

##utils

use Digest::MD5 'md5_hex';
use File::Spec::Functions;
use File::Copy;

sub mk_md5file_and_save{my ($a,$ext)=@_;
  my $md5 = md5_hex($a);
  my $TMPDIR = 'cache-importer';
  mkdir $TMPDIR unless -d $TMPDIR;
  my $file = catfile $TMPDIR, $md5;
  return ($file) if (-f "$file.$ext");
  open(MD5,">","$file.$ext") or die("cant create $file.$ext\n");
  print MD5 $a;
  close MD5;
  return $file;
}

sub mk_md5file_and_cp{my ($f,$ext)=@_;
  open (my $fh, '<', $f) or die "Can't open '$f': $!\n";
  binmode ($fh);
  my $md5 = Digest::MD5->new->addfile($fh)->hexdigest;
  close($fh);
  my $TMPDIR = 'cache-importer';
  mkdir $TMPDIR unless -d $TMPDIR;
  my $file = catfile $TMPDIR, $md5;
  return ($file) if (-f "$file.$ext");
  copy($f,"$file.$ext") or die("cant create $file.$ext\n");
  return $file;
}

sub make{ my ($file,$mkfile)=@_;
  my $F;
  $mkfile ||= $makefilerules;
  open( $F, "|-", "tee debug-make | make -s -f - $file"); 
  print $F "$mkfile\n";
  close $F;
}


sub temp {
    push @temporary_files, @_;
    return $_[0];
}

sub bichomp{
    my $a=shift;
    $a =~ s/^\{(.*)\}$/$1/s   or $a =~ s/^\[(.*)\]$/$1/s;
    $a;
}

sub check_tools_for {
    my $format = shift;

    if($format eq "makefileg"){ require Makefile::GraphViz }

    my %formats = (
         html      => [qw.htmldoc.],
         dot       => [qw.dot pdfcrop neato twopi.],
         gnuplot   => [qw.ps2pdf gnuplot.],
         makefileg => [qw.dot ps2pdf pdfcrop.],
         pod       => [qw.pod2latex.],
         abc       => [qw.abcm2ps ps2pdf pdfcrop abc2midi.],
         camila    => [qw.cam2tex.],
         csv    => [],
         );

    my %tools = (
         htmldoc   => "http://www.easysw.com/htmldoc/",
         ps2pdf    => "http://www.ghostscript.com/",
         pod2latex => "http://www.cpan.org/",
         dot       => "http://www.graphviz.org/",
         twopi     => "http://www.graphviz.org/",
         neato     => "http://www.graphviz.org/",
         gnuplot   => "http://www.gnuplot.info/",
         cam2tex   => "http://natura.di.uminho.pt/download/sources/cam2tex",
         pdfcrop   => "check texlive or other TeX distribution",
         abcm2ps   => "http://abcplus.sourceforge.net/",
         abc2midi   => "package abcMIDI",
         );

    return 1 unless exists $formats{$format};

    for my $tool (@{$formats{$format}}) {
        Config::AutoConf->check_prog($tool) or
            die "$tool is needed to use $format\nPlease install from
$tools{$tool}";
    }

    return 1;
}

sub syst{
    my $a = shift;
    print LOG "...system($a)\n";
    system $a;
}

sub systopen {
    my $a = shift;
    print LOG "...open($a|)\n";
    open X, "-|", $a or die $!;
    1 while (<X>);
    close X;
}

#===

sub getxmlopts {
    my $a1 = bichomp(shift);
    my %save = ();
    my $op={};
    my $n = 0;
    while($a1 =~ /\b(\w+)=(['"])(.*?)\2/){
      $op->{$1}=$2;
    }
    return $op;
}

sub gettexopts {
    my $a1 = bichomp(shift);
    my %save = ();
    my $n = 0;
    $a1 =~ s/(\{.*?\})/$save{++$n}=$1;"__SAVE${n}__"/ge;
    $a1 =~ s/,/=,=/g;
    $a1 =~ s/__SAVE(\d+)__/$save{$1}/g;
    return { map { (m/(\w+)=(.*)/) ? ($1=>$2) : ($_=>"true") } 
                 split(/\s*=,=\s*/,$a1) };
}

sub xmlopt{  my ($a,$dom) = @_;
    die "invalid hash ref $a\n" unless ref($a) eq "HASH";
    my %A=%$a;
    my %d = (); 
    if($dom){
       die "invalid domain ref $dom\n" unless ref($a) eq "HASH";
       $d{$_}=1 for @$dom ;
    }
    for(keys %A){
      if(/^_/               ){ delete $A{$_}; }
      if($dom and not $d{$_}){ delete $A{$_}; }
    }
    return join(" ", (map { "$_='$a->{$_}'" } keys %$a));
}
sub texopts { my ($a,$dom) = @_;
    die "invalid hash ref $a\n" unless ref($a) eq "HASH";
    my %A=%$a;
    my %d = (); 
    if($dom){
       die "invalid domain ref $dom\n" unless ref($dom) eq "ARRAY";
       $d{$_}=1 for @$dom ;
    }
    for(keys %A){
      if(/^_/               ){ delete $A{$_}; }
      if($dom and not $d{$_}){ delete $A{$_}; }
    }
    return join(",", (map { "$_=$a->{$_}" } keys %A));
}