From 55e469a40abbd1a4407556cfab0a3ef12a18ede8 Mon Sep 17 00:00:00 2001 From: Reinhard Kotucha Date: Fri, 21 Sep 2007 21:13:00 +0000 Subject: TLUtils.pm: File Utilities added. Perl-API.txt: updated. git-svn-id: svn://tug.org/texlive/trunk@4992 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/TeXLive/TLUtils.pm | 647 +++++++++++++++++++++++++--------------- Master/tlpkg/doc/Perl-API.txt | 43 +-- 2 files changed, 434 insertions(+), 256 deletions(-) diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm index e0bbe8f48e6..eb2e87e934e 100644 --- a/Master/tlpkg/TeXLive/TLUtils.pm +++ b/Master/tlpkg/TeXLive/TLUtils.pm @@ -1,14 +1,16 @@ # $Id$ # TeXLive::TLUtils.pm -# common functions for TeX Live Infrastructure +# 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. -# -# ideas from Fabrice Popineau's FileUtils.pm. + package TeXLive::TLUtils; +use Fcntl; # required by copy() + +#use File::Basename; =pod @@ -20,31 +22,48 @@ C -- Utilities used in the TeX Live Infrastructure Modules use TeXLive::TLUtils; - TeXLive::TLUtils::sort_uniq(@list); - TeXLive::TLUtils::push_uniq(\@list, @items); - TeXLive::TLUtils::member($item, @list); - TeXLive::TLUtils::debug($string); - TeXLive::TLUtils::initialze_installer; - TeXLive::TLUtils::getenv($string); - TeXLive::TLUtils::which($string); - TeXLive::TLUtils::media; +=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::binaries_available_from_disk; - TeXLive::TLUtils::binaries_available_from_net; TeXLive::TLUtils::get_system_tmpdir; + +=head2 File Utulities + + TeXLive::TLUtils::dirname($path); + TeXLive::TLUtils::basename($path); + TeXLive::TLUtils::dirname_and_basename($path); TeXLive::TLUtils::mkdirhier($path); + TeXLive::TLUtils::copy($file, $target_dir); + +=head2 Installer Functions + + TeXLive::TLUtils::media; + TeXLive::TLUtils::initialze_installer; + TeXLive::TLUtils::binaries_available_from_disk; + TeXLive::TLUtils::binaries_available_from_net; TeXLive::TLUtils::make_var_skeleton($path); TeXLive::TLUtils::make_local_skeleton($path); +=head2 Miscellaneous + + TeXLive::TLUtils::sort_uniq(@list); + TeXLive::TLUtils::push_uniq(\@list, @items); + TeXLive::TLUtils::member($item, @list); + TeXLive::TLUtils::debug($string); + =head1 DESCRIPTION =cut -use File::Basename; BEGIN { use Exporter (); @@ -53,124 +72,164 @@ BEGIN { use vars qw( @ISA @EXPORT_OK ); @ISA = qw(Exporter); @EXPORT_OK = qw( - &sort_uniq - &push_uniq - &member - &debug - &initialize_installer - &getenv - &which - &media &platform &platform_desc &win32 &unix + &getenv + &which &program_exists - &binaries_available_from_disk - &binaries_available_from_net &get_system_tmpdir + &dirname + &basename + &dirname_and_basename &mkdirhier + © + &media + &initialize_installer + &binaries_available_from_disk + &binaries_available_from_net &make_var_skeleton &sub make_local_skeleton + &sort_uniq + &push_uniq + &member + &debug ); } =pod +=head2 Platform Detection + =over 6 -=item C +=item C -The C function sorts the given array and throws away multiple -occurrences of elements. It returns a sorted and unified array. +If the directory C doesn't exist we know that we're on +Windows and we set the global variable C<$::_platform_> to C. +If it exists we call C. The output of C +is filtered as described below. + +CPU type is determined by a regexp. And it's necessary to +C. + +For OS we need a list because we probably have something like +C but we need C. This list might/should contain OSs +which are not currently supported. The list currently supports all +platforms supported by TeX Live 2007 plus Cygwin. + +If a particular platform is not found in this list we use the regexp +C as a last resort and hope it provides something useful. + +The result is stored in a global variable C<$::_platform_>. If you call +C repeatedly, only the first call of C will access +the HD/CD/DVD. =cut -sub sort_uniq { - my (@l) = @_; - my ($e, $f, @r); - $f = ""; - @l = sort(@l); - foreach $e (@l) { - if ($e ne $f) { - $f = $e; - push @r, $e; +sub platform { + my @OSs=qw(aix cygwin darwin freebsd hpux irix linux netbsd openbsd + solaris); + + unless (defined $::_platform_) { + if (-d "/usr/bin") { + my $CPU; # CPU type as reported by config.guess. + my $OS; # O/S type as reported by config.guess. + my $guessed_platform=`$::_installerdir_/config.guess`; + chomp $guessed_platform; + ($CPU=$guessed_platform)=~s/(.*?)-.*/$1/; + foreach my $os (@OSs) { + $OS=$os if $guessed_platform=~/$os/; + } + if ($OS=~/^i.86$/) { + $OS=~s/i.86/i386/; + } + if (length "$OS" < 0) { + ($OS=$guessed_platform)=~s/.*-(.*)/$1/; + } + $::_platform_="$CPU-$OS"; + } else { + $::_platform_="win32"; } } - return @r; + return $::_platform_; } =pod -=item C +=item C -The C function pushes the last elements on the list referenced -by the first argument. +Return a string which describes a particular platform. Same as in TeX +Live 2007 but NetBSD added. =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; - } +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 +=pod -=item C +=item C -The C function returns true if the the first argument is contained -in the list of the remaining arguments. +Return C<1> if platform is Windows and C<0> otherwise. =cut -sub member { - my ($e, @l) = @_; - my ($f); - foreach $f (@l) { - if ($e eq $f) { - return 1; - } - } - return 0; +sub win32 { + return (&platform eq "win32")? 1:0; } =pod -=item C +=item C -The C function echos the argument string to STDERR in case that -the global varialbe C is set. +Return C<1> if platform is UNIX and C<0> otherwise. =cut -sub debug { - print STDERR @_ if ($::opt_debug); +sub unix { + return (&platform eq "win32")? 0:1; } =pod -=item C - -The function C first determines the directory in -which tl-install.pl resides (which is C<`dirname $0`> on UNIX). Then -it calls C and C in order to set the variables -C<$::_media_> and C<$::_platform_>. - -Repeatedly calls to C or C do not access the CD/DVD -again. +=back -=cut +=head2 System Tools -sub initialize_installer { - ($::_installerdir_=$0)=~s/(.*)\/.*$/$1/; - &media; - &platform; -} +=over 6 =item C @@ -230,161 +289,230 @@ sub which { return 0; } -=pod +=pod -=item C +=item C -Return media type. Either C, C, or C. +Return C<1> if C<$program> is in C and C<0> otherwise. -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 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 media { - unless (defined $::_media_) { - if (-d "$::_installerdir_/archive") { - $::_media_="CD"; - } elsif (-d "$::_installerdir_/texmf/web2c") { - $::_media_="DVD"; - } else { - $::_media_="NET"; - } - } - return $::_media_; +sub get_system_tmpdir { + my $systmp=0; + $systmp||=getenv 'TMPDIR'; + $systmp||=getenv 'TMP'; + $systmp||=getenv 'TEMP'; + $systmp||='/tmp'; + return "$systmp"; } =pod -=item C +=back -If the directory C doesn't exist we know that we're on -Windows and we set the global variable C<$::_platform_> to C. -If it exists we call C. The output of C -is filtered as described below. +=head2 File Utulities -CPU type is determined by a regexp. And it's necessary to -C. +=over 6 -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. +=item C -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. +Return C<$path> with its trailing C removed. =cut -sub platform { - my @OSs=qw(aix cygwin darwin freebsd hpux irix linux netbsd openbsd - solaris); +sub dirname { + $_[0]=~/(.*)\/.*/; + return "$1"; +} - unless (defined $::_platform_) { - if (-d "/usr/bin") { - my $CPU; # CPU type as reported by config.guess. - my $OS; # O/S type as reported by config.guess. - my $guessed_platform=`$::_installerdir_/config.guess`; - chomp $guessed_platform; - ($CPU=$guessed_platform)=~s/(.*?)-.*/$1/; - foreach my $os (@OSs) { - $OS=$os if $guessed_platform=~/$os/; - } - if ($OS=~/^i.86$/) { - $OS=~s/i.86/i386/; - } - if (length "$OS" < 0) { - ($OS=$guessed_platform)=~s/.*-(.*)/$1/; +=item C + +Return C<$path> with any leading directory components removed. + +=cut + +sub basename { + $_[0]=~/.*\/(.*)/; + return "$1"; +} + +=item C + +Return C and C. Example: + + ($dir, $file)=dirname_and_basename($path); + +=cut + +sub dirname_and_basename { + $_[0]=~/(.*)\/(.*)/; + return ("$1", "$2"); +} + +=pod + +=item C + +The function C does the same as the UNIX command C. +The optional parameter sets the permission flags. + +=cut + +sub mkdirhier { + my $tree=shift; + my $mode=shift; + my $subdir; + + @dirs=split /\//, $tree; + foreach $dir (@dirs) { + $subdir .= ("$dir" . "/"); + unless (-d $subdir) { + if (defined $mode) { + mkdir ("$subdir", $mode) or die "Can't mkdir '$subdir': $!.\n"; + } else { + mkdir "$subdir" or die "Can't mkdir '$subdir': $!.\n"; } - $::_platform_="$CPU-$OS"; - } else { - $::_platform_="win32"; } } - return $::_platform_; } =pod -=item C +=item C -Return a string which describes a particular platform. Same as in TeX -Live 2007 but NetBSD added. +Copy file C<$file> to directory C<$target_dir>. No external programs +are involved. Since we need C, the Perl module C +is required. The time stamps are preserved and symlinks are created +on UNIX systems. On Windows, C<(-l $file)> will certainly never +return 'C' and symlinks will be copied as regular files. + +C invokes C if target directories do not exist. +These directories are created with mode C<0755>. Because the files +are copied from a read-only media with all write permissions removed, +the write flag is set for the current user, quite similar to + + chmod u+w $target_dir/`basename $file` =cut -sub platform_desc { - my $platform=shift; +sub copy { + my $infile=shift; + my $destdir=shift; + my $outfile; + my @stat; + my $mode; + my $buffer; + my $offset; + my $filename; + my $dirmode=0755; + my $blocksize=2048; + + @stat=lstat "$infile"; + $mode=$stat[2]; + + # set write bit for user if necessary. + $mode+=128 if ($mode%256<128); - 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' - ); + mkdirhier ("$destdir", $dirmode) unless -d "$destdir"; - if (defined $platform_name{$platform}) { - return "$platform_name{$platform}"; + $filename=basename "$infile"; + $outfile="$destdir/$filename"; + +# print "copy $infile => $outfile\n"; +# print "$infile\n"; + + if (-l "$infile") { + symlink readlink "$infile", "$destdir/$filename"; } else { - my $CPU; - my $OS; - ($CPU, $OS)=split '-', "$platform"; - return "$CPU with " . ucfirst "$OS"; + sysopen IN, "$infile", O_RDONLY + or die "Can't open '$infile': $!\n"; + binmode IN; + + sysopen OUT, "$outfile", (O_CREAT|O_WRONLY) , $mode + or die "Can't open '$outfile': $!\n"; + binmode OUT; + + while ($read=sysread IN, $buffer, $blocksize) { + die "system read error: $!\n" unless defined $read; + $offset=0; + while ($read) { + $written=syswrite OUT, $buffer, $read, $offset; + die "system write error: $!\n" unless defined $written; + $read-=$written; + $offset+=$written; + } + } + close OUT; + close IN; + utime $stat[8], $stat[9], "$outfile"; } } -=pod +=pod -=item C +=back -Return C<1> if platform is Windows and C<0> otherwise. +=head2 Installer Functions -=cut +=over 6 -sub win32 { - return (&platform eq "win32")? 1:0; -} -=item C +=item C -Return C<1> if platform is UNIX and C<0> otherwise. +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 unix { - return (&platform eq "win32")? 0:1; +sub media { + unless (defined $::_media_) { + if (-d "$::_installerdir_/archive") { + $::_media_="CD"; + } elsif (-d "$::_installerdir_/texmf/web2c") { + $::_media_="DVD"; + } else { + $::_media_="NET"; + } + } + return $::_media_; } -=pod +=pod -=item C +=item C -Return C<1> if C<$program> is in C and C<0> otherwise. +The function C first determines the directory in +which tl-install.pl resides (which is C<`dirname $0`> on UNIX). Then +it calls C and C in order to set the variables +C<$::_media_> and C<$::_platform_>. + +Repeatedly calls to C or C do not access the CD/DVD +again. =cut -sub program_exists { - my $program=shift; - return (&which ("$program"))? 0:1; +sub initialize_installer { + ($::_installerdir_=$0)=~s/(.*)\/.*$/$1/; + &media; + &platform; } =pod @@ -449,91 +577,136 @@ sub binaries_available_from_net { =pod -=item C +=item C -Evaluate the environment variables C, C, and C in -order to find the system temporary directory. +Generate a skeleton of empty directories in the C tree. =cut -sub get_system_tmpdir { - my $systmp=0; - $systmp||=getenv 'TMPDIR'; - $systmp||=getenv 'TMP'; - $systmp||=getenv 'TEMP'; - $systmp||='/tmp'; - return "$systmp"; +sub make_var_skeleton { + my $prefix=shift; + my $mode=0777; + + mkdirhier "$prefix/tex/generic/config", $mode; + mkdirhier "$prefix/dvipdfm/config", $mode; + mkdirhier "$prefix/tex/plain/config", $mode; + mkdirhier "$prefix/dvips/config", $mode; + mkdirhier "$prefix/fonts/map/dvipdfm/updmap", $mode; + mkdirhier "$prefix/fonts/map/dvips/updmap", $mode; + mkdirhier "$prefix/fonts/map/pdftex/updmap", $mode; + mkdirhier "$prefix/web2c", $mode; + mkdirhier "$prefix/xdvi", $mode; + mkdirhier "$prefix/tex/context/config", $mode; } =pod -=item C +=item C -The function C does the same as the UNIX command C. +Generate a skeleton of empty directories in the C tree. =cut -sub mkdirhier { - my $tree=shift; - my $subdir; - @dirs=split /\//, $tree; - - foreach $dir (@dirs) { - $subdir .= ("$dir" . "/"); - unless (-d $subdir) { - mkdir "$subdir", 0755 || die "Can't mkdir $subdir"; +sub make_local_skeleton { + my $prefix=shift; + my $mode=0755; + + mkdirhier "$prefix/tex/latex/local", $mode; + mkdirhier "$prefix/tex/plain/local", $mode; + mkdirhier "$prefix/dvips/local", $mode; + mkdirhier "$prefix/bibtex/bib/local", $mode; + mkdirhier "$prefix/bibtex/bst/local", $mode; + mkdirhier "$prefix/fonts/tfm/local", $mode; + mkdirhier "$prefix/fonts/vf/local", $mode; + mkdirhier "$prefix/fonts/source/local", $mode; + mkdirhier "$prefix/fonts/type1/local", $mode; + mkdirhier "$prefix/metapost/local", $mode; + mkdirhier "$prefix/web2c", $mode; +} + + +=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 +=item C -Generate a skeleton of empty directories in the C tree. +The C function pushes the last elements on the list referenced +by the first argument. =cut -sub make_var_skeleton { - my $prefix=shift; - - mkdirhier "$prefix/tex/generic/config"; - mkdirhier "$prefix/dvipdfm/config"; - mkdirhier "$prefix/tex/plain/config"; - mkdirhier "$prefix/dvips/config"; - mkdirhier "$prefix/fonts/map/dvipdfm/updmap"; - mkdirhier "$prefix/fonts/map/dvips/updmap"; - mkdirhier "$prefix/fonts/map/pdftex/updmap"; - mkdirhier "$prefix/web2c"; - mkdirhier "$prefix/xdvi"; - mkdirhier "$prefix/tex/context/config"; +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 +=item C -Generate a skeleton of empty directories in the C tree. +The C function returns true if the the first argument is contained +in the list of the remaining arguments. =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"; +sub member { + my ($e, @l) = @_; + my ($f); + foreach $f (@l) { + if ($e eq $f) { + return 1; + } + } + return 0; } -1; +=pod + +=item C + +The C function echos the argument string to STDERR in case that +the global varialbe C is set. + +=cut + +sub debug { + print STDERR @_ if ($::opt_debug); +} =pod @@ -554,6 +727,8 @@ GNU General Public License Version 2 or later. =cut +1; + ### Local Variables: ### perl-indent-level: 2 ### tab-width: 2 diff --git a/Master/tlpkg/doc/Perl-API.txt b/Master/tlpkg/doc/Perl-API.txt index e4ea303ef0c..2b3200c2e74 100644 --- a/Master/tlpkg/doc/Perl-API.txt +++ b/Master/tlpkg/doc/Perl-API.txt @@ -265,23 +265,26 @@ Package TeXLive::TLUtils ------------------------ exported functions: - sort_uniq(@list) - push_uniq(\@list,@list) - member($item, @list) - debug($string) -# dirname($file) -# basename($file) - initialze_installer - getenv($string) - which($string) - media - platform - win32 - unix - program_exists($program) - binaries_available_from_disk($platform) - binaries_available_from_net($platform) - get_system_tmpdir; - mkdirhier($path); - make_var_skeleton($path); - make_local_skeleton($path); + platform; + platform_desc($platform); + win32; + unix; + getenv($string); + which($string); + program_exists($program); + get_system_tmpdir; + dirname($path); + basename($path); + dirname_and_basename($path); + mkdirhier($path); + copy($file, $target_dir); + media; + initialze_installer; + binaries_available_from_disk; + binaries_available_from_net; + make_var_skeleton($path); + make_local_skeleton($path); + sort_uniq(@list); + push_uniq(\@list, @items); + member($item, @list); + debug($string); -- cgit v1.2.3