path: root/Master/tlpkg/TeXLive/TLUtils.pm

# $Id$
# The inevitable utilities for TeX Live.
#
# Copyright 2007, 2008 Norbert Preining, Reinhard Kotucha
# This file is licensed under the GNU General Public License version 2
# or any later version.


package TeXLive::TLUtils;

=pod

=head1 NAME

C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure

=head1 SYNOPSIS

  use TeXLive::TLUtils;

=head2 Platform Detection

  TeXLive::TLUtils::platform;
  TeXLive::TLUtils::platform_desc($platform);
  TeXLive::TLUtils::win32;
  TeXLive::TLUtils::unix;

=head2 System Tools

  TeXLive::TLUtils::getenv($string);
  TeXLive::TLUtils::which($string);
  TeXLive::TLUtils::program_exists($program);
  TeXLive::TLUtils::get_system_tmpdir;

=head2 File Utilities

  TeXLive::TLUtils::dirname($path);
  TeXLive::TLUtils::basename($path);
  TeXLive::TLUtils::dirname_and_basename($path);
  TeXLive::TLUtils::dir_writable($path);
  TeXLive::TLUtils::mkdirhier($path);
  TeXLive::TLUtils::copy($file, $target_dir);
  TeXLive::TLUtils::download_file( $path, $destination [, $progs ] );
  TeXLive::TLUtils::setup_programs( $bindir, $platform);

=head2 Installer Functions

  TeXLive::TLUtils::media;
  TeXLive::TLUtils::initialze_installer;
  TeXLive::TLUtils::make_var_skeleton($path);
  TeXLive::TLUtils::make_local_skeleton($path);
  TeXLive::TLUtils::create_fmtutil($tlpdb,$dest,$localconf);
  TeXLive::TLUtils::create_updmap($tlpdb,$dest,$localconf);
  TeXLive::TLUtils::create_language($tlpdb,$dest,$localconf);
  TeXLive::TLUtils::install_packages($from_tlpdb,$to_tlpdb,$what,$opt_src, $opt_doc)>);
  TeXLive::TLUtils::install_package($what, $filelistref, $target, $platform);

=head2 Miscellaneous

  TeXLive::TLUtils::sort_uniq(@list);
  TeXLive::TLUtils::push_uniq(\@list, @items);
  TeXLive::TLUtils::member($item, @list);
  TeXLive::TLUtils::merge_into(\%to, \%from);
  TeXLive::TLUtils::texdir_check($texdir);
  TeXLive::TLUtils::kpsewhich;
  TeXLive::TLUtils::conv_to_win_path($path);

=head1 DESCRIPTION

=cut


BEGIN {
  use Exporter ();
  use vars qw( @ISA @EXPORT_OK @EXPORT);
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(
    &platform
    &platform_desc
    &win32
    &unix
    &getenv
    &which
    &program_exists
    &get_system_tmpdir
    &dirname
    &basename
    &dirname_and_basename
    &dir_writable
    &mkdirhier
    &copy
    &install_package
    &install_packages
    &media
    &initialize_installer
    &make_var_skeleton
    &sub make_local_skeleton
    &create_fmtutil
    &create_updmap
    &create_language
    &sort_uniq
    &push_uniq
    &texdir_check
    &member
    &kpsewhich
    &quotewords
    &conv_to_win_path
    &setup_programs
    &download_file
    &merge_into
    &process_logging_options
    &welcome
    &welcome_paths
  );
  @EXPORT = qw(setup_programs download_file info log debug ddebug tlwarn process_logging_options win32);
}


use TeXLive::TLConfig;
use Getopt::Long;

$::opt_verbosity = 0;

=pod


=head2 Platform Detection

=over 6

=item C<platform>

If C<$^O=~/MSWin(32|64)$/i> is true we know that we're on
Windows and we set the global variable C<$::_platform_> to C<win32>.
Otherwise 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 TeX Live 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 {
  unless (defined $::_platform_) {
    if ($^O=~/^MSWin(32|64)$/i) {
      $::_platform_="win32";
    } else {
      my $config_guess="$::installerdir/tlpkg/installer/config.guess";
      my @OSs=qw(aix cygwin darwin freebsd hpux irix linux netbsd
                 openbsd solaris);
      my $CPU; # CPU type as reported by config.guess.
      my $OS;  # O/S type as reported by config.guess.
      # We cannot rely on #! in config.guess but have to call /bin/sh
      # explicitly because sometimes the 'noexec' flag is set in
      # /etc/fstab for ISO9660 file systems.
      my $guessed_platform=`/bin/sh $config_guess`;
      chomp $guessed_platform;
      $guessed_platform=~s/^x86_64-(.*)-freebsd$/amd64-$1-freebsd/;
      ($CPU=$guessed_platform)=~s/(.*?)-.*/$1/;
      foreach my $os (@OSs) {
        $OS=$os if $guessed_platform=~/$os/;
      }
      if ($CPU=~/^i.86$/) {
        $CPU=~s/i.86/i386/;
      }
      unless (defined $OS) {
        ($OS=$guessed_platform)=~s/.*-(.*)/$1/;
      }
      $::_platform_="$CPU-$OS";
    }
  }
  return $::_platform_;
}

