path: root/Master/setuptl/TLPM/inst.pm

# This file belongs to TLPM v2.14, TeX Live Package Manager
# Public Domain, P.Jackowski@gust.org.pl

# inst <pkg> [-jrou]
# install <pkg>

sub inst
{
      my ($arg,$pkg,@pkg_list);
      local $tl_target_new;
      local ($quiet_mode,$overwrite,$update,$recurse) = (0,0,0,1);
      while(defined($arg = shift))
      {
            $arg eq ''                       and next
            or &no_opt($arg)                 and push(@pkg_list,$arg)
            or &is_opt($arg,'j','justone')   and do {$recurse = 0;1}
            or &is_opt($arg,'r','recurse')   and $recurse = 1
            or &is_opt($arg,'o','overwrite') and $overwrite = 1
            or &is_opt($arg,'u','update')    and $update = 1 and $overwrite = 1
            or &is_opt($arg,'d','directory') and do {$tl_target_new = shift;1}
            or &is_opt($arg,'q','quiet')     and do {$quiet_mode = 1}
            or &is_opt($arg,'h','help')      and return $heeelp -> ('inst')
            or &rem_opt($arg)                and return $error{'wrong_opt'} -> ($arg,'inst --help');
      }
      return $error{'pkg_unspec'} -> () unless @pkg_list;
      return if &read_source();
      &read_target(); # may be missing
      return if &make_tree($tl_target);
      return if &open_log();
      &install(@pkg_list);
      &close_log;
}

sub install
{
      my $pkg;
      my (@trace,%trace);
      foreach $pkg (@_)
      {
            &is_pkg($pkg,$source_pkges) or $error{'pkg_not_found'} -> ($pkg) and next;
            push(@trace,$pkg);
            if($recurse)
            {
                  push(@trace,&get_pkg_requires_all($pkg,$source_pkges));
            }
      }
      local (@inst_pkges,@inst_files);
      local ($pskip,$ptotal) = (0,0);
      foreach $pkg (@trace) # cleanup; remove duplicates, flush already installed
      {
            next if exists $trace{$pkg};
            $trace{$pkg} = $true;
            ++$ptotal;
            if(not $overwrite and &is_pkg($pkg,$target_pkges))
            {
                  $messf -> ($row_fmt . $wrd_fmt . "\n",$pkg,"skipped");
                  ++$pskip;
                  next;
            }
            push(@inst_pkges,$pkg);
      }
      foreach $pkg (@inst_pkges)
      {
            push(@inst_files,&get_pkg_contains($pkg,$source_pkges));
      }
      local ($fdone,$ftodo,$pdone,$ptodo) = (0,0,0,0); # for progress info
      $ptodo = scalar @inst_pkges;
      $ftodo = scalar @inst_files;
      $install_info -> ();
      return unless $ptodo;
      local $sys_redir = $sys_redir; # to override redirection if debug
      if($debug_mode)
      {
            $sys_redir = '>>' . $tl_target . $tlpm_dbg;
      }
      local ($extract,$extract_params);
      if($tl_type eq 'DVD')
      {
            $extract = \&extract_dvd;
            if($win32)
            {
                  $copying_params = \&copying_params_win32;
                  $extract_params = '/Y /R ' . ($debug_mode ? '/F' : '/C') . ($update ? ' /D' : '');
            }
            else
            {
                  $copying_params = \&copying_params_ux;
                  $extract_params = '-f -L -r --parents '# force, follow links, recursive, append paths
                        . ($debug_mode ? '-v' : '') . ($update ? ' -u' : '');
            }
      }
      else # fortunatelly unzipper setup is common for all lplatforms
      {
            $extract = \&extract_cd;
            $extract_params = ($update ? '-ou' : '-o') . ($debug_mode ? '' : ' -qq');
      }
      local ($inst_progress,$copy_progress);
      if($quiet_mode)
      {
            ($inst_progress,$copy_progress) = (\&relax,\&relax);
      }
      else
      {

            ($inst_progress,$copy_progress) = (\&install_progress,\&copying_progress);
      }
      local (@extract_files,$fextract);
      my ($status,$err);
      $update    and $status = "refreshed"   or
      $overwrite and $status = "reinstalled" or $status = "installed";
      unless($win32){chdir($tl_source)} # cp uses quite dirrefent relative path approach then xcopy
      foreach $pkg (@inst_pkges)
      {
            $messf -> ($row_fmt,$pkg);
            @extract_files = &get_pkg_contains($pkg,$source_pkges);
            $fextract = scalar @extract_files;
            $extract -> ($pkg);
            if($?)
            {
                  $status = "error: $!";
                  $messf -> ("%-12s",$status);
            }
            else
            {
                  $target_pkges -> {$pkg} = $source_pkges -> {$pkg};
                  $messf -> ("%-12s",$status);
                  $inst_progress -> ();
            }
            $mess -> ("\n");
      }
      unless($win32){chdir($curr_dir)}
}

