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

# $Id$
# TeXLive::TLUtils.pm
# common functions for TeX Live Infrastructure
#
# Copyright 2007 Norbert Preining
# This file is licensed under the GNU General Public License version 2
# or any later version.
#
# ideas from Fabrice Popineau's FileUtils.pm.

package TeXLive::TLUtils;

=pod

=head1 NAME

C<TeXLive::TLUtils> -- Utilities used in the TeX Live Infrastructure Modules

=head1 SYNOPSIS

  use TeXLive::TLUtils;

  TeXLive::TLUtils::sort_uniq(@list);
  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

=cut

use File::Basename;

BEGIN {
  use Exporter ();
  use Cwd;
  use File::Path;
  use vars qw( @ISA @EXPORT_OK );
  @ISA = qw(Exporter);
  @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.

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

=cut

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>, 
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

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