diff options
Diffstat (limited to 'Master/tlpkg/TeXLive/TLMedia.pm')
-rw-r--r-- | Master/tlpkg/TeXLive/TLMedia.pm | 168 |
1 files changed, 160 insertions, 8 deletions
diff --git a/Master/tlpkg/TeXLive/TLMedia.pm b/Master/tlpkg/TeXLive/TLMedia.pm index 90af2763348..6980f813959 100644 --- a/Master/tlpkg/TeXLive/TLMedia.pm +++ b/Master/tlpkg/TeXLive/TLMedia.pm @@ -11,6 +11,7 @@ use TeXLive::TLConfig; use TeXLive::TLUtils qw(copy win32 dirname mkdirhier basename download_file merge_into debug ddebug info tlwarn log); use TeXLive::TLPDB; +use TeXLive::TLWinGoo; sub new { @@ -137,8 +138,8 @@ sub install_package { my $container_src_split = $fromtlpdb->config_src_container; my $container_doc_split = $fromtlpdb->config_doc_container; # get options about src/doc splitting from $totlpdb - my $opt_src = $totlpdb->option_install_srcfiles; - my $opt_doc = $totlpdb->option_install_docfiles; + my $opt_src = $totlpdb->option("install_srcfiles"); + my $opt_doc = $totlpdb->option("install_docfiles"); my $real_opt_doc = $opt_doc; if ($tlpobj->category =~ m/documentation/i) { # we do install documenation files for category Documentation @@ -258,10 +259,15 @@ sub install_package { # do the postinstallation actions # # Run the post installation code in the postaction tlpsrc entries + # in case we are on w32 and the admin did install for himself only + # we switch off admin mode + if (win32() && admin() && !$totlpdb->option("w32_multi_user")) { + non_admin(); + } &TeXLive::TLUtils::do_postaction("install", $tlpobj, - $totlpdb->option_file_assocs, - $totlpdb->option_desktop_integration, - $totlpdb->option_post_code); + $totlpdb->option("file_assocs"), + $totlpdb->option("desktop_integration"), + $totlpdb->option("post_code")); } } return 1; @@ -454,7 +460,7 @@ sub remove_package { &TeXLive::TLUtils::do_postaction("remove", $tlp, 0, # option_file_assocs, 0, # option_desktop_integration, - $localtlpdb->option_post_code); + $localtlpdb->option("post_code")); } # my @removals = &TeXLive::TLUtils::removed_dirs (@goodfiles); @@ -474,17 +480,147 @@ sub remove_package { $localtlpdb->save; # # Run the post installation code in the postaction tlpsrc entries + # in case we are on w32 and the admin did install for himself only + # we switch off admin mode + if (win32() && admin() && !$localtlpdb->option("w32_multi_user")) { + non_admin(); + } + # + # Run the post installation code in the postaction tlpsrc entries # the postaction code part cannot be evaluated now since the # files are already removed. if (!$nopostinstall) { &TeXLive::TLUtils::do_postaction("remove", $tlp, - $localtlpdb->option_file_assocs, - $localtlpdb->option_desktop_integration, + $localtlpdb->option("file_assocs"), + $localtlpdb->option("desktop_integration"), 0); } } return 1; } + + +=pod + +=item C<< $tlmedia->add_symlinks() >> +=item C<< $tlmedia->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 respective 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->location; + my $arch = $self->platform(); + my $plat_bindir = "$Master/bin/$arch"; + return if win32(); + $sys_bin = $self->tlpdb->option("sys_bin"); + $sys_man = $self->tlpdb->option("sys_man"); + $sys_info= $self->tlpdb->option("sys_info"); + if ($mode eq "add") { + $errors++ unless add_link_dir_dir($plat_bindir, $sys_bin); + if (-d "$Master/texmf/doc/info") { + $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); + if (-d "$Master/texmf/doc/info") { + $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 && -d "$Master/texmf/doc/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", @_)); +} # member access functions @@ -500,6 +636,22 @@ sub lang_doc_collections { my $self = shift; return @{ $self->{'lang_doc_collect sub schemes { my $self = shift; return @{ $self->{'schemes'} }; } sub systems { my $self = shift; return @{ $self->{'systems'} }; } +# deduce the platform of the referenced media as follows: +# - if the $tlpdb->setting("platform") is there it overrides the detected +# setting +# - if it is not there call TLUtils::platform() +sub platform { + # try to deduce the platform + my $self = shift; + my $tlpdb = $self->tlpdb; + if (defined($tlpdb)) { + my $ret = $tlpdb->setting("platform"); + return $ret if defined $ret; + } + # the platform setting wasn't found in the tlpdb, try TLUtils::platform + return TeXLive::TLUtils::platform(); +} + 1; __END__ |