=pod

=item C<platform_desc($platform)>

Return a string which describes a particular platform identifier, e.g.,
given C<i386-linux> we return C<Intel x86 with GNU/Linux>.

=cut

sub platform_desc {
  my ($platform) = @_;

  my %platform_name=(
    'alpha-linux'    => 'DEC Alpha with GNU/Linux',
    'alphaev5-osf'   => 'DEC Alphaev5 OSF',
    'amd64-freebsd'  => 'x86_64 with FreeBSD',
    'hppa-hpux'      => 'HP-UX',
    'i386-cygwin'    => 'Intel x86 with Cygwin',
    'i386-darwin'    => 'Intel x86 with MacOSX/Darwin',
    'i386-freebsd'   => 'Intel x86 with FreeBSD',
    'i386-openbsd'   => 'Intel x86 with OpenBSD',
    'i386-netbsd'    => 'Intel x86 with NetBSD',
    'i386-linux'     => 'Intel x86 with GNU/Linux',
    'i386-solaris'   => 'Intel x86 with Sun Solaris',
    'mips-irix'      => 'SGI IRIX',
    'powerpc-aix'    => 'PowerPC with AIX',
    'powerpc-darwin' => 'PowerPC with MacOSX/Darwin',
    'powerpc-linux'  => 'PowerPC with GNU/Linux',
    'sparc-linux'    => 'Sparc with GNU/Linux',
    'sparc-solaris'  => 'Sparc with Solaris',
    'win32'          => 'Windows',
    'x86_64-linux'   => 'x86_64 with GNU/Linux'
      );

  # the inconsistency between amd64-freebsd and x86_64-linux is
  # unfortunate (it's the same hardware), but the os people say those
  # are the conventional names on the respective os's, so ...

  if (exists $platform_name{$platform}) {
    return "$platform_name{$platform}";
  } else {
    my ($CPU,$OS) = split ('-', $platform);
    return "$CPU with " . ucfirst "$OS";
  }
}

=pod

=item C<win32>

Return C<1> if platform is Windows and C<0> otherwise.  The test is
currently based on the value of Perl's C<$^O> variable.

=cut

sub win32
{
  if ($^O=~/^MSWin(32|64)$/i) {
    return 1;
  } else {
    return 0;
  }
  # the following needs config.guess, which is quite bad ...
  # return (&platform eq "win32")? 1:0;
}

=pod

=item C<unix>

Return C<1> if platform is UNIX and C<0> otherwise.

=cut

sub unix {
  return (&platform eq "win32")? 0:1;
}

=pod

=back

=head2 System Tools

=over 6

=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<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<get_system_tmpdir>

Evaluate the environment variables C<TMPDIR>, C<TMP>, and C<TEMP> in
order to find the system temporary directory.

=cut

sub get_system_tmpdir {
  my $systmp=0;
  $systmp||=getenv 'TMPDIR';
  $systmp||=getenv 'TMP';
  $systmp||=getenv 'TEMP';
  $systmp||='/tmp';
  return "$systmp";
}

=pod

=back

=head2 File Utulities

=over 6


=item C<dirname($path)>

Return C<$path> with its trailing C</component> removed.

=cut

sub dirname {
  my $path=shift;
  if (win32) {
    $path=~s!\\!/!g;
  }
  if ($path=~m!/!) {  # dirname("foo/bar/baz") -> "foo/bar"
    $path=~m!(.*)/.*!;
    return $1;
  } else {              # dirname("ignore") -> "."
    return ".";
  }
}


=item C<basename($path)>

Return C<$path> with any leading directory components removed.

=cut

sub basename {
  my $path=shift;
  if (win32) {
    $path=~s!\\!/!g;
  }
  if ($path=~m!/!) {  # basename("foo/bar") -> "bar"
    $path=~m!.*/(.*)!;
    return $1;
  } else {            # basename("ignore") -> "ignore"
    return $path;
  }
}


=item C<dirname_and_basename($path)>

Return both C<dirname> and C<basename>.  Example:

  ($dirpart,$filepart) = dirname_and_basename ($path);

=cut

sub dirname_and_basename {
  my $path=shift;
  if (win32) {
    $path=~s!\\!/!g;
  }
  $path=~/(.*)\/(.*)/;
  return ("$1", "$2");
}

=pod

=item C<dir_writable($path)>

Tests whether its argument is writable by trying to write to
it. This function is necessary because the built-in C<-w> test just
looks at mode and uid/guid, which on Windows always returns true and
even on Unix is not always good enough for directories mounted from
a fileserver.

=cut

# Theoretically, the test below, which uses numbers as names, might
# lead to a race condition. OTOH, it should work even on a very
# broken Perl.

