# $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; =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::architectures_available; TeXLive::TLUtils::additional_architectures_available_from_net; 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,@list); 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::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 &architectures_available &additional_architectures_available_from_net &make_var_skeleton &sub make_local_skeleton &create_fmtutil &create_updmap &create_language &sort_uniq &push_uniq &member &kpsewhich "ewords ); @EXPORT = qw(tllog); } use TeXLive::TLConfig qw($DefaultContainerExtension); =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<$netarchrefs> is a reference to a list of arch/os combination which should be installed from the network. 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,$netarchs,$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 { # ok, it could be a binary package which should be installed from # the net my $donefromnet = 0; foreach my $a (@$netarchs) { if ($package =~ m/\.$a$/) { # ok this is a binary we should install from the net $container = "$::texlive_url/$::netarchive/$package.$DefaultContainerExtension"; $donefromnet = 1; last; } } if (!$donefromnet) { # 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 = "$::texlive_url/$::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); } $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 { sub mysystem { my $cmd = shift; # print "DEBUG: $cmd\n"; system("$cmd"); } my ($what, $filelistref, $target, $platform) = @_; my $buffer; my $offset; my $blocksize=2048; $blocksize=4096 if ($::_media_ eq 'NET'); my @filelist = @$filelistref; my $bindir = "$::installerdir/tlpkg/installer"; # unix defaults my $wget = "wget"; my $lzmadec = "$bindir/lzmadec.$::_platform_"; my $tar = "tar"; if (win32()) { $wget = conv_to_win_path("$bindir/wget.exe"); $tar = conv_to_win_path("$bindir/bsdtar.exe"); $lzmadec = conv_to_win_path("$lzmadec"); $target =~ s!/!\\!g; } 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,http://|ftp://,) { # we are installing from the NET # currently the list of file @filelist is NOT EVALUATED!!! if (win32()) { # we need temporary files here # tmpdir is $target/temp my $fn = basename($what); my $tarfile = $fn; $tarfile =~ s/\.lzma$//; mkdirhier("$target/temp"); tllog($::LOG_DEBUG, "Downloading $what to $target\\temp\\$fn\n"); tllog($::LOG_DEBUG, `$wget -q -O \"$target\\temp\\$fn\" \"$what\" 2>\&1`); tllog($::LOG_DEBUG, "Un-lzmaing $target\\temp\\$fn to $target\\temp\\$tarfile\n"); #tllog($::LOG_DEBUG, `type \"$target\\temp\\$fn\" | $lzmadec > \"$target\\temp\\$tarfile\" 2>&1`); tllog($::LOG_DEBUG, `$lzmadec < \"$target\\temp\\$fn\" > \"$target\\temp\\$tarfile\" 2>&1`); tllog($::LOG_DEBUG, "Unpacking temp\\$tarfile\n"); tllog($::LOG_DEBUG, `pushd \"$target\" & $tar -xf \"temp\\$tarfile\" 2>&1`); unlink("$target/temp/$tarfile", "$target/temp/$fn"); } else { tllog($::LOG_DEBUG, "downloading/unlzma-ing/unpacking $what\n"); tllog($::LOG_NORMAL, `$wget -q -O- \"$what\"|\"$lzmadec\"|$tar -xf - -C \"$target\"`); } } elsif ($what =~ m,\.tar.lzma$,) { if (win32()) { my $fn = basename($what); my $tarfile = $fn; $tarfile =~ s/\.lzma$//; mkdirhier("$target/temp"); tllog($::LOG_DEBUG, "Un-lzmaing $what to $target\\temp\\$tarfile\n"); tllog($::LOG_DEBUG, `$lzmadec < \"$what\" > \"$target\\temp\\$tarfile\" 2>&1`); tllog($::LOG_DEBUG, "Unpacking temp\\$tarfile\n"); tllog($::LOG_DEBUG, `pushd \"$target\" & $tar -xf \"temp\\$tarfile\" 2>&1`); unlink("$target/temp/$tarfile"); } else { tllog($::LOG_DEBUG, "downloading/unlzma-ing/unpacking $what\n"); tllog($::LOG_DEBUG, `cat \"$what\"|\"$lzmadec\"|$tar -xf - -C \"$target\" 2>&1`); } } else { die "Don't know how to install $what!\n"; } } 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="$::texlive_url/$::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; } =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/$::diskarchive"; @dir=readdir DIR; chomp @dir; for (@dir) { if ((/bin-kpathsea\.(.*)\.tar\.lzma$/) or (/bin-kpathsea\.(.*)\.zip$/)) { push(@platforms, $1) unless (($1 eq 'doc') || ($1 eq 'source')); } } } 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_url/$::netarchive/texlive.pkgver> 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_url/$::netarchive/texlive.pkgver"; tllog($::LOG_NORMAL, "Loading '$database' ...\n"); my $wget = "wget"; if (win32()) { $wget = conv_to_win_path("$::installerdir/tlpkg/bin/wget.exe"); } open(WGET, "$wget -q --output-document=- $database|") or tllog($::LOG_NORMAL, "Cannot load list of available archs from the net!\n"); while () { chop; my $line=$_; push @::pkgverlines,$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 =item C =item C =item C These three functions create C, C, and C in 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 could 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 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: #