# $Id$ # The inevitable utilities for TeX Live. # # Copyright 2007, 2008 Norbert Preining, Reinhard Kotucha # This file is licensed under the GNU General Public License version 2 # or any later version. package TeXLive::TLUtils; =pod =head1 NAME C -- 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 Utilities TeXLive::TLUtils::dirname($path); TeXLive::TLUtils::basename($path); TeXLive::TLUtils::dirname_and_basename($path); TeXLive::TLUtils::dir_writable($path); TeXLive::TLUtils::mkdirhier($path); TeXLive::TLUtils::rmtree($root, $verbose, $safe); TeXLive::TLUtils::copy($file, $target_dir); TeXLive::TLUtils::download_file($path, $destination [, $progs ]); TeXLive::TLUtils::setup_programs($bindir, $platform); =head2 Installer Functions 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_dat($tlpdb,$dest,$localconf); TeXLive::TLUtils::create_language_def($tlpdb,$dest,$localconf); TeXLive::TLUtils::install_packages($from_tlpdb,$media,$to_tlpdb,$what,$opt_src, $opt_doc)>); 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::merge_into(\%to, \%from); TeXLive::TLUtils::texdir_check($texdir); TeXLive::TLUtils::kpsewhich; TeXLive::TLUtils::conv_to_win_path($path); TeXLive::TLUtils::give_ctan_mirror($path); TeXLive::TLUtils::tlmd5($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 &dir_writable &mkdirhier &rmtree © &install_package &install_packages &make_var_skeleton &make_local_skeleton &create_fmtutil &create_updmap &create_language_dat &create_language_def &sort_uniq &push_uniq &texdir_check &member &kpsewhich "ewords &conv_to_win_path &setup_programs &download_file &merge_into &process_logging_options &welcome &welcome_paths &give_ctan_mirror &tlmd5 ); @EXPORT = qw(setup_programs download_file info log debug ddebug tlwarn process_logging_options win32); } use TeXLive::TLConfig; use Getopt::Long; use Digest::MD5; $::opt_verbosity = 0; =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 { unless (defined $::_platform_) { if ($^O=~/^MSWin(32|64)$/i) { $::_platform_="win32"; } else { my $config_guess="$::installerdir/tlpkg/installer/config.guess"; my @OSs=qw(aix cygwin darwin freebsd hpux irix linux netbsd openbsd solaris); 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 $config_guess`; chomp $guessed_platform; $guessed_platform=~s/^x86_64-(.*)-freebsd/amd64-$1-freebsd/; ($CPU=$guessed_platform)=~s/(.*?)-.*/$1/; $CPU =~ s/^alpha(.*)/alpha/; foreach my $os (@OSs) { $OS=$os if $guessed_platform=~/$os/; } if ($OS eq "darwin") { $CPU = "universal"; # TL provides universal binaries } elsif ($CPU=~/^i.86$/) { $CPU=~s/i.86/i386/; } unless (defined $OS) { ($OS=$guessed_platform)=~s/.*-(.*)/$1/; } $::_platform_="$CPU-$OS"; } } return $::_platform_; } =pod =item C Return a string which describes a particular platform identifier, e.g., given C we return C. =cut sub platform_desc { my ($platform) = @_; my %platform_name=( 'alpha-linux' => 'DEC Alpha with GNU/Linux', 'alphaev5-osf' => 'DEC Alphaev5 OSF', 'amd64-freebsd' => 'x86_64 with FreeBSD', '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', 'universal-darwin' => 'universal binaries for MacOSX/Darwin', 'win32' => 'Windows', 'x86_64-linux' => 'x86_64 with GNU/Linux' ); # the inconsistency between amd64-freebsd and x86_64-linux is # unfortunate (it's the same hardware), but the os people say those # are the conventional names on the respective os's, so ... if (exists $platform_name{$platform}) { return "$platform_name{$platform}"; } else { my ($CPU,$OS) = split ('-', $platform); return "$CPU with " . ucfirst "$OS"; } } =pod =item C Return C<1> if platform is Windows and C<0> otherwise. The test is currently based on the value of Perl's C<$^O> variable. =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 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 { 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 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 Return both C and C. 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 Tests whether its argument is writable by trying to write to it. This function is necessary because the built-in C<-w> test just looks at mode and uid/guid, which on Windows always returns true and even on Unix is not always good enough for directories mounted from a fileserver. =cut # Theoretically, the test below, which uses numbers as names, might # lead to a race condition. OTOH, it should work even on a very # broken Perl. # The Unix test gives the wrong answer when used under Windows Vista # with one of the `virtualized' directories such as Program Files: # lacking administrative permissions, it would write successfully to # the virtualized Program Files rather than fail to write to the # real Program Files. Ugh. sub dir_writable { $path=shift; return 0 unless -d $path; $path =~ s!\\!/!g if win32; $path =~ s!/$!!g; my $i = 0; while (-e $path . "/" . $i) { $i++; } my $f = $path."/".$i; if (win32) { my $fb = $f; $fb =~ s!/!\\!g; return 0 if system('copy /b ' . $ENV{'COMSPEC'} . ' "' . $fb . '" >nul 2>&1'); unlink $f if -e $f; return 1; } else { return 0 unless open TEST, ">".$f; my $written = 0; $written = (print TEST "\n"); close TEST; unlink $f; return $written; } } =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; 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 The C function provides a convenient way to delete a subtree from the directory structure, much like the Unix command C. C takes three arguments: =over 4 =item * the root of the subtree to delete, or a reference to a list of roots. All of the files and directories below each root, as well as the roots themselves, will be deleted. =item * a boolean value, which if TRUE will cause C to print a message each time it examines a file, giving the name of the file, and indicating whether it's using C or C to remove it, or that it's skipping it. (defaults to FALSE) =item * a boolean value, which if TRUE will cause C to skip any files to which you do not have delete access (if running under VMS) or write access (if running under another OS). This will change in the future when a criterion for 'delete permission' under OSs other than VMS is settled. (defaults to FALSE) =back It returns the number of files successfully deleted. Symlinks are simply deleted and not followed. B There are race conditions internal to the implementation of C making it unsafe to use on directory trees which may be altered or moved while C is running, and in particular on any directory trees with any path components or subdirectories potentially writable by untrusted users. Additionally, if the third parameter is not TRUE and C is interrupted, it may leave files and directories with permissions altered to allow deletion (and older versions of this module would even set files and directories to world-read/writable!) Note also that the occurrence of errors in C can be determined I by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent from the return value. =cut #taken from File/Path.pm # my $Is_VMS = $^O eq 'VMS'; my $Is_MacOS = $^O eq 'MacOS'; # These OSes complain if you want to remove a file that you have no # write permission to: my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); sub rmtree { my($roots, $verbose, $safe) = @_; my(@files); my($count) = 0; $verbose ||= 0; $safe ||= 0; if ( defined($roots) && length($roots) ) { $roots = [$roots] unless ref $roots; } else { warn "No root path(s) specified"; return 0; } my($root); foreach $root (@{$roots}) { if ($Is_MacOS) { $root = ":$root" if $root !~ /:/; $root =~ s#([^:])\z#$1:#; } else { $root =~ s#/\z##; } (undef, undef, my $rp) = lstat $root or next; $rp &= 07777; # don't forget setuid, setgid, sticky bits if ( -d _ ) { # notabene: 0700 is for making readable in the first place, # it's also intended to change it to writable in case we have # to recurse in which case we are better than rm -rf for # subtrees with strange permissions chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) or warn "Can't make directory $root read+writeable: $!" unless $safe; if (opendir my $d, $root) { no strict 'refs'; if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { # Blindly untaint dir names @files = map { /^(.*)$/s ; $1 } readdir $d; } else { @files = readdir $d; } closedir $d; } else { warn "Can't read $root: $!"; @files = (); } # Deleting large numbers of files from VMS Files-11 filesystems # is faster if done in reverse ASCIIbetical order @files = reverse @files if $Is_VMS; ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; if ($Is_MacOS) { @files = map("$root$_", @files); } else { @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); } $count += rmtree(\@files,$verbose,$safe); if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { print "skipped $root\n" if $verbose; next; } chmod $rp | 0700, $root or warn "Can't make directory $root writeable: $!" if $force_writeable; print "rmdir $root\n" if $verbose; if (rmdir $root) { ++$count; } else { warn "Can't remove directory $root: $!"; chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) or warn("and can't restore permissions to " . sprintf("0%o",$rp) . "\n"); } } else { if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !(-l $root || -w $root))) { print "skipped $root\n" if $verbose; next; } chmod $rp | 0600, $root or warn "Can't make file $root writeable: $!" if $force_writeable; print "unlink $root\n" if $verbose; # delete all versions under VMS for (;;) { unless (unlink $root) { warn "Can't unlink file $root: $!"; if ($force_writeable) { chmod $rp, $root or warn("and can't restore permissions to " . sprintf("0%o",$rp) . "\n"); } last; } ++$count; last unless $Is_VMS && lstat $root; } } } $count; } =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. Note that C will work with file:/ prefixes, too. =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"; $infile =~ s!^file://*!/!i; $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 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<$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,$media,$totlpdb,$what,$opt_src,$opt_doc) = @_; my $container_src_split = $fromtlpdb->config_src_container; my $container_doc_split = $fromtlpdb->config_doc_container; my $root = $fromtlpdb->root; foreach my $package (@$what) { info("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 $real_opt_doc = $opt_doc; # if we install a package from the Documentation class we # reactivate the do_doc in any case. It should apply ONLY for fonts # and macros! if ($tlpobj->category =~ m/documentation/i) { $real_opt_doc = 1; } my $container; my @installfiles; push @installfiles, $tlpobj->runfiles; push @installfiles, $tlpobj->allbinfiles; push @installfiles, $tlpobj->srcfiles if ($opt_src); push @installfiles, $tlpobj->docfiles if ($real_opt_doc); if ($media eq 'DVD') { $container = [ $root, @installfiles ]; } elsif ($media eq 'CD') { if (-r "$root/$Archive/$package.zip") { $container = "$root/$Archive/$package.zip"; } elsif (-r "$root/$Archive/$package.tar.lzma") { $container = "$root/$Archive/$package.tar.lzma"; } else { # for now only warn and return, should (?) be die!? tlwarn("Cannot find a package $package (.zip or .lzma) in $root/$Archive\n"); next; } } elsif ($media eq 'NET') { $container = "$root/$Archive/$package.$DefaultContainerExtension"; } install_package($container, $tlpobj->containersize, $tlpobj->containermd5, \@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, $tlpobj->srccontainersize, $tlpobj->srccontainermd5, \@installfiles,$totlpdb->root,$vars{'this_platform'}); } if ($container_doc_split && $real_opt_doc && ($package !~ m/\./) && $tlpobj->docfiles) { my $doccontainer = $container; $doccontainer =~ s/(\.tar\.lzma|\.zip)$/.doc$1/; install_package($doccontainer, $tlpobj->doccontainersize, $tlpobj->doccontainermd5, \@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 (!$real_opt_doc) { $tlpobj->clear_docfiles; } $totlpdb->add_tlpobj($tlpobj); # we have to write out the tlpobj file since it is contained in the # archives (.tar.lzma) but at DVD install time we don't have them my $tlpod = $totlpdb->root . "/tlpkg/tlpobj"; mkdirhier( $tlpod ); open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") or die("Cannot open tlpobj file for ".$tlpobj->name); $tlpobj->writeout(\*TMP); close(TMP); } $totlpdb->save; } =pod =item C This function installs the files given in @$filelistref from C<$what> into C<$target>. C<$size> gives the size in bytes of the container, or -1 if we are installing from DVD, i.e., from a list of files to be copied. 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 or C then C<$what> is downloaded from the net and piped through c and C. If $what ends with C<.tar.lzma> (but does not start with C or C, but possibly with C) it is assumed to be a readable file on the system and is piped through C and C 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 { my ($what, $whatsize, $whatmd5, $filelistref, $target, $platform) = @_; my @filelist = @$filelistref; # we assume that $::progs has been set up! my $wget = $::progs{'wget'}; my $lzmadec = $::progs{'lzmadec'}; my $tar = $::progs{'tar'}; if (!defined($wget) || !defined($lzmadec) || !defined($tar)) { die "Programs have not been set up properly, strange!"; } if (ref $what) { # we are getting a ref to a list of files, so install from DVD my ($root, @files) = @$what; foreach my $file (@files) { # @what is taken, not @filelist! # is this still needed? my $dn=dirname($file); mkdirhier("$target/$dn"); copy "$root/$file", "$target/$dn"; } } elsif ($what =~ m,\.tar.lzma$,) { # this is the case when we install from CD or the NET # # in all other cases we create temp files .tar.lzma (or use the present # one), lzmadec them, and then call tar my $fn = basename($what); mkdirhier("$target/temp"); my $lzmafile = "$target/temp/$fn"; my $tarfile = "$target/temp/$fn"; $tarfile =~ s/\.lzma$//; my $lzmafile_quote = $lzmafile; my $tarfile_quote = $tarfile; my $target_quote = $target; if (win32()) { $lzmafile =~ s!/!\\!g; $tarfile =~ s!/!\\!g; $target =~ s!/!\\!g; } $lzmafile_quote = "\"$lzmafile\""; $tarfile_quote = "\"$tarfile\""; $target_quote = "\"$target\""; my $gotfiledone = 0; if (-r $lzmafile) { # check that the downloaded file is not partial if ($whatsize >= 0) { # we have the size given, so check that first my $size = (stat $lzmafile)[7]; if ($size == $whatsize) { # we want to check also the md5sum if we have it present if ($whatmd5) { if (tlmd5($lzmafile) eq $whatmd5) { $gotfiledone = 1; } else { tlwarn("Downloaded file present, size equal, but md5sum differs\nredownloading $what!\n"); } } else { # size ok, no md5sum tlwarn("Downloaded container present, size equal, but no md5sum available. Hope that is fine!\n"); $gotfiledone = 1; } } else { tlwarn("Partial download of $what found, removing it!\n"); unlink($tarfile, $lzmafile); } } else { # ok no size information, hopefully we have md5 sums if ($whatmd5) { if (tlmd5($lzmafile) eq $whatmd5) { $gotfiledone = 1; } else { tlwarn("Downloaded file present, but md5sum differs, removing it!\n"); } } else { tlwarn("container found, but we cannot verify size of md5sum!\nContinuing with it and hope that it is ok!\n"); $gotfiledone = 1; } } debug("Reusing already downloaded container $lzmafile\n") if ($gotfiledone); } if (!$gotfiledone) { if ($what =~ m,http://|ftp://,) { # we are installing from the NET # download the file and put it into temp if (!download_file($what, $lzmafile) || (! -r $lzmafile)) { &main::create_profile("./installation.profile"); tlwarn("Downloading $what did not succeed!\n"); tlwarn("Please retry the install process.\n"); tlwarn("Starting the installer will try to restart the installation!\n"); tlwarn("If that doesn't work you can restart by running the installer with\n"); if (win32()) { tlwarn(" install-tl.bat --profile texlive.profile [other args]\n"); } else { tlwarn(" install-tl --profile texlive.profile [other args]\n"); } die "Downloading $what did not succeed!\n"; } } else { # we are installing from CD # copy it to temp copy($what, "$target/temp"); } } debug("Un-lzmaing $lzmafile to $tarfile\n"); system("$lzmadec < $lzmafile_quote > $tarfile_quote"); if (! -f $tarfile) { die "Unpacking $lzmafile did not succeed, please retry!"; } debug("Unpacking $tarfile\n"); system($tar,"-x","-C",$target,"-f",$tarfile); unlink($tarfile); debug("Keeping $lzmafile for restarting ...\n"); # unlink($lzmafile); } else { die "Don't know how to install $what!\n"; } } =pod =item C Populate the global $::progs hash containing the paths to the programs C, C, C. The C<$bindir> argument specifies the path to the location of the C binaries, the C<$platform> gives the TeX Live platform name, used as the extension on the executables. Returns true if successfull, otherwise false. =cut sub setup_programs { my ($bindir, $platform) = @_; $::progs{'wget'} = "wget"; if (!defined($platform) || ($platform eq "")) { # we assume that we run from the DVD, so we can call platform() and # thus also the config.guess script # but we have to setup $::installerdir because the platform script # relies on it $::installerdir = "$bindir/../.."; $platform = platform(); } $::progs{'lzmadec'} = "$bindir/lzma/lzmadec.$platform"; $::progs{'lzma'} = "$bindir/lzma/lzma.$platform"; $::progs{'tar'} = "tar"; if ($^O =~ /^MSWin(32|64)$/i) { $::progs{'wget'} = conv_to_win_path("$bindir/wget/wget.exe"); $::progs{'tar'} = conv_to_win_path("$bindir/tar.exe"); $::progs{'lzmadec'} = conv_to_win_path("$bindir/lzma/lzmadec.win32.exe"); $::progs{'lzma'} = conv_to_win_path("$bindir/lzma/lzma.exe"); } elsif (-r "$bindir/wget/wget.$platform") { $::progs{'wget'} = "$bindir/wget/wget.$platform"; } # # check that the programs are actually working my $nul = "/dev/null"; $nul = "nul" if ($^O =~ /^MSWin(32|64)$/i); # do not test tar, we rely on the system having a usable one. # The main point is to check the binaries we provide. for my $prog ("lzmadec", "wget") { my $opt = $prog eq "lzmadec" ? "--help" : "--version"; my $ret = system("$::progs{$prog} $opt >$nul 2>$nul"); if ($ret != 0) { warn "TeXLive::TLUtils::setup_programs failed"; # no newline warn "$::progs{$prog} $opt failed (status $ret): $!\n"; warn "Output is:\n"; system ("$::progs{$prog} $opt"); return 0; } } return 1; } =pod =item C Try to download the file given in C<$relpath> from C<$TeXLiveURL> into C<$destination>, which can be either a filename of simply C<|>. In the latter case a file handle is returned. The optional argument C<$progs> is a reference to a hash giving full pathes to the respective programs, at least C. In case that C<$progs> is not given the C<%::progs> is consulted, and if this also does not exist we try "wget". Downloading honors two environment variables C and C. The former overrides C (or what is given in the C<$progs> argument, the latter overrides the default wget arguments given in C<$TeXLive::TLConfig::DefaultWgetArgs>. C must be set up in a way that the place the output should go to is the first argument after the C. Use with care. =cut sub download_file { my ($relpath, $dest, $progs) = @_; my $wget; if (defined($progs) && defined($progs->{'wget'})) { $wget = $progs->{'wget'}; } elsif (defined($::progs{'wget'})) { $wget = $::progs{'wget'}; } else { tlwarn ("Programs have not been set up, trying simply wget"); $wget = "wget"; } my $url; if ($relpath =~ m;^file://*(.*)$;) { my $filetoopen = "/$1"; # $dest is a file name, we have to get the respective dirname if ($dest eq "|") { open(RETFH, "<$filetoopen") or die("Cannot open $filetoopen for reading"); # opening to a pipe always succeeds, so we return immediately return \*RETFH; } else { my $par = dirname ($dest); if (-r $filetoopen) { copy ($filetoopen, $par); return 1; } return 0; } } if ($relpath =~ /^(http|ftp):\/\//) { $url = $relpath; } else { $url = "$TeXLiveURL/$relpath"; } my $ret = _download_file($url, $dest, $wget); return($ret); } sub _download_file { my ($url, $dest, $wgetdefault) = @_; if (win32()) { $dest =~ s!/!\\!g; } my $wget = $ENV{"TL_DOWNLOAD_PROGRAM"} || $wgetdefault; # we set now the args in installer/wgetrc my $wgetargs = $ENV{"TL_DOWNLOAD_ARGS"} || "-q -O"; debug("Trying to download $url\n"); my $ret; if ($dest eq "|") { open(RETFH, "$wget $wgetargs - $url|") or die("Cannot open $url via wget for reading"); # opening to a pipe always succeeds, so we return immediately return \*RETFH; } else { my @wgetargs = split ' ', $wgetargs; $ret = system $wget, @wgetargs, $dest, $url; # we have to reverse the meaning of ret because systems returns # the inverse $ret = ($ret ? 0 : 1); } # return false/undef in case the download did not succeed. return ($ret) unless $ret; debug("Download $url did succeed\n"); if ($dest eq "|") { return \*RETFH; } else { return 1; } } =pod =back =head2 Installer Functions =over 6 =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/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 =item C =item C =item C =item C These four functions create C, C, C, and C 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 @lines = $tlpdb->fmtutil_cnf_lines; _create_config_files ($tlpdb, "texmf/fmtutil/fmtutil-hdr.cnf", $dest, $localconf, 0, '#', \@lines); } sub create_updmap { my ($tlpdb,$dest,$localconf) = @_; my @lines = $tlpdb->updmap_cfg_lines; _create_config_files ($tlpdb, "texmf/web2c/updmap-hdr.cfg", $dest, $localconf, 0, '#', \@lines); } sub create_language_dat { my ($tlpdb,$dest,$localconf) = @_; my @lines = $tlpdb->language_dat_lines; _create_config_files ($tlpdb, "texmf/tex/generic/config/language.us", $dest, $localconf, 0, '%', \@lines); } sub create_language_def { my ($tlpdb,$dest,$localconf) = @_; my @lines = $tlpdb->language_def_lines; my @postlines; push @postlines, "%%% No changes may be made beyond this point.\n"; push @postlines, "\n"; push @postlines, "\\uselanguage {USenglish} %%% This MUST be the last line of the file.\n"; _create_config_files ($tlpdb, "texmf/tex/generic/config/language.us.def", $dest, $localconf, 1, '%', \@lines, @postlines); } sub _create_config_files { my ($tlpdb, $headfile, $dest,$localconf, $keepfirstline, $cc, $tlpdblinesref, @postlines) = @_; my $root = $tlpdb->root; open(INFILE,"<$root/$headfile") or die("Cannot open $root/$headfile"); my @lines = ; push @lines, @$tlpdblinesref; close (INFILE); 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 = ; push @lines, @tmp; } if (@postlines) { push @lines, @postlines; } if ($#lines >= 0) { open(OUTFILE,">$dest") or die("Cannot open $dest for writing: $!"); if (!$keepfirstline) { print OUTFILE $cc; 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. =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 Merges the keys of %from into %to. =cut sub merge_into { my ($to, $from) = @_; foreach my $k (keys %$from) { if (defined($to->{$k})) { push @{$to->{$k}}, @{$from->{$k}}; } else { $to->{$k} = [ @{$from->{$k}} ]; } } } =pod =item C Test whether installation with TEXDIR set to $texdir would succeed due to writing permissions. =cut sub texdir_check { my ($texdir) = shift; # PATH/texlive/2008 my $texdirparent = dirname($texdir); # PATH/texlive my $texdirpparent = dirname($texdirparent); # PATH if ( (dir_writable($texdirpparent)) || ( (-d $texdirparent) && (dir_writable($texdirparent)) ) || ( (-d $texdir) && (dir_writable($texdir)) ) ) { return 1; } return 0; } sub logit { my ($out, $level, @rest) = @_; _logit($out, $level, @rest) unless $::opt_quiet; _logit('file', $level, @rest); } sub _logit { my ($out, $level, @rest) = @_; if ($::opt_verbosity >= $level) { # if $out is a ref/glob to STDOUT or STDERR, print it there if (ref($out) eq "GLOB") { print $out @rest; } else { # we should log it into the logfile, but that might be not initialized # so either print it to the filehandle $::LOGFILE, or push it onto # the to be printed log lines @::LOGLINES if (defined($::LOGFILE)) { print $::LOGFILE @rest; } else { push @::LOGLINES, "@rest"; } } } } =pod =item C Write a normal informational message, the concatenation of the argument strings. The message will be included unless C<-q> was specified. If the log file (see L) is defined, it also writes there. We try to use this sparingly, mainly to give feedback during lengthy operations. =cut sub info { logit(\*STDOUT, 0, @_); } =pod =item C Write a debugging message, the concatenation of the argument strings. The message will be omitted unless C<-v> was specified. If the log file (see L) is defined, it also writes there. =cut sub debug { logit(\*STDOUT, 1, "D:", @_); } =pod =item C Write a deep debugging message, the concatenation of the argument strings. The message will be omitted unless C<-v -v> was specified. If the log file (see L) is defined, it also writes there. This output is extremely voluminous; for example, every line of input when reading the TeX Live Database is reported. It includes everything we ever found useful when debugging. =cut sub ddebug { logit(\*STDOUT, 2, "DD:", @_); } sub log { # warning should always done to stderr and the log file, # independently from the verbosity level my $savequiet = $::opt_quiet; $::opt_quiet = 0; _logit('file', -100, @_); $::opt_quiet = $savequiet; } =pod =item C Write a warning message, the concatenation of the argument strings. This always and unconditionally writes the message to standard error; if the log file (see L) is defined, it also writes there. =cut sub tlwarn { my $savequiet = $::opt_quiet; $::opt_quiet = 0; logit (\*STDERR, -100, @_); $::opt_quiet = $savequiet; } =pod =item C This function handles the common logging options for TeX Live scripts. It should be called before C for any program-specific option handling. For our conventional calling sequence, see (for example) the L script. These are the options handled here: =over 8 =item B<-q> Omit normal informational messages. =item B<-v> Include debugging messages; repeat for maximum debugging, as in C<-v -v>. (C<-vv> does not work, sorry to say.) Further repeats, as in C<-v -v -v>, are accepted but ignored. =item B<-logfile> I Write both all messages (informational, debugging, warnings) to I, in addition to standard output or standard error. In TeX Live, only the installer sets a log file by default, none of other the standard TeX Live scripts use this feature. =back See also the L, L, L, and L functions, which actually write the messages. =cut sub process_logging_options { $::opt_verbosity = 0; $::opt_quiet = 0; my $opt_logfile; # check all the command line options for occurrences of -q and -v # do not report errors my $oldconfig = Getopt::Long::Configure(qw(pass_through permute)); GetOptions("logfile=s" => \$opt_logfile, "v+" => \$::opt_verbosity, "q" => \$::opt_quiet); Getopt::Long::Configure($oldconfig); if ($opt_logfile) { open(TLUTILS_LOGFILE, ">$opt_logfile") || die "open(>$opt_logfile) failed: $!\n"; $::LOGFILE = \*TLUTILS_LOGFILE; $::LOGFILENAME = $opt_logfile; } } =pod =item C This function expands the variable name using C. The variable name should not have a leading $. The C 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 The welcome message. =cut sub welcome { my $welcome=<<"EOF"; See ./index.html for links to documentation. The TeX Live web site (http://tug.org/texlive/) contains any updates and corrections. TeX Live is a joint project of the TeX user groups around the world; please consider supporting it by joining the group best for you. The list of groups is available on the web at http://tug.org/usergroups.html. Welcome to TeX Live! EOF return $welcome; } =pod =item C The same welcome message as above but with hints about C, C, and C. =cut sub welcome_paths { my $welcome=<<"EOF"; See $::vars{'TEXDIR'}/index.html for links to documentation. The TeX Live web site (http://tug.org/texlive/) contains any updates and corrections. TeX Live is a joint project of the TeX user groups around the world; please consider supporting it by joining the group best for you. The list of groups is available on the web at http://tug.org/usergroups.html. Add $::vars{'TEXDIR'}/texmf/doc/man to MANPATH. Add $::vars{'TEXDIR'}/texmf/doc/info to INFOPATH. EOF if ($::vars{'from_dvd'} and !win32()) { $welcome .= <<"EOF"; Set TEXMFCNF to $::vars{'TEXMFSYSVAR'}/web2c. EOF } $welcome .= <<"EOF"; Most importantly, add $::vars{'TEXDIR'}/bin/$::vars{'this_platform'} to your PATH for current and future sessions. Welcome to TeX Live! EOF return $welcome; } =pod 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\\$p"; } if ($p =~ m/ /) { $p = "\"$p\""; } return($p); } sub give_ctan_mirror { my $wget = $::progs{'wget'}; if (!defined ($wget)) { tlwarn ("programs not set up, trying wget\n"); $wget = "wget"; } my $cmd = "$wget $TeXLiveServerURL -O " . (win32() ? "nul" : "/dev/null") . " 2>&1"; my @out = `$cmd`; # now analyze the output my $mirror = $TeXLiveURL; foreach (@out) { if (m/^Location: (\S*)\s*.*$/) { (my $mhost = $1) =~ s,/*$,,; # remove trailing slashes since we add it: $mirror = "$mhost/$TeXLiveServerPath"; last; } } # if we cannot find a mirror, return the default (mirror.ctan.org) itself return $mirror; } sub tlmd5 { my $file = shift; if (-r $file) { open(FILE, $file) or die "Can't open '$file': $!"; binmode(FILE); return Digest::MD5->new->addfile(*FILE)->hexdigest; close(FILE); } else { tlwarn("tlmd5, given file not readable: $file\n"); return ""; } } ############################################# # # 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, 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: #