From 9167358afb2bd622448cf97615899cba00556bc5 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Fri, 3 Jul 2009 15:27:37 +0000 Subject: the "Tokyo-Vienna-cramped-flight-commit": - unify installer keys of the %vars hash to always use option_ prefix if it is an option - unify the layout of things in 00texlive.installation so that user settable things look like opt_$key:vallue, and internal things setting_$key:vale - add list of supported options to TLConfig, with type definitions - use a unified option call $tlpdb->option($key [, $value, $value]) instead of many different $tlpdb->option_foo_bar - adapt install-tl, uninstall-w32, tlmgr, tlpkg/bin, TeXLive::*, installer plugins, to use this new function instead - make the setting_platform:XXXXX (formerly platform:XXXXX) in 00texlive.installation only optional. It is not saved into the TLPDB if the *default* platform as returned by TeXLive::TLUtils::platform() (thus calling config.guess on unix). Only if you override the platform in the installer with -force-arch then this value is set in the TLPDB - implement TLMedia->platform that checks first the included TLPDB for option("platform"), and if that is not given determines the platform using TLUtils::platform(). - move the add_symlinks and remove_symlinks from TLPDB to TLMedia - sanatize the installer modules: perltk is now equivalent to text - tlmgr: . output of tlmgr option [show] does now show all the set options, but ignores irrelevant ones for the respective platform (sys_bin/man/info for win32, desktop_integration etc for unix) . option handling rewritten in a general way so that we only have to add new options to TLConfig::%TLPDBOptionXXXXX . setting an option is verified against the types of the options . implement tlmgr option showall that shows also options that are currently not set/saved in the TLPDB - TLUtils: honor the w32_multi_user setting also for shortcuts and menu items - tlmgrgui: . implement support for most options that are set in the TLPDB . add buttons to remove/add symlinks git-svn-id: svn://tug.org/texlive/trunk@14083 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/TeXLive/TLPDB.pm | 350 +++++++++++++++--------------------------- 1 file changed, 121 insertions(+), 229 deletions(-) (limited to 'Master/tlpkg/TeXLive/TLPDB.pm') diff --git a/Master/tlpkg/TeXLive/TLPDB.pm b/Master/tlpkg/TeXLive/TLPDB.pm index b826db38e73..5c65d57f726 100644 --- a/Master/tlpkg/TeXLive/TLPDB.pm +++ b/Master/tlpkg/TeXLive/TLPDB.pm @@ -49,9 +49,10 @@ C -- A database of TeX Live Packages $tlpdb->config_container_format; $tlpdb->config_release; $tlpdb->config_revision; + $tlpdb->options; $tlpdb->option($key, [$value]); - $tlpdb->add_symlinks(); - $tlpdb->remove_symlinks(); + $tlpdb->settings; + $tlpdb->setting($key, [$value]); $tlpdb->sizes_of_packages($opt_src, $opt_doc [, @packs ]); TeXLive::TLPDB->listdir([$dir]); @@ -62,7 +63,8 @@ C -- A database of TeX Live Packages =cut use TeXLive::TLConfig qw($CategoriesRegexp $DefaultCategory $InfraLocation - $DatabaseName $MetaCategoriesRegexp $Archive); + $DatabaseName $MetaCategoriesRegexp $Archive + %TLPDBOptionType %TLPDBSettingType); use TeXLive::TLUtils qw(dirname mkdirhier member win32 info debug ddebug tlwarn); use TeXLive::TLPOBJ; @@ -328,13 +330,13 @@ sub save { The C functions returns the list of available architectures as set in the options section -(i.e., using option_available_architectures) +(i.e., using setting("available_architectures")) =cut sub available_architectures { my $self = shift; - my @archs = $self->option_available_architectures; + my @archs = $self->setting("available_architectures"); if (! @archs) { # fall back to the old method checking tex\.* my @packs = $self->list_packages; @@ -916,123 +918,6 @@ sub config_revision { } -=pod - -=item C<< $tlpdb->add_symlinks() >> -=item C<< $tlpdb->remove_symlinks() >> - -These two functions try to create/remove symlinks for binaries, man pages, -and info files as specified by the options saved in the tlpdb -($tlpdb->option_sys_bin, $tlpdb->option_sys_man, $tlpdb->option_sys_info). - -The functions return 1 on success and 0 on error. -On Windows it returns undefined. - -=cut - -sub add_link_dir_dir { - my ($from, $to) = @_; - mkdirhier $to; - if (-w $to) { - debug("linking files from $from to $to\n"); - chomp (@files = `ls "$from"`); - my $ret = 1; - for my $f (@files) { - unlink("$to/$f"); - if (system("ln -s \"$from/$f\" \"$to\"")) { - tlwarn("Linking $f from $from to $to failed: $!\n"); - $ret = 0; - } - } - return $ret; - } else { - tlwarn("destination $to not writable, no linking files in $from done.\n"); - return 0; - } -} - -sub remove_link_dir_dir { - my ($from, $to) = @_; - if ((-d "$to") && (-w "$to")) { - debug("removing links from $from to $to\n"); - chomp (@files = `ls "$from"`); - my $ret = 1; - foreach my $f (@files) { - next if (! -r "$to/$f"); - if ((-l "$to/$f") && - (readlink("$to/$f") =~ m;^$from/;)) { - $ret = 0 unless unlink("$to/$f"); - } else { - $ret = 0; - tlwarn ("not removing $to/$f, not a link or wrong destination!\n"); - } - } - # trry to remove the destination directory, it might be empty and - # we might have write permissions, ignore errors - `rmdir "$to" 2>/dev/null`; - return $ret; - } else { - tlwarn ("destination $to not writable, no removal of links done!\n"); - return 0; - } -} - -sub add_remove_symlinks { - my $self = shift; - my $mode = shift; - my $errors = 0; - my $Master = $self->{'root'}; - my $arch = $self->option_platform; - my $plat_bindir = "$Master/bin/$arch"; - return if win32(); - $sys_bin = $self->option_sys_bin; - $sys_man = $self->option_sys_man; - $sys_info= $self->option_sys_info; - if ($mode eq "add") { - $errors++ unless add_link_dir_dir($plat_bindir, $sys_bin); - $errors++ unless add_link_dir_dir("$Master/texmf/doc/info", $sys_info); - } elsif ($mode eq "remove") { - $errors++ unless remove_link_dir_dir($plat_bindir, $sys_bin); - $errors++ unless remove_link_dir_dir("$Master/texmf/doc/info", $sys_info); - } else { - die ("should not happen, unknown mode $mode in add_remove_symlinks!"); - } - mkdirhier $sys_man if ($mode eq "add"); - if (-w $sys_man) { - debug("$mode symlinks for man pages in $sys_man\n"); - my $foo = `(cd "$Master/texmf/doc/man" && echo *)`; - chomp (my @mans = split (' ', $foo)); - foreach my $m (@mans) { - my $mandir = "$Master/texmf/doc/man/$m"; - next unless -d $mandir; - if ($mode eq "add") { - $errors++ unless add_link_dir_dir($mandir, "$sys_man/$m"); - } else { - $errors++ unless remove_link_dir_dir($mandir, "$sys_man/$m"); - } - } - `rmdir "$sys_man" 2>/dev/null` if ($mode eq "remove"); - } else { - tlwarn("destination of man symlink $sys_man not writable, " - . "cannot $mode symlinks.\n"); - $errors++; - } - # we collected errors in $ret, so return the negation of it - if ($errors) { - info("$mode of symlinks failed $errors times, please see above messages.\n"); - return 0; - } else { - return 1; - } -} - -sub add_symlinks { - return (shift->add_remove_symlinks("add", @_)); -} -sub remove_symlinks { - return (shift->add_remove_symlinks("remove", @_)); -} - =pod =item C<< $tlpdb->sizes_of_packages ( $opt_src, $opt_doc, [ @packs ] ) >> @@ -1103,8 +988,8 @@ sub sizes_of_packages { =pod -=item C<< $tlpdb->option_XXXXX >ize += $tlpsizes{$p}; - +=item C<< $tlpdb->option($key [, $val]) >> +=item C<< $tlpdb->setting($key [, $val]) >> Need to be documented @@ -1112,29 +997,34 @@ Need to be documented sub _set_option_value { my $self = shift; - $self->_set_option_value_pkg('00texlive.installation', @_); + $self->_set_value_pkg('00texlive.installation', 'opt_', @_); +} +sub _set_setting_value { + my $self = shift; + $self->_set_value_pkg('00texlive.installation', 'setting_', @_); } -sub _set_option_value_pkg { - my ($self,$pkgname,$key,$value) = @_; +sub _set_value_pkg { + my ($self,$pkgname,$pre,$key,$value) = @_; + my $k = "$pre$key"; my $pkg = $self->{'tlps'}{$pkgname}; my @newdeps; if (!defined($pkg)) { $pkg = new TeXLive::TLPOBJ; $pkg->name($pkgname); $pkg->category("TLCore"); - push @newdeps, "$key:$value"; + push @newdeps, "$k:$value"; } else { my $found = 0; foreach my $d ($pkg->depends) { - if ($d =~ m!^$key:!) { + if ($d =~ m!^$k:!) { $found = 1; - push @newdeps, "$key:$value"; + push @newdeps, "$k:$value"; } else { push @newdeps, $d; } } if (!$found) { - push @newdeps, "$key:$value"; + push @newdeps, "$k:$value"; } } $pkg->depends(@newdeps); @@ -1143,14 +1033,20 @@ sub _set_option_value_pkg { sub _option_value { my $self = shift; - $self->_option_value_pkg('00texlive.installation', @_); + $self->_value_pkg('00texlive.installation', 'opt_', @_); } -sub _option_value_pkg { - my ($self,$pkg,$key) = @_; +sub _setting_value { + my $self = shift; + $self->_value_pkg('00texlive.installation', 'setting_', @_); +} + +sub _value_pkg { + my ($self,$pkg,$pre,$key) = @_; + my $k = "$pre$key"; if (defined($self->{'tlps'}{$pkg})) { foreach my $d ($self->{'tlps'}{$pkg}->depends) { - if ($d =~ m!^$key:(.*)$!) { + if ($d =~ m!^$k:(.*)$!) { return "$1"; } } @@ -1160,117 +1056,113 @@ sub _option_value_pkg { return; } -sub option { - my $self = shift; - my $key = shift; - if (@_) { $self->_set_option_value($key, shift); } - return $self->_option_value($key); -} - sub option_pkg { my $self = shift; my $pkg = shift; my $key = shift; - if (@_) { $self->_set_option_value_pkg($pkg, $key, shift); } - return $self->_option_value_pkg($pkg, $key); -} - -# TODO the above function should be used in the functions below as -# far as possible ... - -sub option_available_architectures { - my $self = shift; - if (@_) { $self->_set_option_value("available_architectures","@_"); } - - # sadly, if the tlpdb is messed up, there may be no architectures. - my $val = $self->_option_value("available_architectures"); - my @archs; - if (defined $val) { - @archs = split(" ", $val); - } else { - warn "no available_architectures, continuing anyway ..."; - @archs = (); + if (@_) { $self->_set_value_pkg($pkg, "opt_", $key, shift); } + my $ret = $self->_value_pkg($pkg, "opt_", $key); + # special case for location == __MASTER__ + if ($ret eq "__MASTER__" && $key eq "location") { + return $self->root; } - return @archs; -} -sub option_create_symlinks { - my $self = shift; - if (@_) { $self->_set_option_value("opt_create_symlinks", shift); } - return $self->_option_value("opt_create_symlinks"); -} -sub option_desktop_integration { - my $self = shift; - if (@_) { $self->_set_option_value("opt_desktop_integration", shift); } - return $self->_option_value("opt_desktop_integration"); -} -sub option_file_assocs { - my $self = shift; - if (@_) { $self->_set_option_value("opt_file_assocs", shift); } - return $self->_option_value("opt_file_assocs"); -} -sub option_post_code { - my $self = shift; - if (@_) { $self->_set_option_value("opt_post_code", shift); } - return $self->_option_value("opt_post_code"); -} -sub option_path { - my $self = shift; - if (@_) { $self->_set_option_value("opt_path", shift); } - return $self->_option_value("opt_path"); -} -sub option_w32_multi_user { - my $self = shift; - if (@_) { $self->_set_option_value("opt_w32_multi_user", shift); } - return $self->_option_value("opt_w32_multi_user"); -} -sub option_install_docfiles { - my $self = shift; - if (@_) { $self->_set_option_value("opt_install_docfiles", shift); } - return $self->_option_value("opt_install_docfiles"); + return $ret; } -sub option_install_srcfiles { +sub option { my $self = shift; - if (@_) { $self->_set_option_value("opt_install_srcfiles", shift); } - return $self->_option_value("opt_install_srcfiles"); -} -sub option_create_formats { - my $self = shift; - if (@_) { $self->_set_option_value("opt_create_formats", shift); } - return $self->_option_value("opt_create_formats"); -} -sub option_paper { - my $self = shift; - if (@_) { $self->_set_option_value("opt_paper", shift); } - return $self->_option_value("opt_paper"); -} -sub option_location { - my $self = shift; - if (@_) { $self->_set_option_value("location", shift); } - my $loc = $self->_option_value("location"); - if ($loc eq "__MASTER__") { + my $key = shift; + if (@_) { $self->_set_option_value($key, shift); } + my $ret = $self->_option_value($key); + # special case for location == __MASTER__ + if (defined($ret) && $ret eq "__MASTER__" && $key eq "location") { return $self->root; } - return $self->_option_value("location"); + return $ret; } -sub option_sys_bin { +sub setting_pkg { my $self = shift; - if (@_) { $self->_set_option_value("opt_sys_bin", shift); } - return $self->_option_value("opt_sys_bin"); + my $pkg = shift; + my $key = shift; + if (@_) { + if ($TLPDBSettingType{$key} eq "l") { + $self->_set_value_pkg($pkg, "setting_", $key, "@_"); + } else { + $self->_set_value_pkg($pkg, "setting_", $key, shift); + } + } + my $ret = $self->_value_pkg($pkg, "setting_", $key); + # check the types of the settings, and if it is a "l" return a list + if ($TLPDBSettingType{$key} eq "l") { + my @ret; + if (defined $ret) { + @ret = split(" ", $ret); + } else { + tlwarn "TLPDB::setting: no $key, returning empty list ...\n"; + @ret = (); + } + return @ret; + } + return $ret; } -sub option_sys_man { +sub setting { my $self = shift; - if (@_) { $self->_set_option_value("opt_sys_man", shift); } - return $self->_option_value("opt_sys_man"); + my $key = shift; + if (@_) { + if ($TLPDBSettingType{$key} eq "l") { + $self->_set_setting_value($key, "@_"); + } else { + $self->_set_setting_value($key, shift); + } + } + my $ret = $self->_setting_value($key); + # check the types of the settings, and if it is a "l" return a list + if ($TLPDBSettingType{$key} eq "l") { + my @ret; + if (defined $ret) { + @ret = split(" ", $ret); + } else { + tlwarn "TLPDB::setting: no $key, returning empty list ...\n"; + @ret = (); + } + return @ret; + } + return $ret; +} + +=pod + +=item C<< $tlpdb->options >> + +Returns a reference to a hash with option names. + +=cut + +sub _keyshash { + my ($self, $pre, $hr) = @_; + my @allowed = keys %$hr; + my %ret; + my $pkg = $self->{'tlps'}{'00texlive.installation'}; + if (defined($pkg)) { + foreach my $d ($pkg->depends) { + if ($d =~ m!^$pre([^:]*):(.*)!) { + if (member($1, @allowed)) { + $ret{$1} = $2; + } else { + tlwarn("Unsupported option/setting $d\n"); + } + } + } + } + return \%ret; } -sub option_sys_info { + +sub options { my $self = shift; - if (@_) { $self->_set_option_value("opt_sys_info", shift); } - return $self->_option_value("opt_sys_info"); + return ($self->_keyshash('opt_', \%TLPDBOptionType)); } -sub option_platform { +sub settings { my $self = shift; - if (@_) { $self->_set_option_value("platform", shift); } - return $self->_option_value("platform"); + return ($self->_keyshash('setting_', \%TLPDBSettingType)); } =pod -- cgit v1.2.3