package Perl::Dist::Strawberry::Step::OutputMSM_MSI;

use 5.012;
use warnings;
use base 'Perl::Dist::Strawberry::Step';

use File::Slurp           qw(read_file write_file);
use File::Copy            qw(copy);
use File::Spec::Functions qw(canonpath catdir catfile);
use File::Path            qw(make_path remove_tree);
use File::Find::Rule;
use File::Basename;
use Data::Dump            qw(pp);
use Data::UUID;
use Template;
use IPC::Run3;
use Digest::SHA1;
use Win32::TieRegistry qw( KEY_READ );

sub new {
  my $class = shift;
  my $self = $class->SUPER::new(@_);
  $self->{data_uuid} = Data::UUID->new();
  $self->{id_counter} = 1000;  
  return $self;
}

sub check {
  my $self = shift;
  #global: app_version
  #global: app_name
  my $bdir = canonpath(catdir($self->global->{build_dir}, 'msm_msi'));
  -d $bdir or make_path($bdir) or die "ERROR: cannot create '$bdir'";
  
  my $d = $self->global->{wixbin_dir} // $self->_detect_wix_dir;
  if (!$d) {
    warn "ERROR: cannot find WiX utils (candle.exe+light.exe) installed\n";
    warn "  you need to install WiX toolset v3.5 from http://wix.sourceforge.net\n";
    warn "  or consider using option -wixbin_dir=<path_to_wix_dir>\n\n";
    die;
  }
  $self->{candle_exe} = canonpath("$d/candle.exe");
  $self->{light_exe} = canonpath("$d/light.exe");

}

