factor out more of the install_package to TLUtils and make it

more or less generic.


git-svn-id: svn://tug.org/texlive/trunk@5700 c570f23f-e606-0410-a88d-b1316a301751

3 files changed, 134 insertions, 9 deletions

diff --git a/Master/tlpkg/TeXLive/TLConfig.pm b/Master/tlpkg/TeXLive/TLConfig.pm
index f0819d34a41..b2d359609e6 100644
--- a/Master/tlpkg/TeXLive/TLConfig.pm
+++ b/Master/tlpkg/TeXLive/TLConfig.pm
@@ -17,6 +17,7 @@ BEGIN {
     $MetaCategoriesRegexp
     $CategoriesRegexp
     $DefaultCategory
+    $DefaultContainerExtension
     $InfraLocation
     $DatabaseName
     $BlockSize
diff --git a/Master/tlpkg/TeXLive/TLPOBJ.pm b/Master/tlpkg/TeXLive/TLPOBJ.pm
index 73a692151a1..5709cd9bf1a 100644
--- a/Master/tlpkg/TeXLive/TLPOBJ.pm
+++ b/Master/tlpkg/TeXLive/TLPOBJ.pm
@@ -747,13 +747,23 @@ sub all_files {
   push (@ret, $self->srcfiles);
   
   my %binfiles = %{$self->binfiles};
-  for my $arch (keys %binfiles) {
+  foreach my $arch (keys %binfiles) {
     push (@ret, @{$binfiles{$arch}});
   }
   
   return @ret;
 }
 
+sub allbinfiles {
+  my $self = shift;
+  my @ret;
+  my %binfiles = %{$self->binfiles};
+  foreach my $arch (keys %binfiles) {
+    push (@ret, @{$binfiles{$arch}});
+  }
+  return @ret;
+}
+
 
 # member access functions
 #
@@ -1184,6 +1194,10 @@ adds or removes files for the given type (only for C<run>, C<src>, C<doc>).
 
 returns a list of all files of all types.
 
+=item C<allbinfiles>
+
+returns a list of all binary files.
+
 =back
 
 =head1 SEE ALSO
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index 8dac6d9f6cf..710b99fc91b 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -40,7 +40,6 @@ C<TeXLive::TLUtils> -- Utilities used in the TeX Live Infrastructure Modules
   TeXLive::TLUtils::dirname_and_basename($path);
   TeXLive::TLUtils::mkdirhier($path);
   TeXLive::TLUtils::copy($file, $target_dir);
-  TeXLive::TLUtils::install_package(@list);
 
 =head2 Installer Functions
 
@@ -53,6 +52,8 @@ C<TeXLive::TLUtils> -- Utilities used in the TeX Live Infrastructure Modules
   TeXLive::TLUtils::create_fmtutil($tlpdb,$texmfsysvar,$texmflocal);
   TeXLive::TLUtils::create_updmap($tlpdb,$texmfsysvar,$texmflocal);
   TeXLive::TLUtils::create_language($tlpdb,$texmfsysvar,$texmflocal);
+  TeXLive::TLUtils::install_packages($from_tlpdb,$to_tlpdb,@list);
+  TeXLive::TLUtils::install_package($what, $filelistref, $target, $platform);
 
 =head2 Miscellaneous
 
@@ -85,6 +86,7 @@ BEGIN {
     &mkdirhier
     &copy
     &install_package
+    &install_packages
     &media
     &initialize_installer
     &architectures_available
@@ -102,8 +104,14 @@ BEGIN {
   );
 }
 
+
+use TeXLive::TLConfig qw($DefaultContainerExtension);
+
+
+
 =pod
 
+
 =head2 Platform Detection
 
 =over 6
@@ -472,14 +480,114 @@ sub copy {
   }
 }
 
-=pod
+sub install_packages {
+  my ($fromtlpdb,$totlpdb,$what,$netarchs,$opt_src,$opt_doc) = @_;
+  foreach my $package (@$what) {
+    print "INSTALL $package\n";
+    my $tlpobj=$fromtlpdb->get_package($package);
+    if (!defined($tlpobj)) {
+      die "STRANGE: $package not to be found in ", $fromtlpdb->root;
+    }
+    my $container;
+    my @installfiles;
+    push @installfiles, $tlpobj->runfiles;
+    push @installfiles, $tlpobj->allbinfiles;
+    push @installfiles, $tlpobj->srcfiles if ($opt_src);
+    push @installfiles, $tlpobj->docfiles if ($opt_doc);
+    if (&media eq 'DVD') {
+      $container = \@installfiles;
+    } elsif (&media eq 'CD') {
+      if (-r "$::installerdir/$::diskarchive/$package.zip") {
+        $container = "$::installerdir/$::diskarchive/$package.zip";
+      } elsif (-r "$::installerdir/$::diskarchive/$package.tar.lzma") {
+        $container = "$::installerdir/$::diskarchive/$package.tar.lzma";
+      } else {
+        # ok, it could be a binary package which should be installed from
+        # the net
+        my $donefromnet = 0;
+        foreach my $a (@$netarchs) {
+          if ($package =~ m/\.$a$/) {
+            # ok this is a binary we should install from the net
+            $container = "$::texlive_url/$::netarchive/$package.$DefaultContainerExtension";
+            $donefromnet = 1;
+            last;
+          }
+        }
+        if (!$donefromnet) {
+          # for now only warn and return, should (?) be die!?
+          warn "Cannot find a package $package (.zip or .lzma) in $::installerdir/$::diskarchive\n";
+          next;
+        }
+      }
+    } elsif (&media eq 'NET') {
+      $container = "$::texlive_url/$::netarchive/$package.$DefaultContainerExtension";
+    }
+    install_package($container,\@installfiles,$totlpdb->root,$vars{'this_platform'});
+    $totlpdb->add_tlpobj($tlpobj);
+  }
+  $totlpdb->save; 
+}
 
-=back
+sub install_package {
+  my ($what, $filelistref, $target, $platform) = @_;
+  my $buffer;
+  my $offset;
+  # shouldn't it be 4096
+  my $blocksize=2048;
+  my @filelist = @$filelistref;
 
-=cut
+  #my $lzmadec="$bindir/lzmadec_$platform";
+  my $lzmadec="lzmadec";
+  my $tar="/bin/tar -xf - -C";
+  my $wget="wget -nv -O-";
+  if (win32) {
+    my $bindir = "$::installerdir/tlpkg/bin/win32";
+    $lzmadec="$bindir/lzma.exe -si -so";
+    $tar="$bindir/tar.exe -xf - -C";
+    $wget="$bindir/wget.exe -nv -O-";
+  }
 
+  if (ref $what) {
+    # we are getting a ref to a list of files, so install from DVD
+    foreach my $file (@$what) {
+      # @what is taken, not @filelist!
+      my $dn=dirname($file);
+      mkdirhier("$target/$dn");
+      copy "$file", "$target/$dn";
+    } 
+  } elsif ($what =~ m,http://|ftp://,) {
+    # we are installing from the NET
+    # currently the list of file @filelist is NOT EVALUATED!!!
+    system "$wget $what|$lzmadec|$tar $target";
+  } elsif ($what =~ m,\.tar.lzma$,) {
+    # we are installing from CD, currently only tar.lzma supported
+    # currently the list of file @filelist is NOT EVALUATED!!!
+    open IN, "$what", or warn "Can't open '$what': $!\n"
+        or die "Can't open '$what': $!\n";
+    binmode IN;
+    
+    open OUT, "|$lzmadec|$tar $target";
+    binmode OUT;
+    
+    while ($read=sysread IN, $buffer, $blocksize) {
+      die "system read error: $!\n" unless defined $read;
+      $offset=0;
+      while ($read) {
+        $written=syswrite OUT, $buffer, $read, $offset;
+        die "system write error: $!\n" unless defined $written;
+        $read-=$written;
+        $offset+=$written;
+      }
+    }    
+    close OUT;
+    close IN;
+  } else {
+    die "Don't know how to install $what!\n";
+  }
+}
 
-sub install_package {
+
+sub install_package_old {
 # either a list of files or a name of one .zip or .tar.lzma file.
   my @what=@_;
 
@@ -538,6 +646,8 @@ sub install_package {
 
 =pod
 
+=back
+
 =head2 Installer Functions
 
 =over 6
@@ -725,7 +835,7 @@ improved (checking for duplicates).
 =cut
 
 sub create_fmtutil {
-  my ($tlpdb,$texmfsysvar,$texmlocalpath) = @_;
+  my ($tlpdb,$texmfsysvar,$texmflocalpath) = @_;
   my $root = $tlpdb->root;
   my @lines = $tlpdb->fmtutil_cnf_lines;
   if (-r "$texmflocalpath/web2c/fmtutil-local.cnf") {
@@ -747,7 +857,7 @@ sub create_fmtutil {
 }
 
 sub create_updmap {
-  my ($tlpdb,$texmfsysvar,$texmlocalpath) = @_;
+  my ($tlpdb,$texmfsysvar,$texmflocalpath) = @_;
   my $root = $tlpdb->root;
   my @lines = $tlpdb->updmap_cfg_lines;
   if (-r "$texmflocalpath/web2c/updmap-local.cfg") {
@@ -769,7 +879,7 @@ sub create_updmap {
 }
 
 sub create_language {
-  my ($tlpdb,$texmfsysvar,$texmlocalpath) = @_;
+  my ($tlpdb,$texmfsysvar,$texmflocalpath) = @_;
   my $root = $tlpdb->root;
   my @lines = $tlpdb->language_dat_lines;
   if (-r "$texmflocalpath/tex/generic/config/language-local.dat") {