# extrating from zip files (CD)

sub extract_cd
{
      my $pkg = shift;
      my @cmd = (&doubleq($tl_unzip -> ()),$extract_params,
                 &doubleq($tl_source . $tl_archive . "$chr_dirsep$pkg.zip"),
                 '-d',&doubleq($tl_target),$sys_redir);
      return sys(@cmd);
}

# copying files (DVD)

sub extract_dvd
{
      my $pkg = shift;
      local ($path,$file,%xcopy);
      local $done = 0;
      my $reg = quotemeta($pkg);
      $reg = qr/$reg_dirsep$reg$reg_dirsep/i;
      # the most expensive here is calling system thousands of times;
      # for sake of speed, we gather files into groups matching '/some/dir/*' and pass wildcards to copy
      foreach $path (@extract_files)
      {
            $path =~ s/$reg_file//;
            $file = $1;
            if($path =~ /$reg/)
            {
                  ++$xcopy{"$path$chr_star"}[0];
                  $xcopy{"$path$chr_star"}[1] = $path;
            }
            else
            {
                  $xcopy{"$path$file"}[0] = 1;
                  $xcopy{"$path$file"}[1] = $path;
            }
      }
      foreach $path (keys %xcopy)
      {

            $done += $xcopy{$path}[0];
            $copy_progress -> ();
            return $? if &sys($copying_params -> ());
      }
      return(0);
}

sub copying_params_win32
{
        return ($tl_xcopy,&doubleq($tl_source . $chr_dirsep . $path),
                  &doubleq($tl_target . $chr_dirsep . $xcopy{$path}[1]),
                  $extract_params,
                  $sys_redir);
}

sub copying_params_ux
{
        return($tl_xcopy, $extract_params, $path, &doubleq($tl_target), $sys_redir);
}

sub install_progress
{
      $pdone += 1;
      $fdone += $fextract;
      printf STDOUT ("%-12s%-12s",&percent($fdone,$ftodo),&percent($pdone,$ptodo))
}

# installing from DVD is slow enough to be confused with crash, hence single package progress info

sub copying_progress # the only things flushed to STDERR
{
      printf STDERR ("\b\b\b\b\b%-5s",&percent($done,$fextract));
}

$install_info = sub
{
      if($pskip)
      {
            $messf -> ($row_fmt , $message_prefix . "$pskip of $ptotal already installed");
            $progres_pre -> ();
      }
      else
      {
            $messf -> ($row_fmt , $message_prefix . "checking packages to install...");
            $progres_pre -> ();
      }
      $mess -> ("\n");
};

$progres_pre = sub
{
      if($ptodo)
      {
            $messf -> ($wrd_fmt . $wrd_fmt . $wrd_fmt,'to do:',
                  &one_or_more($ftodo,"file","files"),
                  &one_or_more($ptodo,"package","packages"));
      }
      else
      {
            $mess -> ("nothing to do");
      }
};

1;