TLPDB.pm: Allow http:// or ftp:// in /path/to/texlive.tlpdb.

TLUtils.pm: More functions added.
Perl-API.txt: Updated.


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

3 files changed, 363 insertions, 19 deletions

diff --git a/Master/tlpkg/TeXLive/TLPDB.pm b/Master/tlpkg/TeXLive/TLPDB.pm
index 3c392242a45..3c16d540402 100644
--- a/Master/tlpkg/TeXLive/TLPDB.pm
+++ b/Master/tlpkg/TeXLive/TLPDB.pm
@@ -10,7 +10,7 @@ package TeXLive::TLPDB;
 =pod
 =head1 NAME
 
-TeXLive::TLPDB - a database of TeX Live Packages
+C<TeXLive::TLPDB> -- A database of TeXLive Packages
 
 =head1 SYNOPSIS
 
@@ -43,8 +43,17 @@ my $_listdir;
 
 =pod
 
-C<TeXLive::TLPDB->new> creates a new C<TLPDB> object. If the argument 
-location is given it will be initialized from this locations.
+=over 6
+
+=item C<< TeXLive::TLPDB->new >>
+
+=item C<< TeXLive::TLPDB->new(location => "$filename") >>
+
+C<< TeXLive::TLPDB->new >> creates a new C<TLPDB> object. If the
+argument C<location> is given it will be initialized from this
+location.  C<$filename> is usually C</path/to/texlive.tlpdb>.  If
+C<$filename> begins with C<http://> or C<ftp://>, the program C<wget>
+is used to download the file.
 
 =cut
 