# The Unix test gives the wrong answer when used under Windows Vista
# with one of the `virtualized' directories such as Program Files:
# lacking administrative permissions, it would write successfully to
# the virtualized Program Files rather than fail to write to the
# real Program Files. Ugh.

sub dir_writable {
  $path=shift;
  return 0 unless -d $path;
  $path =~ s!\\!/!g if win32;
  $path =~ s!/$!!g;
  my $i = 0;
  while (-e $path . "/" . $i) { $i++; }
  my $f = $path."/".$i;
  if (win32) {
    my $fb = $f;
    $fb =~ s!/!\\!g;
    return 0 if
      system('copy /b ' . $ENV{'COMSPEC'} . ' "' . $fb . '" >nul 2>&1');
    unlink $f if -e $f;
    return 1;
  } else {
    return 0 unless open TEST, ">".$f;
    my $written = 0;
    $written = (print TEST "\n");
    close TEST;
    unlink $f;
    return $written;
  }
}

=pod

=item C<mkdirhier($path, [$mode])>

The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>.
The optional parameter sets the permission flags.

=cut

sub mkdirhier {
  my $tree=shift;
  my $mode=shift;
  my $subdir;

  return if (-d "$tree");
  @dirs=split /\//, $tree;
  foreach $dir (@dirs) {
    $subdir .= ("$dir" . "/");
    unless (-d $subdir)  {
      if (defined $mode) {
        mkdir ("$subdir", $mode) or die "Can't mkdir '$subdir': $!.\n";
      } else {
        mkdir "$subdir" or die "Can't mkdir '$subdir': $!.\n";
      }
    }
  }
}

=pod

=item C<copy($file, $target_dir)>

Copy file C<$file> to directory C<$target_dir>.  No external programs
are involved.  Since we need C<sysopen()>, the Perl module C<Fcntl.pm>
is required.  The time stamps are preserved and symlinks are created
on UNIX systems.  On Windows, C<(-l $file)> will certainly never
return 'C<true>' and symlinks will be copied as regular files.

C<copy> invokes C<mkdirhier> if target directories do not exist.
Files have mode C<0777>-I<umask> if they are executable and
C<0666>-I<umask> otherwise.

=cut

sub copy {
  my $infile=shift;
  my $destdir=shift;
  my $outfile;
  my @stat;
  my $mode;
  my $buffer;
  my $offset;
  my $filename;
  my $dirmode=0755;
  my $blocksize=2048;

  mkdirhier ("$destdir") unless -d "$destdir";

  $filename=basename "$infile";
  $outfile="$destdir/$filename";

  if (-l "$infile") {
    symlink readlink "$infile", "$destdir/$filename";
  } else {
    open IN, "$infile" or die "Can't open '$infile': $!\n";
    binmode IN;

    $mode=(-x "$infile")? oct("0777"):oct("0666");
    $mode-=umask;

    open OUT, ">$outfile" or die "Can't open '$outfile': $!\n";
    binmode OUT;

    chmod $mode, "$outfile";

    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;
    @stat=lstat "$infile";
    utime $stat[8], $stat[9], "$outfile";
  }
}

=pod

=item C<install_packages($from_tlpdb, $to_tlpdb, $what, $opt_src, $opt_doc)>

Installs the list of packages found in C<@$what> (a ref to a list) into
the TLPDB given by C<$to_tlpdb>. Information on files are taken from
the TLPDB C<$from_tlpdb>.

C<$opt_src> and C<$opt_doc> specify whether srcfiles and docfiles should be
installed (currently implemented only for installation from DVD).

=cut

