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.


package TeXLive::TLUtils;
use Fcntl; # required by copy()

=pod

=head1 NAME

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

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

=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);

=head2 Miscellaneous

  TeXLive::TLUtils::sort_uniq(@list);
  TeXLive::TLUtils::push_uniq(\@list, @items);
  TeXLive::TLUtils::member($item, @list);
  TeXLive::TLUtils::debug($string);

=head1 DESCRIPTION

=cut


BEGIN {
  use Exporter ();
  use vars qw( @ISA @EXPORT_OK );
  @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
    &media
    &initialize_installer
    &architectures_available
    &additional_architectures_available_from_net
    &make_var_skeleton
    &sub make_local_skeleton
    &sort_uniq
    &push_uniq
    &member
    &debug
  );
}

=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 {
  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 {
  if ($_[0] =~ m!/!) {  # dirname("foo/bar/baz") -> "foo/bar"
    $_[0] =~ m!(.*)/.*!;
    return $1;
  } else {              # dirname("ignore") -> "."
    return ".";
  }
}


=item C<basename($path)>

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

=cut

sub basename {
  if ($_[0] =~ m!/!) {  # basename("foo/bar") -> "bar"
    $_[0] =~ m!.*/(.*)!;
    return $1;
  } else {              # basename("ignore") -> "ignore"
    return $_[0];
  }
}


=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 {
   $_[0]=~/(.*)\/(.*)/;
   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;

  @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 {
    sysopen IN, "$infile", O_RDONLY
        or die "Can't open '$infile': $!\n";
    binmode IN;
    
    $mode=(-x "$infile")? oct("0777"):oct("0666");
    $mode-=umask;
    
    sysopen OUT, "$outfile", (O_CREAT|O_WRONLY), $mode
        or die "Can't open '$outfile': $!\n";
    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;
    @stat=lstat "$infile";
    utime $stat[8], $stat[9], "$outfile";
  }
}

=pod

=back

=cut


sub install_package {
# 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;
  my $blocksize=2048;

  if (win32) {
    my $lzmadec="$bindir/lzma.exe -si -so";
    my $tar="$bindir/tar.exe -xf - -C";
    my $wget="$bindir/wget.exe -nv -O-";
  } else {
    my $lzmadec="$bindir/lzmadec_$platform";
    my $tar="/bin/tar -xf - -C";
    my $wget="wget -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/archive/$what[0]";
    sysopen IN, "$package", O_RDONLY
        or die "Can't open '$infile': $!\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/archive/$what[0]";
    system "$wget $package|$lzmadec|$tar $target";
  } else {
    die "This can't happen.";
  }
}

=pod

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

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

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 {
#  my $me=$0;
#  $me=~s!\\!/!g if $^O=~/^MSWin(32|64)$/i;
#  ($::installerdir=$me)=~s!(.*)/.*$!$1!;
  &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/archive";
    @dir=readdir DIR;
    chomp @dir;
    for (@dir) {
      if (/bin-kpathsea.(.*).zip$/) {
        push @platforms, $1;
      }
    }
  } 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_db_url/texlive.tlpdb> 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_db_url/texlive.pkgver";

  print "\nLoading '$database' ...\n";
  open WGET, "wget -nv --output-document=- $database|"; 
  while (<WGET>) {
    chop;
    my $line=$_;
    next unless /-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/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

=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<debug($string, ...)>

The C<debug> function echos the argument strings to STDERR if
the global variable C<opt_debug> is set.

=cut

sub debug {
  print STDERR "tldbg: @_\n" if $::opt_debug;
}

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