diff options
Diffstat (limited to 'Master/tlpkg')
| -rw-r--r-- | Master/tlpkg/TeXLive/TLPDB.pm | 80 | ||||
| -rw-r--r-- | Master/tlpkg/TeXLive/TLUtils.pm | 283 | ||||
| -rw-r--r-- | Master/tlpkg/doc/Perl-API.txt | 19 |
3 files changed, 363 insertions, 19 deletions
diff --git a/Master/tlpkg/TeXLive/TLPDB.pm b/Master/tlpkg/TeXLive/TLPDB.pm index 3c392242a45..3c16d540402 100644 --- a/Master/tlpkg/TeXLive/TLPDB.pm +++ b/Master/tlpkg/TeXLive/TLPDB.pm @@ -10,7 +10,7 @@ package TeXLive::TLPDB; =pod =head1 NAME -TeXLive::TLPDB - a database of TeX Live Packages +C<TeXLive::TLPDB> -- A database of TeXLive Packages =head1 SYNOPSIS @@ -43,8 +43,17 @@ my $_listdir; =pod -C<TeXLive::TLPDB->new> creates a new C<TLPDB> object. If the argument -location is given it will be initialized from this locations. +=over 6 + +=item C<< TeXLive::TLPDB->new >> + +=item C<< TeXLive::TLPDB->new(location => "$filename") >> + +C<< TeXLive::TLPDB->new >> creates a new C<TLPDB> object. If the +argument C<location> is given it will be initialized from this +location. C<$filename> is usually C</path/to/texlive.tlpdb>. If +C<$filename> begins with C<http://> or C<ftp://>, the program C<wget> +is used to download the file. =cut @@ -65,9 +74,12 @@ sub new { =pod +=item C<< $tlpdb->add_tlpobj($tlpobj) >> + The C<add_tlpobj> adds an object of the type TLPOBJ to the TLPDB. =cut + sub add_tlpobj { my ($self,$tlp) = @_; $self->{'tlps'}{$tlp->name} = $tlp; @@ -75,10 +87,15 @@ sub add_tlpobj { =pod -The C<from_file> function initializes the C<TLPDB> in case the location -was not given at generation time. +=item C<< $tlpdb->from_file($filename) >> + +The C<from_file> function initializes the C<TLPDB> in case the +location was not given at generation time. If C<$filename> begins +with C<http://> or C<ftp://>, the program C<wget> is used to download +the file. =cut + sub from_file { my $self = shift; if (@_ != 1) { @@ -90,7 +107,12 @@ sub from_file { } } $self->location($_[0]); - open(TMP,"<$_[0]") || die("Cannot open tlpdb file: $_[0]"); + if ($_[0]=~/^(http|ftp):\/\//) { + open(TMP, "wget -nv --output-document=- $_[0]|") + || die("Cannot open tlpdb file: $_[0]"); + } else { + open(TMP,"<$_[0]") || die("Cannot open tlpdb file: $_[0]"); + } my $found = 0; do { my $tlp = TeXLive::TLPOBJ->new; @@ -104,10 +126,15 @@ sub from_file { =pod -The C<writeout> function writes the whole TLPDB to STDOUT, or to the file -handle given as argument. +=item C<< $tlpdb->writeout >> + +=item C<< $tlpdb->writeout(FILEHANDLE) >> + +The C<writeout> function writes the whole C<TLPDB> to C<STDOUT>, or to +the file handle given as argument. =cut + sub writeout { my $self = shift; my $fd = (@_ ? $_[0] : STDOUT); @@ -121,10 +148,13 @@ sub writeout { =pod -The C<save> functions saves the TLPDB to the file which has been set +=item C<< $tlpdb->save >> + +The C<save> functions saves the C<TLPDB> to the file which has been set as location. If the location is undefined, die. =cut + sub save { my $self = shift; open(FOO,">$self->{'location'}") || die("Cannot open $self->{'location'} for writing: $!"); @@ -134,10 +164,13 @@ sub save { =pod -The C<get_package> function returns a reference to an TLPOBJ object in case -its name the the argument name coincide. +=item C<< $tlpdb->get_package("packagename") >> + +The C<get_package> function returns a reference to a C<TLPOBJ> object +in case its name the the argument name coincide. =cut + sub get_package { my ($self,$pkg) = @_; if (defined($self->{'tlps'}{$pkg})) { @@ -149,9 +182,12 @@ sub get_package { =pod +=item C<< $tlpdb->list_packages >> + The C<list_packages> function returns the list of all included packages. =cut + sub list_packages { my $self = shift; return (sort keys %{$self->{'tlps'}}); @@ -159,10 +195,13 @@ sub list_packages { =pod -The C<package_revision> function returns the the revision of the +=item C<< $tlpdb->package_revision("packagename") >> + +The C<package_revision> function returns the revision number of the package named in the first argument. =cut + sub package_revision { my ($self,$pkg) = @_; if (defined($self->{'tlps'}{$pkg})) { @@ -174,10 +213,13 @@ sub package_revision { =pod +=item C<< $tlpdb->generate_packagelist >> + The C<generate_packagelist> lists all available TL Packages together with their revisions. =cut + sub generate_packagelist { my $self = shift; my $fd = (@_ ? $_[0] : STDOUT); @@ -188,10 +230,15 @@ sub generate_packagelist { =pod +=item C<< $tlpdb->generate_listfiles >> + +=item C<< $tlpdb->generate_listfiles($destdir) >> + The C<generate_listfiles> generates the list files for the old installers. This function will probably go away. =cut + sub generate_listfiles { my ($self,$destdir) = @_; if (not(defined($destdir))) { @@ -313,10 +360,13 @@ sub _generate_listfile { =pod +=item C<< $tlpdb->location("/path/to/texlive.tlpdb") >> + The function C<location> allows to read and set the location of the -text file of the TeX Live Database. +text file of the TeXLive database. =cut + sub location { my $self = shift; if (@_) { $self->{'location'} = shift } @@ -325,6 +375,8 @@ sub location { =pod +=item C<< $tlpdb->listdir >> + The function C<listdir> allows to read and set the packages variable specifiying where generated list files are created. @@ -335,9 +387,9 @@ sub listdir { return $_listdir; } +=back =pod - =head1 SEE ALSO The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm index 5e5a88f60ec..f30b2410f1f 100644 --- a/Master/tlpkg/TeXLive/TLUtils.pm +++ b/Master/tlpkg/TeXLive/TLUtils.pm @@ -11,9 +11,10 @@ package TeXLive::TLUtils; =pod + =head1 NAME -TeXLive::TLUtils - utilities used in the TeX Live Infrastructure Modules +C<TeXLive::TLUtils> -- Utilities used in the TeX Live Infrastructure Modules =head1 SYNOPSIS @@ -23,6 +24,15 @@ TeXLive::TLUtils - utilities used in the TeX Live Infrastructure Modules TeXLive::TLUtils::push_uniq(\@list, @items); TeXLive::TLUtils::member($item, @list); TeXLive::TLUtils::debug($string); + TeXLive::TLUtils::getenv($string); + TeXLive::TLUtils::which($string); + TeXLive::TLUtils::initialze_installer; + TeXLive::TLUtils::media; + TeXLive::TLUtils::platform; + TeXLive::TLUtils::win32; + TeXLive::TLUtils::program_exists($program); + TeXLive::TLUtils::binaries_available_from_disk($platform); + TeXLive::TLUtils::binaries_available_from_net($platform); =head1 DESCRIPTION @@ -39,11 +49,26 @@ BEGIN { @EXPORT_OK = qw( &sort_uniq &push_uniq + &member + &debug + &getenv + &which + &media + &platform + &initialize_installer + &win32 + &program_exists + &binaries_available_from_disk + &binaries_available_from_net ); } =pod +=over 6 + +=item C<sort_uniq(@list)> + The C<sort_uniq> function sorts the given array and throws away multiple occurrences of elements. It returns a sorted and unified array. @@ -65,6 +90,8 @@ sub sort_uniq { =pod +=item C<push_uniq(\@list, @items)> + The C<push_uniq> function pushes the last elements on the list referenced by the first argument. @@ -82,6 +109,8 @@ sub push_uniq { =pod +=item C<member($item, @list)> + The C<member> function returns true if the the first argument is contained in the list of the remaining arguments. @@ -98,8 +127,32 @@ sub member { return 0; } + +=pod + +=item C<initialize_installer> + +The function C<initialize_installer> first determines the directory in +which tl-install.pl resides (which is C<`dirname $0`> on UNIX). Then +it calls C<media> and C<platform> in order to set the variables +C<$::_media_> and C<$::_platform_>. + +Repeatedly calls to C<media> or C<platform> do not access the CD/DVD +again. + +=cut + +sub initialize_installer { + ($::_installerdir_=$0)=~s/(.*)\/.*$/$1/; + &media; + &platform; +} + + =pod +=item C<debug($string)> + The C<debug> function echos the argument string to STDERR in case that the global varialbe C<opt_debug> is set. @@ -109,10 +162,238 @@ sub debug { print STDERR @_ if ($::opt_debug); } +=pod + +=item C<getenv($string)> + +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<which($string)> + +C<which> does the same as the UNIX command C<which(1)>, but it is +supposed to work on Windows too. On Windows we have to try all the +extensions given in the C<PATHEXT> 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<media> + +Return media type. Either C<CD>, C<DVD>, or C<NET>. + +The result is stored in a global variable C<$::_media_>. If you call +C<media> repeatedly, only the first call of C<media> will access the +CD/DVD. + +=cut + +sub media { + unless (defined $::_media_) { + if (-d "$::_installerdir_/archive") { + $::_media_="CD"; + } elsif (-d "$::_installerdir_/texmf/web2c") { + $::_media_="DVD"; + } else { + $::_media_="NET"; + } + } + return $::_media_; +} + +=pod + +=item C<platform> + +If the directory C</usr/bin> doesn't exist we know that we're on +Windows and we set the global variable C<$::_platform_> to C<win32>. +If it exists we call C<config.guess>. The output of C<config.guess> +is filtered as described below. + +CPU type is determined by a regexp. And it's necessary to +C<s/i.86/i386/>. + +For OS we need a list because we probably have something like +C<linux-gnu> but we need C<linux>. This list might/should contain OSs +which are not currently supported. The list currently supports all +platforms supported by TeXLive 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<platform> repeatedly, only the first call of C<platform> will access +the HD/CD/DVD. + +=cut + +sub platform { + my @OSs=qw(aix cygwin darwin freebsd hpux irix linux netbsd openbsd + solaris); + + unless (defined $::_platform_) { + if (-d "/usr/bin") { + my $CPU; # CPU type as reported by config.guess. + my $OS; # O/S type as reported by config.guess. + 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 $::_platform_; +} + +=pod + +=item C<win32> + +Return C<1> if platform is Windows and C<0> otherwise. + +=cut + +sub win32 { + return (&platform eq "win32")? 1:0; +} + +=pod + +=item C<program_exists($program)> + +Return C<1> if C<$program> is in C<PATH> and C<0> otherwise. + +=cut + +sub program_exists { + my $program=shift; + return (&which ("$program"))? 0:1; +} + +=pod + +=item C<binaries_available_from_disk> + +The function C<binaries_available_from_disk> returns a list of +supported platforms. Media type has to be either C<CD> or C<DVD>. + +=cut + +sub binaries_available_from_disk { + my @dir; + my @platforms; + if (&media eq "CD") { + opendir DIR, "$::_installerdir_/archive"; + } elsif (&media eq "DVD") { + opendir DIR, "$::_installerdir_/texmf/bin"; + } else { + die "Media type must be CD or DVD.\n"; + } + @dir=readdir DIR; + chomp @dir; + if (&media eq "CD") { + for (@dir) { + if (/bin-kpathsea.(.*).zip$/) { + push @platforms, $1; + } + } + } elsif (&media eq "DVD") { + for (@dir) { + push @platforms, $1 unless (/^\./); + } + } else { + die "Media type must be CD or DVD.\n"; + } + return @platforms; +} + +=pod + +=item C<binaries_available_from_net> + +The function C<binaries_available_from_net> returns a list of +platforms supported by the TeXLive server. It downloads the file +C<$::texlive_url/texlive.tlpdb> and looks for files +C</^bin\/(.*)\/kpsewhich/>. + +=cut + +sub binaries_available_from_net { + my @platforms; + open TLPDB, "wget -q --output-document=- $::texlive_url/texlive.tlpdb|" + or die "Can't open $::texlive_url/texlive.tlpdb"; + while (<TLPDB>) { + if (/^bin\/(.*)\/kpsewhich/) { + push @platforms, $1; + } + } + return @platforms; +} + 1; + =pod +=back + =head1 SEE ALSO The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, diff --git a/Master/tlpkg/doc/Perl-API.txt b/Master/tlpkg/doc/Perl-API.txt index feac97832c0..d0557816fb3 100644 --- a/Master/tlpkg/doc/Perl-API.txt +++ b/Master/tlpkg/doc/Perl-API.txt @@ -210,10 +210,12 @@ Package variables: &TeXLive::TLPDB->listdir sets/returns the default location for created list files -Constructore +Constructor TeXLive::TLPDB->new; TeXLive::TLPDB->new ( location => "path/to/tldb/file" ); + TeXLive::TLPDB->new ( location => "http://path/to/tldb/file" ); + TeXLive::TLPDB->new ( location => "ftp://path/to/tldb/file" ); Read/Write functions (with argument set, without arg read) @@ -221,7 +223,9 @@ Read/Write functions (with argument set, without arg read) Input/Output - $tldb->from_file($filename); + $tldb->from_file("path/to/tldb/file"); + $tldb->from_file("http://path/to/tldb/file"); + $tldb->from_file("ftp://path/to/tldb/file"); reads a tldb file (tlp descriptions separated by newlines) $tldb->writeout @@ -265,5 +269,12 @@ exported functions: push_uniq(\@list,@list) dirname($file) basename($file) - - + getenv($string) + which($string) + initialze_installer + media + platform + win32 + program_exists($program) + binaries_available_from_disk($platform) + binaries_available_from_net($platform) |