sub install_packages {
  my ($fromtlpdb,$totlpdb,$what,$opt_src,$opt_doc) = @_;
  my $container_src_split = $fromtlpdb->config_src_container;
  my $container_doc_split = $fromtlpdb->config_doc_container;
  foreach my $package (@$what) {
    info("Installing: $package\n");
    foreach my $h (@::install_packages_hook) {
      &$h("Installing: $package");
    }
    my $tlpobj=$fromtlpdb->get_package($package);
    if (!defined($tlpobj)) {
      die "STRANGE: $package not to be found in ", $fromtlpdb->root;
    }
    my $real_opt_doc = $opt_doc;
    # if we install a package from the Documentation class we
    # reactivate the do_doc in any case. It should apply ONLY for fonts
    # and macros!
    if ($tlpobj->category =~ m/documentation/i) {
      $real_opt_doc = 1;
    }
    my $container;
    my @installfiles;
    push @installfiles, $tlpobj->runfiles;
    push @installfiles, $tlpobj->allbinfiles;
    push @installfiles, $tlpobj->srcfiles if ($opt_src);
    push @installfiles, $tlpobj->docfiles if ($real_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 {
        # for now only warn and return, should (?) be die!?
        tlwarn("Cannot find a package $package (.zip or .lzma) in $::installerdir/$DiskArchive\n");
        next;
      }
    } elsif (&media eq 'NET') {
      $container = "$TeXLiveURL/$NetArchive/$package.$DefaultContainerExtension";
    }
    install_package($container,\@installfiles,$totlpdb->root,$vars{'this_platform'});
    # if we are installing from CD or NET we have to fetch the respective
    # source and doc packages $pkg.source and $pkg.doc and install them, too
    if ((&media eq 'NET') || (&media eq 'CD')) {
      # we install split containers under the following conditions:
      # - the container were split generated
      # - src/doc files should be installed
      # - the package is not already a split one (like .i386-linux)
      # - there are actually src/doc files present
      if ($container_src_split && $opt_src &&
          ($package !~ m/\./) && $tlpobj->srcfiles) {
        my $srccontainer = $container;
        $srccontainer =~ s/(\.tar\.lzma|\.zip)$/.source$1/;
        install_package($srccontainer,\@installfiles,$totlpdb->root,$vars{'this_platform'});
      }
      if ($container_doc_split && $real_opt_doc &&
          ($package !~ m/\./) && $tlpobj->docfiles) {
        my $doccontainer = $container;
        $doccontainer =~ s/(\.tar\.lzma|\.zip)$/.doc$1/;
        install_package($doccontainer,\@installfiles,$totlpdb->root,$vars{'this_platform'});
      }
    }
    # we don't want to have wrong information in the tlpdb, so remove the
    # src/doc files if they are not installed ...
    if (!$opt_src) {
      $tlpobj->clear_srcfiles;
    }
    if (!$real_opt_doc) {
      $tlpobj->clear_docfiles;
    }
    $totlpdb->add_tlpobj($tlpobj);
    # we have to write out the tlpobj file since it is contained in the
    # archives (.tar.lzma) but at DVD install time we don't have them
    my $tlpod = $totlpdb->root . "/tlpkg/tlpobj";
    mkdirhier( $tlpod );
    open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") or
      die("Cannot open tlpobj file for ".$tlpobj->name);
    $tlpobj->writeout(\*TMP);
    close(TMP);
  }
  $totlpdb->save;
}

=pod

=item C<install_package($what, $filelistref, $target, $platform)>

This function installs the files given in @$filelistref from C<$what>
into C<$target>.

If C<$what> is a reference to a list of files then these files are
assumed to be readable and are copied to C<$target>, creating dirs on
the way. In this case the list C<@$filelistref> is not taken into
account.

If C<$what> starts with C<http://> or C<ftp://> then C<$what> is
downloaded from the net and piped through c<lzmadec> and C<tar>.

If $what ends with C<.tar.lzma> (but does not start with C<http://> or
C<ftp://>) it is assumed to be a readable file on the system and is
piped through C<lzmadec> and C<tar> in the very same way.

In both of the last cases currently the list C<$@filelistref> currently
is not taken into account (should be fixed!).

=cut

sub install_package {
  my ($what, $filelistref, $target, $platform) = @_;

  my @filelist = @$filelistref;

  # we assume that $::progs has been set up!
  my $wget = $::progs{'wget'};
  my $lzmadec = $::progs{'lzmadec'};
  my $tar = $::progs{'tar'};
  if (!defined($wget) || !defined($lzmadec) || !defined($tar)) {
    die "Programs have not been set up properly, strange!";
  }
  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!
      # is this still needed?
      my $dn=dirname($file);
      mkdirhier("$target/$dn");
      copy "$file", "$target/$dn";
    }
  } elsif ($what =~ m,\.tar.lzma$,) {
    # this is the case when we install from CD or the NET
    #
    # in all other cases we create temp files .tar.lzma (or use the present
    # one), lzmadec them, and then call tar

    my $fn = basename($what);
    mkdirhier("$target/temp");
    my $lzmafile = "$target/temp/$fn";
    my $tarfile  = "$target/temp/$fn"; $tarfile =~ s/\.lzma$//;
    my $lzmafile_quote = $lzmafile;
    my $tarfile_quote = $tarfile;
    my $target_quote = $target;
    if (win32()) {
      $lzmafile =~ s!/!\\!g;
      $tarfile =~ s!/!\\!g;
      $target =~ s!/!\\!g;
    }
    $lzmafile_quote = "\"$lzmafile\"";
    $tarfile_quote = "\"$tarfile\"";
    $target_quote = "\"$target\"";
    if ($what =~ m,http://|ftp://,) {
      # we are installing from the NET
      # download the file and put it into temp
      if (!download_file($what, $lzmafile) || (! -r $lzmafile)) {
        die "Downloading $what did not succeed, please retry!";
      }
    } else {
      # we are installing from CD
      # copy it to temp
      copy($what, "$target/temp");
    }
    debug("Un-lzmaing $lzmafile to $tarfile\n");
    system("$lzmadec < $lzmafile_quote > $tarfile_quote");
    if (! -f $tarfile) {
      die "Unpacking $lzmafile did not succeed, please retry!";
    }
    debug("Unpacking $tarfile\n");
    system($tar,"-x","-C",$target,"-f",$tarfile);
    unlink($tarfile, $lzmafile);
  } else {
    die "Don't know how to install $what!\n";
  }
}

=pod

=item C<setup_programs( $bindir, $platform )>

