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

# $Id$
# The inevitable utilities for TeX Live.
# 
# Copyright 2007 Norbert Preining
# 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 Utulities

  TeXLive::TLUtils::dirname($path);
  TeXLive::TLUtils::basename($path);
  TeXLive::TLUtils::dirname_and_basename($path);
  TeXLive::TLUtils::mkdirhier($path);
  TeXLive::TLUtils::copy($file, $target_dir);

=head2 Installer Functions

  TeXLive::TLUtils::media;
  TeXLive::TLUtils::initialze_installer;
  TeXLive::TLUtils::architectures_available;
  TeXLive::TLUtils::additional_architectures_available_from_net;
  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,@list);
  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::tllog($level, $string);
  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
    &mkdirhier
    &copy
    &install_package
    &install_packages
    &media
    &initialize_installer
    &architectures_available
    &additional_architectures_available_from_net
    &make_var_skeleton
    &sub make_local_skeleton
    &create_fmtutil
    &create_updmap
    &create_language
    &sort_uniq
    &push_uniq
    &texdir_check
    &member
    &kpsewhich
    &quotewords
  );
  @EXPORT = qw(tllog);
}


use TeXLive::TLConfig qw($DefaultContainerExtension);



=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 {
  my @OSs=qw(aix cygwin darwin freebsd hpux irix linux netbsd openbsd
             solaris);

  unless (defined $::_platform_) {
    if ($^O=~/^MSWin(32|64)$/i) {
      $::_platform_="win32";
    } else {
      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 $::installerdir/config.guess`;
      chomp $guessed_platform;
      ($CPU=$guessed_platform)=~s/(.*?)-.*/$1/;
      foreach my $os (@OSs) {
        $OS=$os if $guessed_platform=~/$os/;
      }
      if ($CPU=~/^i.86$/) {
        $CPU=~s/i.86/i386/;
      }
      if (length "$OS" < 0) {
        ($OS=$guessed_platform)=~s/.*-(.*)/$1/;
      }
      $::_platform_="$CPU-$OS";
    }
  }
  return $::_platform_;
}

=pod

=item C<platform_desc($platform)>

Return a string which describes a particular platform.  Same as in TeX
Live 2007 but NetBSD added.

=cut

sub platform_desc {
  my $platform=shift;

  my %platform_name=(
    'alpha-linux'    => 'DEC Alpha with GNU/Linux',
    'alphaev5-osf'   => 'DEC Alphaev5 OSF',
    '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'   => 'Intel x86_64 with GNU/Linux'
      );

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

=pod

=item C<win32>

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

=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<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, $netarchsref, $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<$netarchrefs> is a reference to a list of arch/os combination which should
be installed from the network.

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,$netarchs,$opt_src,$opt_doc) = @_;
  my $container_src_split = $fromtlpdb->config_src_container;
  my $container_doc_split = $fromtlpdb->config_doc_container;
  foreach my $package (@$what) {
    tllog($::LOG_NORMAL, "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 $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'});
    # 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 && $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 (!$opt_doc) {
      $tlpobj->clear_docfiles;
    }
    $totlpdb->add_tlpobj($tlpobj);
  }
  $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 {
  sub mysystem {
    my $cmd = shift;
    # print "DEBUG: $cmd\n";
    system("$cmd");
  }
  my ($what, $filelistref, $target, $platform) = @_;
  my $buffer;
  my $offset;
  my $blocksize=2048;

  $blocksize=4096 if ($::_media_ eq 'NET');

  my @filelist = @$filelistref;

  my $bindir  = "$::installerdir/tlpkg/installer";
  # unix defaults
  my $wget    = "wget";
  my $lzmadec = "$bindir/lzmadec.$::_platform_";
  my $tar     = "tar";
  if (win32()) {
    $wget    = conv_to_win_path("$bindir/wget.exe");
    #$tar     = conv_to_win_path("$bindir/bsdtar.exe");
    # try Akira's tar.exe
    $tar     = conv_to_win_path("$bindir/tar.exe");
    $lzmadec = conv_to_win_path("$lzmadec");
    $target =~ s!/!\\!g;
  }
  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,http://|ftp://,) {
    # we are installing from the NET
    # currently the list of file @filelist is NOT EVALUATED!!!
    if (win32()) {
      # we need temporary files here
      # tmpdir is $target/temp
      my $fn = basename($what);
      my $tarfile = $fn;
      $tarfile =~ s/\.lzma$//;
      mkdirhier("$target/temp");
      tllog($::LOG_DEBUG, "Downloading $what to $target\\temp\\$fn\n");
      tllog($::LOG_DEBUG, `$wget --tries=2 --timeout=60 -q -O \"$target\\temp\\$fn\" \"$what\" 2>\&1`);
      tllog($::LOG_DEBUG, "Un-lzmaing $target\\temp\\$fn to $target\\temp\\$tarfile\n");
      #tllog($::LOG_DEBUG, `type \"$target\\temp\\$fn\" | $lzmadec > \"$target\\temp\\$tarfile\" 2>&1`);
      tllog($::LOG_DEBUG, `$lzmadec < \"$target\\temp\\$fn\" > \"$target\\temp\\$tarfile\" 2>&1`);
      tllog($::LOG_DEBUG, "Unpacking temp\\$tarfile\n");
      tllog($::LOG_DEBUG, `pushd \"$target\" & $tar -xf \"temp\\$tarfile\" 2>&1`);
      unlink("$target/temp/$tarfile", "$target/temp/$fn");
    } else {
      tllog($::LOG_DEBUG, "downloading/unlzma-ing/unpacking $what\n");
      tllog($::LOG_NORMAL, `$wget --tries=2 --timeout=60 -q -O- \"$what\"|\"$lzmadec\"|$tar -xf - -C \"$target\"`);
    }
  } elsif ($what =~ m,\.tar.lzma$,) {
    if (win32()) {
      my $fn = basename($what);
      my $tarfile = $fn;
      $tarfile =~ s/\.lzma$//;
      mkdirhier("$target/temp");
      tllog($::LOG_DEBUG, "Un-lzmaing $what to $target\\temp\\$tarfile\n");
      tllog($::LOG_DEBUG, `$lzmadec < \"$what\" > \"$target\\temp\\$tarfile\" 2>&1`);
      tllog($::LOG_DEBUG, "Unpacking temp\\$tarfile\n");
      tllog($::LOG_DEBUG, `pushd \"$target\" & $tar -xf \"temp\\$tarfile\" 2>&1`);
      unlink("$target/temp/$tarfile");
    } else {
      tllog($::LOG_DEBUG, "downloading/unlzma-ing/unpacking $what\n");
      tllog($::LOG_DEBUG, `cat \"$what\"|\"$lzmadec\"|$tar -xf - -C \"$target\" 2>&1`);
    }
  } else {
    die "Don't know how to install $what!\n";
  }
}


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.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 warn "Can't open '$package': $!\n"
        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="$::texlive_url/$::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;
}

