# $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 -- 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 © &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 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. Otherwise we call C. The output of C is filtered as described below. CPU type is determined by a regexp. And it's necessary to C. For OS we need a list because we probably have something like C but we need C. 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 repeatedly, only the first call of C 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 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 Return C<1> if platform is Windows and C<0> otherwise. =cut sub win32 { return (&platform eq "win32")? 1:0; } =pod =item C 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 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 C does the same as the UNIX command C, but it is supposed to work on Windows too. On Windows we have to try all the extensions given in the C 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 Return C<1> if C<$program> is in C and C<0> otherwise. =cut sub program_exists { my $program=shift; return (&which ("$program"))? 0:1; } =pod =item C Evaluate the environment variables C, C, and C 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 Return C<$path> with its trailing C removed. =cut sub dirname { if ($_[0] =~ m!/!) { # dirname("foo/bar/baz") -> "foo/bar" $_[0] =~ m!(.*)/.*!; return $1; } else { # dirname("ignore") -> "." return "."; } } =item C 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 Return both C and C. Example: ($dirpart,$filepart) = dirname_and_basename ($path); =cut sub dirname_and_basename { $_[0]=~/(.*)\/(.*)/; return ("$1", "$2"); } =pod =item C The function C does the same as the UNIX command C. 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 C<$file> to directory C<$target_dir>. No external programs are involved. Since we need C, the Perl module C is required. The time stamps are preserved and symlinks are created on UNIX systems. On Windows, C<(-l $file)> will certainly never return 'C' and symlinks will be copied as regular files. C invokes C if target directories do not exist. Files have mode C<0777>-I if they are executable and C<0666>-I 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; # shouldn't it be 4096 my $blocksize=2048; #my $lzmadec="$bindir/lzmadec_$platform"; my $lzmadec="lzcat"; 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/archive/$what[0]"; sysopen IN, "$package", O_RDONLY or warn "Can't open '$infile': $!\n"; #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 Return media type. Either C, C, or C. The result is stored in a global variable C<$::_media_>. If you call C repeatedly, only the first call of C 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 The function C first determines the directory in which tl-install.pl resides (which is C<`dirname $0`> on UNIX). Then it calls C and C 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 or C 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 The function C 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$/) || (/bin-kpathsea.(.*).tar.lzma$/)) { 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 The function C 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 () { 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 Generate a skeleton of empty directories in the C 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 Generate a skeleton of empty directories in the C 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. =over 6 =item C The C 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 The C 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 The C 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 The C function echos the argument strings to STDERR if the global variable C is set. =cut sub debug { print STDERR "tldbg: @_\n" if $::opt_debug; } =pod =back =head1 SEE ALSO The modules L, L, L, L, and the document L 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) 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: #