Sets up the global $::progs hash containing the pathes to the
programs C<wget>, C<tar>, C<lzmadec>. The C<$bindir> argument specifies
the path to the location of the C<lzmadec> binaries, the C<$platform>
gives the extension for the C<lzmadec> binary.

=cut

sub setup_programs {
  my ($bindir, $platform) = @_;
  $::progs{'wget'} = "wget";
  if (!defined($platform) || ($platform eq "")) {
    # we assume that we run from the DVD, so we can call platform() and
    # thus also the config.guess script
    # but we have to setup $::installerdir because that stupid
    # platform script relies on it
    $::installerdir = "$bindir/../..";
    $platform = platform();
  }
  $::progs{'lzmadec'} = "$bindir/lzma/lzmadec.$platform";
  $::progs{'lzma'} = "$bindir/lzma/lzma.$platform";
  $::progs{'tar'} = "tar";
  if (win32()) {
    $::progs{'wget'}    = conv_to_win_path("$bindir/wget.exe");
    $::progs{'tar'}     = conv_to_win_path("$bindir/tar.exe");
    $::progs{'lzmadec'} = conv_to_win_path("$bindir/lzma/lzmadec.win32.exe");
    $::progs{'lzma'}    = conv_to_win_path("$bindir/lzma/lzma.exe");
  }
}

=pod

=item C<download_file( $path, $destination [, $progs ] )>

Try to download the file given in C<$relpath> from either C<$TeXLiveURL>
or C<TeXLiveAlternativeURL> into C<$destination>, which can be either
a filename of simply C<|>. In the latter case a file handle is returned.

The optional argument C<$progs> is a reference to a hash giving full pathes
to the respective programs, at least C<wget>. In case that C<$progs> is not
given the C<%::progs> is consulted, and if this also does not exist we
try "wget".

Downloading honors two environment variables C<TL_DOWNLOAD_PROGRAM> and
C<TL_DOWNLOAD_ARGS>. The former overrides C<wget> (or what is given in the
C<$progs> argument, the latter overrides the default wget arguments
given in C<$TeXLive::TLConfig::DefaultWgetArgs>.

C<TL_DOWNLOAD_ARGS> must be set up in a way that the place the output should
go to is the first argument after the C<TL_DOWNLOAD_ARGS>. Use with care.

=cut

sub download_file {
  my ($relpath, $dest, $progs) = @_;
  my $wget;
  if (defined($progs) && defined($progs->{'wget'})) {
    $wget = $progs->{'wget'};
  } elsif (defined($::progs{'wget'})) {
    $wget = $::progs{'wget'};
  } else {
    tlwarn ("Programs have not been set up, trying simply wget");
    $wget = "wget";
  }
  my $url;
  if ($relpath =~ /^(http|ftp):\/\//) {
    $url = $relpath;
  } else {
    $url = "$TeXLiveURL/$relpath";
  }
  my $ret = _download_file($url, $dest, $wget);
  return($ret) if $ret;
  # if we have a full url given do NOT try an alternative url
  if ($relpath =~ /^(http|ftp):\/\//) {
    # we did get a full url, give up immediately
    return undef;
  }
  # we are still here ... try it with Alternative URL:
  return undef unless ($TeXLiveAlternativeURL);
  # we are still here and TeXLiveAlternativeURL is defined
  $url = "$TeXLiveAlternativeURL/$relpath";
  $ret = _download_file($url, $dest, $wget);
  return($ret) if $ret;
  # still not found, give up
  return undef;
}

sub _download_file {
  my ($url, $dest, $wgetdefault) = @_;
  if (win32()) {
    $dest =~ s!/!\\!g;
  }

  my $wget = $ENV{"TL_DOWNLOAD_PROGRAM"} || $wgetdefault;
  # we set now the args in installer/wgetrc
  my $wgetargs = $ENV{"TL_DOWNLOAD_ARGS"} || "-q -O";


  debug("Trying to download $url\n");
  my $ret;
  if ($dest eq "|") {
    open(RETFH, "$wget $wgetargs - $url|") or
      die("Cannot open $url via wget for reading");
    # opening to a pipe always succeeds, so we return immediately
    return \*RETFH;
  } else {
    my @wgetargs = split ' ', $wgetargs;
    $ret = system $wget, @wgetargs, $dest, $url;
    # we have to reverse the meaning of ret because systems returns
    # the inverse
    $ret = ($ret ? 0 : 1);
  }
  # return false/undef in case the download did not succeed.
  return ($ret) unless $ret;
  debug("Download $url did succeed\n");
  if ($dest eq "|") {
    return \*RETFH;
  } else {
    return 1;
  }
}

sub install_package_old {
# either a list of files or a name of one .zip or .tar.lzma file.
  my @what=@_;

  my $target="$::vars{'TEXDIR'}";
  my $bindir="$::installerdir/tlpkg/bin";
  my $platform=&platform;
  my $buffer;
  my $offset;
  # shouldn't it be 4096
  my $blocksize=2048;

  #my $lzmadec="$bindir/lzmadec_$platform";
  my $lzmadec="lzmadec";
  my $tar="/bin/tar -xf - -C";
  my $wget="wget -nv -O-";
  if (win32) {
    $lzmadec="$bindir/lzma/lzma.exe -si -so";
    $tar="$bindir/tar.exe -xf - -C";
    $wget="$bindir/wget.exe -nv -O-";
  }

  if (&media eq 'DVD') {
    foreach my $file (@what) {
      my $dn=dirname($file);
      mkdirhier("$target/$dn");
      copy "$file", "$target/$dn";
    }
  } elsif (&media eq 'CD') {
    my $package="$::installerdir/$DiskArchive/$what[0]";
    open IN, "$package"
        or die "Can't open '$package': $!\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;
  } elsif (&media eq 'NET') {
    my $package="$TeXLiveURL/$NetArchive/$what[0]";
    system "$wget $package|$lzmadec|$tar $target";
  } else {
    die "This can't happen.";
  }
}

=pod

=back

=head2 Installer Functions

=over 6


=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/$DiskArchive") {
      $::_media_='CD';
    } elsif (-d "$::installerdir/texmf/web2c") {
      $::_media_='DVD';
    } else {
      $::_media_='NET';
    }
  }
  return $::_media_;
}