sub run {
  my $self = shift;
 
  my $bdir = catdir($self->global->{build_dir}, 'msm_msi');
  
  # compute MSM id from MSM guid
  my $msi_guid = $self->{data_uuid}->create_str(); # get random GUID
  my $msm_guid = $self->{data_uuid}->create_str(); # get random GUID
  (my $msm_id = $msm_guid) =~ s/-/_/g;

  # create WXS parts to be inserted into MSM_main.wxs.tt & MSI_main.wxs.tt 
  my $xml_env = $self->_generate_wxml_for_environment();
  my ($xml_start_menu, $xml_start_menu_icons) = $self->_generate_wxml_for_start_menu($msm_id);
  my ($xml_msm, $xml_msi, $id_list_msm, $id_list_msi) = $self->_generate_wxml_for_directory($self->global->{image_dir});
  #debug:
  write_file("$bdir/debug.xml_msi.xml", $xml_msi);
  write_file("$bdir/debug.xml_msm.xml", $xml_msm);
  write_file("$bdir/debug.xml_start_menu.xml", $xml_start_menu);
  write_file("$bdir/debug.xml_start_menu_icons.xml", $xml_start_menu_icons);

  # prepare MSI/MSM filenames 
  my $output_basename = $self->global->{output_basename} // 'perl-output';
  my $msm_file = catfile($self->global->{output_dir}, "$output_basename.msm");
  my $msi_file = catfile($self->global->{output_dir}, "$output_basename.msi");
  my $wixpdb_file = catfile($self->global->{output_dir}, "$output_basename.wixpdb");

  # compute msi_version which has to be 3-numbers (otherwise major upgrade feature does not work)
  my ($v1, $v2, $v3, $v4) = split /\./, $self->global->{app_version};
  $v3 = $v3*1000 + $v4 if defined $v4; #turn 5.14.2.1 to 5.12.2001
 
  # resolve values (only scalars) from config
  for (keys %{$self->{config}}) {
    if (!ref $self->{config}->{$_}) {
      $self->{config}->{$_} = $self->boss->resolve_name($self->{config}->{$_});
    }
  }
  my %vars = (
    # global info taken from 'boss'
    %{$self->global},
    # OutputMSM_MSI config info    
    %{$self->{config}},
    # the following items are computed
    msi_product_guid => $msi_guid,
    msm_package_guid => $msm_guid,
    msi_random_upgrade_code => $self->{data_uuid}->create_str(), # get random GUID
    msm_package_id   => $msm_id,
    msi_version      => sprintf("%d.%d.%d", $v1, $v2, $v3), # e.g. 5.12.2001
    msi_upgr_version => sprintf("%d.%d.%d", $v1, $v2, 0),   # e.g. 5.12.0
    msm_filename     => $msm_file,
    # WXS data
    xml_msm_dirtree     => $xml_msm,
    xml_msi_dirtree     => $xml_msi,
    xml_env             => $xml_env,
    xml_startmenu       => $xml_start_menu,
    xml_startmenu_icons => $xml_start_menu_icons,
  );

  my $f1 = catfile($self->global->{dist_sharedir}, 'msi\MSM_main.wxs.tt');
  my $f2 = catfile($self->global->{dist_sharedir}, 'msi\MSI_main.wxs.tt');
  my $f3 = catfile($self->global->{dist_sharedir}, 'msi\Variables.wxi.tt');
  my $f4 = catfile($self->global->{dist_sharedir}, 'msi\MSI_strings.wxl.tt');  
  my $t = Template->new(ABSOLUTE=>1);
  write_file(catfile($self->global->{debug_dir}, 'TTvars_OutputMSM_MSI_'.time.'.txt'), pp(\%vars)); #debug dump
  $t->process($f1, \%vars, catfile($bdir, 'MSM_main.wxs')) || die $t->error();
  $t->process($f2, \%vars, catfile($bdir, 'MSI_main.wxs')) || die $t->error();
  $t->process($f3, \%vars, catfile($bdir, 'Variables.wxi')) || die $t->error();
  $t->process($f4, \%vars, catfile($bdir, 'MSI_strings.wxl')) || die $t->error();
  
  my $rv;
  my $candle_exe = $self->{candle_exe};
  my $light_exe = $self->{light_exe};
  
  #XXX-FIXME -sice:ICE08|09|32|61 is a hack to handle:
  #light.exe : error LGHT0217 : Error executing ICE action 'ICE32'. The most common cause of this kind of ICE failure is an incorrectly registered
  #            scripting engine. See http://wix.sourceforge.net/faq.html#Error217 for details and how to solve this problem. The following string
  #            format was not expected by the external UI message logger: "Pýi instalaci tohoto bal¡Ÿku zjistil instalaŸn¡ program neoŸek vanou
  #            chybu. M…§e to znamenat, §e u tohoto bal¡Ÿku nastaly pot¡§e. K¢d chyby je 2738. ".
  #light.exe : error LGHT0217 : Error executing ICE action 'ICE08'. The most common cause of this kind of ICE failure is an incorrectly registered
  #            scripting engine. See http://wix.sourceforge.net/faq.html#Error217 for details and how to solve this problem. The following string
  #            format was not expected by the external UI message logger: "Pýi instalaci tohoto bal¡Ÿku zjistil instalaŸn¡ program neoŸek vanou
  #            chybu. M…§e to znamenat, §e u tohoto bal¡Ÿku nastaly pot¡§e. K¢d chyby je 2738. ".
  #light.exe : error LGHT0217 : Error executing ICE action 'ICE61'. The most common cause of this kind of ICE failure is an incorrectly registered
  #            scripting engine. See http://wix.sourceforge.net/faq.html#Error217 for details and how to solve this problem. The following string
  #            format was not expected by the external UI message logger: "The installer has encountered an unexpected error installing this 
  #            package. This may indicate a problem with this package. The error code is 2738. ".

  my $candle1_cmd = [$candle_exe, "$bdir\\MSM_main.wxs", '-out', "$bdir\\MSM_main.wixobj", '-v'];
  my $light1_cmd  = [$light_exe,  "$bdir\\MSM_main.wixobj", '-out', $msm_file, '-pdbout', "$bdir\\MSM_main.wixpdb", qw/-ext WixUIExtension -ext WixUtilExtension -v -sice:ICE32 -sice:ICE08/];
  my $candle2_cmd = [$candle_exe, "$bdir\\MSI_main.wxs", '-out', "$bdir\\MSI_main.wixobj", '-v'];
  my $light2_cmd  = [$light_exe,  "$bdir\\MSI_main.wixobj", '-out', $msi_file, '-pdbout', "$bdir\\MSI_main.wixpdb", '-loc', "$bdir\\MSI_strings.wxl", qw/-ext WixUIExtension -ext WixUtilExtension -sice:ICE38 -sice:ICE43 -sice:ICE48 -sice:ICE47 -v -sice:ICE32 -sice:ICE08 -sice:ICE09 -sice:ICE61/];

  # backup already existing <output_dir>/*.msm and <output_dir>/*.msi
  $self->backup_file($msi_file);
  $self->backup_file($msm_file);

  $self->boss->message(2, "MSM: gonna run $candle1_cmd->[0]");
  $rv = $self->execute_standard($candle1_cmd, catfile($self->global->{debug_dir}, "MSM_candle.log.txt"));
  die "ERROR: MSM candle" unless(defined $rv && $rv == 0);
  
  $self->boss->message(2, "MSM: gonna run $light1_cmd->[0]");
  $rv = $self->execute_standard($light1_cmd, catfile($self->global->{debug_dir}, "MSM_light.log.txt"));
  die "ERROR: MSM light" unless(defined $rv && $rv == 0);
  
  $self->boss->message(2, "MSI: gonna run $candle2_cmd->[0]");
  $rv = $self->execute_standard($candle2_cmd, catfile($self->global->{debug_dir}, "MSI_candle.log.txt"));
  die "ERROR: MSI candle" unless(defined $rv && $rv == 0);
  
  $self->boss->message(2, "MSI: gonna run $light2_cmd->[0]");
  $rv = $self->execute_standard($light2_cmd, catfile($self->global->{debug_dir}, "MSI_light.log.txt"));
  die "ERROR: MSI light" unless(defined $rv && $rv == 0);
  
  #store results
  $self->{data}->{output}->{msi} = $msi_file;
  $self->{data}->{output}->{msm} = $msm_file;
  $self->{data}->{output}->{msm_sha1} = $self->sha1_file($msm_file);
  $self->{data}->{output}->{msi_sha1} = $self->sha1_file($msi_file); # will change after we sign MSI
  $self->{data}->{output}->{msi_guid} = $msi_guid;
  $self->{data}->{output}->{msm_guid} = $msm_guid;
  $self->{data}->{output}->{msm_id}   = $msm_id;

} 

