# $Id$ # The inevitable utilities for TeX Live. # # Copyright 2007 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 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::download_file( $path, $destination [, $progs ] ); TeXLive::TLUtils::setup_programs( $bindir, $platform); =head2 Installer Functions TeXLive::TLUtils::media; TeXLive::TLUtils::initialze_installer; 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($tlpdb,$dest,$localconf); TeXLive::TLUtils::install_packages($from_tlpdb,$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::tllog($level, $string); TeXLive::TLUtils::texdir_check($texdir); TeXLive::TLUtils::kpsewhich; TeXLive::TLUtils::conv_to_win_path($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 &mkdirhier © &install_package &install_packages &media &initialize_installer &make_var_skeleton &sub make_local_skeleton &create_fmtutil &create_updmap &create_language &sort_uniq &push_uniq &texdir_check &member &kpsewhich "ewords &conv_to_win_path &setup_programs &download_file ); @EXPORT = qw(tllog setup_programs download_file); } use TeXLive::TLConfig; =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 { 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 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 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 { 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,$totlpdb,$what,$opt_src,$opt_doc) = @_; my $container_src_split = $fromtlpdb->config_src_container; my $container_doc_split = $fromtlpdb->config_doc_container; foreach my $package (@$what) { tllog($::LOG_NORMAL, "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 $container; my @installfiles; push @installfiles, $tlpobj->runfiles; push @installfiles, $tlpobj->allbinfiles; push @installfiles, $tlpobj->srcfiles if ($opt_src); push @installfiles, $tlpobj->docfiles if ($opt_doc); if (&media eq 'DVD') { $container = \@installfiles; } elsif (&media eq 'CD') { if (-r "$::installerdir/$DiskArchive/$package.zip") { $container = "$::installerdir/$DiskArchive/$package.zip"; } elsif (-r "$::installerdir/$DiskArchive/$package.tar.lzma") { $container = "$::installerdir/$DiskArchive/$package.tar.lzma"; } else { # for now only warn and return, should (?) be die!? warn "Cannot find a package $package (.zip or .lzma) in $::installerdir/$DiskArchive\n"; next; } } elsif (&media eq 'NET') { $container = "$TeXLiveURL/$NetArchive/$package.$DefaultContainerExtension"; } install_package($container,\@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,\@installfiles,$totlpdb->root,$vars{'this_platform'}); } if ($container_doc_split && $opt_doc && ($package !~ m/\./) && $tlpobj->docfiles) { my $doccontainer = $container; $doccontainer =~ s/(.tar.lzma|.zip)$/.doc$1/; install_package($doccontainer,\@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 (!$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>. 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) 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, $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 foreach my $file (@$what) { # @what is taken, not @filelist! # is this still needed? my $dn=dirname($file); mkdirhier("$target/$dn"); copy "$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\""; 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)) { die "Downloading $what did not succeed, please retry!"; } } else { # we are installing from CD # copy it to temp copy($what, "$target/temp"); } tllog($::LOG_DEBUG, "Un-lzmaing $lzmafile to $tarfile\n"); system("$lzmadec < $lzmafile_quote > $tarfile_quote"); if (! -f $tarfile) { die "Unpacking $lzmafile did not succeed, please retry!"; } tllog($::LOG_DEBUG, "Unpacking $tarfile\n"); system($tar,"-x","-C",$target,"-f",$tarfile); unlink($tarfile, $lzmafile); } else { die "Don't know how to install $what!\n"; } } =pod =item C Sets up the global $::progs hash containing the pathes 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 extension for the C binary. =cut sub setup_programs { my ($bindir, $platform) = @_; $::progs{'wget'} = "wget"; $::progs{'lzmadec'} = "$bindir/lzmadec.$platform"; $::progs{'tar'} = "tar"; if (win32()) { $::progs{'wget'} = conv_to_win_path("$bindir/wget.exe"); $::progs{'tar'} = conv_to_win_path("$bindir/tar.exe"); $::progs{'lzmadec'} = conv_to_win_path($::progs{'lzmadec'}); } } =pod =item C Try to download the file given in C<$relpath> from either C<$TeXLiveURL> or C 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 { warn ("Programs have not been set up, trying simply wget"); $wget = "wget"; } my $url; if ($relpath =~ /^(http|ftp):\/\//) { $url = $relpath; } else { $url = "$TeXLiveURL/$relpath"; } my $ret = _download_file($url, $dest, $wget); return($ret) if $ret; # if we have a full url given do NOT try an alternative url if ($relpath =~ /^(http|ftp):\/\//) { # we did get a full url, give up immediately return undef; } # we are still here ... try it with Alternative URL: return undef unless ($TeXLiveAlternativeURL); # we are still here and TeXLiveAlternativeURL is defined $url = "$TeXLiveAlternativeURL/$relpath"; $ret = _download_file($url, $dest, $wget); return($ret) if $ret; # still not found, give up return undef; } 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"; tllog($::LOG_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; tllog($::LOG_DEBUG, "Download $url did succeed\n"); if ($dest eq "|") { return \*RETFH; } else { return 1; } } sub install_package_old { # 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="lzmadec"; 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/$DiskArchive/$what[0]"; open IN, "$package", or warn "Can't open '$package': $!\n" or die "Can't open '$package': $!\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="$TeXLiveURL/$NetArchive/$what[0]"; system "$wget $package|$lzmadec|$tar $target"; } else { die "This can't happen."; } } =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/$DiskArchive") { $::_media_='CD'; } elsif (-d "$::installerdir/texmf/web2c") { $::_media_='DVD'; } else { $::_media_='NET'; } } return $::_media_; } =pod =item C The function C 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 { &media; &platform; $ENV{'WGETRC'}="$::installerdir/tlpkg/installer/wgetrc" } =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 =item C =item C =item C These three functions create 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 $root = $tlpdb->root; my @lines = $tlpdb->fmtutil_cnf_lines; 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 ($#lines >= 0) { open(OUTFILE,">$dest") or die("Cannot open $dest for writing: $!"); printf OUTFILE "# Generated by %s on %s\n", "$0", scalar localtime; print OUTFILE @lines; close(OUTFILE) || warn "close(>$dest) failed: $!"; } } sub create_updmap { my ($tlpdb,$dest,$localconf) = @_; my $root = $tlpdb->root; my @lines = $tlpdb->updmap_cfg_lines; 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 ($#lines >= 0) { open(OUTFILE,">$dest") or die("Cannot open $dest for writing: $!"); printf OUTFILE "# Generated by %s on %s\n", "$0", scalar localtime; print OUTFILE @lines; close(OUTFILE) || warn "close(>$dest) failed: $!"; } } sub create_language { my ($tlpdb,$dest,$localconf) = @_; my $root = $tlpdb->root; my @lines = $tlpdb->language_dat_lines; 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 ($#lines >= 0) { open(OUTFILE,">$dest") or die("Cannot open $dest for writing: $!"); 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 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 (win32()) { if ( (TeXLive::TLWinGoo::dir_writable($texdirpparent)) || ( (-d $texdirparent) && (TeXLive::TLWinGoo::dir_writable($texdirparent)) ) || ( (-d $texdir) && (TeXLive::TLWinGoo::dir_writable($texdir)) ) ) { return 1; } } else { if ( (-w $texdirpparent) || ( (-d $texdirparent) && (-w $texdirparent) ) || ( (-d $texdir) && (-w $texdir) ) ) { return 1; } } return 0; } =pod =item C Debugging output is controlled by 2 global variables: $::LOGLEVELTERMINAL for the output to the terminal, and $::LOGLEVELFILE for the output to the log file (whose filehandle should be saved in $::LOGFILE). If the first argument of C is less or equal to the respective threshold the message is issued to STDERR and log file, respectively. If $::LOGFILE is not defined logging to a log file is completely disabled. Predefined levels of debugging are: $::LOG_NORMAL, $::LOG_DEBUG, $::LOG_DDEBUG, and $::LOG_DDDEBUG with increasing level of detailedness. Note that all TeXLive modules to logging with $::LOG_DDDEBUG! By default the threshold for logging to the log file is $::LOG_DEBUG, and the one for the terminal $::LOG_NORMAL. If you want to disable logging set the respective thershold to $::LOG_ZERO. =cut $::LOG_ZERO = -1; $::LOG_NORMAL = 0; $::LOG_DEBUG = 1; $::LOG_DDEBUG = 2; $::LOG_DDDEBUG = 3; if (!defined($::LOGLEVELFILE)) { $::LOGLEVELFILE = $::LOG_DEBUG; } if (!defined($::LOGLEVELTERMINAL)) { $::LOGLEVELTERMINAL = $::LOG_NORMAL; } sub tllog { my ($imp, @rest) = @_; if (defined($::LOGFILE)) { _tllog($::LOGLEVELFILE,$::LOGFILE,$imp,@rest); } else { _tllog($::LOGLEVELFILE,\@::LOGLINES,$imp,@rest); } my $stderr = \*STDERR; _tllog($::LOGLEVELTERMINAL,$stderr,$imp,@rest); } sub _tllog { my ($threshold,$output,$imp, @rest) = @_; if ($imp <= $threshold) { if (ref($output) eq "GLOB") { # we are writing to a file handle print $output "@rest"; } else { push @{$output}, "@rest"; } } } =pod =item C This function expands the variable name using kpsewhich. The variable name should not have a leading $. The kpsewhich 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 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\\$bindir"; } if ($p =~ m/ /) { $p = "\"$p\""; } return($p); } ############################################# # # 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: #