summaryrefslogtreecommitdiff
path: root/Master/tlpkg/TeXLive/TLPDB.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/TeXLive/TLPDB.pm')
-rw-r--r--Master/tlpkg/TeXLive/TLPDB.pm350
1 files changed, 121 insertions, 229 deletions
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<TeXLive::TLPDB> -- 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<TeXLive::TLPDB> -- 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<available_architectures> 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;
@@ -918,123 +920,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 ] ) >>
This function returns a reference to a hash with package names as keys
@@ -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