sub _generate_wxml_for_environment {
  my ($self) = @_;
  my $result = "";
  my $id = 1;
  for (keys %{$self->{config}->{env}}) {    
    $result .= sprintf("        <Environment Id='env_extra_%s' Name='%s' Value='%s' Action='set' System='yes' Permanent='no' />\n", $id++, $_, $self->{config}->{env}->{$_});
  }
  return $result
}

sub _generate_wxml_for_start_menu {
  my ($self, $msm_id) = @_;
  my $menu_result = "";
  my $ico_result = "";
  my $id = 1;
  $self->{start_menu_icons} = {};
  my ($component_id, $component_guid) = $self->_gen_component_id("start_menu_main.shortcut");
  $menu_result .= "          <Component Id='StartF_$component_id' Guid='$component_guid' KeyPath='yes' Feature='feat_StartMenu'>\n";
  $menu_result .= "            <RemoveFolder Id='StartF_$component_id.rm' On='uninstall' />\n";
  $menu_result .= "          </Component>\n";
  for my $item (@{$self->{config}->{start_menu}}) {       
    $menu_result .= $self->_generate_start_menu_folder($item, 0, $msm_id)   if $item->{type} eq 'folder';
    $menu_result .= $self->_generate_start_menu_shortcut($item, 0, $msm_id) if $item->{type} eq 'shortcut';
  }
  for (keys %{$self->{start_menu_icons}}) {
    $ico_result .= "    <Icon Id='$self->{start_menu_icons}->{$_}' SourceFile='$_' />\n";    
  }
  return ($menu_result, $ico_result);
}

sub _generate_wxml_for_directory {
  my ($self, $rootdir) = @_;  
  my $t = $self->_prepare_marked_tree($rootdir);

  my $msi = $self->_tree2xml($t, 'MSI');
  my $id_list_msi = [ @{$self->{component_id_list}} ];
  $self->{component_id_list} = [];

  my $msm = $self->_tree2xml($t, 'MSM');
  my $id_list_msm = [ @{$self->{component_id_list}} ];
  $self->{component_id_list} = [];

  return ($msm, $msi, $id_list_msm, $id_list_msi);  
}