=pod

=item C<initialize_installer>

The function C<initialize_installer> calls C<media> and C<platform> in
order to set the variables C<$::_media_> and C<$::_platform_>.

Note that C<$0> contains backslashes as path separators on Windows.

Repeatedly calls to C<media> or C<platform> do not access the CD/DVD
again.

=cut

sub initialize_installer {
  &media;
  &platform;
  $ENV{'WGETRC'}="$::installerdir/tlpkg/installer/wgetrc"
}

=pod

=item C<make_var_skeleton($prefix)>

Generate a skeleton of empty directories in the C<TEXMFSYSVAR> tree.

=cut

sub make_var_skeleton {
  my $prefix=shift;

  mkdirhier "$prefix/tex/generic/config";
  mkdirhier "$prefix/dvipdfm/config";
  mkdirhier "$prefix/tex/plain/config";
  mkdirhier "$prefix/dvips/config";
  mkdirhier "$prefix/fonts/map/dvipdfm/updmap";
  mkdirhier "$prefix/fonts/map/dvips/updmap";
  mkdirhier "$prefix/fonts/map/pdftex/updmap";
  mkdirhier "$prefix/fonts/pk";
  mkdirhier "$prefix/fonts/tfm";
  mkdirhier "$prefix/web2c";
  mkdirhier "$prefix/xdvi";
  mkdirhier "$prefix/tex/context/config";
}

=pod

=item C<make_local_skeleton($prefix)>

Generate a skeleton of empty directories in the C<TEXMFLOCAL> tree.

=cut

sub make_local_skeleton {
  my $prefix=shift;

  mkdirhier "$prefix/tex/latex/local";
  mkdirhier "$prefix/tex/plain/local";
  mkdirhier "$prefix/dvips/local";
  mkdirhier "$prefix/bibtex/bib/local";
  mkdirhier "$prefix/bibtex/bst/local";
  mkdirhier "$prefix/fonts/tfm/local";
  mkdirhier "$prefix/fonts/vf/local";
  mkdirhier "$prefix/fonts/source/local";
  mkdirhier "$prefix/fonts/type1/local";
  mkdirhier "$prefix/metapost/local";
  mkdirhier "$prefix/web2c";
}


=pod

=item C<create_fmtutil($tlpdb, $dest, $localconf)>

=item C<create_updmap($tlpdb, $dest, $localconf)>

=item C<create_language($tlpdb, $dest, $localconf)>

These three functions create C<fmtutil.cnf>, C<updmap.cfg>, and
C<language.dat>, respectively, in C<$dest> (which by default is below
C<$TEXMFSYSVAR>).  These functions merge the information present in the
TLPDB C<$tlpdb> (formats, maps, hyphenations) with local configuration
additions: C<$localconf>.

Currently the "merging" is done trivially by appending the content of
the local configuration files at the end of the file. This should be
improved (checking for duplicates).

=cut

sub create_fmtutil {
  my ($tlpdb,$dest,$localconf) = @_;
  my $root = $tlpdb->root;
  my @lines = $tlpdb->fmtutil_cnf_lines;
  if (-r "$localconf") {
    #
    # this should be done more intelligently, but for now only add those
    # lines without any duplication check ...
    open FOO, "<$localconf"
      or die "strange, -r ok but cannot open $localconf: $!";
    my @tmp = <FOO>;
    push @lines, @tmp;
  }
  if ($#lines >= 0) {
    open(OUTFILE,">$dest")
      or die("Cannot open $dest for writing: $!");

    printf OUTFILE "# Generated by %s on %s\n", "$0", scalar localtime;
    print OUTFILE @lines;
    close(OUTFILE) || warn "close(>$dest) failed: $!";
  }
}