=pod

=item C<architectures_available>

The function C<architectures_available> returns a list of
supported platforms.

=cut

sub architectures_available {
  my @dir;
  my @platforms;
	if (&media eq "CD") {
    opendir DIR, "$::installerdir/$::diskarchive";
    @dir=readdir DIR;
    chomp @dir;
    for (@dir) {
      if ((/bin-kpathsea\.(.*)\.tar\.lzma$/) or (/bin-kpathsea\.(.*)\.zip$/)) {
        push(@platforms, $1) unless (($1 eq 'doc') || ($1 eq 'source'));
      }
    }
  } elsif (&media eq "DVD") {
    opendir DIR, "$::installerdir/bin";
    @dir=readdir DIR;
    chomp @dir;
    for my $platform (@dir) {
      push @platforms, $platform unless ($platform=~/^\./);
    }
  } else {
    foreach my $arch ($::tlpdb->available_architectures) {
      push @platforms, $arch;
    }
  }
  return @platforms;
}

=pod

=item C<additional_architectures_available_from_net (\%vars)>

The function C<additional_architectures_available_from_net> returns a
list of additional platforms supported by the TeX Live server.  It
downloads the file C<$::texlive_url/$::netarchive/texlive.pkgver> and
creates a new object c<$::tlpdb_netbin>.  The argument is a reference of
the global C<%vars> hash.