sub _generate_start_menu_shortcut {  # !!!BEWARE!!! this sub is called recursively
  my ($self, $item, $depth, $msm_id) = @_;
  $depth //= 0; 
  my $result = "";
  my $ident = "          " . ("  " x $depth);
  my ($component_id, $component_guid) = $self->_gen_component_id($item->{name}.$depth."start.shortcut");
  my $attr_description = defined $item->{description} ? "Description='$item->{description}'" : "Description='$item->{name}'";
  my $attr_workingdir  = defined $item->{workingdir}  ? "WorkingDirectory='$item->{workingdir}'" : "";
  my $attr_target = $item->{target};
  
  $attr_workingdir =~ s/<MSMID>/$msm_id/g; #XXX-FIXME this is a hack
  $attr_target     =~ s/<MSMID>/$msm_id/g; #XXX-FIXME this is a hack
  
  my $attr_icon = "";
  if (defined $item->{icon}) {
    my $i_file = canonpath($self->boss->resolve_name($item->{icon}));
    my $i_short = "ico_$component_id";    
    $self->{start_menu_icons}->{$i_file} //= $i_short;
    $attr_icon = "Icon='$self->{start_menu_icons}->{$i_file}'";
  }
  $result .= "$ident<Component Id='StartS_$component_id' Guid='$component_guid' Feature='feat_StartMenu'>\n";
  $result .= "$ident  <Shortcut Id='Short_$component_id' Name='$item->{name}' Target='$attr_target'  $attr_description $attr_workingdir $attr_icon/>\n";
  $result .= "$ident  <CreateFolder />\n"; # This is strange but for some reason necessary
  $result .= "$ident</Component>\n";
  return $result;
}

sub _generate_start_menu_folder {  # !!!BEWARE!!! this sub is called recursively
  my ($self, $item, $depth, $msm_id) = @_;
  $depth //= 0; 
  my $result = "";
  my $ident = "          " . ("  " x $depth);
  my ($component_id, $component_guid) = $self->_gen_component_id($item->{name}.$depth."start.folder");
  $result .= "$ident<Directory Id='StartF_$component_id.dir' Name='$item->{name}'>\n";
  $result .= "$ident  <Component Id='StartF_$component_id' Guid='$component_guid' KeyPath='yes' Feature='feat_StartMenu'>\n";
  $result .= "$ident    <RemoveFolder Id='StartF_$component_id.rm' On='uninstall' />\n";
  $result .= "$ident  </Component>\n";
  for my $m (@{$item->{members}}) {       
    $result .= $self->_generate_start_menu_folder($m, $depth+1, $msm_id)   if $m->{type} eq 'folder';
    $result .= $self->_generate_start_menu_shortcut($m, $depth+1, $msm_id) if $m->{type} eq 'shortcut';
  }
  $result .= "$ident</Directory>\n";
  return $result;
}

sub _generate_tree {  # !!!BEWARE!!! this sub is called recursively
  my ($self, $rootdir, $depth) = @_;
  
  my $image_dir = canonpath($self->global->{image_dir});
  $rootdir = canonpath($rootdir);
  (my $short = $rootdir) =~ s/^\Q$image_dir\E[\\]*//;

  $depth = 1 unless defined $depth;
  my $h = { type=>'D', full_name=>$rootdir, short_name=>$short, files=>[], dirs=>[], depth=>$depth };

  my @directories = File::Find::Rule->directory->maxdepth(1)->mindepth(1)->in($rootdir);
  for my $d (sort map { canonpath($_) } @directories) {
    (my $short = $d) =~ s/^\Q$image_dir\E[\\]*//;
    $self->{global_hash}->{$short} = $self->_generate_tree($d, $depth+1);
    push @{$h->{dirs}}, $self->{global_hash}->{$short};
  }
  
  my @files = File::Find::Rule->file->maxdepth(1)->mindepth(1)->in($rootdir);
  for my $f (sort map { canonpath($_) } @files) {
    (my $short = $f) =~ s/^\Q$image_dir\E[\\]*//;
    $self->{global_hash}->{$short} = { type=>'F', full_name=>$f, short_name=>$short, depth=>$depth };
    push @{$h->{files}}, $self->{global_hash}->{$short};
  }
  
  return $h;  
}