sub create_updmap {
  my ($tlpdb,$dest,$localconf) = @_;
  my $root = $tlpdb->root;
  my @lines = $tlpdb->updmap_cfg_lines;
  if (-r "$localconf") {
    #
    # this should be done more intelligently, but for now only add those
    # lines without any duplication check ...
    open FOO, "<$localconf"
      or die "strange, -r ok but cannot open $localconf: $!";
    my @tmp = <FOO>;
    push @lines, @tmp;
  }
  if ($#lines >= 0) {
    open(OUTFILE,">$dest")
      or die("Cannot open $dest for writing: $!");

    printf OUTFILE "# Generated by %s on %s\n", "$0", scalar localtime;
    print OUTFILE @lines;
    close(OUTFILE) || warn "close(>$dest) failed: $!";
  }
}

sub create_language {
  my ($tlpdb,$dest,$localconf) = @_;
  my $root = $tlpdb->root;
  my @lines = $tlpdb->language_dat_lines;
  if (-r "$localconf") {
    #
    # this should be done more intelligently, but for now only add those
    # lines without any duplication check ...
    open FOO, "<$localconf"
      or die "strange, -r ok but cannot open $localconf: $!";
    my @tmp = <FOO>;
    push @lines, @tmp;
  }
  if ($#lines >= 0) {
    open(OUTFILE,">$dest")
      or die("Cannot open $dest for writing: $!");

    printf OUTFILE "%% Generated by %s on %s\n", "$0", scalar localtime;
    print OUTFILE @lines;
    close(OUTFILE) || warn "close(>$dest) failed: $!";
  }
}


=pod

=back

=head2 Miscellaneous

Ideas from Fabrice Popineau's C<FileUtils.pm>.

=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.

=cut

sub sort_uniq {
  my (@l) = @_;
  my ($e, $f, @r);
  $f = "";
  @l = sort(@l);
  foreach $e (@l) {
    if ($e ne $f) {
      $f = $e;
      push @r, $e;
    }
  }
  return @r;
}

=pod

=item C<push_uniq(\@list, @items)>

The C<push_uniq> function pushes the last elements on the list referenced
by the first argument.

=cut

sub push_uniq {
  # can't we use $l as a reference, and then use my?  later ...
  local (*l, @le) = @_;
  foreach my $e (@le) {
    if (! &member($e, @l)) {
      push @l, $e;
    }
  }
}

=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.

=cut

sub member {
  my ($e, @l) = @_;
  my ($f);
  foreach $f (@l) {
    if ($e eq $f) {
      return 1;
    }
  }
  return 0;
}

=pod

=item C<merge_into(\%to, \%from)>

Merges the keys of %from into %to.

=cut

sub merge_into {
  my ($to, $from) = @_;
  foreach my $k (keys %$from) {
    if (defined($to->{$k})) {
      push @{$to->{$k}}, @{$from->{$k}};
    } else {
      $to->{$k} = [ @{$from->{$k}} ];
    }
  }
}

=pod

=item C<texdir_check($texdir)>

Test whether installation with TEXDIR set to $texdir would succeed due to
writing permissions.

=cut

sub texdir_check {
  my ($texdir) = shift;                       # PATH/texlive/2008
  my $texdirparent = dirname($texdir);        # PATH/texlive
  my $texdirpparent = dirname($texdirparent); # PATH
  if ( (dir_writable($texdirpparent)) ||
       ( (-d $texdirparent) && (dir_writable($texdirparent)) ) ||
       ( (-d $texdir) && (dir_writable($texdir)) ) ) {
    return 1;
  }
  return 0;
}



sub logit {
  my ($out, $level, @rest) = @_;
  _logit($out, $level, @rest) unless $::opt_quiet;
  _logit('file', $level, @rest);
}

sub _logit {
  my ($out, $level, @rest) = @_;
  if ($::opt_verbosity >= $level) {
    # if $out is a ref/glob to STDOUT or STDERR, print it there
    if (ref($out) eq "GLOB") {
      print $out @rest;
    } else {
      # we should log it into the logfile, but that might be not initialized
      # so either print it to the filehandle $::LOGFILE, or push it onto
      # the to be printed log lines @::LOGLINES
      if (defined($::LOGFILE)) {
        print $::LOGFILE @rest;
      } else {
        push @::LOGLINES, "@rest";
      }
    }
  }
}

sub info {
  logit(\*STDOUT, 0, @_);
}

sub debug {
  logit(\*STDOUT, 1, "D:", @_);
}

sub ddebug {
  logit(\*STDOUT, 2, "DD:", @_);
}

sub log {
  # warning should always done to stderr and the log file,
  # independently from the verbosity level
  my $savequiet = $::opt_quiet;
  $::opt_quiet = 0;
  _logit('file', -100, @_);
  $::opt_quiet = $savequiet;
}

sub tlwarn {
  # warning should always done to stderr and the log file,
  # independently from the verbosity level
  my $savequiet = $::opt_quiet;
  $::opt_quiet = 0;
  logit(\*STDERR, -100, @_);
  $::opt_quiet = $savequiet;
}