=cut

sub additional_architectures_available_from_net {
  my $vars=shift;
  my @platforms;
  my $database="$::texlive_url/$::netarchive/texlive.pkgver";

  tllog($::LOG_NORMAL, "Loading '$database' ...\n");
  my $wget = "wget";
  if (win32()) {
    $wget = conv_to_win_path("$::installerdir/tlpkg/bin/wget.exe");
  }
  open(WGET, "$wget -q --output-document=- $database|") or
    tllog($::LOG_NORMAL, "Cannot load list of available archs from the net!\n");
  while (<WGET>) {
    chop;
    my $line=$_;
    push @::pkgverlines,$line;
    next unless /\s+-1$/;
    ($platform, undef)=split " ", $line;
    unless (defined $vars->{"diskbin_$platform"}) {
      push @platforms, $platform;
    }
  }
  return @platforms;
  close WGET;
}

=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<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
  return 1 if (win32());
  my $texdirparent = dirname($texdir);        # PATH/texlive
  my $texdirpparent = dirname($texdirparent); # PATH
  if ( (-w $texdirpparent) ||
       ( (-d $texdirparent) && (-w $texdirparent) ) ||
       ( (-d $texdir) && (-w $texdir) ) ) {
    return 1;
  }
  return 0;
}

=pod

=item C<tllog($type, $rest, ...)>

Debugging output is controlled by 2 global variables: $::LOGLEVELTERMINAL
for the output to the terminal, and $::LOGLEVELFILE for the output to
the log file (whose filehandle should be saved in $::LOGFILE).

If the first argument of C<tllog> is less or equal to the respective
threshold the message is issued to STDERR and log file, respectively.

If $::LOGFILE is not defined logging to a log file is completely disabled.

Predefined levels of debugging are: $::LOG_NORMAL, $::LOG_DEBUG, $::LOG_DDEBUG,
and $::LOG_DDDEBUG with increasing level of detailedness.

Note that all TeXLive modules to logging with $::LOG_DDDEBUG!

By default the threshold for logging to the log file is $::LOG_DEBUG, and
the one for the terminal $::LOG_NORMAL.

If you want to disable logging set the respective thershold to $::LOG_ZERO.

=cut

$::LOG_ZERO = -1;
$::LOG_NORMAL = 0;
$::LOG_DEBUG = 1;
$::LOG_DDEBUG = 2;
$::LOG_DDDEBUG = 3;
if (!defined($::LOGLEVELFILE)) {
  $::LOGLEVELFILE = $::LOG_DEBUG;
}
if (!defined($::LOGLEVELTERMINAL)) {
  $::LOGLEVELTERMINAL = $::LOG_NORMAL;
}

sub tllog {
  my ($imp, @rest) = @_;
  if (defined($::LOGFILE)) {
    _tllog($::LOGLEVELFILE,$::LOGFILE,$imp,@rest);
  } else {
    _tllog($::LOGLEVELFILE,\@::LOGLINES,$imp,@rest);
  }
  my $stderr = \*STDERR;
  _tllog($::LOGLEVELTERMINAL,$stderr,$imp,@rest);
}

sub _tllog {
  my ($threshold,$output,$imp, @rest) = @_;
  if ($imp <= $threshold) {
    if (ref($output) eq "GLOB") {
      # we are writing to a file handle
      print $output "@rest";
    } else {
      push @{$output}, "@rest";
    }
  }
}


=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<conv_to_win_path($path)>

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: #