sub _mark_tree {  # !!!BEWARE!!! this sub is called recursively
  my ($self, $root, $mark) = @_;
  $root->{mark} = $mark;
  if ($root->{type} eq 'D') {
    $self->_mark_tree($_, $mark) for (@{$root->{dirs}});
    $self->_mark_tree($_, $mark) for (@{$root->{files}});
  }
}

sub _prepare_marked_tree {
  my ($self, $rootdir, $type) = @_;

  $self->boss->message(3, "generate tree - started (takes some time)");
  my $t = $self->_generate_tree($rootdir);  
  $self->boss->message(3, "generate tree - items=", scalar(keys $self->{global_hash}));
  
  # by default all go to MSM
  $self->_mark_tree($t, 'MSM');

  # let us move items matching 'exclude_msm' from MSM to MSI
  my @e;
  for my $i (@{$self->{config}->{exclude_msm}}) {
    if (ref($i) eq 'Regexp') {
      push @e, grep {/$i/} (keys $self->{global_hash});
    }
    else {
      push @e, grep {lc($_) eq lc($i)} (keys $self->{global_hash});
    }
  }
  $self->_mark_tree($self->{global_hash}->{$_}, 'MSI') for (@e);

  # let us completely drop items matching 'exclude' these will be neither in MSM nor MSI
  my @s;
  for my $i (@{$self->{config}->{exclude}}) {
    if (ref($i) eq 'Regexp') {
      push @s, grep {/$i/} (keys $self->{global_hash});
    }
    else {
      push @s, grep {lc($_) eq lc($i)} (keys $self->{global_hash});
    }
  }
  $self->_mark_tree($self->{global_hash}->{$_}, 'EXCLUDE') for (@s);

  return $t;
}

sub _tree2xml {  # !!!BEWARE!!! this sub is called recursively
  my ($self, $root, $mark, $not_root) = @_;
    
  my ($component_id, $component_guid, $dir_id);
  my $result = "";
  my $ident = "    " . "  " x $root->{depth};
  
  # dir-start
  if ($not_root && $root->{mark} eq $mark) {
    $dir_id = $self->_gen_dir_id($root->{short_name});
    my $dir_basename = basename($root->{full_name});
    my $dir_shortname = $self->_get_short_basename($root->{full_name});
    $result .= $ident . qq[<Directory Id="$dir_id" Name="$dir_basename" ShortName="$dir_shortname">\n];
  }
  
  my @f = grep { $_->{mark} eq $mark } @{$root->{files}};
  my @d = grep { $_->{mark} eq $mark } @{$root->{dirs}};
  my $feat = $mark eq 'MSM' ? '' : "Feature='feat_$mark'";
  
  if (defined $dir_id) {
    ($component_id, $component_guid) = $self->_gen_component_id($root->{short_name}."create");
    # put KeyPath to the component as Directory does not have KeyPath attribute
    # if a Component has KeyPath="yes", then the directory this component is installed to becomes a key path
    # see: http://stackoverflow.com/questions/10358989/wix-using-keypath-on-components-directories-files-registry-etc-etc
    $result .= $ident ."  ". qq[<Component Id="$component_id" Guid="{$component_guid}" KeyPath="yes" $feat>\n];
    $result .= $ident ."  ". qq[    <CreateFolder />\n];
    $result .= $ident ."  ". qq[    <RemoveFolder Id="rm.$dir_id" On="uninstall" />\n]; #XXX-TODO not sure about this
    $result .= $ident ."  ". qq[</Component>\n];
  }
  
  if (scalar(@f) > 0) {
    for my $f (@f) {
      my $file_id = $self->_gen_file_id($f->{short_name});
      my $file_basename = basename($f->{full_name});
      my $file_shortname = $self->_get_short_basename($f->{full_name});
      ($component_id, $component_guid) = $self->_gen_component_id($file_shortname."files");
      # in 1file/component scenario set KeyPath on file, not on Component
      # see: http://stackoverflow.com/questions/10358989/wix-using-keypath-on-components-directories-files-registry-etc-etc
      $result .= $ident ."  ". qq[<Component Id="$component_id" Guid="{$component_guid}" $feat>\n];
      $result .= $ident ."  ". qq[  <File Id="$file_id" Name="$file_basename" ShortName="$file_shortname" Source="$f->{full_name}" KeyPath="yes" />\n]; # XXX-TODO consider ReadOnly="yes"
      $result .= $ident ."  ". qq[</Component>\n];
    }
  }
  
  $result .= $self->_tree2xml($_, $mark, 1) for (@d);
  $result .= $ident . qq[</Directory>\n] if $not_root && $root->{mark} eq $mark;
  
  return $result;
}

