view release on metacpan or  search on metacpan

lib/Perl/Dist/Strawberry/Step/OutputMSM_MSI.pm  view on Meta::CPAN

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