sub process_logging_options {
  $::opt_verbosity = 0;
  $::opt_quiet = 0;
  # check all the command line options for occurrences of -q and -v
  # do not report errors
  my $oldconfig = Getopt::Long::Configure(qw(pass_through permute));
  GetOptions("v+" => \$::opt_verbosity, "q" => \$::opt_quiet);
  Getopt::Long::Configure($oldconfig);
}

=pod

=item C<kpsewhich($varname)>

This function expands the variable name using kpsewhich. The variable
name should not have a leading $. The kpsewhich binary has to be in
the path.

=cut

sub kpsewhich {
  my $var = shift;
  my $ret = `kpsewhich -var-value=$var`;
  chomp ($ret);
  return($ret);
}

=pod

=item C<welcome>

The welcome message.

=cut

sub welcome {
  my $welcome=<<"EOF";

 See ./index.html for links to documentation.  The TeX Live web site
 (http://tug.org/texlive/) contains any updates and corrections.

 TeX Live is a joint project of the TeX user groups around the world;
 please consider supporting it by joining the group best for you.  
 The list of groups is available on the web at http://tug.org/usergroups.html.

 Welcome to TeX Live!
EOF
  return $welcome;
}

=pod

=item C<welcome>

The same welcome message as above but with hints about C<PATH>, C<MANPATH>, 
and C<INFOPATH>. 

=cut

sub welcome_paths {
  my $welcome=<<"EOF";

 See ./index.html for links to documentation.  The TeX Live web site
 (http://tug.org/texlive/) contains any updates and corrections.

 TeX Live is a joint project of the TeX user groups around the world;
 please consider supporting it by joining the group best for you.  
 The list of groups is available on the web at 
 http://tug.org/usergroups.html.

 Add $::vars{'TEXDIR'}/texmf/doc/man to MANPATH.
 Add $::vars{'TEXDIR'}/texmf/doc/info to INFOPATH.
 Most importantly, add $::vars{'TEXDIR'}/bin/$::vars{'this_platform'}
 to your PATH for current and future sessions.

 Welcome to TeX Live!
EOF
  return $welcome;
}

=pod

This function returns a "windowsified" path, i.e., replacing all forward
slashes to backslashes, and adding additional " around (in case of spaces
in $path). Furthermore it makes the path absolute. So if $path does not
start with an arbitrary char followed by : we add the output of `cd`.

=cut

sub conv_to_win_path {
  my $p = shift;
  $p =~ s!/!\\!g;
  # we need absolute pathes, too
  if ($p !~ m!^.:!) {
    my $cwd = `cd`;
    chomp($cwd);
    $p = "$cwd\\$bindir";
  }
  if ($p =~ m/ /) { $p = "\"$p\""; }
  return($p);
}

#############################################
#
# Taken from Text::ParseWords
#
sub quotewords {
  my($delim, $keep, @lines) = @_;
  my($line, @words, @allwords);

  foreach $line (@lines) {
    @words = parse_line($delim, $keep, $line);
    return() unless (@words || !length($line));
    push(@allwords, @words);
  }
  return(@allwords);
}

sub parse_line {
  my($delimiter, $keep, $line) = @_;
  my($word, @pieces);

  no warnings 'uninitialized';	# we will be testing undef strings

  while (length($line)) {
    $line =~ s/^(["'])			# a $quote
              ((?:\\.|(?!\1)[^\\])*)	# and $quoted text
              \1				# followed by the same quote
                |				# --OR--
            ^((?:\\.|[^\\"'])*?)		# an $unquoted text
            (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["']))
                  # plus EOL, delimiter, or quote
      //xs or return;		# extended layout
    my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4);
    return() unless( defined($quote) || length($unquoted) || length($delim));

    if ($keep) {
      $quoted = "$quote$quoted$quote";
    } else {
      $unquoted =~ s/\\(.)/$1/sg;
      if (defined $quote) {
        $quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
        $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
      }
    }
    $word .= substr($line, 0, 0);	# leave results tainted
    $word .= defined $quote ? $quoted : $unquoted;

    if (length($delim)) {
      push(@pieces, $word);
      push(@pieces, $delim) if ($keep eq 'delimiters');
      undef $word;
    }
    if (!length($line)) {
      push(@pieces, $word);
    }
  }
  return(@pieces);
}


=pod

=back

=head1 SEE ALSO

The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>,
L<TeXLive::TLPDB>, L<TeXLive::TLTREE>, and the
document L<Perl-API.txt> and the specification in the TeX Live
repository trunk/Master/tlpkg/doc/.

=head1 AUTHORS AND COPYRIGHT

This script and its documentation were written for the TeX Live
distribution (L<http://tug.org/texlive>) and both are licensed under the
GNU General Public License Version 2 or later.

=cut

1;

### Local Variables:
### perl-indent-level: 2
### tab-width: 2
### indent-tabs-mode: nil
### End:
# vim:set tabstop=2 expandtab: #