#XXX-FIXME occasionally Win32::GetShortPathName does not produce valid 8.3 name!!!
#sub _get_short_basename {
#  my ($self, $name) = @_;
#  my $result = basename(Win32::GetShortPathName($name));;
#  $result =~ s/~/!/g; # this replacement is necessary, otherwise wix3 will croak
#  
#  return $result;
#}

sub _random_shortname {
  my $self = shift;
  my @ch = ('A'..'Z', 0..9, split(//,'!@#^(){}_-'));
  my $r;
  $r .= $ch[int(rand(scalar(@ch)))] for (1..8);
  return $r;
}

sub _get_short_basename {
  my ($self, $name) = @_;
  my $base = basename($name);;
  
  my ($n, $e) = $base =~ /^(.*?)(\..*)?$/;
  if ($n =~ /^[A-Z0-9\Q!#@^(){}_-\E]{1,8}$/i && (!defined $e || $e =~ /^\.[A-Z0-9\Q!#@^(){}_-\E]{1,3}$/i)) {
    return $base;
  }
  else {
    $n =~ s/[^A-Z0-9\Q!#@^(){}_-\E]//gi;
    $n = substr(substr($n, 0, 4) . $self->_random_shortname, 0, 8);
    if (defined $e) {   
      $e =~ s/[^A-Z0-9\Q!#@^(){}_-\E]//gi;
      $e = substr(substr($e, 0, 3) . $self->_random_shortname, 0, 3);
      return "$n.$e";
    }
    return $n;
  }
}

sub _gen_component_id {
  my ($self, $subj) = @_;
  my $i = "i" . $self->{id_counter}++;
  my $g = $self->{data_uuid}->create_str(); # get random GUID
  push @{$self->{component_id_list}}, $i;
  return ($i, $g);
}

sub _gen_file_id {
  my ($self, $file) = @_;
  my $r;
  $r = "f_perl_bin_perl_exe"  if lc($file) eq 'perl\bin\perl.exe';
  $r = "f_perl_bin_wperl_exe" if lc($file) eq 'perl\bin\wperl.exe';
  $r = "f_perl1_reloc_txt"    if lc($file) eq 'perl1.reloc.txt';
  $r = "f_perl2_reloc_txt"    if lc($file) eq 'perl2.reloc.txt';
  $r = "f_readme_txt"         if lc($file) eq 'readme.txt';
  $r = "f_relocation_pl"      if lc($file) eq 'relocation.pl.bat';
  return  $r // "f" . $self->{id_counter}++;
}

sub _gen_dir_id {
  my ($self, $dir) = @_;
  my $r;
  $r = "d_c"           if lc($dir) eq 'c';
  $r = "d_c_bin"       if lc($dir) eq 'c\bin';
  $r = "d_perl"        if lc($dir) eq 'perl';
  $r = "d_perl_bin"    if lc($dir) eq 'perl\bin';
  $r = "d_perl_site"   if lc($dir) eq 'perl\site';
  $r = "d_perl_vendor" if lc($dir) eq 'perl\vendor';
  $r = "d_win32"       if lc($dir) eq 'win32';
  return $r // "d" . $self->{id_counter}++;
}

sub _detect_wix_dir {
  my $self = shift;
  for my $v (qw/3.0 3.5 3.6/) {
    my $WIX_REGISTRY_KEY = "HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows Installer XML/$v";
    # 0x200 = KEY_WOW64_32KEY
    my $r = Win32::TieRegistry->new($WIX_REGISTRY_KEY => { Access => KEY_READ|0x200, Delimiter => q{/} });
    next unless $r;
    my $d = $r->TiedRef->{'InstallRoot'};
    next unless $d && -d $d && -f "$d/candle.exe" && -f "$d/light.exe";
    return $d;
  }
  return;
}

1;