@@ -65,9 +74,12 @@ sub new {
 
 =pod
 
+=item C<< $tlpdb->add_tlpobj($tlpobj) >>
+
 The C<add_tlpobj> adds an object of the type TLPOBJ to the TLPDB.
 
 =cut
+
 sub add_tlpobj {
   my ($self,$tlp) = @_;
   $self->{'tlps'}{$tlp->name} = $tlp;
@@ -75,10 +87,15 @@ sub add_tlpobj {
 
 =pod
 
-The C<from_file> function initializes the C<TLPDB> in case the location
-was not given at generation time.
+=item C<< $tlpdb->from_file($filename) >>
+
+The C<from_file> function initializes the C<TLPDB> in case the
+location was not given at generation time.  If C<$filename> begins
+with C<http://> or C<ftp://>, the program C<wget> is used to download
+the file.
 
 =cut
+
 sub from_file {
   my $self = shift;
   if (@_ != 1) {
@@ -90,7 +107,12 @@ sub from_file {
     }
   }
   $self->location($_[0]);
-  open(TMP,"<$_[0]") || die("Cannot open tlpdb file: $_[0]");
+  if ($_[0]=~/^(http|ftp):\/\//) {
+    open(TMP, "wget -nv --output-document=- $_[0]|") 
+        || die("Cannot open tlpdb file: $_[0]"); 
+  } else {
+    open(TMP,"<$_[0]") || die("Cannot open tlpdb file: $_[0]");
+  }
   my $found = 0;
   do {
     my $tlp = TeXLive::TLPOBJ->new;
@@ -104,10 +126,15 @@ sub from_file {
 
 =pod
 
-The C<writeout> function writes the whole TLPDB to STDOUT, or to the file
-handle given as argument.
+=item C<< $tlpdb->writeout >>
+
+=item C<< $tlpdb->writeout(FILEHANDLE) >>
+
+The C<writeout> function writes the whole C<TLPDB> to C<STDOUT>, or to
+the file handle given as argument.
 
 =cut
+
 sub writeout {
   my $self = shift;
   my $fd = (@_ ? $_[0] : STDOUT);
@@ -121,10 +148,13 @@ sub writeout {
 
 =pod
 
-The C<save> functions saves the TLPDB to the file which has been set
+=item C<< $tlpdb->save >>
+
+The C<save> functions saves the C<TLPDB> to the file which has been set
 as location. If the location is undefined, die.
 
 =cut
+
 sub save {
   my $self = shift;
   open(FOO,">$self->{'location'}") || die("Cannot open $self->{'location'} for writing: $!");
@@ -134,10 +164,13 @@ sub save {
 
 =pod
 
-The C<get_package> function returns a reference to an TLPOBJ object in case
-its name the the argument name coincide.
+=item C<< $tlpdb->get_package("packagename") >> 
+
+The C<get_package> function returns a reference to a C<TLPOBJ> object
+in case its name the the argument name coincide.
 
 =cut
+
 sub get_package {
   my ($self,$pkg) = @_;
   if (defined($self->{'tlps'}{$pkg})) {
@@ -149,9 +182,12 @@ sub get_package {
 
 =pod
 
+=item C<< $tlpdb->list_packages >>
+
 The C<list_packages> function returns the list of all included packages.
 
 =cut
+
 sub list_packages {
   my $self = shift;
   return (sort keys %{$self->{'tlps'}});
@@ -159,10 +195,13 @@ sub list_packages {
 
 =pod
 
-The C<package_revision> function returns the the revision of the
+=item C<< $tlpdb->package_revision("packagename") >>
+
+The C<package_revision> function returns the revision number of the
 package named in the first argument.
 
 =cut
+
 sub package_revision {
   my ($self,$pkg) = @_;
   if (defined($self->{'tlps'}{$pkg})) {
@@ -174,10 +213,13 @@ sub package_revision {
 
 =pod
 
+=item C<< $tlpdb->generate_packagelist >>
+
 The C<generate_packagelist> lists all available TL Packages together
 with their revisions.
 
 =cut
+
 sub generate_packagelist {
   my $self = shift;
   my $fd = (@_ ? $_[0] : STDOUT);
@@ -188,10 +230,15 @@ sub generate_packagelist {
 
 =pod
 
+=item C<< $tlpdb->generate_listfiles >>
+
+=item C<< $tlpdb->generate_listfiles($destdir) >>
+
 The C<generate_listfiles> generates the list files for the old 
 installers. This function will probably go away.
 
 =cut
+
 sub generate_listfiles {
   my ($self,$destdir) = @_;
   if (not(defined($destdir))) {
@@ -313,10 +360,13 @@ sub _generate_listfile {
 
 =pod
 
+=item C<< $tlpdb->location("/path/to/texlive.tlpdb") >>
+
 The function C<location> allows to read and set the location of the
-text file of the TeX Live Database.
+text file of the TeXLive database.
 
 =cut
+
 sub location {
   my $self = shift;
   if (@_) { $self->{'location'} = shift }
@@ -325,6 +375,8 @@ sub location {
 
 =pod
 
+=item C<< $tlpdb->listdir >>
+
 The function C<listdir> allows to read and set the packages variable
 specifiying where generated list files are created.
 
@@ -335,9 +387,9 @@ sub listdir {
   return $_listdir;
 }
 
+=back
 
 =pod
-
 =head1 SEE ALSO
 
 The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, 
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index 5e5a88f60ec..f30b2410f1f 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -11,9 +11,10 @@
 package TeXLive::TLUtils;
 
 =pod
+
 =head1 NAME
 
-TeXLive::TLUtils - utilities used in the TeX Live Infrastructure Modules
+C<TeXLive::TLUtils> -- Utilities used in the TeX Live Infrastructure Modules
 
 =head1 SYNOPSIS
 
@@ -23,6 +24,15 @@ TeXLive::TLUtils - utilities used in the TeX Live Infrastructure Modules
   TeXLive::TLUtils::push_uniq(\@list, @items);
   TeXLive::TLUtils::member($item, @list);
   TeXLive::TLUtils::debug($string);
+  TeXLive::TLUtils::getenv($string);
+  TeXLive::TLUtils::which($string);
+  TeXLive::TLUtils::initialze_installer;
+  TeXLive::TLUtils::media;
+  TeXLive::TLUtils::platform;
+  TeXLive::TLUtils::win32;
+  TeXLive::TLUtils::program_exists($program);
+  TeXLive::TLUtils::binaries_available_from_disk($platform);
+  TeXLive::TLUtils::binaries_available_from_net($platform);
 
 =head1 DESCRIPTION
 
@@ -39,11 +49,26 @@ BEGIN {
   @EXPORT_OK = qw(
     &sort_uniq
     &push_uniq
+    &member
+    &debug
+    &getenv
+    &which
+    &media
+    &platform
+    &initialize_installer
+    &win32
+    &program_exists
+    &binaries_available_from_disk
+    &binaries_available_from_net
   );
 }
 
 =pod
 
+=over 6
+
+=item C<sort_uniq(@list)>
+
 The C<sort_uniq> function sorts the given array and throws away multiple
 occurrences of elements. It returns a sorted and unified array.
 
@@ -65,6 +90,8 @@ sub sort_uniq {
 
 =pod
 
+=item C<push_uniq(\@list, @items)>
+
 The C<push_uniq> function pushes the last elements on the list referenced
 by the first argument.
 
@@ -82,6 +109,8 @@ sub push_uniq {
 
 =pod
 
+=item C<member($item, @list)>
+
 The C<member> function returns true if the the first argument is contained
 in the list of the remaining arguments.
 
@@ -98,8 +127,32 @@ sub member {
   return 0;
 }
 
+
+=pod
+
+=item C<initialize_installer>
+
+The function C<initialize_installer> first determines the directory in
+which tl-install.pl resides (which is C<`dirname $0`> on UNIX).  Then
+it calls C<media> and C<platform> in order to set the variables
+C<$::_media_> and C<$::_platform_>.
+
+Repeatedly calls to C<media> or C<platform> do not access the CD/DVD
+again.
+
+=cut
+
+sub initialize_installer {
+  ($::_installerdir_=$0)=~s/(.*)\/.*$/$1/;
+  &media;
+  &platform;
+}
+
+
 =pod
 
+=item C<debug($string)>
+
 The C<debug> function echos the argument string to STDERR in case that
 the global varialbe C<opt_debug> is set.
 
@@ -109,10 +162,238 @@ sub debug {
   print STDERR @_ if ($::opt_debug);
 }
 
+=pod
+
+=item C<getenv($string)>
+
+Get an environment variable.  It is assumed that the environment
+variable contains a path.  On Windows all backslashes are replaced by
+forward slashes as required by Perl.  If this behavior is not desired,
+use C<$ENV{"$variable"}> instead.  C<0> is returned if the
+environment variable is not set.
+
+=cut
+
+sub getenv {
+  my $envvar=shift;
+  my $var=$ENV{"$envvar"};
+  return 0 unless (defined "$var");
+  if (&win32) {
+    $var=~s@\\@/@g;  # change \ -> / (required by Perl)
+  }
+  return "$var";
+}
+
+=pod
+
+=item C<which($string)>
+
+C<which> does the same as the UNIX command C<which(1)>, but it is
+supposed to work on Windows too.  On Windows we have to try all the
+extensions given in the C<PATHEXT> environment variable.  We also try
+without appending an extension because if C<$string> comes from an
+environment variable, an extension might aleady be present.
+
+=cut
+
+sub which {
+	my $prog=shift;
+	my @PATH;
+	my $PATH=getenv('PATH');
+	if (&win32) {
+		my @PATHEXT=split ';', getenv('PATHEXT');
+		push @PATHEXT, '';  # if argument contains an extension
+		@PATH=split ';', $PATH;
+		for my $dir (@PATH) {
+			for my $ext (@PATHEXT) {
+				if (-f "$dir/$prog$ext") {
+					return "$dir/$prog$ext";
+				}
+			}
+		}
+	} else {
+		@PATH=split ':', $PATH;
+		for my $dir (@PATH) {
+			if (-x "$dir/$prog") {
+				return "$dir/$prog";
+			}
+		}
+	} 
+	return 0;
+}
+
+=pod
+
+
+=item C<media>
+
+Return media type.  Either C<CD>, C<DVD>, or C<NET>.
+
+The result is stored in a global variable C<$::_media_>.  If you call
+C<media> repeatedly, only the first call of C<media> will access the
+CD/DVD.
+
+=cut
+
+sub media {
+  unless (defined $::_media_) {
+    if (-d "$::_installerdir_/archive") {
+      $::_media_="CD";
+    } elsif (-d "$::_installerdir_/texmf/web2c") {
+      $::_media_="DVD";
+    } else {
+      $::_media_="NET";
+    }
+  }
+  return $::_media_;
+}
+
+=pod
+
+=item C<platform>
+
+If the directory C</usr/bin> doesn't exist we know that we're on
+Windows and we set the global variable C<$::_platform_> to C<win32>.
+If it exists we call C<config.guess>.  The output of C<config.guess>
+is filtered as described below.
+
+CPU type is determined by a regexp.  And it's necessary to
+C<s/i.86/i386/>.
+
+For OS we need a list because we probably have something like
+C<linux-gnu> but we need C<linux>.  This list might/should contain OSs
+which are not currently supported.  The list currently supports all
+platforms supported by TeXLive 2007 plus Cygwin.
+
+If a particular platform is not found in this list we use the regexp
+C</.*-(.*$)/> as a last resort and hope it provides something useful.
+
+The result is stored in a global variable C<$::_platform_>.  If you call
+C<platform> repeatedly, only the first call of C<platform> will access
+the HD/CD/DVD.
+
+=cut
+
+sub platform {
+  my @OSs=qw(aix cygwin darwin freebsd hpux irix linux netbsd openbsd
+             solaris); 
+
+  unless (defined $::_platform_) {
+    if (-d "/usr/bin") {
+      my $CPU; # CPU type as reported by config.guess.
+      my $OS;  # O/S type as reported by config.guess.
+      my $guessed_platform=`$::_installerdir_/config.guess`;
+      chomp $guessed_platform;
+      ($CPU=$guessed_platform)=~s/(.*?)-.*/$1/;
+      foreach my $os (@OSs) {
+        $OS=$os if $guessed_platform=~/$os/;
+      }
+      if ($OS=~/^i.86$/) {
+        $OS=~s/i.86/i386/;
+      }      
+      if (length "$OS" < 0) {
+        ($OS=$guessed_platform)=~s/.*-(.*)/$1/;
+      }
+      $::_platform_="$CPU-$OS";
+    } else {
+      $::_platform_="win32";
+    }
+  }
+  return $::_platform_;
+}
+
+=pod 
+
+=item C<win32>
+
+Return C<1> if platform is Windows and C<0> otherwise.
+
+=cut
+
+sub win32 {
+  return (&platform eq "win32")? 1:0;
+}
+
+=pod 
+
+=item C<program_exists($program)>
+
+Return C<1> if C<$program> is in C<PATH> and C<0> otherwise.
+
+=cut
+
+sub program_exists {
+  my $program=shift;
+  return (&which ("$program"))? 0:1;
+}
+
+=pod
+
+=item C<binaries_available_from_disk>
+
+The function C<binaries_available_from_disk> returns a list of
+supported platforms.  Media type has to be either C<CD> or C<DVD>.
+
+=cut
+
+sub binaries_available_from_disk {
+  my @dir;
+  my @platforms;
+	if (&media eq "CD") {
+    opendir DIR, "$::_installerdir_/archive";
+  } elsif (&media eq "DVD") {
+    opendir DIR, "$::_installerdir_/texmf/bin";
+  } else {
+    die "Media type must be CD or DVD.\n";
+  }
+  @dir=readdir DIR;
+  chomp @dir;
+  if (&media eq "CD") {
+    for (@dir) {
+      if (/bin-kpathsea.(.*).zip$/) {
+        push @platforms, $1;
+      }
+    }
+  } elsif (&media eq "DVD") {
+    for (@dir) {
+      push @platforms, $1 unless (/^\./);
+    }
+  } else {
+    die "Media type must be CD or DVD.\n";
+  }
+  return @platforms;
+}
+  
+=pod
+
+=item C<binaries_available_from_net>
+
+The function C<binaries_available_from_net> returns a list of
+platforms supported by the TeXLive server.  It downloads the file
+C<$::texlive_url/texlive.tlpdb> and looks for files
+C</^bin\/(.*)\/kpsewhich/>.
+
+=cut
+               
+sub binaries_available_from_net {
+  my @platforms;
+  open TLPDB, "wget -q --output-document=- $::texlive_url/texlive.tlpdb|"
+       or die "Can't open $::texlive_url/texlive.tlpdb";
+  while (<TLPDB>) {
+    if (/^bin\/(.*)\/kpsewhich/) {
+      push @platforms, $1;
+    }
+  }
+  return @platforms;
+}
+
 1;
 
+
 =pod
 
+=back
+
 =head1 SEE ALSO
 
 The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, 
diff --git a/Master/tlpkg/doc/Perl-API.txt b/Master/tlpkg/doc/Perl-API.txt
index feac97832c0..d0557816fb3 100644
--- a/Master/tlpkg/doc/Perl-API.txt
+++ b/Master/tlpkg/doc/Perl-API.txt
@@ -210,10 +210,12 @@ Package variables:
 	&TeXLive::TLPDB->listdir
 		sets/returns the default location for created list files
 
-Constructore
+Constructor
 
 	TeXLive::TLPDB->new;
 	TeXLive::TLPDB->new ( location => "path/to/tldb/file" );
+	TeXLive::TLPDB->new ( location => "http://path/to/tldb/file" );
+	TeXLive::TLPDB->new ( location => "ftp://path/to/tldb/file" );
 
 Read/Write functions (with argument set, without arg read)
 
@@ -221,7 +223,9 @@ Read/Write functions (with argument set, without arg read)
 
 Input/Output
 
-	$tldb->from_file($filename);
+	$tldb->from_file("path/to/tldb/file");
+	$tldb->from_file("http://path/to/tldb/file");
+	$tldb->from_file("ftp://path/to/tldb/file");
 		reads a tldb file (tlp descriptions separated by newlines)
 	
 	$tldb->writeout
@@ -265,5 +269,12 @@ exported functions:
 	push_uniq(\@list,@list)
 	dirname($file)
 	basename($file)
-
-
+	getenv($string)
+	which($string)
+	initialze_installer
+	media
+	platform
+	win32
+	program_exists($program)
+	binaries_available_from_disk($platform)
+	binaries_available_from_net($platform)