# $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); =head2 Installer Functions TeXLive::TLUtils::media; TeXLive::TLUtils::initialze_installer; TeXLive::TLUtils::binaries_available_from_disk; TeXLive::TLUtils::binaries_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 Cwd; use File::Path; 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 © &media &initialize_installer &binaries_available_from_disk &binaries_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 the directory C doesn't exist we know that we're on Windows and we set the global variable C<$::_platform_> to C. If it exists 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 (-d "/usr/bin") { 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"; } else { $::_platform_="win32"; } } 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. These directories are created with mode C<0755>. Because the files are copied from a read-only media with all write permissions removed, the write flag is set for the current user, quite similar to chmod u+w $target_dir/`basename $file` =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; @stat=lstat "$infile"; $mode=$stat[2]; # set write bit for user if necessary. #$mode+=128 if ($mode%256<128); mkdirhier ("$destdir") unless -d "$destdir"; $filename=basename "$infile"; $outfile="$destdir/$filename"; # print "copy $infile => $outfile\n"; # print "$infile\n"; if (-l "$infile") { symlink readlink "$infile", "$destdir/$filename"; } else { sysopen IN, "$infile", O_RDONLY or die "Can't open '$infile': $!\n"; binmode IN; sysopen OUT, "$outfile", (O_CREAT|O_WRONLY) 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; utime $stat[8], $stat[9], "$outfile"; } } =pod =back =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_>. Repeatedly calls to C or C do not access the CD/DVD again. =cut sub initialize_installer { ($::_installerdir_=$0)=~s/(.*)\/.*$/$1/; &media; &platform; } =pod =item C The function C returns a list of supported platforms. Media type has to be either C or C. =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_/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 my $platform (@dir) { push @platforms, $platform unless ($platform=~/^\./); } } else { die "Media type must be CD or DVD.\n"; } return @platforms; } =pod =item C The function C returns a list of platforms supported by the TeXLive server. It downloads the file C<$::texlive_url/texlive.tlpdb> and looks for files C. =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 () { if (/^ bin\/(.*)\/kpsewhich/) { push @platforms, $1; } } return @platforms; } =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/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: #