diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/TeXLive |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/TeXLive')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm | 719 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLConfig.pm | 367 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLCrypto.pm | 600 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLDownload.pm | 209 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLPDB.pm | 3002 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm | 1837 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLPSRC.pm | 1194 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLPaper.pm | 972 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLTREE.pm | 541 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm | 4578 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm | 1444 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TeXCatalogue.pm | 340 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/trans.pl | 219 |
13 files changed, 16022 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm new file mode 100644 index 0000000000..4a2a125f44 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm @@ -0,0 +1,719 @@ +# $Id: TLConfFile.pm 44447 2017-06-04 02:03:31Z preining $ +# TeXLive::TLConfFile.pm - reading and writing conf files +# Copyright 2010-2017 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLConfFile; + +use TeXLive::TLUtils; + +my $svnrev = '$Revision: 44447 $'; +my $_modulerevision; +if ($svnrev =~ m/: ([0-9]+) /) { + $_modulerevision = $1; +} else { + $_modulerevision = "unknown"; +} +sub module_revision { + return $_modulerevision; +} + +sub new +{ + my $class = shift; + my ($fn, $cc, $sep, $typ) = @_; + my $self = {} ; + $self{'file'} = $fn; + $self{'cc'} = $cc; + $self{'sep'} = $sep; + if (defined($typ)) { + if ($typ eq 'last-win' || $typ eq 'first-win' || $typ eq 'multiple') { + $self{'type'} = $typ; + } else { + printf STDERR "Unknown type of conffile: $typ\n"; + printf STDERR "Should be one of: last-win first-win multiple\n"; + return; + } + } else { + # default type for backward compatibility is last-win + $self{'type'} = 'last-win'; + } + bless $self, $class; + return $self->reparse; +} + +sub reparse +{ + my $self = shift; + my %config = parse_config_file($self->file, $self->cc, $self->sep); + my $lastkey = undef; + my $lastkeyline = undef; + $self{'keyvalue'} = (); + $self{'confdata'} = \%config; + $self{'changed'} = 0; + my $in_postcomment = 0; + for my $i (0..$config{'lines'}) { + if ($config{$i}{'type'} eq 'comment') { + $lastkey = undef; + $lastkeyline = undef; + $is_postcomment = 0; + } elsif ($config{$i}{'type'} eq 'data') { + $lastkey = $config{$i}{'key'}; + $lastkeyline = $i; + $self{'keyvalue'}{$lastkey}{$i}{'value'} = $config{$i}{'value'}; + $self{'keyvalue'}{$lastkey}{$i}{'status'} = 'unchanged'; + if (defined($config{$i}{'postcomment'})) { + $in_postcomment = 1; + } else { + $in_postcomment = 0; + } + } elsif ($config{$i}{'type'} eq 'empty') { + $lastkey = undef; + $lastkeyline = undef; + $is_postcomment = 0; + } elsif ($config{$i}{'type'} eq 'continuation') { + if (defined($lastkey)) { + if (!$in_postcomment) { + $self{'keyvalue'}{$lastkey}{$lastkeyline}{'value'} .= + $config{$i}{'value'}; + } + } + # otherwise we are in a continuation of a comment!!! so nothing to do + } else { + print "-- UNKNOWN TYPE\n"; + } + } + return $self; +} + +sub file +{ + my $self = shift; + return($self{'file'}); +} +sub cc +{ + my $self = shift; + return($self{'cc'}); +} +sub sep +{ + my $self = shift; + return($self{'sep'}); +} +sub type +{ + my $self = shift; + return($self{'type'}); +} + +sub key_present +{ + my ($self, $key) = @_; + return defined($self{'keyvalue'}{$key}); +} + +sub keys +{ + my $self = shift; + return keys(%{$self{'keyvalue'}}); +} + +sub keyvaluehash +{ + my $self = shift; + return \%{$self{'keyvalue'}}; +} +sub confdatahash +{ + my $self = shift; + return $self{'confdata'}; +} + +sub by_lnr +{ + # order of lines + # first all the line numbers >= 0, + # then the negative line numbers in reverse order + # (negative line numbers refer to new entries in the conffile) + # example: + # line number in order: 0 3 6 7 9 -1 -2 -3 + return ($a >= 0 && $b >= 0 ? $a <=> $b : $b <=> $a); +} + +sub value +{ + my ($self, $key, $value, @restvals) = @_; + my $t = $self->type; + if (defined($value)) { + if (defined($self{'keyvalue'}{$key})) { + my @key_lines = sort by_lnr CORE::keys %{$self{'keyvalue'}{$key}}; + if ($t eq 'multiple') { + my @newval = ( $value, @restvals ); + my $newlen = $#newval; + # in case of assigning to a multiple value stuff, + # we assign to the first n elements, delete superficial + # or add new ones if necessary + # $value should be a reference to an array of values + my $listp = $self{'keyvalue'}{$key}; + my $oldlen = $#key_lines; + my $minlen = ($newlen < $oldlen ? $newlen : $oldlen); + for my $i (0..$minlen) { + if ($listp->{$key_lines[$i]}{'value'} ne $newval[$i]) { + $listp->{$key_lines[$i]}{'value'} = $newval[$i]; + if ($listp->{$key_lines[$i]}{'status'} ne 'new') { + $listp->{$key_lines[$i]}{'status'} = 'changed'; + } + $self{'changed'} = 1; + } + } + if ($minlen < $oldlen) { + # we are assigning less values to more lines, so we have to + # remove the remaining ones + for my $i (($minlen+1)..$oldlen) { + $listp->{$key_lines[$i]}{'status'} = 'deleted'; + } + $self{'changed'} = 1; + } + if ($minlen < $newlen) { + # we have new values + my $ll = $key_lines[$#key_lines]; + # if we are adding the first new entry, set line to -1, + # otherwise decrease the line number (already negative + # for new lines) + $ll = ($ll >= 0 ? -1 : $ll-1); + for my $i (($minlen+1)..$newlen) { + $listp->{$ll}{'status'} = 'new'; + $listp->{$ll}{'value'} = $newval[$i]; + $ll--; + } + $self{'changed'} = 1; + } + } else { + # select element based on first-win or last-win type + my $ll = $key_lines[($t eq 'first-win' ? 0 : $#key_lines)]; + #print "lastwin = $ll\n"; + if ($self{'keyvalue'}{$key}{$ll}{'value'} ne $value) { + $self{'keyvalue'}{$key}{$ll}{'value'} = $value; + # as long as the key/value pair is not new, + # we set its status to changed + if ($self{'keyvalue'}{$key}{$ll}{'status'} ne 'new') { + $self{'keyvalue'}{$key}{$ll}{'status'} = 'changed'; + } + $self{'changed'} = 1; + } + } + } else { # all new key + my @newval = ( $value, @restvals ); + my $newlen = $#newval; + for my $i (0..$newlen) { + $self{'keyvalue'}{$key}{-($i+1)}{'value'} = $value; + $self{'keyvalue'}{$key}{-($i+1)}{'status'} = 'new'; + } + $self{'changed'} = 1; + } + } + # $self->dump_myself(); + if (defined($self{'keyvalue'}{$key})) { + my @key_lines = sort by_lnr CORE::keys %{$self{'keyvalue'}{$key}}; + if ($t eq 'first-win') { + return $self{'keyvalue'}{$key}{$key_lines[0]}{'value'}; + } elsif ($t eq 'last-win') { + return $self{'keyvalue'}{$key}{$key_lines[$#key_lines]}{'value'}; + } elsif ($t eq 'multiple') { + return map { $self{'keyvalue'}{$key}{$_}{'value'} } @key_lines; + } else { + die "That should not happen: wrong type: $!"; + } + } + return; +} + +sub delete_key +{ + my ($self, $key) = @_; + %config = %{$self{'confdata'}}; + if (defined($self{'keyvalue'}{$key})) { + for my $l (CORE::keys %{$self{'keyvalue'}{$key}}) { + $self{'keyvalue'}{$key}{$l}{'status'} = 'deleted'; + } + $self{'changed'} = 1; + } +} + +sub rename_key +{ + my ($self, $oldkey, $newkey) = @_; + %config = %{$self{'confdata'}}; + for my $i (0..$config{'lines'}) { + if (($config{$i}{'type'} eq 'data') && + ($config{$i}{'key'} eq $oldkey)) { + $config{$i}{'key'} = $newkey; + $self{'changed'} = 1; + } + } + if (defined($self{'keyvalue'}{$oldkey})) { + $self{'keyvalue'}{$newkey} = $self{'keyvalue'}{$oldkey}; + delete $self{'keyvalue'}{$oldkey}; + $self{'keyvalue'}{$newkey}{'status'} = 'changed'; + $self{'changed'} = 1; + } +} + +sub is_changed +{ + my $self = shift; + return $self{'changed'}; +} + +sub save +{ + my $self = shift; + my $outarg = shift; + my $closeit = 0; + # unless $outarg is defined or we are changed, return immediately + return if (! ( defined($outarg) || $self->is_changed)); + # + %config = %{$self{'confdata'}}; + # + # determine where to write to + my $out = $outarg; + my $fhout; + if (!defined($out)) { + $out = $config{'file'}; + my $dn = TeXLive::TLUtils::dirname($out); + TeXLive::TLUtils::mkdirhier($dn); + if (!open(CFG, ">$out")) { + tlwarn("Cannot write to $out: $!\n"); + return 0; + } + $closeit = 1; + $fhout = \*CFG; + } else { + # check what we got there for $out + if (ref($out) eq 'SCALAR') { + # that is a file name + my $dn = TeXLive::TLUtils::dirname($out); + TeXLive::TLUtils::mkdirhier($dn); + if (!open(CFG, ">$out")) { + tlwarn("Cannot write to $out: $!\n"); + return 0; + } + $fhout = \*CFG; + $closeit = 1; + } elsif (ref($out) eq 'GLOB') { + # that hopefully is a fh + $fhout = $out; + } else { + tlwarn("Unknown out argument $out\n"); + return 0; + } + } + + # + # first we write the config file as close as possible to orginal layout, + # and after that we add new key/value pairs + my $current_key_value_is_changed = 0; + for my $i (0..$config{'lines'}) { + if ($config{$i}{'type'} eq 'comment') { + print $fhout "$config{$i}{'value'}"; + print $fhout ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'empty') { + print $fhout ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'data') { + $current_key_value_is_changed = 0; + # we have to check whether the original data has been changed!! + if ($self{'keyvalue'}{$config{$i}{'key'}}{$i}{'status'} eq 'changed') { + $current_key_value_is_changed = 1; + print $fhout "$config{$i}{'key'} $config{'sep'} $self{'keyvalue'}{$config{$i}{'key'}}{$i}{'value'}"; + if (defined($config{$i}{'postcomment'})) { + print $fhout $config{$i}{'postcomment'}; + } + # if a value is changed, we do not print out multiline stuff + # as keys are not split + print $fhout "\n"; + } elsif ($self{'keyvalue'}{$config{$i}{'key'}}{$i}{'status'} eq 'deleted') { + $current_key_value_is_changed = 1; + } else { + $current_key_value_is_changed = 0; + # the original already contains the final \, so only print new line + print $fhout "$config{$i}{'original'}\n"; + } + } elsif ($config{$i}{'type'} eq 'continuation') { + if ($current_key_value_is_changed) { + # ignore continuation lines if values are changed + } else { + print $fhout "$config{$i}{'value'}"; + print $fhout ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } + } + } + # + # save new keys + for my $k (CORE::keys %{$self{'keyvalue'}}) { + for my $l (CORE::keys %{$self{'keyvalue'}{$k}}) { + if ($self{'keyvalue'}{$k}{$l}{'status'} eq 'new') { + print $fhout "$k $config{'sep'} $self{'keyvalue'}{$k}{$l}{'value'}\n"; + } + } + } + close $fhout if $closeit; + # + # reparse myself + if (!defined($outarg)) { + $self->reparse; + } +} + + + + +# +# parse/write config file +# these functions allow reading and writing of config files +# that consists of comments (comment char/string is the second argument) +# and pairs +# \s* key \s* SEP \s* value \s* +# where SEP is the third argument, +# and key does not contain neither white space nor SEP +# and value can be arbitry +# +# continuation lines are allowed +# Furthermore, at least the separator has to be on the same line as the key!! +# Continuations followed by comment lines are invalid! +# +sub parse_config_file { + my ($file, $cc, $sep) = @_; + my @data; + if (!open(CFG, "<$file")) { + @data = (); + } else { + @data = <CFG>; + chomp(@data); + close(CFG); + } + + my %config = (); + $config{'file'} = $file; + $config{'cc'} = $cc; + $config{'sep'} = $sep; + + my $lines = $#data; + my $cont_running = 0; + for my $l (0..$lines) { + $config{$l}{'original'} = $data[$l]; + if ($cont_running) { + if ($data[$l] =~ m/^(.*)\\$/) { + $config{$l}{'type'} = 'continuation'; + $config{$l}{'multiline'} = 1; + $config{$l}{'value'} = $1; + next; + } else { + # last line of a continuation + # do nothing, we will finish here + $config{$l}{'type'} = 'continuation'; + $config{$l}{'value'} = $data[$l]; + $cont_running = 0; + next; + } + } + # ignore continuation after comments, that is the behaviour the + # kpathsea library is using, so we follow it here + if ($data[$l] =~ m/$cc/) { + $data[$l] =~ s/\\$//; + } + # continuation line + if ($data[$l] =~ m/^(.*)\\$/) { + $cont_running = 1; + $config{$l}{'multiline'} = 1; + # remove the continuation marker so that we can do everything + # as normal below + $data[$l] =~ s/\\$//; + # we will continue below + } + # from now on, if $cont_running == 1, then it means that + # we are in the FIRST line of a multi line setting, so evaluate + # it accordingly to get the key if necessary + + # empty lines are treated as comments + if ($data[$l] =~ m/^\s*$/) { + $config{$l}{'type'} = 'empty'; + next; + } + if ($data[$l] =~ m/^\s*$cc/) { + # save the full line as is into the config hash + $config{$l}{'type'} = 'comment'; + $config{$l}{'value'} = $data[$l]; + next; + } + # mind that the .*? is making the .* NOT greedy, ie matching as few as + # possible. That way we can get rid of the comments at the end of lines + if ($data[$l] =~ m/^\s*([^\s$sep]+)\s*$sep\s*(.*?)(\s*)?($cc.*)?$/) { + $config{$l}{'type'} = 'data'; + $config{$l}{'key'} = $1; + $config{$l}{'value'} = $2; + if (defined($3)) { + my $postcomment = $3; + if (defined($4)) { + $postcomment .= $4; + } + # check that there is actually a comment in the second part of the + # line. Otherwise we might add the continuation lines of that + # line to the value + if ($postcomment =~ m/$cc/) { + $config{$l}{'postcomment'} = $postcomment; + } + } + next; + } + # if we are still here, that means we cannot evaluate the config file + # give a BIG FAT WARNING but save the line as comment and continue + # anyway + warn("WARNING WARNING WARNING\n"); + warn("Cannot parse config file $file ($cc, $sep)\n"); + warn("The following line (l.$l) seems to be wrong:\n"); + warn(">>> $data[$l]\n"); + warn("We will treat this line as a comment!\n"); + $config{$l}{'type'} = 'comment'; + $config{$l}{'value'} = $data[$l]; + } + # save the number of lines in the config hash + $config{'lines'} = $lines; + #print "====DEBUG dumping config ====\n"; + #dump_config_data(\%config); + #print "====DEBUG writing config ====\n"; + #write_config_file(\%config); + #print "=============================\n"; + return %config; +} + +sub dump_myself { + my $self = shift; + print "======== DUMPING SELF =============\n"; + dump_config_data($self{'confdata'}); + print "DUMPING KEY VALUES\n"; + for my $k (CORE::keys %{$self{'keyvalue'}}) { + print "key = $k\n"; + for my $l (sort CORE::keys %{$self{'keyvalue'}{$k}}) { + print " line =$l= value =", $self{'keyvalue'}{$k}{$l}{'value'}, "= status =", $self{'keyvalue'}{$k}{$l}{'status'}, "=\n"; + } + } + print "=========== END DUMP ==============\n"; +} + +sub dump_config_data { + my $foo = shift; + my %config = %{$foo}; + print "config file name: $config{'file'}\n"; + print "config comment char: $config{'cc'}\n"; + print "config separator: $config{'sep'}\n"; + print "config lines: $config{'lines'}\n"; + for my $i (0..$config{'lines'}) { + print "line ", $i+1, ": $config{$i}{'type'}"; + if ($config{$i}{'type'} eq 'comment') { + print "\nCOMMENT = $config{$i}{'value'}\n"; + } elsif ($config{$i}{'type'} eq 'data') { + print "\nKEY = $config{$i}{'key'}\nVALUE = $config{$i}{'value'}\n"; + print "MULTLINE = ", ($config{$i}{'multiline'} ? "1" : "0"), "\n"; + } elsif ($config{$i}{'type'} eq 'empty') { + print "\n"; + # do nothing + } elsif ($config{$i}{'type'} eq 'continuation') { + print "\nVALUE = $config{$i}{'value'}\n"; + print "MULTLINE = ", ($config{$i}{'multiline'} ? "1" : "0"), "\n"; + } else { + print "-- UNKNOWN TYPE\n"; + } + } +} + +sub write_config_file { + my $foo = shift; + my %config = %{$foo}; + for my $i (0..$config{'lines'}) { + if ($config{$i}{'type'} eq 'comment') { + print "$config{$i}{'value'}"; + print ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'data') { + print "$config{$i}{'key'} $config{'sep'} $config{$i}{'value'}"; + if ($config{$i}{'multiline'}) { + print "\\"; + } + print "\n"; + } elsif ($config{$i}{'type'} eq 'empty') { + print ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'continuation') { + print "$config{$i}{'value'}"; + print ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } else { + print STDERR "-- UNKNOWN TYPE\n"; + } + } +} + + +1; +__END__ + + +=head1 NAME + +C<TeXLive::TLConfFile> -- TeX Live Config File Access Module + +=head1 SYNOPSIS + + use TeXLive::TLConfFile; + + $conffile = TeXLive::TLConfFile->new($file_name, $comment_char, $separator, $type); + $conffile->file; + $conffile->cc; + $conffile->sep; + $conffile->type + $conffile->key_present($key); + $conffile->keys; + $conffile->value($key [, $value, ...]); + $conffile->is_changed; + $conffile->save; + $conffile->reparse; + +=head1 DESCRIPTION + +This module allows parsing, changing, saving of configuration files +of a general style. It also supports three different paradigma +with respect to multiple occurrences of keys: C<first-win> specifies +a configuration file where the first occurrence of a key specifies +the value, C<last-win> specifies that the last wins, and +C<multiple> that all keys are kept. + +The configuration files (henceforth conffiles) can contain comments +initiated by the $comment_char defined at instantiation time. +Everything after a $comment_char, as well as empty lines, will be ignored. + +The rest should consists of key/value pairs separated by the separator, +defined as well at instantiation time. + +Whitespace around the separator, and before and after key and value +are allowed. + +Comments can be on the same line as key/value pairs and are also preserved +over changes. + +Continuation lines (i.e., lines with last character being a backslash) +are allowed after key/value pairs, but the key and +the separator has to be on the same line. + +Continuations are not possible in comments, so a terminal backslash in +a comment will be ignored, and in fact not written out on save. + +=head2 Methods + +=over 4 + +=item B<< $conffile = TeXLive::TLConfFile->new($file_name, $comment_char, $separator [, $type]) >> + +instantiates a new TLConfFile and returns the object. The file specified +by C<$file_name> does not have to exist, it will be created at save time. + +The C<$comment_char> can actually be any regular expression, but +embedding grouping is a bad idea as it will break parsing. + +The C<$separator> can also be any regular expression. + +The C<$type>, if present, has to be one of C<last-win> (the default), +C<first-win>, or C<multiple>. + +=item B<< $conffile->file >> + +Returns the location of the configuration file. Not changeable (at the moment). + +=item B<< $conffile->cc >> + +Returns the comment character. + +=item B<< $conffile->sep >> + +Returns the separator. + +=item B<< $conffile->type >> + +Returns the type. + +=item B<< $conffile->key_present($key) >> + +Returns true (1) if the given key is present in the config file, otherwise +returns false (0). + +=item B<< $conffile->keys >> + +Returns the list of keys currently set in the config file. + +=item B<< $conffile->value($key [, $value, ...]) >> + +With one argument, returns the current setting of C<$key>, or undefined +if the key is not set. If the configuration file is of C<multiple> +type a list of keys ordered by occurrence in the file is returned. + +With two (or more) arguments changes (or adds) the key/value pair to +the config file and returns the I<new> value. +In case of C<first-win> or C<last-win>, the respective occurrence +of the key is changed, and the others left intact. In this case only +the first C<$value> is used. + +In case of C<multiple> the C<$values> are assigned to the keys in the +order of occurrence in the file. If extra values are present, they +are added. If on the contrary less values then already existing +keys are passed, the remaining keys are deleted. + +=item B<< $conffile->rename_key($oldkey, $newkey) >> + +Renames a key from C<$oldkey> to C<$newkey>. It does not automatically +save the new config file. + +=item B<< $conffile->is_changed >> + +Returns true (1) if some real change has happened in the configuration file, +that is a value has been changed to something different, or a new +setting has been added. + +Note that changing a setting back to the original one will not reset +the changed flag. + +=item B<< $conffile->save >> + +Saves the config file, preserving as much structure and comments of +the original file as possible. + +=item B<< $conffile->reparse >> + +Reparses the configuration file. + + +=back + +=head1 EXAMPLES + +For parsing a C<texmf.cnf> file you can use + + $tmfcnf = TeXLive::TLConfFile->new(".../texmf-dist/web2c", "[#%]", "="); + +since the allowed comment characters for texmf.cnf files are # and %. +After that you can query keys: + + $tmfcnf->value("TEXMFMAIN"); + $tmfcnf->value("trie_size", 900000); + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLConfig.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLConfig.pm new file mode 100644 index 0000000000..9babc8f226 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLConfig.pm @@ -0,0 +1,367 @@ +# $Id: TLConfig.pm 50190 2019-03-01 23:32:44Z preining $ +# TeXLive::TLConfig.pm - module exporting configuration values +# Copyright 2007-2018 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLConfig; + +my $svnrev = '$Revision: 50190 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +BEGIN { + use Exporter (); + use vars qw( @ISA @EXPORT_OK @EXPORT ); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + $ReleaseYear + @MetaCategories + @NormalCategories + @Categories + $MetaCategoriesRegexp + $CategoriesRegexp + $DefaultCategory + @AcceptedFallbackDownloaders + %FallbackDownloaderProgram + %FallbackDownloaderArgs + $DefaultCompressorFormat + $CompressorExtRegexp + %Compressors + $InfraLocation + $DatabaseName + $PackageBackupDir + $BlockSize + $Archive + $TeXLiveServerURL + $TeXLiveServerPath + $TeXLiveURL + @CriticalPackagesList + $CriticalPackagesRegexp + $WindowsMainMenuName + $RelocPrefix + $RelocTree + %TLPDBOptions + %TLPDBSettings + %TLPDBConfigs + $NetworkTimeout + $PartialEngineSupport + $F_OK $F_WARNING $F_ERROR $F_NOPOSTACTION + $ChecksumLength + $ChecksumProgram + $ChecksumExtension + ); + @EXPORT = @EXPORT_OK; +} + +# the year of our release, will be used in the location of the +# network packages, and in menu names, and other places. +$ReleaseYear = 2019; + +# users can upgrade from this year to the current year; might be the +# same as the release year, or any number of releases earlier. +# Generally not tested. +$MinRelease = 2016; + +# Meta Categories do not ship files, but only call for other packages. +our @MetaCategories = qw/Collection Scheme/; +our $MetaCategoriesRegexp = '(Collection|Scheme)'; +# +# Normal Categories contain actial files and do not depend on other things. +our @NormalCategories = qw/Package TLCore ConTeXt/; +# +# list of all Categories +our @Categories = (@MetaCategories, @NormalCategories); + +# repeat, as a regexp. +our $CategoriesRegexp = '(Collection|Scheme|Package|TLCore|ConTeXt)'; + +our $DefaultCategory = "Package"; + +# location of various infra files (texlive.tlpdb, .tlpobj etc) +# relative to a root (e.g., the Master/, or the installation path) +our $InfraLocation = "tlpkg"; +our $DatabaseName = "texlive.tlpdb"; + +# location of backups in default autobackup setting (under tlpkg) +our $PackageBackupDir = "$InfraLocation/backups"; + +our $BlockSize = 4096; + +# timeout for network connections (wget, LWP) in seconds +our $NetworkTimeout = 30; + +our $Archive = "archive"; +our $TeXLiveServerURL = "http://mirror.ctan.org"; +# from 2009 on we try to put them all into tlnet directly without any +# release year since we hope that we can switch over to 2010 on the fly +# our $TeXLiveServerPath = "systems/texlive/tlnet/$ReleaseYear"; +our $TeXLiveServerPath = "systems/texlive/tlnet"; +our $TeXLiveURL = "$TeXLiveServerURL/$TeXLiveServerPath"; + +# Relocatable packages. +our $RelocTree = "texmf-dist"; +our $RelocPrefix = "RELOC"; + +our @CriticalPackagesList = qw/texlive.infra/; +our $CriticalPackagesRegexp = '^(texlive\.infra)'; +if ($^O =~ /^MSWin/i) { + push (@CriticalPackagesList, "tlperl.win32"); + $CriticalPackagesRegexp = '^(texlive\.infra|tlperl\.win32$)'; +} + +# +our @AcceptedFallbackDownloaders = qw/curl wget/; +our %FallbackDownloaderProgram = ( 'wget' => 'wget', 'curl' => 'curl'); +our %FallbackDownloaderArgs = ( + 'curl' => ['--user-agent', 'texlive/curl', '--retry', '10', + '--fail', '--location', + '--connect-timeout', "$NetworkTimeout", '--silent', '--output'], + 'wget' => ['--user-agent=texlive/wget', '--tries=10', + "--timeout=$NetworkTimeout", '-q', '-O'], +); +# the way we package things on the web +our $DefaultCompressorFormat = "xz"; +# priority defines which compressor is selected for backups/rollback containers +# less is better +our %Compressors = ( + "lz4" => { + "decompress_args" => ["-dcf"], + "compress_args" => ["-zfmq"], + "extension" => "lz4", + "priority" => 10, + }, + "gzip" => { + "decompress_args" => ["-dcf"], + "compress_args" => ["-f"], + "extension" => "gz", + "priority" => 20, + }, + "xz" => { + "decompress_args" => ["-dcf"], + "compress_args" => ["-zf"], + "extension" => "xz", + "priority" => 30, + }, +); +our $CompressorExtRegexp = "(" + . join("|", map { $Compressors{$_}{'extension'} } keys %Compressors) + . ")"; + +# archive (not user) settings. +# these can be overridden by putting them into 00texlive.config.tlpsrc +# in the format +# depend key/value +our %TLPDBConfigs = ( + "container_split_src_files" => 1, + "container_split_doc_files" => 1, + "container_format" => $DefaultCompressorFormat, + "minrelease" => $MinRelease, + "release" => $ReleaseYear, + "frozen" => 0, +); + +# definition of the option strings and their value types +# possible types are: +# - u: url +# - b: boolean, saved as 0/1 +# - p: path (local path) +# - n: natural number +# it allows n:[a]..[b] +# if a is empty start at -infty +# if b is empty end at +infty +# so "n:.." is equivalent to "n" + +# $TLPDBOptions{"option"}->[0] --> type +# ->[1] --> default value +# ->[2] --> tlmgr name +# ->[3] --> tlmgr description +# the "option" is the value in the TLPDB + +our %TLPDBOptions = ( + "autobackup" => + [ "n:-1..", 1, "autobackup", + "Number of backups to keep" ], + "backupdir" => + [ "p", $PackageBackupDir, "backupdir", + "Directory for backups" ], + "create_formats" => + [ "b", 1, "formats", + "Create formats on installation" ], + "desktop_integration" => + [ "b", 1, "desktop_integration", + "Create Start menu shortcuts (w32)" ], + "file_assocs" => + [ "n:0..2", 1, "fileassocs", + "Change file associations (w32)" ], + "generate_updmap" => + [ "b", 0, "generate_updmap", + "Run tlmgr generate updmap after maps have changed" ], + "install_docfiles" => + [ "b", 1, "docfiles", + "Install documentation files" ], + "install_srcfiles" => + [ "b", 1, "srcfiles", + "Install source files" ], + "location" => + [ "u", "__MASTER__", "repository", + "Default package repository" ], + "post_code" => + [ "b", 1, "postcode", + "Run postinst code blobs" ], + "sys_bin" => + [ "p", "/usr/local/bin", "sys_bin", + "Destination for symlinks for binaries" ], + "sys_info" => + [ "p", "/usr/local/share/info", "sys_info", + "Destination for symlinks for info docs" ], + "sys_man" => + [ "p", "/usr/local/share/man", "sys_man", + "Destination for symlinks for man pages" ], + "w32_multi_user" => + [ "b", 1, "multiuser", + "Install for all users (w32)" ], +); + + +our %TLPDBSettings = ( + "platform" => [ "s", "Main platform for this computer" ], + "available_architectures" => [ "l","All available/installed architectures" ], + "usertree" => [ "b", "This tree acts as user tree" ] +); + +our $WindowsMainMenuName = "TeX Live $ReleaseYear"; + +# Comma-separated list of engines which do not exist on all platforms. +our $PartialEngineSupport = "luajittex,mfluajit"; + +# Flags for error handling across the scripts and modules +# all fine +our $F_OK = 0; +# +# some warnings, but we still try to run post actions +our $F_WARNING = 1; +# +# error, terminating +our $F_ERROR = 2; +# +# all fine, but no need to run post actions +our $F_NOPOSTACTION = 4; + +# The length of a checksum generated by tlchecksum and contained in +# texlive.tlpdb.checksum. Needs to be in agreement with the hash +# method used in TLCrypto::tlchecksum and TLCrypto::tldigest +our $ChecksumLength = 128; + +# The program generating the checksum for the file given as first +# argument +our $ChecksumProgram = "sha512sum"; + +# The extension of the checksum file +our $ChecksumExtension = "sha512"; + +1; + + +=head1 NAME + +C<TeXLive::TLConfig> -- TeX Live Configuration module + +=head1 SYNOPSIS + + use TeXLive::TLConfig; + +=head1 DESCRIPTION + +The L<TeXLive::TLConfig> module contains definitions of variables +configuring all of TeX Live. + +=over 4 + +=head1 EXPORTED VARIABLES + +All of the following variables are pulled into the callers namespace, +i.e., are declared with C<EXPORT> (and C<EXPORT_OK>). + +=item C<@TeXLive::TLConfig::MetaCategories> + +The list of meta categories, i.e., those categories whose packages only +depend on other packages, but don't ship any files. Currently +C<Collection> and <Scheme>. + +=item C<@TeXLive::TLConfig::NormalCategories> + +The list of normal categories, i.e., those categories whose packages do +ship files. Currently C<TLCore>, C<Package>, C<ConTeXt>. + +=item C<@TeXLive::TLConfig::Categories> + +The list of all categories, i.e., the union of the above. + +=item C<$TeXLive::TLConfig::CategoriesRegexp> + +A regexp matching any category. + +=item C<$TeXLive::TLConfig::DefaultCategory> + +The default category used when creating new packages. + +=item C<$TeXLive::TLConfig::InfraLocation> + +The subdirectory with various infrastructure files (C<texlive.tlpdb>, +tlpobj files, ...) relative to the root of the installation; currently +C<tlpkg>. + +=item C<$TeXLive::TLConfig::BlockSize> + +The assumed block size, currently 4k. + +=item C<$TeXLive::TLConfig::Archive> +=item C<$TeXLive::TLConfig::TeXLiveURL> + +These values specify where to find packages. + +=item C<$TeXLive::TLConfig::TeXLiveServerURL> +=item C<$TeXLive::TLConfig::TeXLiveServerPath> + +C<TeXLiveURL> is concatenated from these values, with a string between. +The defaults are respectively, C<http://mirror.ctan.org> and +C<systems/texlive/tlnet/>. + +=item C<@TeXLive::TLConfig::CriticalPackagesList> +=item C<@TeXLive::TLConfig::CriticalPackagesRegexp> + +A list of all those packages which we do not update regularly since they +are too central, currently texlive.infra and (for Windows) tlperl.win32. + +=item C<$TeXLive::TLConfig::RelocTree> + +The texmf-tree name that can be relocated, defaults to C<texmf-dist>. + +=item C<$TeXLive::TLConfig::RelocPrefix> + +The string that replaces the C<RelocTree> in the tlpdb if a package is +relocated, defaults to C<RELOC>". + +=back + +=head1 SEE ALSO + +All the other TeX Live modules and scripts, especially C<tlmgr> and +C<install-tl>, and the documentation in the repository: +C<Master/tlpkg/doc/>. + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLCrypto.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLCrypto.pm new file mode 100644 index 0000000000..293d9555b9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLCrypto.pm @@ -0,0 +1,600 @@ +# $Id: TLCrypto.pm 51838 2019-08-07 21:53:30Z karl $ +# TeXLive::TLCrypto.pm - handle checksums and signatures. +# Copyright 2016-2019 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLCrypto; + +use Digest::MD5; + +use TeXLive::TLConfig; +use TeXLive::TLUtils qw(debug ddebug win32 which platform + conv_to_w32_path tlwarn tldie); + +my $svnrev = '$Revision: 51838 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +=pod + +=head1 NAME + +C<TeXLive::TLCrypto> -- checksums and cryptographic signatures + +=head1 SYNOPSIS + + use TeXLive::TLCrypto; # requires Digest::MD5 and Digest::SHA + +=head2 Setup + + TeXLive::TLCrypto::setup_checksum_method(); + +=head2 Checksums + + TeXLive::TLCrypto::tlchecksum($path); + TeXLive::TLCrypto::verify_checksum($file, $url); + +=head2 Signatures + + TeXLive::TLCrypto::setup_gpg(); + TeXLive::TLCrypto::verify_signature($file, $url); + +=head1 DESCRIPTION + +=cut + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT_OK @EXPORT); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + &tlchecksum + &tl_short_digest + &verify_checksum + &setup_gpg + &verify_signature + %VerificationStatusDescription + $VS_VERIFIED $VS_CHECKSUM_ERROR $VS_SIGNATURE_ERROR $VS_CONNECTION_ERROR + $VS_UNSIGNED $VS_GPG_UNAVAILABLE $VS_PUBKEY_MISSING $VS_UNKNOWN + $VS_EXPKEYSIG $VS_REVKEYSIG + ); + @EXPORT = qw( + %VerificationStatusDescription + $VS_VERIFIED $VS_CHECKSUM_ERROR $VS_SIGNATURE_ERROR $VS_CONNECTION_ERROR + $VS_UNSIGNED $VS_GPG_UNAVAILABLE $VS_PUBKEY_MISSING $VS_UNKNOWN + $VS_EXPKEYSIG $VS_REVKEYSIG + ); +} + +=pod + +=over 4 + +=item C<< setup_checksum_method() >> + +Tries to find a checksum method: check usability of C<Digest::SHA>, +then the programs C<openssl>, C<sha512sum>, and C<shasum>, in that +order. On old-enough Macs, C<openssl> is present but does not have +the option C<-sha512>, while the separate program C<shasum> does suffice. + +Returns the checksum method as a string, and also sets +C<<$::checksum_method>>, or false if none found. + +=cut + +sub setup_checksum_method { + # make it a noop if already defined + # the checksum method could also be "" meaning that there + # is none. We do not need to check again. Thus we check + # on defined. + return ($::checksum_method) if defined($::checksum_method); + # default is no checksum + $::checksum_method = ""; + # for debugging + # $::checksum_method = "sha512sum"; + # return($::checksum_method); + # try to load Digest::SHA, and if that fails, use our own slow modules + eval { + require Digest::SHA; + Digest::SHA->import('sha512_hex'); + debug("Using checksum method digest::sha\n"); + $::checksum_method = "digest::sha"; + }; + if ($@ && ($^O !~ /^MSWin/i)) { + # for unix like environments we test other programs (openssl, sha512sum, + # shasum), too + my $ret; + + # first for openssl dgst -sha512 + # old MacOS openssl does not support -sha512! + $ret = system("openssl dgst -sha512 >/dev/null 2>&1 </dev/null" ); + if ($ret == 0) { + debug("Using checksum method openssl\n"); + return($::checksum_method = "openssl"); + } + + # next for sha512sum, but this is not available on old MacOS + if (TeXLive::TLUtils::which("sha512sum")) { + debug("Using checksum method sha512sum\n"); + return($::checksum_method = "sha512sum"); + } + + # shasum for old Macs + $ret = system("shasum -a 512 >/dev/null 2>&1 </dev/null" ); + if ($ret == 0) { + debug("Using checksum method shasum\n"); + return($::checksum_method = "shasum"); + } + + debug("Cannot find usable checksum method!\n"); + } + return($::checksum_method); +} + + +=pod + +=item C<< tlchecksum($file) >> + +Return checksum of C<$file>. + +=cut + +sub tlchecksum { + my ($file) = @_; + # this is here for the case that a script forgets to + # set up the checksum method! + if (!$::checksum_method) { + setup_checksum_method(); + } + tldie("no checksum method available\n") if (!$::checksum_method); + if (-r $file) { + my ($out, $ret); + if ($::checksum_method eq "openssl") { + ($out, $ret) = TeXLive::TLUtils::run_cmd("openssl dgst -sha512 $file"); + chomp($out); + } elsif ($::checksum_method eq "sha512sum") { + ($out, $ret) = TeXLive::TLUtils::run_cmd("sha512sum $file"); + chomp($out); + } elsif ($::checksum_method eq "shasum") { + ($out, $ret) = TeXLive::TLUtils::run_cmd("shasum -a 512 $file"); + chomp($out); + } elsif ($::checksum_method eq "digest::sha") { + open(FILE, $file) || die "open($file) failed: $!"; + binmode(FILE); + $out = Digest::SHA->new(512)->addfile(*FILE)->hexdigest; + close(FILE); + $ret = 0; + } else { + tldie("unknown checksum program: $::checksum_method\n"); + } + if ($ret != 0) { + tlwarn("tlchecksum: cannot compute checksum: $file\n"); + return ""; + } + ddebug("tlchecksum: out = $out\n"); + my $cs; + if ($::checksum_method eq "openssl") { + (undef,$cs) = split(/= /,$out); + } elsif ($::checksum_method eq "sha512sum") { + ($cs,undef) = split(' ',$out); + } elsif ($::checksum_method eq "shasum") { + ($cs,undef) = split(' ',$out); + } elsif ($::checksum_method eq "digest::sha") { + $cs = $out; + } + debug("tlchecksum($file): ===$cs===\n"); + if (length($cs) != 128) { + tlwarn("unexpected output from $::checksum_method: $out\n"); + return ""; + } + return $cs; + } else { + tlwarn("tlchecksum: given file not readable: $file\n"); + return ""; + } +} + +# sub tlchecksum { +# my ($file) = @_; +# if (-r $file) { +# open(FILE, $file) || die "open($file) failed: $!"; +# binmode(FILE); +# my $cshash = $dig->new(512)->addfile(*FILE)->hexdigest; +# close(FILE); +# return $cshash; +# } else { +# tlwarn("tlchecksum: given file not readable: $file\n"); +# return ""; +# } +# } + +=pod + +=item C<< tl_short_digest($str) >> + +Return short digest (MD5) of C<$str>. + +=cut + +sub tl_short_digest { return (Digest::MD5::md5_hex(shift)); } + +# emacs-page +=pod + +=item C<< verify_checksum($file, $checksum_url) >> + +Verifies that C<$file> has checksum C<$checksum_url>, and if gpg is +available also verifies that the checksum is signed. + +Returns +C<$VS_VERIFIED> on success, +C<$VS_CONNECTION_ERROR> on connection error, +C<$VS_UNSIGNED> on missing signature file, +C<$VS_GPG_UNAVAILABLE> if no gpg program is available, +C<$VS_PUBKEY_MISSING> if the pubkey is not available, +C<$VS_CHECKSUM_ERROR> on checksum errors, +C<$VS_EXPKEYSIG> if the signature is good but was made with an expired key, +C<$VS_REVKEYSIG> if the signature is good but was made with a revoked key, +and C<$VS_SIGNATURE_ERROR> on signature errors. +In case of errors returns an informal message as second argument. + +=cut + +sub verify_checksum { + my ($file, $checksum_url) = @_; + # don't do anything if we cannot determine a checksum method + # return -2 which is as much as missing signature + return($VS_UNSIGNED) if (!$::checksum_method); + my $checksum_file + = TeXLive::TLUtils::download_to_temp_or_file($checksum_url); + + # next step is verification of tlpdb checksum with checksum file + # existenc of checksum_file was checked above + if (!$checksum_file) { + debug("verify_checksum: download did not succeed for $checksum_url\n"); + return($VS_CONNECTION_ERROR, "download did not succeed: $checksum_url"); + } + + # check that we have a non-trivial size for the checksum file + # the size should be at least 128 + 1 + length(filename) > 129 + { + my $css = -s $checksum_file; + if ($css <= 128) { + debug("verify_checksum: size of checksum file suspicious: $css\n"); + return($VS_CONNECTION_ERROR, "download corrupted: $checksum_url"); + } + } + + # check the signature + my ($ret, $msg) = verify_signature($checksum_file, $checksum_url); + + if ($ret != 0) { + debug("verify_checksum: returning $ret and $msg\n"); + return ($ret, $msg) + } + + # verify local data + open $cs_fh, "<$checksum_file" or die("cannot read file: $!"); + if (read ($cs_fh, $remote_digest, $ChecksumLength) != $ChecksumLength) { + close($cs_fh); + debug("verify_checksum: incomplete read from\n $checksum_file\nfor\n $file\nand\n $checksum_url\n"); + return($VS_CHECKSUM_ERROR, "incomplete read from $checksum_file"); + } else { + close($cs_fh); + debug("verify_checksum: found remote digest\n $remote_digest\nfrom\n $checksum_file\nfor\n $file\nand\n $checksum_url\n"); + } + $local_digest = tlchecksum($file); + debug("verify_checksum: local_digest = $local_digest\n"); + if ($local_digest ne $remote_digest) { + return($VS_CHECKSUM_ERROR, "digest disagree"); + } + + # we are still here, so checksum also succeeded + debug("checksum of local copy identical with remote hash\n"); + + return(0); +} + +# emacs-page +=pod + +=item C<< setup_gpg() >> + +Tries to set up gpg command line C<$::gpg> used for verification of +downloads. Checks for the environment variable C<TL_GNUPG>; if that +envvar is not set, first C<gpg>, then C<gpg2>, then, on Windows only, +C<tlpkg/installer/gpg/gpg.exe> is looked for. Further adaptation of the +invocation of C<gpg> can be done using the two enviroment variables +C<TL_GNUPGHOME>, which is passed to C<gpg> with C<--homedir>, and +C<TL_GNUPGARGS>, which replaces the default arguments +C<--no-secmem-warning --no-permission-warning>. + +Returns 1/0 on success/failure. + +=cut + +sub setup_gpg { + my $master = shift; + my $found = 0; + my $prg; + if ($ENV{'TL_GNUPG'}) { + # if envvar is set, don't look for anything else. + $prg = test_one_gpg($ENV{'TL_GNUPG'}); + $found = 1 if ($prg); + } else { + # no envvar, look for gpg + $prg = test_one_gpg('gpg'); + $found = 1 if ($prg); + + # no gpg, look for gpg2 + if (!$found) { + $prg = test_one_gpg('gpg2'); + $found = 1 if ($prg); + } + if (!$found) { + # test also a shipped version from tlgpg + my $p = "$master/tlpkg/installer/gpg/gpg." . + ($^O =~ /^MSWin/i ? "exe" : platform()) ; + debug("Testing for gpg in $p\n"); + if (-r $p) { + if ($^O =~ /^MSWin/i) { + $prg = conv_to_w32_path($p); + } else { + $prg = "\"$p\""; + } + $found = 1; + } + } + } + return 0 if (!$found); + + # $prg is already properly quoted! + + # ok, we found one + # Set up the gpg invocation: + my $gpghome = ($ENV{'TL_GNUPGHOME'} ? $ENV{'TL_GNUPGHOME'} : + "$master/tlpkg/gpg" ); + $gpghome =~ s!/!\\!g if win32(); + my $gpghome_quote = "\"$gpghome\""; + # mind the final space for following args + $::gpg = "$prg --homedir $gpghome_quote "; + # + # check for additional keyring + # originally we wanted to use TEXMFSYSCONFIG, but gnupg on Windows + # is so stupid that it *prepends* GNUPGHOME to paths starting with + # a drive letter like c:/ + # Thus we switch to using repository-keys.gpg in GNUPGHOME! + my $addkr = "$gpghome/repository-keys.gpg"; + if (-r $addkr) { + debug("setup_gpg: using additional keyring $addkr\n"); + $::gpg .= "--keyring repository-keys.gpg "; + } + if ($ENV{'TL_GNUPGARGS'}) { + $::gpg .= $ENV{'TL_GNUPGARGS'}; + } else { + $::gpg .= "--no-secmem-warning --no-permission-warning --lock-never "; + } + debug("gpg command line: $::gpg\n"); + return 1; +} + +sub test_one_gpg { + my $prg = shift; + my $cmdline; + debug("Testing for gpg in $prg\n"); + if ($^O =~ /^MSWin/i) { + # Perl on Windows somehow does not allow calling a program + # without a full path - at least a call to "gpg" tells me + # that "c:/Users/norbert/gpg" is not recognized ... + # consequence - use which! + $prg = which($prg); + return "" if (!$prg); + $prg = conv_to_w32_path($prg); + $cmdline = "$prg --version >nul 2>&1"; + } else { + $cmdline = "$prg --version >/dev/null 2>&1"; + } + my $ret = system($cmdline); + if ($ret == 0) { + debug(" ... gpg ok! [$cmdline]\n"); + return $prg; + } else { + debug(" ... gpg not ok! [$cmdline]\n"); + return ""; + } +} + +# emacs-page +=pod + +=item C<< verify_signature($file, $url) >> + +Verifies a download of C<$url> into C<$file> by cheking the +gpg signature in C<$url.asc>. + +Returns +$VS_VERIFIED on success, +$VS_REVKEYSIG on good signature but from revoked key, +$VS_EXPKEYSIG on good signature but from expired key, +$VS_UNSIGNED on missing signature file, +$VS_SIGNATURE_ERROR on signature error, +$VS_GPG_UNAVAILABLE if no gpg is available, and +$VS_PUBKEY_MISSING if a pubkey is missing. +In case of errors returns an informal message as second argument. + +=cut + +sub verify_signature { + my ($file, $url) = @_; + my $signature_url = "$url.asc"; + + # if we have $::gpg set, we try to verify cryptographic signatures + if ($::gpg) { + my $signature_file + = TeXLive::TLUtils::download_to_temp_or_file($signature_url); + if ($signature_file) { + { + # we expect a signature to be at least + # 30 header line + 30 footer line + 256 > 300 + my $sigsize = -s $signature_file; + if ($sigsize < 300) { + debug("cryptographic signature seems to be corrupted (size $sigsize<300): $signature_url, $signature_file\n"); + return($VS_UNSIGNED, "cryptographic signature download seems to be corrupted (size $sigsize<300)"); + } + } + # check also the first line of the signature file for + # -----BEGIN PGP SIGNATURE----- + { + open my $file, '<', $signature_file; + chomp(my $firstLine = <$file>); + close $file; + if ($firstLine !~ m/^-----BEGIN PGP SIGNATURE-----/) { + debug("cryptographic signature seems to be corrupted (first line not signature): $signature_url, $signature_file, $firstLine\n"); + return($VS_UNSIGNED, "cryptographic signature download seems to be corrupted (first line of $signature_url not signature: $firstLine)"); + } + } + my ($ret, $out) = gpg_verify_signature($file, $signature_file); + if ($ret == $VS_VERIFIED) { + # no need to show the output + debug("cryptographic signature of $url verified\n"); + return($VS_VERIFIED); + } elsif ($ret == $VS_PUBKEY_MISSING) { + return($VS_PUBKEY_MISSING, $out); + } elsif ($ret == $VS_EXPKEYSIG) { + return($VS_EXPKEYSIG, $out); + } elsif ($ret == $VS_REVKEYSIG) { + return($VS_REVKEYSIG, $out); + } else { + return($VS_SIGNATURE_ERROR, <<GPGERROR); +cryptographic signature verification of + $file +against + $signature_url +failed. Output was: +$out +Please try from a different mirror and/or wait a few minutes +and try again; usually this is because of transient updates. +If problems persist, feel free to report to texlive\@tug.org. +GPGERROR + } + } else { + debug("no access to cryptographic signature $signature_url\n"); + return($VS_UNSIGNED, "no access to cryptographic signature"); + } + } else { + debug("gpg prog not defined, no checking of signatures\n"); + # we return 0 (= success) if not gpg is available + return($VS_GPG_UNAVAILABLE, "no gpg available"); + } + # not reached + return ($VS_UNKNOWN); +} + +=pod + +=item C<< gpg_verify_signature($file, $sig) >> + +Internal routine running gpg to verify signature C<$sig> of C<$file>. + +=cut + +sub gpg_verify_signature { + my ($file, $sig) = @_; + my ($file_quote, $sig_quote); + if (win32()) { + $file =~ s!/!\\!g; + $sig =~ s!/!\\!g; + } + $file_quote = TeXLive::TLUtils::quotify_path_with_spaces ($file); + $sig_quote = TeXLive::TLUtils::quotify_path_with_spaces ($sig); + my ($status_fh, $status_file) = TeXLive::TLUtils::tl_tmpfile(); + close($status_fh); + my ($out, $ret) + = TeXLive::TLUtils::run_cmd("$::gpg --status-file \"$status_file\" --verify $sig_quote $file_quote 2>&1"); + # read status file + open($status_fd, "<", $status_file) || die("Cannot open status file: $!"); + my @status_lines = <$status_fd>; + close($status_fd); + chomp(@status_lines); + debug(join("\n", "STATUS OUTPUT", @status_lines)); + if ($ret == 0) { + # verification still might return success but key is expired! + if (grep(/EXPKEYSIG/, @status_lines)) { + return($VS_EXPKEYSIG, "expired key"); + } + if (grep(/REVKEYSIG/, @status_lines)) { + return($VS_REVKEYSIG, "revoked key"); + } + debug("verification succeeded, output:\n$out\n"); + return ($VS_VERIFIED, $out); + } else { + if (grep(/^\[GNUPG:\] NO_PUBKEY (.*)/, @status_lines)) { + debug("missing pubkey $1\n"); + return ($VS_PUBKEY_MISSING, "missing pubkey $1"); + } + # we could do more checks on what is the actual problem here! + return ($VS_SIGNATURE_ERROR, $out); + } +} + +=pod + +=item C<< %VerificationStatusDescription >> + +Provides a textual representation for the verification status values. + +=cut + +our $VS_VERIFIED = 0; +our $VS_CHECKSUM_ERROR = 1; +our $VS_SIGNATURE_ERROR = 2; +our $VS_CONNECTION_ERROR = -1; +our $VS_UNSIGNED = -2; +our $VS_GPG_UNAVAILABLE = -3; +our $VS_PUBKEY_MISSING = -4; +our $VS_EXPKEYSIG = -5; +our $VS_EXPSIG = -6; +our $VS_REVKEYSIG = -7; +our $VS_UNKNOWN = -100; + +our %VerificationStatusDescription = ( + $VS_VERIFIED => 'verified', + $VS_CHECKSUM_ERROR => 'checksum error', + $VS_SIGNATURE_ERROR => 'signature error', + $VS_CONNECTION_ERROR => 'connection error', + $VS_UNSIGNED => 'unsigned', + $VS_GPG_UNAVAILABLE => 'gpg unavailable', + $VS_PUBKEY_MISSING => 'pubkey missing', + $VS_EXPKEYSIG => 'valid signature with expired key', + $VS_EXPSIG => 'valid but expired signature', + $VS_UNKNOWN => 'unknown', +); + +=back +=cut + +1; +__END__ + +=head1 SEE ALSO + +The modules L<TeXLive::Config>, L<TeXLive::TLUtils>, etc., +and the documentation in the repository: C<Master/tlpkg/doc/>. +Also the standard modules L<Digest::MD5> and L<Digest::SHA>. + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLDownload.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLDownload.pm new file mode 100644 index 0000000000..e756914562 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLDownload.pm @@ -0,0 +1,209 @@ +# $Id: TLDownload.pm 42254 2016-10-11 01:22:02Z preining $ +# TeXLive::TLDownload.pm - module for abstracting the download modes +# Copyright 2009-2016 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLDownload; + +use TeXLive::TLUtils; +use TeXLive::TLConfig; + +my $svnrev = '$Revision: 42254 $'; +my $_modulerevision; +if ($svnrev =~ m/: ([0-9]+) /) { + $_modulerevision = $1; +} else { + $_modulerevision = "unknown"; +} +sub module_revision { + return $_modulerevision; +} + +my $MAX_ERRORCOUNT = 5; + +# since Net::HTTP and Net::FTP are shipped by the same packages +# we only test for Net::HTTP, if that fails, let us know ;-) +our $net_lib_avail = 0; +eval { require LWP; }; +if ($@) { + debug("LWP is not available, falling back to wget.\n"); + $net_lib_avail = 0; +} else { + require LWP::UserAgent; + require HTTP::Status; + $net_lib_avail = 1; + ddebug("LWP available, doing persistent downloads.\n"); +} + + +sub new +{ + my $class = shift; + my $self = {}; + my $ua = LWP::UserAgent->new( + agent => "texlive/lwp", + # use LWP::ConnCache, and keep 1 connection open + keep_alive => 1, + env_proxy => 1, + timeout => $TeXLive::TLConfig::NetworkTimeout, + ); + $self->{'ua'} = $ua; + $self->{'enabled'} = 1; + $self->{'errorcount'} = 0; + bless $self, $class; + return $self; +} + + + + +sub enabled +{ + my $self = shift; + return $self->{'enabled'}; +} +sub disabled +{ + my $self = shift; + return (!$self->{'enabled'}); +} +sub enable +{ + my $self = shift; + $self->{'enabled'} = 1; + # also reset the error conter + $self->reset_errorcount; +} +sub disable +{ + my $self = shift; + $self->{'enabled'} = 0; +} +sub errorcount +{ + my $self = shift; + if (@_) { $self->{'errorcount'} = shift } + return $self->{'errorcount'}; +} +sub incr_errorcount +{ + my $self = shift; + return(++$self->{'errorcount'}); +} +sub decr_errorcount +{ + my $self = shift; + if ($self->errorcount > 0) { + return(--$self->{'errorcount'}); + } else { + return($self->errorcount(0)); + } +} + +sub reset_errorcount { + my $self = shift; + $self->{'errorcount'} = 0; +} + +sub get_file { + my ($self,$url,$out,$size) = @_; + # + # automatically disable if error count is getting too big + if ($self->errorcount > $MAX_ERRORCOUNT) { + $self->disable; + } + # return if disabled + return if $self->disabled; + # + my $realout = $out; + my ($outfh, $outfn); + if ($out eq "|") { + ($outfh, $outfn) = tl_tmpfile(); + $realout = $outfn; + } + my $response = $self->{'ua'}->get($url, ':content_file' => $realout); + if ($response->is_success) { + $self->decr_errorcount; + if ($out ne "|") { + return 1; + } else { + # seek to beginning of file + seek $outfh, 0, 0; + return $outfh; + } + } else { + debug("TLDownload::get_file: response error: " + . $response->status_line . " (for $url)\n"); + $self->incr_errorcount; + return; + } +} + + + +1; +__END__ + + +=head1 NAME + +C<TeXLive::TLDownload> -- TeX Live Download abstraction module + +=head1 SYNOPSIS + + use TeXLive::TLDownload; + + $TeXLive::TLDownload::net_lib_avail + my $dl = TeXLive::TLDownload->new(); + $dl->get_file($relpath, $output [, $expected_size ]); + if ($dl->enabled) ... + if ($dl->disabled) ... + $dl->enable; + $dl->disable; + $dl->errorcount([n]); + $dl->incr_errorcount; + $dl->decr_errorcount; + $dl->reset_errorcount; + +=head1 DESCRIPTION + +The C<TeXLive::TLDownload> is a wrapper around the LWP modules that +allows for persistent connections and different protocols. At load +time it checks for the existence of the LWP module(s), and sets +C<$TeXLive::TLDownload::net_lib_avail> accordingly. + +=head2 Using proxies + +Please see C<LWP::UserAgent> for details, in a nut shell one can +specify proxies by setting C<I<protocol>_proxy> variables. + +=head2 Automatic disabling + +The TLDownload module implements some automatic disabling feature. +Every time a download did not succeed an internal counter (errorcount) +is increased, everytime it did succeed it is decreased (to a minimum of 0). +If the number of error goes above the maximal error count, the download +object will be disabled and get_file always returns undef. + +In this cases the download can be reset with the reset_errorcount and +enable function. + +=head1 SEE ALSO + +LWP + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLPDB.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLPDB.pm new file mode 100644 index 0000000000..6b942d2f74 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLPDB.pm @@ -0,0 +1,3002 @@ +# $Id: TLPDB.pm 51841 2019-08-07 22:31:44Z karl $ +# TeXLive::TLPDB.pm - tlpdb plain text database files. +# Copyright 2007-2019 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLPDB; + +my $svnrev = '$Revision: 51841 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +=pod + +=head1 NAME + +C<TeXLive::TLPDB> -- A database of TeX Live Packages + +=head1 SYNOPSIS + + use TeXLive::TLPDB; + + TeXLive::TLPDB->new (); + TeXLive::TLPDB->new (root => "/path/to/texlive/installation/root"); + + $tlpdb->root("/path/to/root/of/texlive/installation"); + $tlpdb->copy; + $tlpdb->from_file($filename); + $tlpdb->writeout; + $tlpdb->writeout(FILEHANDLE); + $tlpdb->as_json; + $tlpdb->save; + $tlpdb->media; + $tlpdb->available_architectures(); + $tlpdb->add_tlpobj($tlpobj); + $tlpdb->needed_by($pkg); + $tlpdb->remove_tlpobj($pkg); + $tlpdb->get_package("packagename"); + $tlpdb->list_packages ( [$tag] ); + $tlpdb->expand_dependencies(["-only-arch",] $totlpdb, @list); + $tlpdb->expand_dependencies(["-no-collections",] $totlpdb, @list); + $tlpdb->find_file("filename"); + $tlpdb->collections; + $tlpdb->schemes; + $tlpdb->updmap_cfg_lines; + $tlpdb->fmtutil_cnf_lines; + $tlpdb->language_dat_lines; + $tlpdb->language_def_lines; + $tlpdb->language_lua_lines; + $tlpdb->package_revision("packagename"); + $tlpdb->location; + $tlpdb->platform; + $tlpdb->is_verified; + $tlpdb->verification_status; + $tlpdb->config_src_container; + $tlpdb->config_doc_container; + $tlpdb->config_container_format; + $tlpdb->config_release; + $tlpdb->config_minrelease; + $tlpdb->config_revision; + $tlpdb->config_frozen; + $tlpdb->options; + $tlpdb->option($key, [$value]); + $tlpdb->reset_options(); + $tlpdb->add_default_options(); + $tlpdb->settings; + $tlpdb->setting($key, [$value]); + $tlpdb->setting([-clear], $key, [$value]); + $tlpdb->sizes_of_packages($opt_src, $opt_doc, $ref_arch_list [, @packs ]); + $tlpdb->sizes_of_packages_with_deps($opt_src, $opt_doc, $ref_arch_list [, @packs ]); + $tlpdb->install_package($pkg, $dest_tlpdb); + $tlpdb->remove_package($pkg, %options); + $tlpdb->install_package_files($file [, $file ]); + + TeXLive::TLPDB->listdir([$dir]); + $tlpdb->generate_listfiles([$destdir]); + + $tlpdb->make_virtual; + $tlpdb->is_virtual; + $tlpdb->virtual_add_tlpdb($tlpdb, $tag); + $tlpdb->virtual_remove_tlpdb($tag); + $tlpdb->virtual_get_tags(); + $tlpdb->virtual_get_tlpdb($tag); + $tlpdb->virtual_get_package($pkg, $tag); + $tlpdb->candidates($pkg); + $tlpdb->virtual_candidate($pkg); + $tlpdb->virtual_pinning( [ $pin_file_TLConfFile ] ); + +=head1 DESCRIPTION + +=cut + +use TeXLive::TLConfig qw($CategoriesRegexp $DefaultCategory $InfraLocation + $DatabaseName $MetaCategoriesRegexp $Archive + $DefaultCompressorFormat %Compressors $CompressorExtRegexp + %TLPDBOptions %TLPDBSettings $ChecksumExtension + $RelocPrefix $RelocTree); +use TeXLive::TLCrypto; +use TeXLive::TLPOBJ; +use TeXLive::TLUtils qw(dirname mkdirhier member win32 info log debug ddebug + tlwarn basename download_file merge_into tldie system_pipe); +use TeXLive::TLWinGoo; + +use Cwd 'abs_path'; + +my $_listdir; + +=pod + +=over 4 + +=item C<< TeXLive::TLPDB->new >> + +=item C<< TeXLive::TLPDB->new( [root => "$path"] ) >> + +C<< TeXLive::TLPDB->new >> creates a new C<TLPDB> object. If the +argument C<root> is given it will be initialized from the respective +location starting at $path. If C<$path> begins with C<http://>, C<https://>, +C<ftp://>, C<scp://>, C<ssh://> or C<I<user>@I<host>:>, the respective file +is downloaded. The C<$path> can also start with C<file:/> in which case it +is treated as a file on the filesystem in the usual way. + +Returns an object of type C<TeXLive::TLPDB>, or undef if the root was +given but no package could be read from that location. + +=cut + +sub new { + my $class = shift; + my %params = @_; + my $self = { + root => $params{'root'}, + tlps => $params{'tlps'}, + verified => 0 + }; + my $verify = defined($params{'verify'}) ? $params{'verify'} : 0; + ddebug("TLPDB new: verify=$verify\n"); + $_listdir = $params{'listdir'} if defined($params{'listdir'}); + bless $self, $class; + if (defined($params{'tlpdbfile'})) { + my $nr_packages_read = $self->from_file($params{'tlpdbfile'}, + 'from-file' => 1, 'verify' => $verify); + if ($nr_packages_read == 0) { + # that is bad, we didn't read anything, so return undef. + return undef; + } + return $self; + } + if (defined($self->{'root'})) { + my $nr_packages_read + = $self->from_file("$self->{'root'}/$InfraLocation/$DatabaseName", + 'verify' => $verify); + if ($nr_packages_read == 0) { + # that is bad, we didn't read anything, so return undef. + return undef; + } + } + return $self; +} + + +sub copy { + my $self = shift; + my $bla = {}; + %$bla = %$self; + bless $bla, "TeXLive::TLPDB"; + return $bla; +} + +=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) = @_; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot add tlpobj to a virtual tlpdb\n"); + return 0; + } + $self->{'tlps'}{$tlp->name} = $tlp; +} + +=pod + +=item C<< $tlpdb->needed_by($pkg) >> + +Returns an array of package names depending on $pkg. + +=cut + +sub needed_by { + my ($self,$pkg) = @_; + my @ret; + for my $p ($self->list_packages) { + my $tlp = $self->get_package($p); + DEPENDS: for my $d ($tlp->depends) { + # exact match + if ($d eq $pkg) { + push @ret, $p; + last DEPENDS; # of the for loop on all depends + } + # + if ($d =~ m/^(.*)\.ARCH$/) { + my $parent = $1; + for my $a ($self->available_architectures) { + if ($pkg eq "$parent.$a") { + push @ret, $p; + last DEPENDS; + } + } + } + } + } + return @ret; +} + +=pod + +=item C<< $tlpdb->remove_tlpobj($pkg) >> + +Remove the package named C<$pkg> from the tlpdb. Gives a warning if the +package is not present + +=cut + +sub remove_tlpobj { + my ($self,$pkg) = @_; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot remove tlpobj from a virtual tlpdb\n"); + return 0; + } + if (defined($self->{'tlps'}{$pkg})) { + delete $self->{'tlps'}{$pkg}; + } else { + tlwarn("TLPDB: package to be removed not found: $pkg\n"); + } +} + +=pod + +=item C<< $tlpdb->from_file($filename, @args) >> + +The C<from_file> function initializes the C<TLPDB> if the root was not +given at generation time. See L<TLPDB::new> for more information. + +It returns the actual number of packages (TLPOBJs) read from +C<$filename>, and zero if there are problems (and gives warnings). + +=cut + +sub from_file { + my ($self, $path, @args) = @_; + my %params = @args; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot initialize a virtual tlpdb from_file\n"); + return 0; + } + if (@_ < 2) { + die "$0: from_file needs filename for initialization"; + } + my $root_from_path = dirname(dirname($path)); + if (defined($self->{'root'})) { + if ($self->{'root'} ne $root_from_path) { + if (!$params{'from-file'}) { + tlwarn("TLPDB: initialization from different location than original;\n"); + tlwarn("TLPDB: hope you are sure!\n"); + tlwarn("TLPDB: root=$self->{'root'}, root_from_path=$root_from_path\n"); + } + } + } else { + $self->root($root_from_path); + } + $self->verification_status($VS_UNKNOWN); + my $retfh; + my $tlpdbfile; + my $is_verified = 0; + # do media detection + my $rootpath = $self->root; + if ($rootpath =~ m,https?://|ftp://,) { + $media = 'NET'; + } elsif ($rootpath =~ m,$TeXLive::TLUtils::SshURIRegex,) { + $media = 'NET'; + } else { + if ($rootpath =~ m,file://*(.*)$,) { + $rootpath = "/$1"; + } + if ($params{'media'}) { + $media = $params{'media'}; + } elsif (-d "$rootpath/texmf-dist/web2c") { + $media = 'local_uncompressed'; + } elsif (-d "$rootpath/texmf/web2c") { # older + $media = 'local_uncompressed'; + } elsif (-d "$rootpath/web2c") { + $media = 'local_uncompressed'; + } elsif (-d "$rootpath/$Archive") { + $media = 'local_compressed'; + } else { + # we cannot find the right type, return zero, hope people notice + tlwarn("Cannot determine type of tlpdb from $rootpath!\n"); + return 0; + } + } + $self->{'media'} = $media; + # + # actually load the TLPDB + if ($path =~ m;^((https?|ftp)://|file:\/\/*); || $path =~ m;$TeXLive::TLUtils::SshURIRegex;) { + debug("TLPDB.pm: trying to initialize from $path\n"); + # now $xzfh filehandle is open, the file created + # TLUtils::download_file will just overwrite what is there + # on windows that doesn't work, so we close the fh immediately + # this creates a short loophole, but much better than before anyway + my $tlpdbfh; + ($tlpdbfh, $tlpdbfile) = TeXLive::TLUtils::tl_tmpfile(); + # same as above + close($tlpdbfh); + # if we have xz available we try the xz file + my $xz_succeeded = 0 ; + my $compressorextension = "<UNSET>"; + if (defined($::progs{$DefaultCompressorFormat})) { + # we first try the xz compressed file + my ($xzfh, $xzfile) = TeXLive::TLUtils::tl_tmpfile(); + close($xzfh); + my $decompressor = $::progs{$DefaultCompressorFormat}; + $compressorextension = $Compressors{$DefaultCompressorFormat}{'extension'}; + my @decompressorArgs = @{$Compressors{$DefaultCompressorFormat}{'decompress_args'}}; + debug("trying to download $path.$compressorextension to $xzfile\n"); + my $ret = TeXLive::TLUtils::download_file("$path.$compressorextension", "$xzfile"); + # better to check both, the return value AND the existence of the file + if ($ret && (-r "$xzfile")) { + # ok, let the fun begin + debug("decompressing $xzfile to $tlpdbfile\n"); + # xz *hopefully* returns 0 on success and anything else on failure + # we don't have to negate since not zero means error in the shell + # and thus in perl true + if (!system_pipe($decompressor, $xzfile, $tlpdbfile, 1, @decompressorArgs)) { + debug("$decompressor $xzfile failed, trying plain file\n"); + unlink($xzfile); # the above command only removes in case of success + } else { + $xz_succeeded = 1; + debug("found the uncompressed $DefaultCompressorFormat file\n"); + } + } + } else { + debug("no $DefaultCompressorFormat defined ...\n"); + } + if (!$xz_succeeded) { + debug("TLPDB: downloading $path.$compressorextension didn't succeed, try $path\n"); + my $ret = TeXLive::TLUtils::download_file($path, $tlpdbfile); + # better to check both, the return value AND the existence of the file + if ($ret && (-r $tlpdbfile)) { + # do nothing + } else { + unlink($tlpdbfile); + tldie( "$0: TLPDB::from_file could not initialize from: $path\n" + . "$0: Maybe the repository setting should be changed.\n" + . "$0: More info: https://tug.org/texlive/acquire.html\n"); + } + } + # if we are still here, then either the xz version was downloaded + # and unpacked, or the non-xz version was downloaded, and in both + # cases the result, i.e., the unpackaged tlpdb, is in $tlpdbfile + # + # before we open and proceed, verify the downloaded file + if ($params{'verify'} && $media ne 'local_uncompressed') { + my ($r, $m) = TeXLive::TLCrypto::verify_checksum($tlpdbfile, "$path.$ChecksumExtension"); + if ($r == $VS_CHECKSUM_ERROR) { + tldie("$0: checksum error when downloading $tlpdbfile from $path: $m\n"); + } elsif ($r == $VS_SIGNATURE_ERROR) { + tldie("$0: signature verification error of $tlpdbfile from $path: $m\n"); + } elsif ($r == $VS_CONNECTION_ERROR) { + tldie("$0: cannot download: $m\n"); + } elsif ($r == $VS_UNSIGNED) { + debug("$0: remote database checksum is not signed, continuing anyway: $m\n"); + $self->verification_status($r); + } elsif ($r == $VS_GPG_UNAVAILABLE) { + debug("$0: TLPDB: no gpg available, continuing anyway!\n"); + $self->verification_status($r); + } elsif ($r == $VS_PUBKEY_MISSING) { + debug("$0: TLPDB: pubkey missing, continuing anyway!\n"); + $self->verification_status($r); + } elsif ($r == $VS_VERIFIED) { + $is_verified = 1; + $self->verification_status($r); + } else { + tldie("$0: unexpected return value from verify_checksum: $r\n"); + } + } + open($retfh, "<$tlpdbfile") || die "$0: open($tlpdbfile) failed: $!"; + } else { + if ($params{'verify'} && $media ne 'local_uncompressed') { + my ($r, $m) = TeXLive::TLCrypto::verify_checksum($path, "$path.$ChecksumExtension"); + if ($r == $VS_CHECKSUM_ERROR) { + tldie("$0: checksum error when downloading $path from $path: $m\n"); + } elsif ($r == $VS_SIGNATURE_ERROR) { + tldie("$0: signature verification error of $path from $path: $m\n"); + } elsif ($r == $VS_CONNECTION_ERROR) { + tldie("$0: cannot download: $m\n"); + } elsif ($r == $VS_UNSIGNED) { + debug("$0: remote database checksum is not signed, continuing anyway!\n"); + $self->verification_status($r); + } elsif ($r == $VS_GPG_UNAVAILABLE) { + debug("$0: TLPDB: no gpg available, continuing anyway!\n"); + $self->verification_status($r); + } elsif ($r == $VS_PUBKEY_MISSING) { + debug("$0: TLPDB: pubkey missing, continuing anyway!\n"); + $self->verification_status($r); + } elsif ($r == $VS_EXPKEYSIG) { + debug("$0: TLPDB: signature verified, but key expired, continuing anyway!\n"); + $self->verification_status($r); + } elsif ($r == $VS_VERIFIED) { + $is_verified = 1; + $self->verification_status($r); + } else { + tldie("$0: unexpected return value from verify_checksum: $r\n"); + } + } + open(TMP, "<$path") || die "$0: open($path) failed: $!"; + $retfh = \*TMP; + } + my $found = 0; + my $ret = 0; + do { + my $tlp = TeXLive::TLPOBJ->new; + $ret = $tlp->from_fh($retfh,1); + if ($ret) { + $self->add_tlpobj($tlp); + $found++; + } + } until (!$ret); + if (! $found) { + debug("$0: Could not load packages from\n"); + debug(" $path\n"); + } + + $self->{'verified'} = $is_verified; + + close($retfh); + return($found); +} + +=pod + +=item C<< $tlpdb->writeout >> + +=item C<< $tlpdb->writeout(FILEHANDLE) >> + +The C<writeout> function writes the database to C<STDOUT>, or +the file handle given as argument. + +=cut + +sub writeout { + my $self = shift; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot writeout a virtual tlpdb\n"); + return 0; + } + my $fd = (@_ ? $_[0] : STDOUT); + foreach (sort keys %{$self->{'tlps'}}) { + ddebug("writeout: tlpname=$_ ", $self->{'tlps'}{$_}->name, "\n"); + $self->{'tlps'}{$_}->writeout($fd); + print $fd "\n"; + } +} + +=pod + +=item C<< $tlpdb->as_json >> + +The C<as_json> function returns a JSON UTF8 encoded representation of the +database, that is a JSON array of packages. If the database is virtual, +a JSON array where each element is a hash with two keys, C<tag> giving +the tag of the sub-database, and C<tlpdb> giving the JSON of the database. + +=cut + +sub as_json { + my $self = shift; + my $ret = "{"; + if ($self->is_virtual) { + my $firsttlpdb = 1; + for my $k (keys %{$self->{'tlpdbs'}}) { + $ret .= ",\n" if (!$firsttlpdb); + $ret .= "\"$k\":"; + $firsttlpdb = 0; + $ret .= $self->{'tlpdbs'}{$k}->_as_json; + } + } else { + $ret .= "\"main\":"; + $ret .= $self->_as_json; + } + $ret .= "}\n"; + return($ret); +} + +sub options_as_json { + my $self = shift; + die("calling _as_json on virtual is not supported!") if ($self->is_virtual); + my $opts = $self->options; + my @opts; + for my $k (keys %TLPDBOptions) { + my %foo; + $foo{'name'} = $k; + $foo{'tlmgrname'} = $TLPDBOptions{$k}[2]; + $foo{'description'} = $TLPDBOptions{$k}[3]; + $foo{'format'} = $TLPDBOptions{$k}[0]; + $foo{'default'} = "$TLPDBOptions{$k}[1]"; + # if ($TLPDBOptions{$k}[0] =~ m/^n/) { + # if (exists($opts->{$k})) { + # $foo{'value'} = $opts->{$k}; + # $foo{'value'} += 0; + # } + # $foo{'default'} += 0; + # } elsif ($TLPDBOptions{$k}[0] eq "b") { + # if (exists($opts->{$k})) { + # $foo{'value'} = ($opts->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); + # } + # $foo{'default'} = ($foo{'default'} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); + # } elsif ($k eq "location") { + # my %def; + # $def{'main'} = $TLPDBOptions{$k}[1]; + # $foo{'default'} = \%def; + # if (exists($opts->{$k})) { + # my %repos = TeXLive::TLUtils::repository_to_array($opts->{$k}); + # $foo{'value'} = \%repos; + # } + # } elsif ($TLPDBOptions{$k}[0] eq "p") { + # # strings/path + # if (exists($opts->{$k})) { + # $foo{'value'} = $opts->{$k}; + # } + # } else { + + # TREAT ALL VALUES AS STRINGS, otherwise not parsable JSON + # treat as strings + if (exists($opts->{$k})) { + $foo{'value'} = $opts->{$k}; + } + # } + push @opts, \%foo; + } + return(TeXLive::TLUtils::encode_json(\@opts)); +} + +sub settings_as_json { + my $self = shift; + die("calling _as_json on virtual is not supported!") if ($self->is_virtual); + my $sets = $self->settings; + my @json; + for my $k (keys %TLPDBSettings) { + my %foo; + $foo{'name'} = $k; + $foo{'type'} = $TLPDBSettings{$k}[0]; + $foo{'description'} = $TLPDBSettings{$k}[1]; + # if ($TLPDBSettings{$k}[0] eq "b") { + # if (exists($sets->{$k})) { + # $foo{'value'} = ($sets->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); + # } + # } elsif ($TLPDBSettings{$k} eq "available_architectures") { + # if (exists($sets->{$k})) { + # my @lof = $self->available_architectures; + # $foo{'value'} = \@lof; + # } + # } else { + if (exists($sets->{$k})) { + $foo{'value'} = "$sets->{$k}"; + } + # } + push @json, \%foo; + } + return(TeXLive::TLUtils::encode_json(\@json)); +} + +sub configs_as_json { + my $self = shift; + die("calling _as_json on virtual is not supported!") if ($self->is_virtual); + my %cfgs; + $cfgs{'container_split_src_files'} = ($self->config_src_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); + $cfgs{'container_split_doc_files'} = ($self->config_doc_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); + $cfgs{'container_format'} = $self->config_container_format; + $cfgs{'release'} = $self->config_release; + $cfgs{'minrelease'} = $self->config_minrelease; + return(TeXLive::TLUtils::encode_json(\%cfgs)); +} + +sub _as_json { + my $self = shift; + die("calling _as_json on virtual is not supported!") if ($self->is_virtual); + my $ret = "{"; + $ret .= '"options":'; + $ret .= $self->options_as_json(); + $ret .= ',"settings":'; + $ret .= $self->settings_as_json(); + $ret .= ',"configs":'; + $ret .= $self->configs_as_json(); + $ret .= ',"tlpkgs": ['; + my $first = 1; + foreach (keys %{$self->{'tlps'}}) { + $ret .= ",\n" if (!$first); + $first = 0; + $ret .= $self->{'tlps'}{$_}->as_json; + } + $ret .= "]}"; + return($ret); +} + +=pod + +=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; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot save a virtual tlpdb\n"); + return 0; + } + my $path = $self->location; + mkdirhier(dirname($path)); + my $tmppath = "$path.tmp"; + open(FOO, ">$tmppath") || die "$0: open(>$tmppath) failed: $!"; + $self->writeout(\*FOO); + close(FOO); + # on Windows the renaming sometimes fails, try to copy and unlink the + # .tmp file. This we do for all archs, cannot hurt. + # if we managed that one, we move it over + TeXLive::TLUtils::copy ("-f", $tmppath, $path); + unlink ($tmppath) or tlwarn ("TLPDB: cannot unlink $tmppath: $!\n"); +} + +=pod + +=item C<< $tlpdb->media >> + +Returns the media code the respective installation resides on. + +=cut + +sub media { + my $self = shift ; + if ($self->is_virtual) { + return "virtual"; + } + return $self->{'media'}; +} + +=pod + +=item C<< $tlpdb->available_architectures >> + +The C<available_architectures> functions returns the list of available +architectures as set in the options section +(i.e., using setting("available_architectures")) + +=cut + +sub available_architectures { + my $self = shift; + my @archs; + if ($self->is_virtual) { + for my $k (keys %{$self->{'tlpdbs'}}) { + TeXLive::TLUtils::push_uniq \@archs, $self->{'tlpdbs'}{$k}->available_architectures; + } + return sort @archs; + } else { + return $self->_available_architectures; + } +} + +sub _available_architectures { + my $self = shift; + my @archs = $self->setting("available_architectures"); + if (! @archs) { + # fall back to the old method checking tex\.* + my @packs = $self->list_packages; + map { s/^tex\.// ; push @archs, $_ ; } grep(/^tex\.(.*)$/, @packs); + } + return @archs; +} + +=pod + +=item C<< $tlpdb->get_package("pkgname") >> + +The C<get_package> function returns a reference to the C<TLPOBJ> object +corresponding to the I<pkgname>, or undef. + +=cut + +sub get_package { + my ($self,$pkg,$tag) = @_; + if ($self->is_virtual) { + if (defined($tag)) { + if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { + return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; + } else { + debug("TLPDB::get_package: package $pkg not found in repository $tag\n"); + return; + } + } else { + $tag = $self->{'packages'}{$pkg}{'target'}; + if (defined($tag)) { + return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; + } else { + return; + } + } + } else { + return $self->_get_package($pkg); + } +} + +sub _get_package { + my ($self,$pkg) = @_; + return undef if (!$pkg); + if (defined($self->{'tlps'}{$pkg})) { + my $ret = $self->{'tlps'}{$pkg}; + return $self->{'tlps'}{$pkg}; + } else { + return undef; + } +} + +=pod + +=item C<< $tlpdb->media_of_package($pkg [, $tag]) >> + +returns the media type of the package. In the virtual case a tag can +be given and the media of that repository is used, otherwise the +media of the virtual candidate is given. + +=cut + +sub media_of_package { + my ($self, $pkg, $tag) = @_; + if ($self->is_virtual) { + if (defined($tag)) { + if (defined($self->{'tlpdbs'}{$tag})) { + return $self->{'tlpdbs'}{$tag}->media; + } else { + tlwarn("TLPDB::media_of_package: tag not known: $tag\n"); + return; + } + } else { + my (undef,undef,undef,$maxtlpdb) = $self->virtual_candidate($pkg); + return $maxtlpdb->media; + } + } else { + return $self->media; + } +} + +=pod + +=item C<< $tlpdb->list_packages >> + +The C<list_packages> function returns the list of all included packages. + +By default, for virtual tlpdbs only packages that are installable +are listed. That means, packages that are only in subsidiary repositories +but are not specifically pinned to it cannot be installed and are thus +not listed. Adding "-all" argument lists also these packages. + +Finally, if there is another argument, the tlpdb must be virtual, +and the argument must specify a tag/name of a sub-tlpdb. In this +case all packages (without exceptions) from this repository are returned. + +=cut + +sub list_packages { + my $self = shift; + my $arg = shift; + my $tag; + my $showall = 0; + if (defined($arg)) { + if ($arg eq "-all") { + $showall = 1; + } else { + $tag = $arg; + } + } + if ($self->is_virtual) { + if ($showall) { + return (sort keys %{$self->{'packages'}}); + } + if ($tag) { + if (defined($self->{'tlpdbs'}{$tag})) { + return $self->{'tlpdbs'}{$tag}->list_packages; + } else { + tlwarn("TLPDB::list_packages: tag not defined: $tag\n"); + return 0; + } + } + # we have to be careful here: If a package + # is only present in a subsidiary repository + # and the package is *not* explicitly + # pinned to it, it will not be installable. + # This is what we want. But in this case + # we don't want it to be listed by default. + # + my @pps; + for my $p (keys %{$self->{'packages'}}) { + push @pps, $p if (defined($self->{'packages'}{$p}{'target'})); + } + return (sort @pps); + } else { + return $self->_list_packages; + } +} + +sub _list_packages { + my $self = shift; + return (sort keys %{$self->{'tlps'}}); +} + +=pod + +=item C<< $tlpdb->expand_dependencies(["control",] $tlpdb, ($pkgs)) >> + +If the first argument is the string C<"-only-arch">, expands only +dependencies of the form C<.>I<ARCH>. + +If the first argument is C<"-no-collections">, then dependencies between +"same-level" packages (scheme onto scheme, collection onto collection, +package onto package) are ignored. + +C<-only-arch> and C<-no-collections> cannot be specified together; has +to be one or the other. + +The next (or first) argument is the target TLPDB, then a list of +packages. + +In the virtual case, if a package name is tagged with C<@repository-tag> +then all the dependencies will still be expanded between all included +databases. Only in case of C<.>I<ARCH> dependencies the repository-tag +is sticky. + +We return a list of package names, the closure of the package list with +respect to the depends operator. (Sorry, that was for mathematicians.) + +=cut + +sub expand_dependencies { + my $self = shift; + my $only_arch = 0; + my $no_collections = 0; + my $first = shift; + my $totlpdb; + if ($first eq "-only-arch") { + $only_arch = 1; + $totlpdb = shift; + } elsif ($first eq "-no-collections") { + $no_collections = 1; + $totlpdb = shift; + } else { + $totlpdb = $first; + } + my %install = (); + my @archs = $totlpdb->available_architectures; + for my $p (@_) { + next if ($p =~ m/^\s*$/); + my ($pp, $aa) = split('@', $p); + $install{$pp} = (defined($aa) ? $aa : 0);; + } + my $changed = 1; + while ($changed) { + $changed = 0; + my @pre_select = keys %install; + ddebug("pre_select = @pre_select\n"); + for my $p (@pre_select) { + next if ($p =~ m/^00texlive/); + my $pkg = $self->get_package($p, ($install{$p}?$install{$p}:undef)); + if (!defined($pkg)) { + ddebug("W: $p is mentioned somewhere but not available, disabling\n"); + $install{$p} = 0; + next; + } + for my $p_dep ($pkg->depends) { + ddebug("checking $p_dep in $p\n"); + my $tlpdd = $self->get_package($p_dep); + if (defined($tlpdd)) { + # before we ignored all deps of schemes and colls if -no-collections + # was given, but this prohibited auto-install of new collections + # even if the scheme is updated. + # Now we suppress only "same-level dependencies", so scheme -> scheme + # and collections -> collections and package -> package + # hoping that this works out better + # if ($tlpdd->category =~ m/$MetaCategoriesRegexp/) { + if ($tlpdd->category eq $pkg->category) { + # we ignore same-level dependencies if "-no-collections" is given + ddebug("expand_deps: skipping $p_dep in $p due to -no-collections\n"); + next if $no_collections; + } + } + if ($p_dep =~ m/^(.*)\.ARCH$/) { + my $foo = "$1"; + foreach $a (@archs) { + # install .ARCH packages from the same sub repository as the + # main packages + $install{"$foo.$a"} = $install{$foo} + if defined($self->get_package("$foo.$a")); + } + } elsif ($p_dep =~ m/^(.*)\.win32$/) { + # a win32 package should *only* be installed if we are installing + # the win32 arch + if (grep(/^win32$/,@archs)) { + $install{$p_dep} = 0; + } + } else { + $install{$p_dep} = 0 unless $only_arch; + } + } + } + + # check for newly selected packages + my @post_select = keys %install; + ddebug("post_select = @post_select\n"); + if ($#pre_select != $#post_select) { + $changed = 1; + } + } + # create return list + return map { $install{$_} eq "0"?$_:"$_\@" . $install{$_} } keys %install; + #return(keys %install); +} + +=pod + +=item C<< $tlpdb->find_file("filename") >> + +The C<find_file> returns a list of packages:filename +containing a file named C<filename>. + +=cut + +# TODO adapt for searching in *all* tags ??? +sub find_file { + my ($self,$fn) = @_; + my @ret = (); + for my $pkg ($self->list_packages) { + for my $f ($self->get_package($pkg)->contains_file($fn)) { + push (@ret, "$pkg:$f"); + } + } + return @ret; +} + +=pod + +=item C<< $tlpdb->collections >> + +The C<collections> function returns a list of all collection names. + +=cut + +sub collections { + my $self = shift; + my @ret; + foreach my $p ($self->list_packages) { + if ($self->get_package($p)->category eq "Collection") { + push @ret, $p; + } + } + return @ret; +} + +=pod + +=item C<< $tlpdb->schemes >> + +The C<schemes> function returns a list of all scheme names. + +=cut + +sub schemes { + my $self = shift; + my @ret; + foreach my $p ($self->list_packages) { + if ($self->get_package($p)->category eq "Scheme") { + push @ret, $p; + } + } + return @ret; +} + + + +=pod + +=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) = @_; + my $tlp = $self->get_package($pkg); + if (defined($tlp)) { + return $tlp->revision; + } else { + return; + } +} + +=pod + +=item C<< $tlpdb->generate_packagelist >> + +The C<generate_packagelist> prints TeX Live package names in the object +database, together with their revisions, to the file handle given in the +first (optional) argument, or C<STDOUT> by default. It also outputs all +available architectures as packages with revision number -1. + +=cut + +sub generate_packagelist { + my $self = shift; + my $fd = (@_ ? $_[0] : STDOUT); + foreach (sort $self->list_packages) { + print $fd $self->get_package($_)->name, " ", + $self->get_package($_)->revision, "\n"; + } + foreach ($self->available_architectures) { + print $fd "$_ -1\n"; + } +} + +=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))) { + $destdir = TeXLive::TLPDB->listdir; + } + foreach (sort $self->list_package) { + $tlp = $self->get_package($_); + $self->_generate_listfile($tlp, $destdir); + } +} + +sub _generate_listfile { + my ($self,$tlp,$destdir) = @_; + my $listname = $tlp->name; + my @files = $tlp->all_files; + @files = TeXLive::TLUtils::sort_uniq(@files); + &mkpath("$destdir") if (! -d "$destdir"); + my (@lop, @lot); + foreach my $d ($tlp->depends) { + my $subtlp = $self->get_package($d); + if (defined($subtlp)) { + if ($subtlp->is_meta_package) { + push @lot, $d; + } else { + push @lop, $d; + } + } else { + # pseudo-dependencies on $Package.ARCH can be ignored + if ($d !~ m/\.ARCH$/) { + tlwarn("TLPDB: package $tlp->name depends on $d, but this does not exist\n"); + } + } + } + open(TMP, ">$destdir/$listname") + || die "$0: open(>$destdir/$listname) failed: $!"; + + # title and size information for collections and schemes in the + # first two lines, marked with * + if ($tlp->category eq "Collection") { + print TMP "*Title: ", $tlp->shortdesc, "\n"; + # collections references Packages, we have to collect the sizes of + # all the Package-tlps included + # What is unclear for me is HOW the size is computed for bin-* + # packages. The collection-basic contains quite a lot of + # bin-files, but the sizes for the different archs differ. + # I guess we have to take the maximum? + my $s = 0; + foreach my $p (@lop) { + my $subtlp = $self->get_package($p); + if (!defined($subtlp)) { + tlwarn("TLPDB: $listname references $p, but this is not in tlpdb\n"); + } + $s += $subtlp->total_size; + } + # in case the collection itself ships files ... + $s += $tlp->runsize + $tlp->srcsize + $tlp->docsize; + print TMP "*Size: $s\n"; + } elsif ($tlp->category eq "Scheme") { + print TMP "*Title: ", $tlp->shortdesc, "\n"; + my $s = 0; + # schemes size includes ONLY those packages which are directly + # included and directly included files, not the size of the + # included collections. But if a package is included in one of + # the called for collections AND listed directly, we don't want + # to count its size two times + my (@inccol,@incpkg,@collpkg); + # first we add all the packages tlps that are directly included + @incpkg = @lop; + # now we select all collections, and for all collections we + # again select all non-meta-packages + foreach my $c (@lot) { + my $coll = $self->get_package($c); + foreach my $d ($coll->depends) { + my $subtlp = $self->get_package($d); + if (defined($subtlp)) { + if (!($subtlp->is_meta_package)) { + TeXLive::TLUtils::push_uniq(\@collpkg,$d); + } + } else { + tlwarn("TLPDB: collection $coll->name depends on $d, but this does not exist\n"); + } + } + } + # finally go through all packages and add the ->total_size + foreach my $p (@incpkg) { + if (!TeXLive::TLUtils::member($p,@collpkg)) { + $s += $self->get_package($p)->total_size; + } + } + $s += $tlp->runsize + $tlp->srcsize + $tlp->docsize; + print TMP "*Size: $s\n"; + } + # dependencies and inclusion of packages + foreach my $t (@lot) { + # strange, schemes mark included collections via -, while collections + # themselves mark deps on other collections with +. collections are + # never referenced in Packages. + if ($listname =~ m/^scheme/) { + print TMP "-"; + } else { + print TMP "+"; + } + print TMP "$t\n"; + } + foreach my $t (@lop) { print TMP "+$t\n"; } + # included files + foreach my $f (@files) { print TMP "$f\n"; } + # also print the listfile itself + print TMP "$destdir/$listname\n"; + # execute statements + foreach my $e ($tlp->executes) { + print TMP "!$e\n"; + } + # finish + close(TMP); +} + +=pod + +=item C<< $tlpdb->root([ "/path/to/installation" ]) >> + +The function C<root> allows to read and set the root of the +installation. + +=cut + +sub root { + my $self = shift; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot set/edit root of a virtual tlpdb\n"); + return 0; + } + if (@_) { $self->{'root'} = shift } + return $self->{'root'}; +} + +=pod + +=item C<< $tlpdb->location >> + +Return the location of the actual C<texlive.tlpdb> file used. This is a +read-only function; you cannot change the root of the TLPDB using this +function. + +See C<00texlive.installation.tlpsrc> for a description of the +special value C<__MASTER>. + +=cut + +sub location { + my $self = shift; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot get location of a virtual tlpdb\n"); + return 0; + } + return "$self->{'root'}/$InfraLocation/$DatabaseName"; +} + +=pod + +=item C<< $tlpdb->platform >> + +returns the platform of this installation. + +=cut + +# 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 $ret = $self->setting("platform"); + return $ret if defined $ret; + # the platform setting wasn't found in the tlpdb, try TLUtils::platform + return TeXLive::TLUtils::platform(); +} + +=pod + +=item C<< $tlpdb->is_verified >> + +Returns 0/1 depending on whether the tlpdb was verified by checking +the cryptographic signature. + +=cut + +sub is_verified { + my $self = shift; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot set/edit verified property of a virtual tlpdb\n"); + return 0; + } + if (@_) { $self->{'verified'} = shift } + return $self->{'verified'}; +} +=pod + +=item C<< $tlpdb->verification_status >> + +Returns the id of the verification status. To obtain a textual representation +us %TLCrypto::VerificationStatusDescription. + +=cut + +sub verification_status { + my $self = shift; + if ($self->is_virtual) { + tlwarn("TLPDB: cannot set/edit verification status of a virtual tlpdb\n"); + return 0; + } + if (@_) { $self->{'verification_status'} = shift } + return $self->{'verification_status'}; +} + +=pod + +=item C<< $tlpdb->listdir >> + +The function C<listdir> allows to read and set the packages variable +specifying where generated list files are created. + +=cut + +sub listdir { + my $self = shift; + if (@_) { $_listdir = $_[0] } + return $_listdir; +} + +=pod + +=item C<< $tlpdb->config_src_container >> + +Returns 1 if the texlive config option for src files splitting on +container level is set. See Options below. + +=cut + +sub config_src_container { + my $self = shift; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); + } else { + $tlp = $self->{'tlps'}{'00texlive.config'}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^container_split_src_files/(.*)$!) { + return "$1"; + } + } + } + return 0; +} + +=pod + +=item C<< $tlpdb->config_doc_container >> + +Returns 1 if the texlive config option for doc files splitting on +container level is set. See Options below. + +=cut + +sub config_doc_container { + my $self = shift; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); + } else { + $tlp = $self->{'tlps'}{'00texlive.config'}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^container_split_doc_files/(.*)$!) { + return "$1"; + } + } + } + return 0; +} + +=pod + +=item C<< $tlpdb->config_container_format >> + +Returns the currently set default container format. See Options below. + +=cut + +sub config_container_format { + my $self = shift; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); + } else { + $tlp = $self->{'tlps'}{'00texlive.config'}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^container_format/(.*)$!) { + return "$1"; + } + } + } + return ""; +} + +=pod + +=item C<< $tlpdb->config_release >> + +Returns the currently set release. See Options below. + +=cut + +sub config_release { + my $self = shift; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); + } else { + $tlp = $self->{'tlps'}{'00texlive.config'}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^release/(.*)$!) { + return "$1"; + } + } + } + return ""; +} + +=pod + +=item C<< $tlpdb->config_minrelease >> + +Returns the currently allowed minimal release. See Options below. + +=cut + +sub config_minrelease { + my $self = shift; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); + } else { + $tlp = $self->{'tlps'}{'00texlive.config'}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^minrelease/(.*)$!) { + return "$1"; + } + } + } + return; +} + +=pod + +=item C<< $tlpdb->config_frozen >> + +Returns true if the location is frozen. + +=cut + +sub config_frozen { + my $self = shift; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); + } else { + $tlp = $self->{'tlps'}{'00texlive.config'}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^frozen/(.*)$!) { + return "$1"; + } + } + } + return; +} + + +=pod + +=item C<< $tlpdb->config_revision >> + +Returns the currently set revision. See Options below. + +=cut + +sub config_revision { + my $self = shift; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); + } else { + $tlp = $self->{'tlps'}{'00texlive.config'}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^revision/(.*)$!) { + return "$1"; + } + } + } + return ""; +} + +=pod + +=item C<< $tlpdb->sizes_of_packages_with_deps ( $opt_src, $opt_doc, $ref_arch_list, [ @packs ] ) >> + +=item C<< $tlpdb->sizes_of_packages ( $opt_src, $opt_doc, $ref_arch_list, [ @packs ] ) >> + +These functions return a reference to a hash with package names as keys +and the sizes in bytes as values. The sizes are computed for the list of +package names given as the fourth argument, or all packages if not +specified. The difference between the two functions is that the C<_with_deps> +gives the size of packages including the size of all depending sizes. + +If anything has been computed one additional key is synthesized, +C<__TOTAL__>, which contains the total size of all packages under +consideration. In the case of C<_with_deps> this total computation +does B<not> count packages multiple times, even if they appear +multiple times as dependencies. + +If the third argument is a reference to a list of architectures, then +only the sizes for the binary packages for these architectures are used, +otherwise all sizes for all architectures are summed. + +=cut + +sub sizes_of_packages { + my ($self, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_; + return $self->_sizes_of_packages(0, $opt_src, $opt_doc, $arch_list_ref, @packs); +} + +sub sizes_of_packages_with_deps { + my ($self, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_; + return $self->_sizes_of_packages(1, $opt_src, $opt_doc, $arch_list_ref, @packs); +} + + +sub _sizes_of_packages { + my ($self, $with_deps, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_; + @packs || ( @packs = $self->list_packages() ); + my @expacks; + if ($with_deps) { + # don't expand collection->collection dependencies + #@exppacks = $self->expand_dependencies('-no-collections', $self, @packs); + @exppacks = $self->expand_dependencies($self, @packs); + } else { + @exppacks = @packs; + } + my @archs; + if ($arch_list_ref) { + @archs = @$arch_list_ref; + } else { + # if nothing is passed on, we use all available archs + @archs = $self->available_architectures; + } + my %tlpsizes; + my %tlpobjs; + my $totalsize = 0; + foreach my $p (@exppacks) { + $tlpobjs{$p} = $self->get_package($p); + my $media = $self->media_of_package($p); + if (!defined($tlpobjs{$p})) { + warn "STRANGE: $p not to be found in ", $self->root; + next; + } + # + # in case we are calling the _with_deps variant, we always + # compute *UNCOMPRESSED* sizes (not the container sizes!!!) + if ($with_deps) { + $tlpsizes{$p} = $self->size_of_one_package('local_uncompressed' , $tlpobjs{$p}, + $opt_src, $opt_doc, @archs); + } else { + $tlpsizes{$p} = $self->size_of_one_package($media, $tlpobjs{$p}, + $opt_src, $opt_doc, @archs); + } + $totalsize += $tlpsizes{$p}; + } + my %realtlpsizes; + if ($totalsize) { + $realtlpsizes{'__TOTAL__'} = $totalsize; + } + if (!$with_deps) { + for my $p (@packs) { + $realtlpsizes{$p} = $tlpsizes{$p}; + } + } else { # the case with dependencies + # make three rounds: for packages, collections, schemes + # size computations include only those from lower-levels + # that is, scheme-scheme, collection-collection + # does not contribute to the size + for my $p (@exppacks) { + next if ($p =~ m/scheme-/); + next if ($p =~ m/collection-/); + $realtlpsizes{$p} = $tlpsizes{$p}; + } + for my $p (@exppacks) { + # only collections + next if ($p !~ m/collection-/); + $realtlpsizes{$p} = $tlpsizes{$p}; + ddebug("=== $p adding deps\n"); + for my $d ($tlpobjs{$p}->depends) { + next if ($d =~ m/^collection-/); + next if ($d =~ m/^scheme-/); + ddebug("=== going for $d\n"); + if (defined($tlpsizes{$d})) { + $realtlpsizes{$p} += $tlpsizes{$d}; + ddebug("=== found $tlpsizes{$d} for $d\n"); + } else { + # silently ignore missing defined packages - they should have + # been computed by expand-dependencies + debug("TLPDB.pm: size with deps: sub package not found main=$d, dep=$p\n"); + } + } + } + for my $p (@exppacks) { + # only schemes + next if ($p !~ m/scheme-/); + $realtlpsizes{$p} = $tlpsizes{$p}; + ddebug("=== $p adding deps\n"); + for my $d ($tlpobjs{$p}->depends) { + # should not be necessary, we don't have collection -> scheme deps + next if ($d =~ m/^scheme-/); + ddebug("=== going for $d\n"); + if (defined($realtlpsizes{$d})) { + $realtlpsizes{$p} += $realtlpsizes{$d}; + ddebug("=== found $realtlpsizes{$d} for $d\n"); + } else { + # silently ignore missing defined packages - they should have + # been computed by expand-dependencies + debug("TLPDB.pm: size with deps: sub package not found main=$d, dep=$p\n"); + } + } + } + } + return \%realtlpsizes; +} + +sub size_of_one_package { + my ($self, $media, $tlpobj, $opt_src, $opt_doc, @used_archs) = @_; + my $size = 0; + if ($media ne 'local_uncompressed') { + # we use the container size as the measuring unit since probably + # downloading will be the limiting factor + $size = $tlpobj->containersize; + $size += $tlpobj->srccontainersize if $opt_src; + $size += $tlpobj->doccontainersize if $opt_doc; + } else { + # we have to add the respective sizes, that is checking for + # installation of src and doc file + $size = $tlpobj->runsize; + $size += $tlpobj->srcsize if $opt_src; + $size += $tlpobj->docsize if $opt_doc; + my %foo = %{$tlpobj->binsize}; + for my $k (keys %foo) { + if (@used_archs && member($k, @used_archs)) { + $size += $foo{$k}; + } + } + # packages sizes are stored in blocks; transform that to bytes. + $size *= $TeXLive::TLConfig::BlockSize; + } + return $size; +} + +=pod + +=item C<< $tlpdb->install_package_files($f [, $f]) >> + +Install a package from a package file, i.e. a .tar.xz. +Returns the number of packages actually installed successfully. + +=cut + +sub install_package_files { + my ($self, @files) = @_; + + my $ret = 0; + + my $opt_src = $self->option("install_srcfiles"); + my $opt_doc = $self->option("install_docfiles"); + + for my $f (@files) { + + # - create a tmp directory + my $tmpdir = TeXLive::TLUtils::tl_tmpdir(); + # - unpack everything there + { + my ($ret, $msg) = TeXLive::TLUtils::unpack($f, $tmpdir); + if (!$ret) { + tlwarn("TLPDB::install_package_files: $msg\n"); + next; + } + } + # we are still here, so the files have been unpacked properly + # we need now to find the tlpobj in $tmpdir/tlpkg/tlpobj/ + my ($tlpobjfile, $anotherfile) = <$tmpdir/tlpkg/tlpobj/*.tlpobj>; + if (defined($anotherfile)) { + # we found several tlpobj files, that is not allowed, stop + tlwarn("TLPDB::install_package_files: several tlpobj files in $what in tlpkg/tlpobj/, stopping!\n"); + next; + } + # - read the tlpobj from there + my $tlpobj = TeXLive::TLPOBJ->new; + $tlpobj->from_file($tlpobjfile); + # we didn't die in this process, so that seems to be a proper tlpobj + # (btw, why didn't I work on proper return values!?!) + + # + # we are now ready for installation + # if this package existed before, remove it from the tlpdb + if ($self->get_package($tlpobj->name)) { + $self->remove_package($tlpobj->name); + } + + # code partially from TLPDB->not_virtual_install_package!!! + my @installfiles = (); + my $reloc = 1 if $tlpobj->relocated; + foreach ($tlpobj->runfiles) { push @installfiles, $_; }; + foreach ($tlpobj->allbinfiles) { push @installfiles, $_; }; + if ($opt_src) { foreach ($tlpobj->srcfiles) { push @installfiles, $_; } } + if ($opt_doc) { foreach ($tlpobj->docfiles) { push @installfiles, $_; } } + # + # remove the RELOC prefix, but do NOT replace it with RelocTree + @installfiles = map { s!^$RelocPrefix/!!; $_; } @installfiles; + # if the first argument of _install_data is scalar, it is the + # place from where files should be installed + if (!_install_data ($tmpdir, \@installfiles, $reloc, \@installfiles, $self)) { + tlwarn("TLPDB::install_package_files: couldn't install $what!\n"); + next; + } + if ($reloc) { + if ($self->setting("usertree")) { + $tlpobj->cancel_reloc_prefix; + } else { + $tlpobj->replace_reloc_prefix; + } + $tlpobj->relocated(0); + } + my $tlpod = $self->root . "/tlpkg/tlpobj"; + mkdirhier( $tlpod ); + open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") or + die("Cannot open tlpobj file for ".$tlpobj->name); + $tlpobj->writeout(\*TMP); + close(TMP); + $self->add_tlpobj($tlpobj); + $self->save; + TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj); + # 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() && !$self->option("w32_multi_user")) { + non_admin(); + } + # for now desktop_integration maps to both installation + # of desktop shortcuts and menu items, but we can split them later + &TeXLive::TLUtils::do_postaction("install", $tlpobj, + $self->option("file_assocs"), + $self->option("desktop_integration"), + $self->option("desktop_integration"), + $self->option("post_code")); + + # remember that we installed this package correctly + $ret++; + } + return $ret; +} + + +=pod + +=item C<< $tlpdb->install_package($pkg, $dest_tlpdb [, $tag]) >> + +Installs the package $pkg into $dest_tlpdb. +If C<$tag> is present and the tlpdb is virtual, tries to install $pkg +from the repository tagged with $tag. + +=cut + +sub install_package { + my ($self, $pkg, $totlpdb, $tag) = @_; + if ($self->is_virtual) { + if (defined($tag)) { + if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { + return $self->{'tlpdbs'}{$tag}->install_package($pkg, $totlpdb); + } else { + tlwarn("TLPDB::install_package: package $pkg not found" + . " in repository $tag\n"); + return; + } + } else { + my ($maxtag, $maxrev, $maxtlp, $maxtlpdb) + = $self->virtual_candidate($pkg); + return $maxtlpdb->install_package($pkg, $totlpdb); + } + } else { + if (defined($tag)) { + tlwarn("TLPDB: not a virtual tlpdb, ignoring tag $tag" + . " on installation of $pkg\n"); + } + return $self->not_virtual_install_package($pkg, $totlpdb); + } + return; +} + +sub not_virtual_install_package { + my ($self, $pkg, $totlpdb) = @_; + my $fromtlpdb = $self; + my $ret; + die("TLPDB not initialized, cannot find tlpdb!") + unless (defined($fromtlpdb)); + + my $tlpobj = $fromtlpdb->get_package($pkg); + if (!defined($tlpobj)) { + tlwarn("TLPDB::not_virtual_install_package: cannot find package: $pkg\n"); + return 0; + } else { + 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 $real_opt_doc = $opt_doc; + my $reloc = 1 if $tlpobj->relocated; + my $container; + my @installfiles; + my $root = $self->root; + # make sure that there is no terminal / in $root, otherwise we + # will get double // somewhere + $root =~ s!/$!!; + foreach ($tlpobj->runfiles) { + # s!^!$root/!; + push @installfiles, $_; + } + foreach ($tlpobj->allbinfiles) { + # s!^!$root/!; + push @installfiles, $_; + } + if ($opt_src) { + foreach ($tlpobj->srcfiles) { + # s!^!$root/!; + push @installfiles, $_; + } + } + if ($real_opt_doc) { + foreach ($tlpobj->docfiles) { + # s!^!$root/!; + push @installfiles, $_; + } + } + my $media = $self->media; + if ($media eq 'local_uncompressed') { + $container = \@installfiles; + } elsif ($media eq 'local_compressed') { + for my $ext (map { $Compressors{$_}{'extension'} } keys %Compressors) { + if (-r "$root/$Archive/$pkg.tar.$ext") { + $container = "$root/$Archive/$pkg.tar.$ext"; + } + } + if (!$container) { + tlwarn("TLPDB: cannot find package $pkg.tar.$CompressorExtRegexp in $root/$Archive\n"); + return(0); + } + } elsif (&media eq 'NET') { + $container = "$root/$Archive/$pkg.tar." . $Compressors{$DefaultCompressorFormat}{'extension'}; + } + debug("TLPDB::not_virtual_install_package: trying to install $container\n"); + $self->_install_data ($container, $reloc, \@installfiles, $totlpdb, $tlpobj->containersize, $tlpobj->containerchecksum) + || return(0); + # if we are installing from local_compressed or NET we have to fetch the respective + # source and doc packages $pkg.source and $pkg.doc and install them, too + if (($media eq 'NET') || ($media eq 'local_compressed')) { + # we install split containers under the following conditions: + # - the container were split generated + # - src/doc files should be installed + # (- the package is not already a split one (like .i386-linux)) + # the above test has been removed because it would mean that + # texlive.infra.doc.tar.xz + # will never be installed, and we do already check that there + # are at all src/doc files, which in split packages of the form + # foo.ARCH are not present. And if they are present, than that is fine, + # too (bin-foobar.win32.doc.tar.xz) + # - there are actually src/doc files present + if ($container_src_split && $opt_src && $tlpobj->srcfiles) { + my $srccontainer = $container; + $srccontainer =~ s/\.tar\.$CompressorExtRegexp$/.source.tar.$1/; + $self->_install_data ($srccontainer, $reloc, \@installfiles, $totlpdb, $tlpobj->srccontainersize, $tlpobj->srccontainerchecksum) + || return(0); + } + if ($container_doc_split && $real_opt_doc && $tlpobj->docfiles) { + my $doccontainer = $container; + $doccontainer =~ s/\.tar\.$CompressorExtRegexp$/.doc.tar.$1/; + $self->_install_data ($doccontainer, $reloc, \@installfiles, $totlpdb, $tlpobj->doccontainersize, $tlpobj->doccontainerchecksum) + || return(0); + } + # + # if we installed from NET/local_compressed and we got a relocatable container + # make sure that the stray texmf-dist/tlpkg directory is removed + # in USER MODE that should NOT be done because we keep the information + # there, but for now do it unconditionally + if ($tlpobj->relocated) { + my $reloctree = $totlpdb->root . "/" . $RelocTree; + my $tlpkgdir = $reloctree . "/" . $InfraLocation; + my $tlpod = $tlpkgdir . "/tlpobj"; + TeXLive::TLUtils::rmtree($tlpod) if (-d $tlpod); + # we try to remove the tlpkg directory, that will succeed only + # if it is empty. So in normal installations it won't be, but + # if we are installing a relocated package it is texmf-dist/tlpkg + # which will be (hopefully) empty + rmdir($tlpkgdir) if (-d "$tlpkgdir"); + } + } + # we don't want to have wrong information in the tlpdb, so remove the + # src/doc files if they are not installed ... + if (!$opt_src) { + $tlpobj->clear_srcfiles; + } + if (!$real_opt_doc) { + $tlpobj->clear_docfiles; + } + # if a package is relocatable we have to cancel the reloc prefix + # and unset the relocated setting + # before we save it to the local tlpdb + if ($tlpobj->relocated) { + if ($totlpdb->setting("usertree")) { + $tlpobj->cancel_reloc_prefix; + } else { + $tlpobj->replace_reloc_prefix; + } + $tlpobj->relocated(0); + } + # we have to write out the tlpobj file since it is contained in the + # archives (.tar.xz) but at DVD install time we don't have them + my $tlpod = $totlpdb->root . "/tlpkg/tlpobj"; + mkdirhier($tlpod); + my $count = 0; + my $tlpobj_file = ">$tlpod/" . $tlpobj->name . ".tlpobj"; + until (open(TMP, $tlpobj_file)) { + # The open might fail for no good reason on Windows. + # Try again for a while, but not forever. + if ($count++ == 100) { die "$0: open($tlpobj_file) failed: $!"; } + select (undef, undef, undef, .1); # sleep briefly + } + $tlpobj->writeout(\*TMP); + close(TMP); + $totlpdb->add_tlpobj($tlpobj); + $totlpdb->save; + # compute the return value + TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj); + # 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(); + } + # for now desktop_integration maps to both installation + # of desktop shortcuts and menu items, but we can split them later + &TeXLive::TLUtils::do_postaction("install", $tlpobj, + $totlpdb->option("file_assocs"), + $totlpdb->option("desktop_integration"), + $totlpdb->option("desktop_integration"), + $totlpdb->option("post_code")); + } + return 1; +} + +# +# _install_data +# actually does the installation work +# returns 1 on success and 0 on error +# +# if the first argument is a string, then files are taken from this directory +# otherwise it is a tlpdb from where to install +# +sub _install_data { + my ($self, $what, $reloc, $filelistref, $totlpdb, $whatsize, $whatcheck) = @_; + + my $target = $totlpdb->root; + my $tempdir = TeXLive::TLUtils::tl_tmpdir(); + + my @filelist = @$filelistref; + + if (ref $what) { + # determine the root from where we install + # if the first argument $self is a string, then it should be the + # root from where to install the files, otherwise it should be + # a TLPDB object (installation from DVD) + my $root; + if (!ref($self)) { + $root = $self; + } else { + $root = $self->root; + } + # if we are installing a reloc, add the RelocTree to the target + if ($reloc) { + if (!$totlpdb->setting("usertree")) { + $target .= "/$RelocTree"; + } + } + + foreach my $file (@$what) { + # @what is taken, not @filelist! + # is this still needed? + my $dn=dirname($file); + mkdirhier("$target/$dn"); + TeXLive::TLUtils::copy "$root/$file", "$target/$dn"; + } + # we always assume that copy will work + return(1); + } elsif ($what =~ m,\.tar\.$CompressorExtRegexp$,) { + if ($reloc) { + if (!$totlpdb->setting("usertree")) { + $target .= "/$RelocTree"; + } + } + my $ww = ($whatsize || "<unset>"); + my $ss = ($whatcheck || "<unset>"); + debug("tlpdb:_install_data: what=$what, target=$target, size=$ww, checksum=$ss, tmpdir=$tempdir\n"); + my ($ret, $pkg) = TeXLive::TLUtils::unpack($what, $target, 'size' => $whatsize, 'checksum' => $whatcheck, 'tmpdir' => $tempdir); + if (!$ret) { + tlwarn("TLPDB::_install_package: $pkg\n"); + return(0); + } + # remove the $pkg.tlpobj, we recreate it anyway again + unlink ("$target/tlpkg/tlpobj/$pkg.tlpobj") + if (-r "$target/tlpkg/tlpobj/$pkg.tlpobj"); + return(1); + } else { + tlwarn("TLPDB::_install_package: don't know how to install $what\n"); + return(0); + } +} + +=pod + +=item << $tlpdb->remove_package($pkg, %options) >> + +Removes a single package with all the files and the entry in the db; +warns if the package does not exist. + +=cut + +# remove_package removes a single package with all files (including the +# tlpobj files) and the entry from the tlpdb. +sub remove_package { + my ($self, $pkg, %opts) = @_; + my $localtlpdb = $self; + my $tlp = $localtlpdb->get_package($pkg); + my $usertree = $localtlpdb->setting("usertree"); + if (!defined($tlp)) { + tlwarn ("TLPDB: package not present, so nothing to remove: $pkg\n"); + } else { + my $currentarch = $self->platform(); + if ($pkg eq "texlive.infra" || $pkg eq "texlive.infra.$currentarch") { + log ("Not removing $pkg, it is essential!\n"); + return 0; + } + # we have to chdir to $localtlpdb->root + my $Master = $localtlpdb->root; + chdir ($Master) || die "chdir($Master) failed: $!"; + my @files = $tlp->all_files; + # also remove the .tlpobj file + push @files, "tlpkg/tlpobj/$pkg.tlpobj"; + # and the ones from src/doc splitting + if (-r "tlpkg/tlpobj/$pkg.source.tlpobj") { + push @files, "tlpkg/tlpobj/$pkg.source.tlpobj"; + } + if (-r "tlpkg/tlpobj/$pkg.doc.tlpobj") { + push @files, "tlpkg/tlpobj/$pkg.doc.tlpobj"; + } + # + # some packages might be relocated, thus having the RELOC prefix + # in user mode we just remove the prefix, in normal mode we + # replace it with texmf-dist + # since we don't have user mode + if ($tlp->relocated) { + for (@files) { + if (!$usertree) { + s:^$RelocPrefix/:$RelocTree/:; + } + } + } + # + # we want to check that a file is only listed in one package, so + # in case that a file to be removed is listed in another package + # we will warn and *not* remove it + my %allfiles; + for my $p ($localtlpdb->list_packages) { + next if ($p eq $pkg); # we have to skip the to be removed package + for my $f ($localtlpdb->get_package($p)->all_files) { + $allfiles{$f} = $p; + } + } + my @goodfiles = (); + my @badfiles = (); + my @debugfiles = (); + for my $f (@files) { + # in usermode we have to add texmf-dist again for comparison + if (defined($allfiles{$f})) { + # this file should be removed but is mentioned somewhere, too + # take into account if we got a warn list + if (defined($opts{'remove-warn-files'})) { + my %a = %{$opts{'remove-warn-files'}}; + if (defined($a{$f})) { + push @badfiles, $f; + } else { + # NO NOTHING HERE!!! + # DON'T PUSH IT ON @goodfiles, it will be removed, which we do + # NOT want. We only want to suppress the warning! + push @debugfiles, $f; + } + } else { + push @badfiles, $f; + } + } else { + push @goodfiles, $f; + } + } + if ($#debugfiles >= 0) { + debug("The following files will not be removed due to the removal of $pkg.\n"); + debug("But we do not warn on it because they are moved to other packages.\n"); + for my $f (@debugfiles) { + debug(" $f - $allfiles{$f}\n"); + } + } + if ($#badfiles >= 0) { + # warn the user + tlwarn("TLPDB: These files would have been removed due to removal of\n"); + tlwarn("TLPDB: $pkg, but are part of another package:\n"); + for my $f (@badfiles) { + tlwarn(" $f - $allfiles{$f}\n"); + } + } + # + # Run only the postaction code thing now since afterwards the + # files will be gone ... + if (defined($opts{'nopostinstall'}) && $opts{'nopostinstall'}) { + &TeXLive::TLUtils::do_postaction("remove", $tlp, + 0, # tlpdbopt_file_assocs, + 0, # tlpdbopt_desktop_integration, menu part + 0, # tlpdbopt_desktop_integration, desktop part + $localtlpdb->option("post_code")); + } + # + my @removals = &TeXLive::TLUtils::removed_dirs (@goodfiles); + # now do the removal + for my $entry (@goodfiles) { + unlink $entry; + } + for my $d (@removals) { + rmdir $d; + } + $localtlpdb->remove_tlpobj($pkg); + TeXLive::TLUtils::announce_execute_actions("disable", $tlp); + # should we save at each removal??? + # advantage: the tlpdb actually reflects what is installed + # disadvantage: removing a collection calls the save routine several times + # still I consider it better that the tlpdb is in a consistent state + $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. + # Again, desktop integration maps to desktop and menu links + if (!$opts{'nopostinstall'}) { + &TeXLive::TLUtils::do_postaction("remove", $tlp, + $localtlpdb->option("file_assocs"), + $localtlpdb->option("desktop_integration"), + $localtlpdb->option("desktop_integration"), + 0); + } + } + return 1; +} + + +=pod + +=item C<< $tlpdb->option($key [, $val]) >> +=item C<< $tlpdb->setting($key [, $val]) >> + +Need to be documented + +=cut + +sub _set_option_value { + my $self = shift; + $self->_set_value_pkg('00texlive.installation', 'opt_', @_); +} +sub _set_setting_value { + my $self = shift; + $self->_set_value_pkg('00texlive.installation', 'setting_', @_); +} +sub _set_value_pkg { + my ($self,$pkgname,$pre,$key,$value) = @_; + my $k = "$pre$key"; + my $pkg; + if ($self->is_virtual) { + $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname); + } else { + $pkg = $self->{'tlps'}{$pkgname}; + } + my @newdeps; + if (!defined($pkg)) { + $pkg = new TeXLive::TLPOBJ; + $pkg->name($pkgname); + $pkg->category("TLCore"); + push @newdeps, "$k:$value"; + } else { + my $found = 0; + foreach my $d ($pkg->depends) { + if ($d =~ m!^$k:!) { + $found = 1; + push @newdeps, "$k:$value"; + } else { + push @newdeps, $d; + } + } + if (!$found) { + push @newdeps, "$k:$value"; + } + } + $pkg->depends(@newdeps); + $self->add_tlpobj($pkg); +} + +sub _clear_option { + my $self = shift; + $self->_clear_pkg('00texlive.installation', 'opt_', @_); +} + +sub _clear_setting { + my $self = shift; + $self->_clear_pkg('00texlive.installation', 'setting_', @_); +} + +sub _clear_pkg { + my ($self,$pkgname,$pre,$key) = @_; + my $k = "$pre$key"; + my $pkg; + if ($self->is_virtual) { + $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname); + } else { + $pkg = $self->{'tlps'}{$pkgname}; + } + my @newdeps; + if (!defined($pkg)) { + return; + } else { + foreach my $d ($pkg->depends) { + if ($d =~ m!^$k:!) { + # do nothing, we drop the value + } else { + push @newdeps, $d; + } + } + } + $pkg->depends(@newdeps); + $self->add_tlpobj($pkg); +} + + +sub _get_option_value { + my $self = shift; + $self->_get_value_pkg('00texlive.installation', 'opt_', @_); +} + +sub _get_setting_value { + my $self = shift; + $self->_get_value_pkg('00texlive.installation', 'setting_', @_); +} + +sub _get_value_pkg { + my ($self,$pkg,$pre,$key) = @_; + my $k = "$pre$key"; + my $tlp; + if ($self->is_virtual) { + $tlp = $self->{'tlpdbs'}{'main'}->get_package($pkg); + } else { + $tlp = $self->{'tlps'}{$pkg}; + } + if (defined($tlp)) { + foreach my $d ($tlp->depends) { + if ($d =~ m!^$k:(.*)$!) { + return "$1"; + } + } + return; + } + tlwarn("TLPDB: $pkg not found, cannot read option $key.\n"); + return; +} + +sub option_pkg { + my $self = shift; + my $pkg = shift; + my $key = shift; + if (@_) { $self->_set_value_pkg($pkg, "opt_", $key, shift); } + my $ret = $self->_get_value_pkg($pkg, "opt_", $key); + # special case for location == __MASTER__ + if (defined($ret) && $ret eq "__MASTER__" && $key eq "location") { + return $self->root; + } + return $ret; +} +sub option { + my $self = shift; + my $key = shift; + if (@_) { $self->_set_option_value($key, shift); } + my $ret = $self->_get_option_value($key); + # special case for location == __MASTER__ + if (defined($ret) && $ret eq "__MASTER__" && $key eq "location") { + return $self->root; + } + return $ret; +} +sub setting_pkg { + my $self = shift; + my $pkg = shift; + my $key = shift; + if (@_) { + if ($TLPDBSettings{$key}->[0] eq "l") { + $self->_set_value_pkg($pkg, "setting_", $key, "@_"); + } else { + $self->_set_value_pkg($pkg, "setting_", $key, shift); + } + } + my $ret = $self->_get_value_pkg($pkg, "setting_", $key); + # check the types of the settings, and if it is a "l" return a list + if ($TLPDBSettings{$key}->[0] eq "l") { + my @ret; + if (defined $ret) { + @ret = split(" ", $ret); + } else { + tlwarn "TLPDB::setting_pkg: no $key, returning empty list\n"; + @ret = (); + } + return @ret; + } + return $ret; +} +sub setting { + my $self = shift; + my $key = shift; + if ($key eq "-clear") { + my $realkey = shift; + $self->_clear_setting($realkey); + return; + } + if (@_) { + if ($TLPDBSettings{$key}->[0] eq "l") { + $self->_set_setting_value($key, "@_"); + } else { + $self->_set_setting_value($key, shift); + } + } + my $ret = $self->_get_setting_value($key); + # check the types of the settings, and if it is a "l" return a list + if ($TLPDBSettings{$key}->[0] 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 reset_options { + my $self = shift; + for my $k (keys %TLPDBOptions) { + $self->option($k, $TLPDBOptions{$k}->[1]); + } +} + +sub add_default_options { + my $self = shift; + for my $k (sort keys %TLPDBOptions) { + # if the option is not set already, do set it to defaults + if (! $self->option($k) ) { + $self->option($k, $TLPDBOptions{$k}->[1]); + } + } +} + +=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; + if ($self->is_virtual) { + $pkg = $self->{'tlpdbs'}{'main'}->get_package('00texlive.installation'); + } else { + $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("TLPDB::_keyshash: Unsupported option/setting $d\n"); + } + } + } + } + return \%ret; +} + +sub options { + my $self = shift; + return ($self->_keyshash('opt_', \%TLPDBOptions)); +} +sub settings { + my $self = shift; + return ($self->_keyshash('setting_', \%TLPDBSettings)); +} + +=pod + +=item C<< $tlpdb->format_definitions >> + +This function returns a list of references to hashes where each hash +represents a parsed AddFormat line. + +=cut + +sub format_definitions { + my $self = shift; + my @ret; + foreach my $p ($self->list_packages) { + my $obj = $self->get_package ($p); + die "$0: No TeX Live package named $p, strange" if ! $obj; + push @ret, $obj->format_definitions; + } + return(@ret); +} + +=item C<< $tlpdb->fmtutil_cnf_lines >> + +The function C<fmtutil_cnf_lines> returns the list of a fmtutil.cnf file +containing only those formats present in the installation. + +Every format listed in the tlpdb but listed in the arguments +will not be included in the list of lines returned. + +=cut +sub fmtutil_cnf_lines { + my $self = shift; + my @lines; + foreach my $p ($self->list_packages) { + my $obj = $self->get_package ($p); + die "$0: No TeX Live package named $p, strange" if ! $obj; + push @lines, $obj->fmtutil_cnf_lines(@_); + } + return(@lines); +} + +=item C<< $tlpdb->updmap_cfg_lines ( [@disabled_maps] ) >> + +The function C<updmap_cfg_lines> returns the list of a updmap.cfg file +containing only those maps present in the installation. + +A map file mentioned in the tlpdb but listed in the arguments will not +be included in the list of lines returned. + +=cut +sub updmap_cfg_lines { + my $self = shift; + my @lines; + foreach my $p ($self->list_packages) { + my $obj = $self->get_package ($p); + die "$0: No TeX Live package named $p, strange" if ! $obj; + push @lines, $obj->updmap_cfg_lines(@_); + } + return(@lines); +} + +=item C<< $tlpdb->language_dat_lines ( [@disabled_hyphen_names] ) >> + +The function C<language_dat_lines> returns the list of all +lines for language.dat that can be generated from the tlpdb. + +Every hyphenation pattern listed in the tlpdb but listed in the arguments +will not be included in the list of lines returned. + +=cut + +sub language_dat_lines { + my $self = shift; + my @lines; + foreach my $p ($self->list_packages) { + my $obj = $self->get_package ($p); + die "$0: No TeX Live package named $p, strange" if ! $obj; + push @lines, $obj->language_dat_lines(@_); + } + return(@lines); +} + +=item C<< $tlpdb->language_def_lines ( [@disabled_hyphen_names] ) >> + +The function C<language_def_lines> returns the list of all +lines for language.def that can be generated from the tlpdb. + +Every hyphenation pattern listed in the tlpdb but listed in the arguments +will not be included in the list of lines returned. + +=cut + +sub language_def_lines { + my $self = shift; + my @lines; + foreach my $p ($self->list_packages) { + my $obj = $self->get_package ($p); + die "$0: No TeX Live package named $p, strange" if ! $obj; + push @lines, $obj->language_def_lines(@_); + } + return(@lines); +} + +=item C<< $tlpdb->language_lua_lines ( [@disabled_hyphen_names] ) >> + +The function C<language_lua_lines> returns the list of all +lines for language.dat.lua that can be generated from the tlpdb. + +Every hyphenation pattern listed in the tlpdb but listed in the arguments +will not be included in the list of lines returned. + +=cut + +sub language_lua_lines { + my $self = shift; + my @lines; + foreach my $p ($self->list_packages) { + my $obj = $self->get_package ($p); + die "$0: No TeX Live package named $p, strange" if ! $obj; + push @lines, $obj->language_lua_lines(@_); + } + return(@lines); +} + +=back + +=head1 VIRTUAL DATABASES + +The purpose of virtual databases is to collect several data sources +and present them in one way. The normal functions will always return +the best candidate for the set of functions. + +More docs to be written someday, maybe. + +=over 4 + +=cut + +# +# packages are saved: +# $self->{'packages'}{$pkgname}{'tags'}{$tag}{'revision'} = $rev +# $self->{'packages'}{$pkgname}{'tags'}{$tag}{'tlp'} = $tlp +# $self->{'packages'}{$pkgname}{'target'} = $target_tag +# + +sub is_virtual { + my $self = shift; + if (defined($self->{'virtual'}) && $self->{'virtual'}) { + return 1; + } + return 0; +} + +sub make_virtual { + my $self = shift; + if (!$self->is_virtual) { + if ($self->list_packages) { + tlwarn("TLPDB: cannot convert initialized tlpdb to virtual\n"); + return 0; + } + $self->{'virtual'} = 1; + } + return 1; +} + +sub virtual_get_tags { + my $self = shift; + return keys %{$self->{'tlpdbs'}}; +} + +sub virtual_get_tlpdb { + my ($self, $tag) = @_; + if (!$self->is_virtual) { + tlwarn("TLPDB: cannot remove tlpdb from a non-virtual tlpdb!\n"); + return 0; + } + if (!defined($self->{'tlpdbs'}{$tag})) { + tlwarn("TLPDB::virtual_get_tlpdb: unknown tag: $tag\n"); + return 0; + } + return $self->{'tlpdbs'}{$tag}; +} + +sub virtual_add_tlpdb { + my ($self, $tlpdb, $tag) = @_; + if (!$self->is_virtual) { + tlwarn("TLPDB: cannot virtual_add_tlpdb to a non-virtual tlpdb!\n"); + return 0; + } + $self->{'tlpdbs'}{$tag} = $tlpdb; + for my $p ($tlpdb->list_packages) { + my $tlp = $tlpdb->get_package($p); + $self->{'packages'}{$p}{'tags'}{$tag}{'revision'} = $tlp->revision; + $self->{'packages'}{$p}{'tags'}{$tag}{'tlp'} = $tlp; + } + $self->check_evaluate_pinning(); + return 1; +} + +sub virtual_remove_tlpdb { + my ($self, $tag) = @_; + if (!$self->is_virtual) { + tlwarn("TLPDB: Cannot remove tlpdb from a non-virtual tlpdb!\n"); + return 0; + } + if (!defined($self->{'tlpdbs'}{$tag})) { + tlwarn("TLPDB: virtual_remove_tlpdb: unknown tag $tag\n"); + return 0; + } + for my $p ($self->{'tlpdbs'}{$tag}->list_packages) { + delete $self->{'packages'}{$p}{'tags'}{$tag}; + } + delete $self->{'tlpdbs'}{$tag}; + $self->check_evaluate_pinning(); + return 1; +} + +sub virtual_get_package { + my ($self, $pkg, $tag) = @_; + if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { + return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; + } else { + tlwarn("TLPDB: virtual pkg $pkg not found in tag $tag\n"); + return; + } +} + +=item C<< $tlpdb->candidates ( $pkg ) >> + +Returns the list of candidates for the given package in the +format + + tag/revision + +If the returned list is empty, then the database was not virtual and +no install candidate was found. + +If the returned list contains undef as first element, the database +is virtual, and no install candidate was found. + +The remaining elements in the list are all repositories that provide +that package. + +Note that there might not be an install candidate, but still the +package is provided by a sub-repository. This can happen if a package +is present only in the sub-repository and there is no explicit pin +for that package in the pinning file. + +=cut + +sub is_repository { + my $self = shift; + my $tag = shift; + if (!$self->is_virtual) { + return ( ($tag eq $self->{'root'}) ? 1 : 0 ); + } + return ( defined($self->{'tlpdbs'}{$tag}) ? 1 : 0 ); +} + + +# returns a list of tag/rev +sub candidates { + my $self = shift; + my $pkg = shift; + my @ret = (); + if ($self->is_virtual) { + if (defined($self->{'packages'}{$pkg})) { + my $t = $self->{'packages'}{$pkg}{'target'}; + if (defined($t)) { + push @ret, "$t/" . $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}; + } else { + $t = ""; + # no target found, but maybe available somewhere else, + # we return undef as first one + push @ret, undef; + } + # make sure that we always check for main as repo + my @repos = keys %{$self->{'packages'}{$pkg}}; + for my $r (sort keys %{$self->{'packages'}{$pkg}{'tags'}}) { + push @ret, "$r/" . $self->{'packages'}{$pkg}{'tags'}{$r}{'revision'} + if ($t ne $r); + } + } + } else { + my $tlp = $self->get_package($pkg); + if (defined($tlp)) { + push @ret, "main/" . $tlp->revision; + } + } + return @ret; +} + +=item C<< $tlpdb->candidate ( ) >> + +Returns either a list of four undef, if no install candidate is found, +or the following information on the install candidate as list: the tag +name of the repository, the revision number of the package in the +candidate repository, the tlpobj of the package in the candidate +repository, and the candidate repository's TLPDB itself. + +=cut + +# +sub virtual_candidate { + my ($self, $pkg) = @_; + my $t = $self->{'packages'}{$pkg}{'target'}; + if (defined($t)) { + return ($t, $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}, + $self->{'packages'}{$pkg}{'tags'}{$t}{'tlp'}, $self->{'tlpdbs'}{$t}); + } + return(undef,undef,undef,undef); +} + +=item C<< $tlpdb->virtual_pinning ( [ $pinfile_TLConfFile] ) >> + +Sets or returns the C<TLConfFile> object for the pinning data. + +=cut + +sub virtual_pindata { + my $self = shift; + return ($self->{'pindata'}); +} + +sub virtual_update_pins { + my $self = shift; + if (!$self->is_virtual) { + tlwarn("TLPDB::virtual_update_pins: Non-virtual tlpdb can't have pins.\n"); + return 0; + } + my $pincf = $self->{'pinfile'}; + my @pins; + for my $k ($pincf->keys) { + for my $v ($pincf->value($k)) { + # we recompose the values into lines again, as we *might* have + # options later, i.e., lines of the format + # repo:pkg:opt + push (@pins, $self->make_pin_data_from_line("$k:$v")); + } + } + $self->{'pindata'} = \@pins; + $self->check_evaluate_pinning(); + return ($self->{'pindata'}); +} +sub virtual_pinning { + my ($self, $pincf) = @_; + if (!$self->is_virtual) { + tlwarn("TLPDB::virtual_pinning: Non-virtual tlpdb can't have pins.\n"); + return 0; + } + if (!defined($pincf)) { + return ($self->{'pinfile'}); + } + $self->{'pinfile'} = $pincf; + $self->virtual_update_pins(); + return ($self->{'pinfile'}); +} + +# +# current format: +# <repo>:<pkg_glob>[,<pkg_glob>,...][:<options>] +# only supported options for now is +# revision +# meaning that, if for the selected package there is no other +# "non-revision" pinning, then all repo/package versions are compared +# using normal revision comparison, and the biggest revision number wins. +# That allows you to have the same package in several repos: +# repo1:foo:revision +# repo2:foo:revision +# repo1:* +# repo2:* +# means that: +# for package "foo" the revision numbers of "foo" in the repos "repo1", +# "repo2", and "main" are numerically compared and biggest number wins. +# for all other packages of "repo1" and "repo2", other repositories +# are not considered. +# +# NOT IMPLEMENTED YET!!! +# +# $pin{'repo'} = $repo; +# $pin{'glob'} = $glob; +# $pin{'re'} = $re; +# $pin{'line'} = $line; # for debug/warning purpose +sub make_pin_data_from_line { + my $self = shift; + my $l = shift; + my ($a, $b, $c) = split(/:/, $l); + my @ret; + my %m; + $m{'repo'} = $a; + $m{'line'} = $l; + if (defined($c)) { + $m{'options'} = $c; + } + # split the package globs + for (split(/,/, $b)) { + # remove leading and terminal white space + s/^\s*//; + s/\s*$//; + my %mm = %m; + $mm{'glob'} = $_; + $mm{'re'} = glob_to_regex($_); + push @ret, \%mm; + } + return @ret; +} + +sub check_evaluate_pinning { + my $self = shift; + my @pins = (defined($self->{'pindata'}) ? @{$self->{'pindata'}} : ()); + # + # run through the pin lines and make sure that all the conditions + # and requirements are obeyed + my %pkgs = %{$self->{'packages'}}; + # main:* + my ($mainpin) = $self->make_pin_data_from_line("main:*"); + # the default main:* is always considered to be matched + $mainpin->{'hit'} = 1; + push @pins, $mainpin; + # # sort pins so that we first check specific lines without occurrences of + # # special characters, and then those with special characters. + # # The definitions are based on glob style rules, saved in $pp->{'glob'} + # # so we simply check whether there is * or ? in the string + # @pins = sort { + # my $ag = $a->{'glob'}; + # my $bg = $b->{'glob'}; + # my $cAs = () = $ag =~ /\*/g; # number of * in glob of $a + # my $cBs = () = $bg =~ /\*/g; # number of * in glob of $b + # my $cAq = () = $ag =~ /\?/g; # number of ? in glob of $a + # my $cBq = () = $bg =~ /\?/g; # number of ? in glob of $b + # my $aVal = 2 * $cAs + $cAq; + # my $bVal = 2 * $cBs + $cBq; + # $aVal <=> $bVal + # } @pins; + for my $pkg (keys %pkgs) { + PINS: for my $pp (@pins) { + my $pre = $pp->{'re'}; + if (($pkg =~ m/$pre/) && + (defined($self->{'packages'}{$pkg}{'tags'}{$pp->{'repo'}}))) { + $self->{'packages'}{$pkg}{'target'} = $pp->{'repo'}; + # register that this pin was hit + $pp->{'hit'} = 1; + last PINS; + } + } + } + # check that all pinning lines where hit + # If a repository has a catch-all pin + # foo:* + # then we do not warn about any other pin (foo:abcde) not being hit. + my %catchall; + for my $p (@pins) { + $catchall{$p->{'repo'}} = 1 if ($p->{'glob'} eq "*"); + } + for my $p (@pins) { + next if defined($p->{'hit'}); + next if defined($catchall{$p->{'repo'}}); + tlwarn("tlmgr (TLPDB): pinning warning: the package pattern ", + $p->{'glob'}, " on the line:\n ", $p->{'line'}, + "\n does not match any package\n"); + } +} + + +# implementation copied from Text/Glob.pm (copyright Richard Clamp). +# changes made: +# remove $strict_leading_dot and $strict_wildcard_slash if calls +# and execute the code unconditionally, as we do not change the +# default settings of 1 of these two variables. +sub glob_to_regex { + my $glob = shift; + my $regex = glob_to_regex_string($glob); + return qr/^$regex$/; +} + +sub glob_to_regex_string +{ + my $glob = shift; + my ($regex, $in_curlies, $escaping); + local $_; + my $first_byte = 1; + for ($glob =~ m/(.)/gs) { + if ($first_byte) { + $regex .= '(?=[^\.])' unless $_ eq '.'; + $first_byte = 0; + } + if ($_ eq '/') { + $first_byte = 1; + } + if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || + $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { + $regex .= "\\$_"; + } + elsif ($_ eq '*') { + $regex .= $escaping ? "\\*" : "[^/]*"; + } + elsif ($_ eq '?') { + $regex .= $escaping ? "\\?" : "[^/]"; + } + elsif ($_ eq '{') { + $regex .= $escaping ? "\\{" : "("; + ++$in_curlies unless $escaping; + } + elsif ($_ eq '}' && $in_curlies) { + $regex .= $escaping ? "}" : ")"; + --$in_curlies unless $escaping; + } + elsif ($_ eq ',' && $in_curlies) { + $regex .= $escaping ? "," : "|"; + } + elsif ($_ eq "\\") { + if ($escaping) { + $regex .= "\\\\"; + $escaping = 0; + } + else { + $escaping = 1; + } + next; + } + else { + $regex .= $_; + $escaping = 0; + } + $escaping = 0; + } + print "# $glob $regex\n" if debug; + + return $regex; +} + +sub match_glob { + print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; + my $glob = shift; + my $regex = glob_to_regex $glob; + local $_; + grep { $_ =~ $regex } @_; +} + +=pod + +=back + +=head1 OPTIONS + +Options regarding the full TeX Live installation to be described are saved +in a package C<00texlive.config> as values of C<depend> lines. This special +package C<00texlive.config> does not contain any files, only depend lines +which set one or more of the following options: + +=over 4 + +=item C<container_split_src_files/[01]> + +=item C<container_split_doc_files/[01]> + +These options specify that at container generation time the source and +documentation files for a package have been put into a separate container +named C<package.source.extension> and C<package.doc.extension>. + +=item C<container_format/I<format>> + +This option specifies a format for containers. The currently supported +formats are C<xz> and C<zip>. But note that C<zip> is untested. + +=item C<release/I<relspec>> + +This option specifies the current release. The first four characters must +be a year. + +=item C<minrelease/I<relspec>> + +This option specifies the minimum release for which this repository is +valid. + +=back + +To set these options the respective lines should be added to +C<00texlive.config.tlpsrc>. + +=head1 SEE ALSO + +The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, L<TeXLive::TLTREE>, +L<TeXLive::TLUtils>, etc., and the documentation in the repository: +C<Master/tlpkg/doc/>. + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +1; + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab autoindent: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm new file mode 100644 index 0000000000..54f868218c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm @@ -0,0 +1,1837 @@ +# $Id: TLPOBJ.pm 50211 2019-03-03 21:52:59Z preining $ +# TeXLive::TLPOBJ.pm - module for using tlpobj files +# Copyright 2007-2019 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLPOBJ; + +my $svnrev = '$Revision: 50211 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +use TeXLive::TLConfig qw($DefaultCategory $CategoriesRegexp + $MetaCategoriesRegexp $InfraLocation + %Compressors $DefaultCompressorFormat + $RelocPrefix $RelocTree); +use TeXLive::TLCrypto; +use TeXLive::TLTREE; +use TeXLive::TLUtils; + +our $_tmp; +my $_containerdir; + + +sub new { + my $class = shift; + my %params = @_; + my $self = { + name => $params{'name'}, + category => defined($params{'category'}) ? $params{'category'} : $DefaultCategory, + shortdesc => $params{'shortdesc'}, + longdesc => $params{'longdesc'}, + catalogue => $params{'catalogue'}, + relocated => $params{'relocated'}, + runfiles => defined($params{'runfiles'}) ? $params{'runfiles'} : [], + runsize => $params{'runsize'}, + srcfiles => defined($params{'srcfiles'}) ? $params{'srcfiles'} : [], + srcsize => $params{'srcsize'}, + docfiles => defined($params{'docfiles'}) ? $params{'docfiles'} : [], + docsize => $params{'docsize'}, + executes => defined($params{'executes'}) ? $params{'executes'} : [], + postactions => defined($params{'postactions'}) ? $params{'postactions'} : [], + # note that binfiles is a HASH with keys of $arch! + binfiles => defined($params{'binfiles'}) ? $params{'binfiles'} : {}, + binsize => defined($params{'binsize'}) ? $params{'binsize'} : {}, + depends => defined($params{'depends'}) ? $params{'depends'} : [], + revision => $params{'revision'}, + cataloguedata => defined($params{'cataloguedata'}) ? $params{'cataloguedata'} : {}, + }; + $_containerdir = $params{'containerdir'} if defined($params{'containerdir'}); + bless $self, $class; + return $self; +} + + +sub copy { + my $self = shift; + my $bla = {}; + %$bla = %$self; + bless $bla, "TeXLive::TLPOBJ"; + return $bla; +} + + +sub from_file { + my $self = shift; + if (@_ != 1) { + die("TLPOBJ:from_file: Need a filename for initialization"); + } + open(TMP,"<$_[0]") || die("Cannot open tlpobj file: $_[0]"); + $self->from_fh(\*TMP); +} + +sub from_fh { + my ($self,$fh,$multi) = @_; + my $started = 0; + my $lastcmd = ""; + my $arch; + my $size; + + while (my $line = <$fh>) { + # we do not worry about whitespace at the end of a line; + # that would be a bug in the db creation, and it takes some + # noticeable time to get rid of it. So just chomp. + chomp($line); + + # we call tllog only when something will be logged, to speed things up. + # this is the inner loop bounding the time to read tlpdb. + dddebug("reading line: >>>$line<<<\n") if ($::opt_verbosity >= 3); + $line =~ /^#/ && next; # skip comment lines + if ($line =~ /^\s*$/) { + if (!$started) { next; } + if (defined($multi)) { + # we may read from a tldb file + return 1; + } else { + # we are reading one tldb file, nothing else allowed + die("No empty line allowed within tlpobj files!"); + } + } + + my ($cmd, $arg) = split(/\s+/, $line, 2); + # first command must be name + $started || $cmd eq 'name' + or die("First directive needs to be 'name', not $line"); + + # now the big switch, ordered by decreasing number of occurences + if ($cmd eq '') { + if ($lastcmd eq "runfiles" || $lastcmd eq "srcfiles") { + push @{$self->{$lastcmd}}, $arg; + } elsif ($lastcmd eq "docfiles") { + my ($f, $rest) = split(' ', $arg, 2); + push @{$self->{'docfiles'}}, $f; + # docfiles can have tags, but the parse_line function is so + # time intense that we try to call it only when necessary + if (defined $rest) { + # parse_line has problems with double quotes in double quotes + # my @words = &TeXLive::TLUtils::parse_line('\s+', 0, $rest); + # do manual parsing + # this is not optimal, but since we support only two tags there + # are not so many cases + # Warning: need tp check the double cases first!!! + if ($rest =~ m/^language="(.*)"\s+details="(.*)"\s*$/) { + $self->{'docfiledata'}{$f}{'details'} = $2; + $self->{'docfiledata'}{$f}{'language'} = $1; + } elsif ($rest =~ m/^details="(.*)"\s+language="(.*)"\s*$/) { + $self->{'docfiledata'}{$f}{'details'} = $1; + $self->{'docfiledata'}{$f}{'language'} = $2; + } elsif ($rest =~ m/^details="(.*)"\s*$/) { + $self->{'docfiledata'}{$f}{'details'} = $1; + } elsif ($rest =~ m/^language="(.*)"\s*$/) { + $self->{'docfiledata'}{$f}{'language'} = $1; + } else { + tlwarn("$0: Unparsable tagging in TLPDB line: $line\n"); + } + } + } elsif ($lastcmd eq "binfiles") { + push @{$self->{'binfiles'}{$arch}}, $arg; + } else { + die("Continuation of $lastcmd not allowed, please fix tlpobj: line = $line!\n"); + } + } elsif ($cmd eq "longdesc") { + my $desc = defined $arg ? $arg : ''; + if (defined($self->{'longdesc'})) { + $self->{'longdesc'} .= " $desc"; + } else { + $self->{'longdesc'} = $desc; + } + } elsif ($cmd =~ /^catalogue-(.+)$/o) { + $self->{'cataloguedata'}{$1} = $arg if defined $arg; + } elsif ($cmd =~ /^(doc|src|run)files$/o) { + my $type = $1; + for (split ' ', $arg) { + my ($k, $v) = split('=', $_, 2); + if ($k eq 'size') { + $self->{"${type}size"} = $v; + } else { + die "Unknown tag: $line"; + } + } + } elsif ($cmd eq 'containersize' || $cmd eq 'srccontainersize' + || $cmd eq 'doccontainersize') { + $arg =~ /^[0-9]+$/ or die "Invalid size value: $line!"; + $self->{$cmd} = $arg; + } elsif ($cmd eq 'containermd5' || $cmd eq 'srccontainermd5' + || $cmd eq 'doccontainermd5') { + $arg =~ /^[a-f0-9]{32}$/ or die "Invalid md5 value: $line!"; + $self->{$cmd} = $arg; + } elsif ($cmd eq 'containerchecksum' || $cmd eq 'srccontainerchecksum' + || $cmd eq 'doccontainerchecksum') { + $arg =~ /^[a-f0-9]{$TeXLive::TLConfig::ChecksumLength}$/ + or die "Invalid checksum value: $line!"; + $self->{$cmd} = $arg; + } elsif ($cmd eq 'name') { + $arg =~ /^([-.\w]+)$/ or die("Invalid name: $line!"); + $self->{'name'} = $arg; + $started && die("Cannot have two name directives: $line!"); + $started = 1; + } elsif ($cmd eq 'category') { + $self->{'category'} = $arg; + if ($self->{'category'} !~ /^$CategoriesRegexp/o) { + tlwarn("Unknown category " . $self->{'category'} . " for package " + . $self->name . " found.\nPlease update texlive.infra.\n"); + } + } elsif ($cmd eq 'revision') { + $self->{'revision'} = $arg; + } elsif ($cmd eq 'shortdesc') { + $self->{'shortdesc'} .= defined $arg ? $arg : ' '; + } elsif ($cmd eq 'execute' || $cmd eq 'postaction' + || $cmd eq 'depend') { + push @{$self->{$cmd . 's'}}, $arg if defined $arg; + } elsif ($cmd eq 'binfiles') { + for (split ' ', $arg) { + my ($k, $v) = split('=', $_, 2); + if ($k eq 'arch') { + $arch = $v; + } elsif ($k eq 'size') { + $size = $v; + } else { + die "Unknown tag: $line"; + } + } + if (defined($size)) { + $self->{'binsize'}{$arch} = $size; + } + } elsif ($cmd eq 'relocated') { + ($arg eq '0' || $arg eq '1') or die "Invalid value: $line!"; + $self->{'relocated'} = $arg; + } elsif ($cmd eq 'catalogue') { + $self->{'catalogue'} = $arg; + } else { + die("Unknown directive ...$line... , please fix it!"); + } + $lastcmd = $cmd unless $cmd eq ''; + } + return $started; +} + +sub recompute_revision { + my ($self,$tltree, $revtlpsrc) = @_; + my @files = $self->all_files; + my $filemax = 0; + $self->revision(0); + foreach my $f (@files) { + $filemax = $tltree->file_svn_lastrevision($f); + $self->revision(($filemax > $self->revision) ? $filemax : $self->revision); + } + if (defined($revtlpsrc)) { + if ($self->revision < $revtlpsrc) { + $self->revision($revtlpsrc); + } + } +} + +sub recompute_sizes { + my ($self,$tltree) = @_; + $self->{'docsize'} = $self->_recompute_size("doc",$tltree); + $self->{'srcsize'} = $self->_recompute_size("src",$tltree); + $self->{'runsize'} = $self->_recompute_size("run",$tltree); + foreach $a ($tltree->architectures) { + $self->{'binsize'}{$a} = $self->_recompute_size("bin",$tltree,$a); + } +} + + +sub _recompute_size { + my ($self,$type,$tltree,$arch) = @_; + my $nrivblocks = 0; + if ($type eq "bin") { + my %binfiles = %{$self->{'binfiles'}}; + if (defined($binfiles{$arch})) { + foreach $f (@{$binfiles{$arch}}) { + my $s = $tltree->size_of($f); + $nrivblocks += int($s/$TeXLive::TLConfig::BlockSize); + $nrivblocks++ if (($s%$TeXLive::TLConfig::BlockSize) > 0); + } + } + } else { + if (defined($self->{"${type}files"}) && (@{$self->{"${type}files"}})) { + foreach $f (@{$self->{"${type}files"}}) { + my $s = $tltree->size_of($f); + if (defined($s)) { + $nrivblocks += int($s/$TeXLive::TLConfig::BlockSize); + $nrivblocks++ if (($s%$TeXLive::TLConfig::BlockSize) > 0); + } else { + printf STDERR "size for $f not defined, strange ...\n"; + } + } + } + } + return $nrivblocks; +} + +sub writeout { + my $self = shift; + my $fd = (@_ ? $_[0] : STDOUT); + print $fd "name ", $self->name, "\n"; + print $fd "category ", $self->category, "\n"; + defined($self->{'revision'}) && print $fd "revision $self->{'revision'}\n"; + defined($self->{'catalogue'}) && print $fd "catalogue $self->{'catalogue'}\n"; + defined($self->{'shortdesc'}) && print $fd "shortdesc $self->{'shortdesc'}\n"; + defined($self->{'license'}) && print $fd "license $self->{'license'}\n"; + defined($self->{'relocated'}) && $self->{'relocated'} && print $fd "relocated 1\n"; + # don't want to use FileHandle.pm; see man perlform + #format_name $fd "multilineformat"; + select((select($fd),$~ = "multilineformat")[0]); + $fd->format_lines_per_page (99999); # no pages in this format + if (defined($self->{'longdesc'})) { + $_tmp = "$self->{'longdesc'}"; + write $fd; # use that multilineformat + } + if (defined($self->{'depends'})) { + foreach (@{$self->{'depends'}}) { + print $fd "depend $_\n"; + } + } + if (defined($self->{'executes'})) { + foreach (@{$self->{'executes'}}) { + print $fd "execute $_\n"; + } + } + if (defined($self->{'postactions'})) { + foreach (@{$self->{'postactions'}}) { + print $fd "postaction $_\n"; + } + } + if (defined($self->{'containersize'})) { + print $fd "containersize $self->{'containersize'}\n"; + } + if (defined($self->{'containermd5'})) { + print $fd "containermd5 $self->{'containermd5'}\n"; + } + if (defined($self->{'containerchecksum'})) { + print $fd "containerchecksum $self->{'containerchecksum'}\n"; + } + if (defined($self->{'doccontainersize'})) { + print $fd "doccontainersize $self->{'doccontainersize'}\n"; + } + if (defined($self->{'doccontainermd5'})) { + print $fd "doccontainermd5 $self->{'doccontainermd5'}\n"; + } + if (defined($self->{'doccontainerchecksum'})) { + print $fd "doccontainerchecksum $self->{'doccontainerchecksum'}\n"; + } + if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) { + print $fd "docfiles size=$self->{'docsize'}\n"; + foreach my $f (sort @{$self->{'docfiles'}}) { + print $fd " $f"; + if (defined($self->{'docfiledata'}{$f}{'details'})) { + my $tmp = $self->{'docfiledata'}{$f}{'details'}; + #$tmp =~ s/\"/\\\"/g; + print $fd ' details="', $tmp, '"'; + } + if (defined($self->{'docfiledata'}{$f}{'language'})) { + my $tmp = $self->{'docfiledata'}{$f}{'language'}; + #$tmp =~ s/\"/\\\"/g; + print $fd ' language="', $tmp, '"'; + } + print $fd "\n"; + } + } + if (defined($self->{'srccontainersize'})) { + print $fd "srccontainersize $self->{'srccontainersize'}\n"; + } + if (defined($self->{'srccontainermd5'})) { + print $fd "srccontainermd5 $self->{'srccontainermd5'}\n"; + } + if (defined($self->{'srccontainerchecksum'})) { + print $fd "srccontainerchecksum $self->{'srccontainerchecksum'}\n"; + } + if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) { + print $fd "srcfiles size=$self->{'srcsize'}\n"; + foreach (sort @{$self->{'srcfiles'}}) { + print $fd " $_\n"; + } + } + if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) { + print $fd "runfiles size=$self->{'runsize'}\n"; + foreach (sort @{$self->{'runfiles'}}) { + print $fd " $_\n"; + } + } + foreach my $arch (sort keys %{$self->{'binfiles'}}) { + if (@{$self->{'binfiles'}{$arch}}) { + print $fd "binfiles arch=$arch size=", $self->{'binsize'}{$arch}, "\n"; + foreach (sort @{$self->{'binfiles'}{$arch}}) { + print $fd " $_\n"; + } + } + } + # writeout all the catalogue keys + foreach my $k (sort keys %{$self->cataloguedata}) { + print $fd "catalogue-$k ", $self->cataloguedata->{$k}, "\n"; + } +} + +sub writeout_simple { + my $self = shift; + my $fd = (@_ ? $_[0] : STDOUT); + print $fd "name ", $self->name, "\n"; + print $fd "category ", $self->category, "\n"; + if (defined($self->{'depends'})) { + foreach (@{$self->{'depends'}}) { + print $fd "depend $_\n"; + } + } + if (defined($self->{'executes'})) { + foreach (@{$self->{'executes'}}) { + print $fd "execute $_\n"; + } + } + if (defined($self->{'postactions'})) { + foreach (@{$self->{'postactions'}}) { + print $fd "postaction $_\n"; + } + } + if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) { + print $fd "docfiles\n"; + foreach (sort @{$self->{'docfiles'}}) { + print $fd " $_\n"; + } + } + if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) { + print $fd "srcfiles\n"; + foreach (sort @{$self->{'srcfiles'}}) { + print $fd " $_\n"; + } + } + if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) { + print $fd "runfiles\n"; + foreach (sort @{$self->{'runfiles'}}) { + print $fd " $_\n"; + } + } + foreach my $arch (sort keys %{$self->{'binfiles'}}) { + if (@{$self->{'binfiles'}{$arch}}) { + print $fd "binfiles arch=$arch\n"; + foreach (sort @{$self->{'binfiles'}{$arch}}) { + print $fd " $_\n"; + } + } + } +} + +sub as_json { + my $self = shift; + my %addargs = @_; + my %foo = %{$self}; + # set the additional args + for my $k (keys %addargs) { + if (defined($addargs{$k})) { + $foo{$k} = $addargs{$k}; + } else { + delete($foo{$k}); + } + } + # make sure numbers are encoded as numbers + for my $k (qw/revision runsize docsize srcsize containersize lrev rrev + srccontainersize doccontainersize runcontainersize/) { + $foo{$k} += 0 if exists($foo{$k}); + } + for my $k (keys %{$foo{'binsize'}}) { + $foo{'binsize'}{$k} += 0; + } + # encode boolean as boolean flags + if (exists($foo{'relocated'})) { + if ($foo{'relocated'}) { + $foo{'relocated'} = TeXLive::TLUtils::True(); + } else { + $foo{'relocated'} = TeXLive::TLUtils::False(); + } + } + # adjust the docfiles entry to the specification in JSON-formats + my @docf = $self->docfiles; + my $dfd = $self->docfiledata; + my @newdocf; + for my $f ($self->docfiles) { + my %newd; + $newd{'file'} = $f; + if (defined($dfd->{$f})) { + # TODO should we check that there are actually only "details" + # and "language" as key? + for my $k (keys %{$dfd->{$f}}) { + $newd{$k} = $dfd->{$f}->{$k}; + } + } + push @newdocf, \%newd; + } + $foo{'docfiles'} = [ @newdocf ]; + delete($foo{'docfiledata'}); + # + my $utf8_encoded_json_text = TeXLive::TLUtils::encode_json(\%foo); + return $utf8_encoded_json_text; +} + + +sub cancel_reloc_prefix { + my $self = shift; + my @docfiles = $self->docfiles; + for (@docfiles) { s:^$RelocPrefix/::; } + $self->docfiles(@docfiles); + my @runfiles = $self->runfiles; + for (@runfiles) { s:^$RelocPrefix/::; } + $self->runfiles(@runfiles); + my @srcfiles = $self->srcfiles; + for (@srcfiles) { s:^$RelocPrefix/::; } + $self->srcfiles(@srcfiles); + # if there are bin files they have definitely NOT the + # texmf-dist prefix, so we cannot cancel it anyway +} + +sub replace_reloc_prefix { + my $self = shift; + my @docfiles = $self->docfiles; + for (@docfiles) { s:^$RelocPrefix/:$RelocTree/:; } + $self->docfiles(@docfiles); + my @runfiles = $self->runfiles; + for (@runfiles) { s:^$RelocPrefix/:$RelocTree/:; } + $self->runfiles(@runfiles); + my @srcfiles = $self->srcfiles; + for (@srcfiles) { s:^$RelocPrefix/:$RelocTree/:; } + $self->srcfiles(@srcfiles); + # docfiledata needs to be adapted too + my $data = $self->docfiledata; + my %newdata; + while (my ($k, $v) = each %$data) { + $k =~ s:^$RelocPrefix/:$RelocTree/:; + $newdata{$k} = $v; + } + $self->docfiledata(%newdata); + # if there are bin files they have definitely NOT the + # texmf-dist prefix, so we cannot cancel it anyway +} + +sub cancel_common_texmf_tree { + my $self = shift; + my @docfiles = $self->docfiles; + for (@docfiles) { s:^$RelocTree/:$RelocPrefix/:; } + $self->docfiles(@docfiles); + my @runfiles = $self->runfiles; + for (@runfiles) { s:^$RelocTree/:$RelocPrefix/:; } + $self->runfiles(@runfiles); + my @srcfiles = $self->srcfiles; + for (@srcfiles) { s:^$RelocTree/:$RelocPrefix/:; } + $self->srcfiles(@srcfiles); + # docfiledata needs to be adapted too + my $data = $self->docfiledata; + my %newdata; + while (my ($k, $v) = each %$data) { + $k =~ s:^$RelocTree/:$RelocPrefix/:; + $newdata{$k} = $v; + } + $self->docfiledata(%newdata); + # if there are bin files they have definitely NOT the + # texmf-dist prefix, so we cannot cancel it anyway +} + +sub common_texmf_tree { + my $self = shift; + my $tltree; + my $dd = 0; + my @files = $self->all_files; + foreach ($self->all_files) { + my $tmp; + ($tmp) = split m@/@; + if (defined($tltree) && ($tltree ne $tmp)) { + return; + } else { + $tltree = $tmp; + } + } + # if there are no files then it is by default relocatable, so + # return the right tree + if (!@files) { + $tltree = $RelocTree; + } + return $tltree; +} + + +sub make_container { + my ($self,$type,$instroot,$destdir,$containername,$relative) = @_; + if (!($type eq 'tar' || + TeXLive::TLUtils::member($type, @{$::progs{'working_compressors'}}))) { + tlwarn "$0: TLPOBJ supports @{$::progs{'working_compressors'}} and tar containers, not $type\n"; + tlwarn "$0: falling back to $DefaultCompressorFormat as container type!\n"; + $type = $DefaultCompressorFormat; + } + + if (!defined($containername)) { + $containername = $self->name; + } + my @files = $self->all_files; + my $compresscmd; + my $tlpobjdir = "$InfraLocation/tlpobj"; + @files = TeXLive::TLUtils::sort_uniq(@files); + # we do relative packages ONLY if the files do NOT span multiple + # texmf trees. check this here + my $tltree; + if ($relative) { + $tltree = $self->common_texmf_tree; + if (!defined($tltree)) { + die ("$0: package $containername spans multiple trees, " + . "relative generation not allowed"); + } + if ($tltree ne $RelocTree) { + die ("$0: building $containername container relocatable but the common" + . " prefix is not $RelocTree"); + } + s,^$RelocTree/,, foreach @files; + } + # load Cwd only if necessary ... + require Cwd; + my $cwd = &Cwd::getcwd; + if ("$destdir" !~ m@^(.:)?[/\\]@) { + # we have an relative containerdir, so we have to make it absolute + $destdir = "$cwd/$destdir"; + } + &TeXLive::TLUtils::mkdirhier("$destdir"); + chdir($instroot); + # in the relative case we have to chdir to the respective tltree + # and put the tlpobj into the root! + my $removetlpkgdir = 0; + if ($relative) { + chdir("./$tltree"); + # in the relocatable case we will probably create the tlpkg dir + # in texmf-dist/tlpkg and want to remove it afterwards. + $removetlpkgdir = 1; + # we don't need to change the $tlpobjdir because we put it in + # all cases into tlpkg/tlpobj + #$tlpobjdir = "./tlpkg/tlpobj"; + } + # we add the .tlpobj into the .tlpobj directory + my $removetlpobjdir = 0; + if (! -d "$tlpobjdir") { + &TeXLive::TLUtils::mkdirhier("$tlpobjdir"); + $removetlpobjdir = 1; + } + open(TMP,">$tlpobjdir/$self->{'name'}.tlpobj") + || die "$0: create($tlpobjdir/$self->{'name'}.tlpobj) failed: $!"; + # when we do relative we have to cancel the prefix before writing out + my $selfcopy = $self->copy; + if ($relative) { + $selfcopy->cancel_common_texmf_tree; + $selfcopy->relocated($relative); + } + $selfcopy->writeout(\*TMP); + close(TMP); + push(@files, "$tlpobjdir/$self->{'name'}.tlpobj"); + $tarname = "$containername.tar"; + + # start the fun + my $tar = $::progs{'tar'}; + if (!defined($tar)) { + tlwarn("$0: programs not set up, trying \"tar\".\n"); + $tar = "tar"; + } + + $containername = $tarname; + + # Here we need to distinguish between making the master containers for + # tlnet (where we can assume GNU tar) and making backups on a user's + # machine (where we can assume nothing). We determine this by whether + # there's a revision suffix in the container name. + # + # For the master containers, we want to set the owner/group, exclude + # .svn directories, and force ustar format. This last is for the sake + # of packages such as pgf which have filenames long enough that they + # overflow standard tar format and result in special things being + # done. We don't want the GNU-specific special things. + # + my $is_user_container = ( $containername =~ /\.r[0-9]/ ); + my @attrs + = $is_user_container + ? () + : ( "--owner", "0", "--group", "0", "--exclude", ".svn", + "--format", "ustar" ); + my @cmdline = ($tar, "-cf", "$destdir/$tarname", @attrs); + + # Get list of files and symlinks to back up. Nothing else should be + # in the list. + my @files_to_backup = (); + for my $f (@files) { + if (-f $f || -l $f) { + push(@files_to_backup, $f); + } elsif (! -e $f) { + tlwarn("$0: (make_container $containername) $f does not exist\n"); + } else { + tlwarn("$0: (make_container $containername) $f not file or symlink\n"); + } + } + + my $tartempfile = ""; + if (win32()) { + # Since we provide our own (GNU) tar on Windows, we know it has -T. + my $tmpdir = TeXLive::TLUtils::tl_tmpdir(); + $tartempfile = "$tmpdir/mc$$"; + open(TMP, ">$tartempfile") || die "open(>$tartempfile) failed: $!"; + print TMP map { "$_\n" } @files_to_backup; + close(TMP) || warn "close(>$tartempfile) failed: $!"; + push(@cmdline, "-T", $tartempfile); + } else { + # For Unix, we pass all the files on the command line, because there + # is no portable (across different platforms and different tars) way + # to pass them on stdin. Unfortunately, this can be too lengthy of + # a command line -- our biggest package is tex4ht, which needs about + # 200k. CentOS 5.2, at least, starts complaining around 140k. + # + # Therefore, if the command is likely to be too long, we call + # our collapse_dirs routine; in practice, this eliminates + # essentially all the individual files, leaving just a few + # directories, which is no problem. (For example, tex4ht collapses + # down to five directories and one file.) + # + # Although in principle we could do this in all cases, collapse_dirs + # isn't the most thoroughly tested function in the world. It seems + # safer to only do it in the (few) potentially problematic cases. + # + if (length ("@files_to_backup") > 50000) { + @files_to_backup = TeXLive::TLUtils::collapse_dirs(@files_to_backup); + # A complication, as always. collapse_dirs returns absolute paths. + # We want to change them back to relative so that the backup tar + # has the same structure. + # in relative mode we have to remove the texmf-dist prefix, too + s,^$instroot/,, foreach @files_to_backup; + if ($relative) { + s,^$RelocTree/,, foreach @files_to_backup; + } + } + push(@cmdline, @files_to_backup); + } + + # Run tar. Unlink both here in case the container is also plain tar. + unlink("$destdir/$tarname"); + unlink("$destdir/$containername"); + xsystem(@cmdline); + + if ($type ne 'tar') { + # compress it + my $compressor = $::progs{$type}; + if (!defined($compressor)) { + # fall back to $type as compressor, but that shouldn't happen + tlwarn("$0: programs not set up, trying \"$type\".\n"); + $compressor = $type; + } + my @compressorargs = @{$Compressors{$type}{'compress_args'}}; + my $compressorextension = $Compressors{$type}{'extension'}; + $containername = "$tarname.$compressorextension"; + debug("selected compressor: $compressor with @compressorargs, " + . "on $destdir/$tarname\n"); + + # compress it. + if (-r "$destdir/$tarname") { + # system return 0 on success + if (system($compressor, @compressorargs, "$destdir/$tarname")) { + tlwarn("$0: Couldn't compress $destdir/$tarname\n"); + return (0,0, ""); + } + # make sure we remove the original tar since old lz4 versions + # cannot automatically delete it. + # We remove the tar file only when the compressed file was + # correctly created, something that should only happen in the + # most strange cases. + unlink("$destdir/$tarname") + if ((-r "$destdir/$tarname") && (-r "$destdir/$containername")); + } else { + tlwarn("$0: Couldn't find $destdir/$tarname to run $compressor\n"); + return (0, 0, ""); + } + } + + # compute the size. + if (! -r "$destdir/$containername") { + tlwarn ("$0: Couldn't find $destdir/$containername\n"); + return (0, 0, ""); + } + my $size = (stat "$destdir/$containername") [7]; + # + # if we are creating a system container, or there is a way to + # compute the checksums, do it + my $checksum = ""; + if (!$is_user_container || $::checksum_method) { + $checksum = TeXLive::TLCrypto::tlchecksum("$destdir/$containername"); + } + + # cleaning up + unlink("$tlpobjdir/$self->{'name'}.tlpobj"); + unlink($tartempfile) if $tartempfile; + rmdir($tlpobjdir) if $removetlpobjdir; + rmdir($InfraLocation) if $removetlpkgdir; + xchdir($cwd); + + debug(" done $containername, size $size, $checksum\n"); + return ($size, $checksum, "$destdir/$containername"); +} + + + +sub is_arch_dependent { + my $self = shift; + if (keys %{$self->{'binfiles'}}) { + return 1; + } else { + return 0; + } +} + +# computes the total size of a package +# if no arguments are given this is +# docsize + runsize + srcsize + max of binsize +sub total_size { + my ($self,@archs) = @_; + my $ret = $self->docsize + $self->runsize + $self->srcsize; + if ($self->is_arch_dependent) { + my $max = 0; + my %foo = %{$self->binsize}; + foreach my $k (keys %foo) { + $max = $foo{$k} if ($foo{$k} > $max); + } + $ret += $max; + } + return($ret); +} + + +# update_from_catalogue($tlc) +# Update the current TLPOBJ object with the information from the +# corresponding entry in C<$tlc->entries>. +# +sub update_from_catalogue { + my ($self, $tlc) = @_; + my $tlcname = $self->name; + if (defined($self->catalogue)) { + $tlcname = $self->catalogue; + } elsif ($tlcname =~ m/^bin-(.*)$/) { + if (!defined($tlc->entries->{$tlcname})) { + $tlcname = $1; + } + } + $tlcname = lc($tlcname); + if (defined($tlc->entries->{$tlcname})) { + my $entry = $tlc->entries->{$tlcname}; + # Record the id of the catalogue entry if it's found due to + # quest4texlive. + if ($entry->entry->{'id'} ne $tlcname) { + $self->catalogue($entry->entry->{'id'}); + } + if (defined($entry->entry->{'date'})) { + my $foo = $entry->entry->{'date'}; + $foo =~ s/^.Date: //; + # trying to extract the interesting part of a subversion date + # keyword expansion here, e.g., + # $Date: 2019-03-03 22:52:59 +0100 (Sun, 03 Mar 2019) $ + # ->2007-08-15 19:43:35 +0100 + $foo =~ s/ \(.*\)( *\$ *)$//; # maybe nothing after parens + $self->cataloguedata->{'date'} = $foo; + } + if (defined($entry->license)) { + $self->cataloguedata->{'license'} = $entry->license; + } + if (defined($entry->version) && $entry->version ne "") { + $self->cataloguedata->{'version'} = $entry->version; + } + if (defined($entry->ctan) && $entry->ctan ne "") { + $self->cataloguedata->{'ctan'} = $entry->ctan; + } + # TODO TODO TODO + # we should rewrite the also fields to TeX Live package names ... + # for now these are CTAN package names! + # warning, we expect that cataloguedata entries are strings, + # so stringify these lists + if (@{$entry->also}) { + $self->cataloguedata->{'also'} = "@{$entry->also}"; + } + if (@{$entry->alias}) { + $self->cataloguedata->{'alias'} = "@{$entry->alias}"; + } + if (@{$entry->topics}) { + $self->cataloguedata->{'topics'} = "@{$entry->topics}"; + } + if (%{$entry->contact}) { + for my $k (keys %{$entry->contact}) { + $self->cataloguedata->{"contact-$k"} = $entry->contact->{$k}; + } + } + #if (defined($entry->texlive)) { + # $self->cataloguedata->{'texlive'} = $entry->texlive; + #} + #if (defined($entry->miktex)) { + # $self->cataloguedata->{'miktex'} = $entry->miktex; + #} + if (defined($entry->caption) && $entry->caption ne "") { + $self->{'shortdesc'} = $entry->caption unless $self->{'shortdesc'}; + } + if (defined($entry->description) && $entry->description ne "") { + $self->{'longdesc'} = $entry->description unless $self->{'longdesc'}; + } + # + # we need to do the following: + # - take the href entry for a documentation file entry in the TC + # - remove the 'ctan:' prefix + # - remove the <ctan path='...'> part + # - match the rest against all docfiles in an intelligent way + # + # Example: + # juramisc.xml contains: + # <documentation details='Package documentation' language='de' + # href='ctan:/macros/latex/contrib/juramisc/doc/jmgerdoc.pdf'/> + # <ctan path='/macros/latex/contrib/juramisc'/> + my @tcdocfiles = keys %{$entry->docs}; # Catalogue doc files. + my %tcdocfilebasenames; # basenames of those, as we go. + my @tlpdocfiles = $self->docfiles; # TL doc files. + foreach my $tcdocfile (sort @tcdocfiles) { # sort so shortest first + #warn "looking at tcdocfile $tcdocfile\n"; + my $tcdocfilebasename = $tcdocfile; + $tcdocfilebasename =~ s/^ctan://; # remove ctan: prefix + $tcdocfilebasename =~ s,.*/,,; # remove all but the base file name + #warn " got basename $tcdocfilebasename\n"; + # + # If we've already seen this basename, skip. This is for the sake + # of README files, which can exist in different directories but + # get renamed into different files in TL for various annoying reasons; + # e.g., ibygrk, rsfs, songbook. In these cases, it turns out we + # always prefer the first entry (top-level README). + next if exists $tcdocfilebasenames{$tcdocfilebasename}; + $tcdocfilebasenames{$tcdocfilebasename} = 1; + # + foreach my $tlpdocfile (@tlpdocfiles) { + #warn "considering merge into tlpdocfile $tlpdocfile\n"; + if ($tlpdocfile =~ m,/$tcdocfilebasename$,) { + # update the language/detail tags from Catalogue if present. + if (defined($entry->docs->{$tcdocfile}{'details'})) { + my $tmp = $entry->docs->{$tcdocfile}{'details'}; + #warn "merging details for $tcdocfile: $tmp\n"; + # remove all embedded quotes, they are just a pain + $tmp =~ s/"//g; + $self->{'docfiledata'}{$tlpdocfile}{'details'} = $tmp; + } + if (defined($entry->docs->{$tcdocfile}{'language'})) { + my $tmp = $entry->docs->{$tcdocfile}{'language'}; + #warn "merging lang for $tcdocfile: $tmp\n"; + $self->{'docfiledata'}{$tlpdocfile}{'language'} = $tmp; + } + } + } + } + } +} + +sub is_meta_package { + my $self = shift; + if ($self->category =~ /^$MetaCategoriesRegexp$/) { + return 1; + } + return 0; +} + +sub docfiles_package { + my $self = shift; + if (not($self->docfiles)) { return ; } + my $tlp = new TeXLive::TLPOBJ; + $tlp->name($self->name . ".doc"); + $tlp->shortdesc("doc files of " . $self->name); + $tlp->revision($self->revision); + $tlp->category($self->category); + $tlp->add_docfiles($self->docfiles); + $tlp->docsize($self->docsize); + # $self->clear_docfiles(); + # $self->docsize(0); + return($tlp); +} + +sub srcfiles_package { + my $self = shift; + if (not($self->srcfiles)) { return ; } + my $tlp = new TeXLive::TLPOBJ; + $tlp->name($self->name . ".source"); + $tlp->shortdesc("source files of " . $self->name); + $tlp->revision($self->revision); + $tlp->category($self->category); + $tlp->add_srcfiles($self->srcfiles); + $tlp->srcsize($self->srcsize); + # $self->clear_srcfiles(); + # $self->srcsize(0); + return($tlp); +} + +sub split_bin_package { + my $self = shift; + my %binf = %{$self->binfiles}; + my @retlist; + foreach $a (keys(%binf)) { + my $tlp = new TeXLive::TLPOBJ; + $tlp->name($self->name . ".$a"); + $tlp->shortdesc("$a files of " . $self->name); + $tlp->revision($self->revision); + $tlp->category($self->category); + $tlp->add_binfiles($a,@{$binf{$a}}); + $tlp->binsize( $a => $self->binsize->{$a} ); + push @retlist, $tlp; + } + if (keys(%binf)) { + push @{$self->{'depends'}}, $self->name . ".ARCH"; + } + $self->clear_binfiles(); + return(@retlist); +} + + +# Helpers. +# +sub add_files { + my ($self,$type,@files) = @_; + die("Cannot use add_files for binfiles, we need that arch!") + if ($type eq "bin"); + &TeXLive::TLUtils::push_uniq(\@{ $self->{"${type}files"} }, @files); +} + +sub remove_files { + my ($self,$type,@files) = @_; + die("Cannot use remove_files for binfiles, we need that arch!") + if ($type eq "bin"); + my @finalfiles; + foreach my $f (@{$self->{"${type}files"}}) { + if (not(&TeXLive::TLUtils::member($f,@files))) { + push @finalfiles,$f; + } + } + $self->{"${type}files"} = [ @finalfiles ]; +} + +sub contains_file { + my ($self,$fn) = @_; + # if the filename already contains a / do not add it at the beginning + my $ret = ""; + if ($fn =~ m!/!) { + return(grep(m!$fn$!, $self->all_files)); + } else { + return(grep(m!(^|/)$fn$!,$self->all_files)); + } +} + +sub all_files { + my ($self) = shift; + my @ret = (); + + push (@ret, $self->docfiles); + push (@ret, $self->runfiles); + push (@ret, $self->srcfiles); + push (@ret, $self->allbinfiles); + + return @ret; +} + +sub allbinfiles { + my $self = shift; + my @ret = (); + my %binfiles = %{$self->binfiles}; + + foreach my $arch (keys %binfiles) { + push (@ret, @{$binfiles{$arch}}); + } + + return @ret; +} + +sub format_definitions { + my $self = shift; + my $pkg = $self->name; + my @ret; + for my $e ($self->executes) { + if ($e =~ m/AddFormat\s+(.*)\s*/) { + my %r = TeXLive::TLUtils::parse_AddFormat_line("$1"); + if (defined($r{"error"})) { + die "$r{'error'}, package $pkg, execute $e"; + } + push @ret, \%r; + } + } + return @ret; +} + +# +# execute stuff +# +sub fmtutil_cnf_lines { + my $obj = shift; + my @disabled = @_; + my @fmtlines = (); + my $first = 1; + my $pkg = $obj->name; + foreach my $e ($obj->executes) { + if ($e =~ m/AddFormat\s+(.*)\s*/) { + my %r = TeXLive::TLUtils::parse_AddFormat_line("$1"); + if (defined($r{"error"})) { + die "$r{'error'}, package $pkg, execute $e"; + } + if ($first) { + push @fmtlines, "#\n# from $pkg:\n"; + $first = 0; + } + my $mode = ($r{"mode"} ? "" : "#! "); + $mode = "#! " if TeXLive::TLUtils::member ($r{'name'}, @disabled); + push @fmtlines, "$mode$r{'name'} $r{'engine'} $r{'patterns'} $r{'options'}\n"; + } + } + return @fmtlines; +} + + +sub updmap_cfg_lines { + my $obj = shift; + my @disabled = @_; + my %maps; + foreach my $e ($obj->executes) { + if ($e =~ m/addMap (.*)$/) { + $maps{$1} = 1; + } elsif ($e =~ m/addMixedMap (.*)$/) { + $maps{$1} = 2; + } elsif ($e =~ m/addKanjiMap (.*)$/) { + $maps{$1} = 3; + } + # others are ignored here + } + my @updmaplines; + foreach (sort keys %maps) { + next if TeXLive::TLUtils::member($_, @disabled); + if ($maps{$_} == 1) { + push @updmaplines, "Map $_\n"; + } elsif ($maps{$_} == 2) { + push @updmaplines, "MixedMap $_\n"; + } elsif ($maps{$_} == 3) { + push @updmaplines, "KanjiMap $_\n"; + } else { + tlerror("Should not happen!\n"); + } + } + return(@updmaplines); +} + + +sub language_dat_lines { + my $self = shift; + local @disabled = @_; # we use @disabled in the nested sub + my @lines = $self->_parse_hyphen_execute(\&make_dat_lines, 'dat'); + return @lines; + + sub make_dat_lines { + my ($name, $lhm, $rhm, $file, $syn) = @_; + my @ret; + return if TeXLive::TLUtils::member($name, @disabled); + push @ret, "$name $file\n"; + foreach (@$syn) { + push @ret, "=$_\n"; + } + return @ret; + } +} + + +sub language_def_lines { + my $self = shift; + local @disabled = @_; # we use @disabled in the nested sub + my @lines = $self->_parse_hyphen_execute(\&make_def_lines, 'def'); + return @lines; + + sub make_def_lines { + my ($name, $lhm, $rhm, $file, $syn) = @_; + return if TeXLive::TLUtils::member($name, @disabled); + my $exc = ""; + my @ret; + push @ret, "\\addlanguage\{$name\}\{$file\}\{$exc\}\{$lhm\}\{$rhm\}\n"; + foreach (@$syn) { + # synonyms in language.def ??? + push @ret, "\\addlanguage\{$_\}\{$file\}\{$exc\}\{$lhm\}\{$rhm\}\n"; + #debug("Ignoring synonym $_ for $name when creating language.def\n"); + } + return @ret; + } +} + + +sub language_lua_lines { + my $self = shift; + local @disabled = @_; # we use @disabled in the nested sub + my @lines = $self->_parse_hyphen_execute(\&make_lua_lines, 'lua', '--'); + return @lines; + + sub make_lua_lines { + my ($name, $lhm, $rhm, $file, $syn, $patt, $hyph, $special) = @_; + return if TeXLive::TLUtils::member($name, @disabled); + my @syn = (@$syn); # avoid modifying the original + map { $_ = "'$_'" } @syn; + my @ret; + push @ret, "['$name'] = {", "\tloader = '$file',", + "\tlefthyphenmin = $lhm,", "\trighthyphenmin = $rhm,", + "\tsynonyms = { " . join(', ', @syn) . " },"; + push @ret, "\tpatterns = '$patt'," if defined $patt; + push @ret, "\thyphenation = '$hyph'," if defined $hyph; + push @ret, "\tspecial = '$special'," if defined $special; + push @ret, '},'; + map { $_ = "\t$_\n" } @ret; + return @ret; + } +} + + +sub _parse_hyphen_execute { + my ($obj, $coderef, $db, $cc) = @_; + $cc ||= '%'; # default comment char + my @langlines = (); + my $pkg = $obj->name; + my $first = 1; + foreach my $e ($obj->executes) { + if ($e =~ m/AddHyphen\s+(.*)\s*/) { + my %r = TeXLive::TLUtils::parse_AddHyphen_line("$1"); + if (defined($r{"error"})) { + die "$r{'error'}, package $pkg, execute $e"; + } + if (not TeXLive::TLUtils::member($db, @{$r{"databases"}})) { + next; + } + if ($first) { + push @langlines, "$cc from $pkg:\n"; + $first = 0; + } + if ($r{"comment"}) { + push @langlines, "$cc $r{comment}\n"; + } + my @foo = &$coderef ($r{"name"}, $r{"lefthyphenmin"}, + $r{"righthyphenmin"}, $r{"file"}, $r{"synonyms"}, + $r{"file_patterns"}, $r{"file_exceptions"}, + $r{"luaspecial"}); + push @langlines, @foo; + } + } + return @langlines; +} + + + +# member access functions +# +sub _set_get_array_value { + my $self = shift; + my $key = shift; + if (@_) { + if (defined($_[0])) { + $self->{$key} = [ @_ ]; + } else { + $self->{$key} = [ ]; + } + } + return @{ $self->{$key} }; +} +sub name { + my $self = shift; + if (@_) { $self->{'name'} = shift } + return $self->{'name'}; +} +sub category { + my $self = shift; + if (@_) { $self->{'category'} = shift } + return $self->{'category'}; +} +sub shortdesc { + my $self = shift; + if (@_) { $self->{'shortdesc'} = shift } + return $self->{'shortdesc'}; +} +sub longdesc { + my $self = shift; + if (@_) { $self->{'longdesc'} = shift } + return $self->{'longdesc'}; +} +sub revision { + my $self = shift; + if (@_) { $self->{'revision'} = shift } + return $self->{'revision'}; +} +sub relocated { + my $self = shift; + if (@_) { $self->{'relocated'} = shift } + return ($self->{'relocated'} ? 1 : 0); +} +sub catalogue { + my $self = shift; + if (@_) { $self->{'catalogue'} = shift } + return $self->{'catalogue'}; +} +sub srcfiles { + _set_get_array_value(shift, "srcfiles", @_); +} +sub containersize { + my $self = shift; + if (@_) { $self->{'containersize'} = shift } + return ( defined($self->{'containersize'}) ? $self->{'containersize'} : -1 ); +} +sub srccontainersize { + my $self = shift; + if (@_) { $self->{'srccontainersize'} = shift } + return ( defined($self->{'srccontainersize'}) ? $self->{'srccontainersize'} : -1 ); +} +sub doccontainersize { + my $self = shift; + if (@_) { $self->{'doccontainersize'} = shift } + return ( defined($self->{'doccontainersize'}) ? $self->{'doccontainersize'} : -1 ); +} +sub containermd5 { + my $self = shift; + if (@_) { $self->{'containermd5'} = shift } + if (defined($self->{'containermd5'})) { + return ($self->{'containermd5'}); + } else { + tlwarn("TLPOBJ: MD5 sums are no longer supported, please adapt your code!\n"); + return (""); + } +} +sub srccontainermd5 { + my $self = shift; + if (@_) { $self->{'srccontainermd5'} = shift } + if (defined($self->{'srccontainermd5'})) { + return ($self->{'srccontainermd5'}); + } else { + tlwarn("TLPOBJ: MD5 sums are no longer supported, please adapt your code!\n"); + return (""); + } +} +sub doccontainermd5 { + my $self = shift; + if (@_) { $self->{'doccontainermd5'} = shift } + if (defined($self->{'doccontainermd5'})) { + return ($self->{'doccontainermd5'}); + } else { + tlwarn("TLPOBJ: MD5 sums are no longer supported, please adapt your code!\n"); + return (""); + } +} +sub containerchecksum { + my $self = shift; + if (@_) { $self->{'containerchecksum'} = shift } + return ( defined($self->{'containerchecksum'}) ? $self->{'containerchecksum'} : "" ); +} +sub srccontainerchecksum { + my $self = shift; + if (@_) { $self->{'srccontainerchecksum'} = shift } + return ( defined($self->{'srccontainerchecksum'}) ? $self->{'srccontainerchecksum'} : "" ); +} +sub doccontainerchecksum { + my $self = shift; + if (@_) { $self->{'doccontainerchecksum'} = shift } + return ( defined($self->{'doccontainerchecksum'}) ? $self->{'doccontainerchecksum'} : "" ); +} +sub srcsize { + my $self = shift; + if (@_) { $self->{'srcsize'} = shift } + return ( defined($self->{'srcsize'}) ? $self->{'srcsize'} : 0 ); +} +sub clear_srcfiles { + my $self = shift; + $self->{'srcfiles'} = [ ] ; +} +sub add_srcfiles { + my ($self,@files) = @_; + $self->add_files("src",@files); +} +sub remove_srcfiles { + my ($self,@files) = @_; + $self->remove_files("src",@files); +} +sub docfiles { + _set_get_array_value(shift, "docfiles", @_); +} +sub clear_docfiles { + my $self = shift; + $self->{'docfiles'} = [ ] ; +} +sub docsize { + my $self = shift; + if (@_) { $self->{'docsize'} = shift } + return ( defined($self->{'docsize'}) ? $self->{'docsize'} : 0 ); +} +sub add_docfiles { + my ($self,@files) = @_; + $self->add_files("doc",@files); +} +sub remove_docfiles { + my ($self,@files) = @_; + $self->remove_files("doc",@files); +} +sub docfiledata { + my $self = shift; + my %newfiles = @_; + if (@_) { $self->{'docfiledata'} = \%newfiles } + return $self->{'docfiledata'}; +} +sub binfiles { + my $self = shift; + my %newfiles = @_; + if (@_) { $self->{'binfiles'} = \%newfiles } + return $self->{'binfiles'}; +} +sub clear_binfiles { + my $self = shift; + $self->{'binfiles'} = { }; +} +sub binsize { + my $self = shift; + my %newsizes = @_; + if (@_) { $self->{'binsize'} = \%newsizes } + return $self->{'binsize'}; +} +sub add_binfiles { + my ($self,$arch,@files) = @_; + &TeXLive::TLUtils::push_uniq(\@{ $self->{'binfiles'}{$arch} }, @files); +} +sub remove_binfiles { + my ($self,$arch,@files) = @_; + my @finalfiles; + foreach my $f (@{$self->{'binfiles'}{$arch}}) { + if (not(&TeXLive::TLUtils::member($f,@files))) { + push @finalfiles,$f; + } + } + $self->{'binfiles'}{$arch} = [ @finalfiles ]; +} +sub runfiles { + _set_get_array_value(shift, "runfiles", @_); +} +sub clear_runfiles { + my $self = shift; + $self->{'runfiles'} = [ ] ; +} +sub runsize { + my $self = shift; + if (@_) { $self->{'runsize'} = shift } + return ( defined($self->{'runsize'}) ? $self->{'runsize'} : 0 ); +} +sub add_runfiles { + my ($self,@files) = @_; + $self->add_files("run",@files); +} +sub remove_runfiles { + my ($self,@files) = @_; + $self->remove_files("run",@files); +} +sub depends { + _set_get_array_value(shift, "depends", @_); +} +sub executes { + _set_get_array_value(shift, "executes", @_); +} +sub postactions { + _set_get_array_value(shift, "postactions", @_); +} +sub containerdir { + my @self = shift; + if (@_) { $_containerdir = $_[0] } + return $_containerdir; +} +sub cataloguedata { + my $self = shift; + my %ct = @_; + if (@_) { $self->{'cataloguedata'} = \%ct } + return $self->{'cataloguedata'}; +} + +$: = " \n"; # don't break at - +format multilineformat = +longdesc ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ +$_tmp +. + +1; +__END__ + + +=head1 NAME + +C<TeXLive::TLPOBJ> -- TeX Live Package Object access module + +=head1 SYNOPSIS + + use TeXLive::TLPOBJ; + + my $tlpobj=TeXLive::TLPOBJ->new(name => "foobar"); + +=head1 DESCRIPTION + +The L<TeXLive::TLPOBJ> module provide access to TeX Live Package Object +files describing a self-contained package. + +=head1 FILE SPECIFICATION + +Please see L<TeXLive::TLPSRC> documentation for the specification. The +only differences are that the various C<*pattern> keys are invalid, and +instead there are the respective C<*files> keys described below. Furthermore +some more I<keys> is allowed: C<revision> which specifies the maximum of +all last changed revision of files contained in the package, anything +starting with C<catalogue-> specifying information coming from the +TeX Catalogue, and C<relocated> taking either 0 or 1 indicating that +this packages has been relocated, i.e., in the containers the +initial C<texmf-dist> directory has been stripped off. + +All these keys have in common that they are followed by a list of files +I<indented> by one space. They differ only in the first line itself +(described below). + +=over 4 + +=item C<srcfiles>, C<runfiles>, C<binfiles>, C<docfiles> +each of these items contains addition the sum of sizes of the +single files (in number of C<TeXLive::TLConfig::BlockSize> blocks, which +is currently 4k). + + srcfiles size=NNNNNN + runfiles size=NNNNNN + +=item C<docfiles> + +The docfiles line itself is similar to the C<srcfiles> and C<runfiles> lines +above: + + docfiles size=NNNNNN + +But the lines listing the files are allowed to have additional tags: + + /------- excerpt from achemso.tlpobj + |... + |docfiles size=1702468 + | texmf-dist/doc/latex/aeguill/README details="Package Readme" + | texmf-dist/doc/latex/achemso/achemso.pdf details="Package documentation" language="en" + |... + +Currently only the tags C<details> and C<language> are allowed. These +additional information can be accessed via the C<docfiledata> function +returning a hash with the respective files (including path) as key. + +=item C<binfiles> + +Since C<binfiles> are different for the different architectures one +C<tlpobj> file can contain C<binfiles> lines for different +architectures. The architecture is specified on the C<binfiles> using +the C<arch=>I<XXX> tag. Thus, C<binfiles> lines look like + + binfiles arch=XXXX size=NNNNN + +=back + +Here is an excerpt from the representation of the C<dvipsk> package, +with C<|> characters inserted to show the indentation: + + |name dvipsk + |category TLCore + |revision 4427 + |docfiles size=959434 + | texmf-dist/doc/dvips/dvips.html + | ... + |runfiles size=1702468 + | texmf-dist/dvips/base/color.pro + | ... + | texmf-dist/scripts/pkfix/pkfix.pl + |binfiles arch=i386-solaris size=329700 + | bin/i386-solaris/afm2tfm + | bin/i386-solaris/dvips + | bin/i386-solaris/pkfix + |binfiles arch=win32 size=161280 + | bin/win32/afm2tfm.exe + | bin/win32/dvips.exe + | bin/win32/pkfix.exe + |... + +=head1 PACKAGE VARIABLES + +TeXLive::TLPOBJ has one package wide variable which is C<containerdir> where +generated container files are saved (if not otherwise specified. + + TeXLive::TLPOBJ->containerdir("path/to/container/dir"); + +=head1 MEMBER ACCESS FUNCTIONS + +For any of the I<keys> a function + + $tlpobj->key + +is available, which returns the current value when called without an argument, +and sets the respective value when called with an argument. For the +TeX Catalogue Data the function + + $tlpobj->cataloguedata + +returns and takes as argument a hash. + +Arguments and return values for C<name>, C<category>, C<shortdesc>, +C<longdesc>, C<catalogue>, C<revision> are single scalars. + +Arguments and return values for C<depends>, C<executes> are lists. + +Arguments and return values for C<docfiles>, C<runfiles>, C<srcfiles> +are lists. + +Arguments and return values for C<binfiles> is a hash with the +architectures as keys. + +Arguments and return values for C<docfiledata> is a hash with the +full file names of docfiles as key, and the value is again a hash. + +The size values are handled with these functions: + + $tlpobj->docsize + $tlpobj->runsize + $tlpobj->srcsize + $tlpobj->binsize("arch1" => size1, "arch2" => size2, ...) + +which set or get the current value of the respective sizes. Note that also +the C<binsize> function returns (and takes as argument) a hash with the +architectures as keys, similar to the C<runfiles> functions (see above). + +Futhermore, if the tlpobj is contained ina tlpdb which describes a media +where the files are distributed in packed format (usually as .tar.xz), +there are 6 more possible keys: + + $tlpobj->containersize + $tlpobj->doccontainersize + $tlpobj->srccontainersize + $tlpobj->containerchecksum + $tlpobj->doccontainerchecksum + $tlpobj->srccontainerchecksum + +describing the respective sizes and checksums in bytes and as hex string, resp. +The latter two are only present if src/doc file container splitting is +activated for that install medium. + +=head1 OTHER FUNCTIONS + +The following functions can be called for an C<TLPOBJ> object: + +=over 4 + +=item C<new> + +The constructor C<new> returns a new C<TLPSRC> object. The arguments +to the C<new> constructor can be in the usual hash representation for +the different keys above: + + $tlpobj=TLPOBJ->new(name => "foobar", shortdesc => "The foobar package"); + +=item C<from_file("filename")> + +reads a C<tlpobj> file. + + $tlpobj = new TLPOBJ; + $tlpobj->from_file("path/to/the/tlpobj/file"); + +=item C<from_fh($filehandle[, $multi])> + +read the textual representation of a TLPOBJ from an already opened +file handle. If C<$multi> is undef (i.e., not given) then multiple +tlpobj in the same file are treated as errors. If C<$multi> is defined, +then returns after reading one tlpobj. + +Returns C<1> if it found a C<tlpobj>, otherwise C<0>. + +=item C<writeout> + +writes the textual representation of a C<TLPOBJ> object to C<stdout>, +or the filehandle if given: + + $tlpsrc->writeout; + $tlpsrc->writeout(\*FILEHANDLE); + +=item C<writeout_simple> + +debugging function for comparison with C<tpm>/C<tlps>, will go away. + +=item C<as_json> + +returns the representation of the C<TLPOBJ> in JSON format. + +=item C<common_texmf_tree> + +if all files of the package are from the same texmf tree, this tree +is returned, otherwise an undefined value. That is also a check +whether a package is relocatable. + +=item C<make_container($type,$instroot[, $destdir[, $containername[, $relative]]])> + +creates a container file of the all files in the C<TLPOBJ> +in C<$destdir> (if not defined then C<< TLPOBJ->containerdir >> is used). + +The C<$type> variable specifies the type of container to be used. +Currently only C<zip> or C<xz> are allowed, and are generating +zip files and tar.xz files, respectively. + +The file name of the created container file is C<$containername.extension>, +where extension is either C<.zip> or C<.tar.xz>, depending on the +setting of C<$type>. If no C<$containername> is specified the package name +is used. + +All container files B<also> contain the respective +C<TLPOBJ> file in C<tlpkg/tlpobj/$name.tlpobj>. + +The argument C<$instroot> specifies the root of the installation from +which the files should be taken. + +If the argument C<$relative> is present and true (perlish true) AND the +packages does not span multiple texmf trees (i.e., all the first path +components of all files are the same) then a relative packages is created, +i.e., the first path component is stripped. In this case the tlpobj file +is placed into the root of the installation. + +This is used to distribute packages which can be installed in any arbitrary +texmf tree (of other distributions, too). + +Return values are the size, the checksum, and the full name of the container. + +=item C<recompute_sizes($tltree)> + +recomputes the sizes based on the information present in C<$tltree>. + +=item C<recompute_revision($tltree [, $revtlpsrc ])> + +recomputes the revision based on the information present in C<$tltree>. +The optional argument C<$rectlpsrc> can be an additional revision number +which is taken into account. C<$tlpsrc->make_tlpobj> adds the revision +number of the C<tlpsrc> file here so that collections (which do not +contain files) also have revision number. + +=item C<update_from_catalogue($texcatalogue)> + +adds information from a C<TeXCatalogue> object +(currently license, version, url, and updates docfiles with details and +languages tags if present in the Catalogue). + +=item C<split_bin_package> + +splits off the binfiles of C<TLPOBJ> into new independent C<TLPOBJ> with +the original name plus ".arch" for every arch for which binfiles are present. +The original package is changed in two respects: the binfiles are removed +(since they are now in the single name.arch packages), and an additional +depend on "name.ARCH" is added. Note that the ARCH is a placeholder. + +=item C<srcfiles_package> + +=item C<docfiles_package> + +splits off the srcfiles or docfiles of C<TLPOBJ> into new independent +C<TLPOBJ> with +the original name plus ".sources". The source/doc files are +B<not> removed from the original package, since these functions are only +used for the creation of split containers. + +=item C<is_arch_dependent> + +returns C<1> if there are C<binfiles>, otherwise C<0>. + +=item C<total_size> + +If no argument is given returns the sum of C<srcsize>, C<docsize>, +C<runsize>. + +If arguments are given, they are assumed to be architecture names, and +it returns the above plus the sum of sizes of C<binsize> for those +architectures. + +=item C<is_meta_package> + +Returns true if the package is a meta package as defined in TLConfig +(Currently Collection and Scheme). + +=item C<clear_{src,run,doc,bin}files> + +Removes all the src/run/doc/binfiles from the C<TLPOBJ>. + +=item C<{add,remove}_{src,run,doc}files(@files)> + +adds or removes files to the respective list of files. + +=item C<{add,remove}_binfiles($arch, @files)> + +adds or removes files from the list of C<binfiles> for the given architecture. + +=item C<{add,remove}_files($type, $files)> + +adds or removes files for the given type (only for C<run>, C<src>, C<doc>). + +=item C<contains_file($filename)> + +returns the list of files matching $filename which are contained in +the package. If $filename contains a / the matching is only anchored +at the end with $. Otherwise it is prefix with a / and anchored at the end. + +=item C<all_files> + +returns a list of all files of all types. However, binary files won't +be found until dependencies have been expanded via (most likely) +L<TeXLive::TLPDB::expand_dependencies>. For a more or less standalone +example, see the C<find_old_files> function in the +script C<Master/tlpkg/libexec/place>. + +=item C<allbinfiles> + +returns a list of all binary files. + +=item C<< $tlpobj->format_definitions >> + +The function C<format_definitions> returns a list of references to hashes +where each hash is a format definition. + +=item C<< $tlpobj->fmtutil_cnf_lines >> + +The function C<fmtutil_cnf_lines> returns the lines for fmtutil.cnf +for this package. + +=item C<< $tlpobj->updmap_cfg_lines >> + +The function C<updmap_cfg_lines> returns the list lines for updmap.cfg +for the given package. + +=item C<< $tlpobj->language_dat_lines >> + +The function C<language_dat_lines> returns the list of all +lines for language.dat that can be generated from the tlpobj + +=item C<< $tlpobj->language_def_lines >> + +The function C<language_def_lines> returns the list of all +lines for language.def that can be generated from the tlpobj. + +=item C<< $tlpobj->language_lua_lines >> + +The function C<language_lua_lines> returns the list of all +lines for language.dat.lua that can be generated from the tlpobj. + +=back + +=head1 SEE ALSO + +The modules L<TeXLive::TLConfig>, L<TeXLive::TLCrypto>, +L<TeXLive::TLUtils>, L<TeXLive::TLPSRC>, L<TeXLive::TLPDB>, +L<TeXLive::TLTREE>, L<TeXLive::TeXCatalogue>, etc., and the +documentation in the repository: C<Master/tlpkg/doc/>. + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLPSRC.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLPSRC.pm new file mode 100644 index 0000000000..1bd1e73808 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLPSRC.pm @@ -0,0 +1,1194 @@ +# $Id: TLPSRC.pm 49434 2018-12-17 18:48:58Z karl $ +# TeXLive::TLPSRC.pm - module for handling tlpsrc files +# Copyright 2007-2018 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLPSRC; + +use FileHandle; +use TeXLive::TLConfig qw($CategoriesRegexp $DefaultCategory); +use TeXLive::TLUtils; +use TeXLive::TLPOBJ; +use TeXLive::TLTREE; + +my $svnrev = '$Revision: 49434 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +my $_tmp; # sorry +my %autopatterns; # computed once internally + +sub new { + my $class = shift; + my %params = @_; + my $self = { + name => $params{'name'}, + category => defined($params{'category'}) ? $params{'category'} + : $DefaultCategory, + shortdesc => $params{'shortdesc'}, + longdesc => $params{'longdesc'}, + catalogue => $params{'catalogue'}, + runpatterns => $params{'runpatterns'}, + srcpatterns => $params{'srcpatterns'}, + docpatterns => $params{'docpatterns'}, + binpatterns => $params{'binpatterns'}, + postactions => $params{'postactions'}, + executes => defined($params{'executes'}) ? $params{'executes'} : [], + depends => defined($params{'depends'}) ? $params{'depends'} : [], + }; + bless $self, $class; + return $self; +} + + +sub from_file { + my $self = shift; + die "need exactly one filename for initialization" if @_ != 1; + my $srcfile = $_[0]; + my $pkgname = TeXLive::TLUtils::basename($srcfile); + $pkgname =~ s/\.tlpsrc$//; + + if (! -r "$srcfile") { + # if the argument is not readable as is, try looking for it in the + # hierarchy where we are. The %INC hash records where packages were + # found, so we use that to locate ourselves. + (my $trydir = $INC{"TeXLive/TLPSRC.pm"}) =~ s,/[^/]*$,,; + chomp ($trydir = `cd $trydir/../tlpsrc && pwd`); # make absolute + my $tryfile = "$trydir/$pkgname.tlpsrc"; + #warn "$trydir\n$tryfile\n"; + $srcfile = $tryfile if -r $tryfile; + } + + open(TMP, "<$srcfile") || die("failed to open tlpsrc '$srcfile': $!"); + my @lines = <TMP>; + close(TMP); + + my $name = $pkgname; + my $category = "Package"; + my $shortdesc = ""; + my $longdesc= ""; + my $catalogue = ""; + my (@executes, @depends); + my (@runpatterns, @docpatterns, @binpatterns, @srcpatterns); + my (@postactions); + my $foundnametag = 0; + my $finished = 0; + my $savedline = ""; + my %tlpvars; + $tlpvars{"PKGNAME"} = $name; + + my $lineno = 0; + for my $line (@lines) { + $lineno++; + + # we allow continuation lines in tlpsrc files, i.e., lines ending with \. + if ($line =~ /^(.*)\\$/) { + $savedline .= $1; + next; + } + if ($savedline ne "") { + # we are in a continuation line + $line = "$savedline$line"; + $savedline = ""; + } + + $line =~ /^\s*#/ && next; # skip comment lines + next if $line =~ /^\s*$/; # skip blank lines + # (blank lines are significant in tlpobj, but not tlpsrc) + # + $line =~ /^ / + && die "$srcfile:$lineno: non-continuation indentation not allowed: `$line'"; + # + # remove trailing white space. + $line =~ s/\s+$//; + + # expand tlpvars while reading in (except in descriptions). + # that means we have to respect *order* and define variables + # as we read the tlpsrc file. + if ($line !~ /^(short|long)desc\s/) { + #debug: my $origline = $line; + for my $k (keys %tlpvars) { + $line =~ s/\$\{\Q$k\E\}/$tlpvars{$k}/g; + } + # check that no variables remain unexpanded, or rather, for any + # remaining $ (which we don't otherwise allow in tlpsrc files, so + # should never occur) ... except for ${ARCH} which we specially + # expand in TLTREE.pm. (Sigh: we distribute one file dvi$pdf.bat, + # but fortunately it is matched by a directory.) + # + (my $testline = $line) =~ s,\$\{ARCH\},,g; + $testline =~ /\$/ + && die "$srcfile:$lineno: variable undefined or syntax error: $line\n"; + #debug: warn "new line $line, from $origline\n" if $origline ne $line; + } # end variable expansion. + + # names of source packages can either be + # - normal names: ^[-\w]+$ + # - win32 specific packages: ^[-\w]+\.win32$ + # - normal texlive specific packages: ^texlive.*\..*$ + # - configuration texlive specific packages: ^00texlive.*\..*$ + if ($line =~ /^name\s/) { + $line =~ /^name\s+([-\w]+(\.win32)?|(00)?texlive\..*)$/; + $foundnametag + && die "$srcfile:$lineno: second name directive not allowed: $line" + . "(have $name)\n"; + $name = $1; + $foundnametag = 1; + # let's assume that $PKGNAME doesn't occur before any name + # directive (which would result in different expansions); there is + # no need for it in practice. + $tlpvars{"PKGNAME"} = $name; + + } elsif ($line =~ /^category\s+$CategoriesRegexp$/) { + $category = $1; + + } elsif ($line =~ /^shortdesc\s*(.*)$/) { + $shortdesc + && die "$srcfile:$lineno: second shortdesc not allowed: $line" + . "(have $shortdesc)\n"; + $shortdesc = $1; + + } elsif ($line =~ /^shortdesc$/) { + $shortdesc = ""; + + } elsif ($line =~ /^longdesc$/) { + $longdesc .= "\n"; + + } elsif ($line =~ /^longdesc\s+(.*)$/) { + $longdesc .= "$1 "; + + } elsif ($line =~ /^catalogue\s+(.*)$/) { + $catalogue + && die "$srcfile:$lineno: second catalogue not allowed: $line" + . "(have $catalogue)\n"; + $catalogue = $1; + + } elsif ($line =~ /^runpattern\s+(.*)$/) { + push (@runpatterns, $1) if ($1 ne ""); + + } elsif ($line =~ /^srcpattern\s+(.*)$/) { + push (@srcpatterns, $1) if ($1 ne ""); + + } elsif ($line =~ /^docpattern\s+(.*)$/) { + push (@docpatterns, $1) if ($1 ne ""); + + } elsif ($line =~ /^binpattern\s+(.*)$/) { + push (@binpatterns, $1) if ($1 ne ""); + + } elsif ($line =~ /^execute\s+(.*)$/) { + push (@executes, $1) if ($1 ne ""); + + } elsif ($line =~ /^depend\s+(.*)$/) { + push (@depends, $1) if ($1 ne ""); + + } elsif ($line =~ /^postaction\s+(.*)$/) { + push (@postactions, $1) if ($1 ne ""); + + } elsif ($line =~ /^tlpsetvar\s+([-_a-zA-Z0-9]+)\s+(.*)$/) { + $tlpvars{$1} = $2; + + } else { + die "$srcfile:$lineno: unknown tlpsrc directive, fix: $line\n"; + } + } + $self->_srcfile($srcfile); + if ($name =~ m/^[[:space:]]*$/) { + die "Cannot deduce name from file argument and name tag not found"; + } + $self->name($name); + $self->category($category); + $self->catalogue($catalogue) if $catalogue; + $self->shortdesc($shortdesc) if $shortdesc; + $self->longdesc($longdesc) if $longdesc; + $self->srcpatterns(@srcpatterns) if @srcpatterns; + $self->runpatterns(@runpatterns) if @runpatterns; + $self->binpatterns(@binpatterns) if @binpatterns; + $self->docpatterns(@docpatterns) if @docpatterns; + $self->executes(@executes) if @executes; + $self->depends(@depends) if @depends; + $self->postactions(@postactions) if @postactions; +} + + +sub writeout { + my $self = shift; + my $fd = (@_ ? $_[0] : STDOUT); + format_name $fd "multilineformat"; # format defined in TLPOBJ, and $: + $fd->format_lines_per_page (99999); # no pages in this format + print $fd "name ", $self->name, "\n"; + print $fd "category ", $self->category, "\n"; + defined($self->{'catalogue'}) && print $fd "catalogue $self->{'catalogue'}\n"; + defined($self->{'shortdesc'}) && print $fd "shortdesc $self->{'shortdesc'}\n"; + if (defined($self->{'longdesc'})) { + $_tmp = "$self->{'longdesc'}"; + write $fd; # use that multilineformat + } + if (defined($self->{'depends'})) { + foreach (@{$self->{'depends'}}) { + print $fd "depend $_\n"; + } + } + if (defined($self->{'executes'})) { + foreach (@{$self->{'executes'}}) { + print $fd "execute $_\n"; + } + } + if (defined($self->{'postactions'})) { + foreach (@{$self->{'postactions'}}) { + print $fd "postaction $_\n"; + } + } + if (defined($self->{'srcpatterns'}) && (@{$self->{'srcpatterns'}})) { + foreach (sort @{$self->{'srcpatterns'}}) { + print $fd "srcpattern $_\n"; + } + } + if (defined($self->{'runpatterns'}) && (@{$self->{'runpatterns'}})) { + foreach (sort @{$self->{'runpatterns'}}) { + print $fd "runpattern $_\n"; + } + } + if (defined($self->{'docpatterns'}) && (@{$self->{'docpatterns'}})) { + foreach (sort @{$self->{'docpatterns'}}) { + print $fd "docpattern $_\n"; + } + } + if (defined($self->{'binpatterns'}) && (@{$self->{'binpatterns'}})) { + foreach (sort @{$self->{'binpatterns'}}) { + print $fd "binpattern $_\n"; + } + } +} + + +# the hard work, generate the TLPOBJ data. +# +sub make_tlpobj { + my ($self,$tltree,$autopattern_root) = @_; + my %allpatterns = &find_default_patterns($autopattern_root); + my $category_patterns = $allpatterns{$self->category}; + + my $tlp = TeXLive::TLPOBJ->new; + $tlp->name($self->name); + $tlp->category($self->category); + $tlp->shortdesc($self->{'shortdesc'}) if (defined($self->{'shortdesc'})); + $tlp->longdesc($self->{'longdesc'}) if (defined($self->{'longdesc'})); + $tlp->catalogue($self->{'catalogue'}) if (defined($self->{'catalogue'})); + $tlp->executes(@{$self->{'executes'}}) if (defined($self->{'executes'})); + $tlp->postactions(@{$self->{'postactions'}}) if (defined($self->{'postactions'})); + $tlp->depends(@{$self->{'depends'}}) if (defined($self->{'depends'})); + $tlp->revision(0); + + # convert each fmttrigger to a depend line, if not already present. + if (defined($tlp->executes)) { # else no fmttriggers + my @deps = (defined($tlp->depends) ? $tlp->depends : ()); + my $tlpname = $tlp->name; + for my $e ($tlp->executes) { + # we only check for AddFormat lines + if ($e =~ m/^\s*AddFormat\s+(.*)\s*$/) { + my %fmtline = TeXLive::TLUtils::parse_AddFormat_line($1); + if (defined($fmtline{"error"})) { + tlwarn ("error in parsing $e for return hash: $fmtline{error}\n"); + } else { + # make sure that we don't add circular deps + TeXLive::TLUtils::push_uniq (\@deps, + grep { $_ ne $tlpname } @{$fmtline{'fmttriggers'}}); + } + } + } + $tlp->depends(@deps); + } + + my $filemax; + my $usedefault; + my @allpospats; + my @allnegpats; + my $pkgname = $self->name; + my @autoaddpat; + + # src/run/doc patterns + # + # WARNING WARNING WARNING + # the "bin" must be last since we drop through for further dealing + # with specialities of the bin patterns!!!! + for my $pattype (qw/src run doc bin/) { + @allpospats = (); + @allnegpats = (); + @autoaddpat = (); + $usedefault = 1; + foreach my $p (@{$self->{${pattype} . 'patterns'}}) { + if ($p =~ m/^a\s+(.*)\s*$/) { + # format + # a toplevel1 toplevel2 toplevel3 ... + # which add autopatterns as if we are doing single packages + # toplevel1 toplevel2 toplevel3 + push @autoaddpat, split(' ', $1); + } elsif ($p =~ m/^!\+(.*)$/) { + push @allnegpats, $1; + } elsif ($p =~ m/^\+!(.*)$/) { + push @allnegpats, $1; + } elsif ($p =~ m/^\+(.*)$/) { + push @allpospats, $1; + } elsif ($p =~ m/^!(.*)$/) { + push @allnegpats, $1; + $usedefault = 0; + } else { + push @allpospats, $p; + $usedefault = 0; + } + } + + if ($usedefault) { + push @autoaddpat, $pkgname; + } + if (defined($category_patterns)) { + for my $a (@autoaddpat) { + my $type_patterns = $category_patterns->{$pattype}; + for my $p (@{$type_patterns}) { + # the occurrence of %[str:]NAME[:str]% and its + # expansion is documented in 00texlive.autopatterns.tlpsrc + # we have to make a copy of $p otherwise we change it in the + # hash once and for all + my $pp = $p; + while ($pp =~ m/%(([^%]*):)?NAME(:([^%]*))?%/) { + my $nn = $a; + if (defined($1)) { + $nn =~ s/^$2//; + } + if (defined($3)) { + $nn =~ s/$4$//; + } + $pp =~ s/%(([^%]*):)?NAME(:([^%]*))?%/$nn/; + } + # replace the string %NAME% with the actual package name + #(my $pp = $p) =~ s/%NAME%/$a/g; + # sort through the patterns, and make sure that * are added to + # tag the default patterns + if ($pp =~ m/^!(.*)$/) { + push @allnegpats, "*$1"; + } else { + push @allpospats, "*$pp"; + } + } + } + } + # at this point we do NOT do the actual pattern matching for + # bin patterns, since we have some specialities to do + last if ($pattype eq "bin"); + + # for all other patterns we create the list and add the files + foreach my $p (@allpospats) { + ddebug("pos pattern $p\n"); + $self->_do_normal_pattern($p,$tlp,$tltree,$pattype); + } + foreach my $p (@allnegpats) { + ddebug("neg pattern $p\n"); + $self->_do_normal_pattern($p,$tlp,$tltree,$pattype,1); + } + } + # + # binpatterns + # + # mind that @allpospats and @allnegpats have already been set up + # in the above loop. We only have to deal with the specialities of + # the bin patterns + foreach my $p (@allpospats) { + my @todoarchs = $tltree->architectures; + my $finalp = $p; + if ($p =~ m%^(\w+)/(!?[-_a-z0-9,]+)\s+(.*)$%) { + my $pt = $1; + my $aa = $2; + my $pr = $3; + if ($aa =~ m/^!(.*)$/) { + # negative specification + my %negarchs; + foreach (split(/,/,$1)) { + $negarchs{$_} = 1; + } + my @foo = (); + foreach (@todoarchs) { + push @foo, $_ unless defined($negarchs{$_}); + } + @todoarchs = @foo; + } else { + @todoarchs = split(/,/,$aa); + } + # set $p to the pattern without arch specification + $finalp = "$pt $pr"; + } + # one final trick + # if the original pattern string matches bin/win32/ then we *only* + # work on the win32 arch + if ($finalp =~ m! bin/win32/!) { + @todoarchs = qw/win32/; + } + # now @todoarchs contains only those archs for which we want + # to match the pattern + foreach my $arch (@todoarchs) { + # get only those files matching the pattern + my @archfiles = $tltree->get_matching_files('bin',$finalp, $pkgname, $arch); + if (!@archfiles) { + if (($arch ne "win32") || defined($::tlpsrc_pattern_warn_win)) { + tlwarn("$self->{name} ($arch): no hit on binpattern $finalp\n"); + } + } + $tlp->add_binfiles($arch,@archfiles); + } + } + foreach my $p (@allnegpats) { + my @todoarchs = $tltree->architectures; + my $finalp = $p; + if ($p =~ m%^(\w+)/(!?[-_a-z0-9,]+)\s+(.*)$%) { + my $pt = $1; + my $aa = $2; + my $pr = $3; + if ($aa =~ m/^!(.*)$/) { + # negative specification + my %negarchs; + foreach (split(/,/,$1)) { + $negarchs{$_} = 1; + } + my @foo = (); + foreach (@todoarchs) { + push @foo, $_ unless defined($negarchs{$_}); + } + @todoarchs = @foo; + } else { + @todoarchs = split(/,/,$aa); + } + # set $p to the pattern without arch specification + $finalp = "$pt $pr"; + } + # now @todoarchs contains only those archs for which we want + # to match the pattern + foreach my $arch (@todoarchs) { + # get only those files matching the pattern + my @archfiles = $tltree->get_matching_files('bin', $finalp, $pkgname, $arch); + if (!@archfiles) { + if (($arch ne "win32") || defined($::tlpsrc_pattern_warn_win)) { + tlwarn("$self->{name} ($arch): no hit on negative binpattern $finalp\n") + unless $::tlpsrc_pattern_no_warn_negative; + # see comments in libexec/place script. + } + } + $tlp->remove_binfiles($arch,@archfiles); + } + } + # add the revision number of the .tlpsrc file to the compute list: + $tlp->recompute_revision($tltree, + $tltree->file_svn_lastrevision("tlpkg/tlpsrc/$self->{name}.tlpsrc")); + $tlp->recompute_sizes($tltree); + return $tlp; +} + +sub _do_normal_pattern { + my ($self,$p,$tlp,$tltree,$type,$negative) = @_; + my $is_default_pattern = 0; + if ($p =~ m/^\*/) { + $is_default_pattern = 1; + $p =~ s/^\*//; + } + my @matchfiles = $tltree->get_matching_files($type, $p, $self->{'name'}); + if (!$is_default_pattern && !@matchfiles + && ($p !~ m,^f ignore,) && ($p !~ m,^d tlpkg/backups,)) { + tlwarn("$self->{name}: no hit for pattern $p\n") + unless $negative && $::tlpsrc_pattern_no_warn_negative; + } + if (defined($negative) && $negative == 1) { + $tlp->remove_files($type,@matchfiles); + } else { + $tlp->add_files($type,@matchfiles); + } +} + + +# get the default patterns for all categories from an external file, +# return hash with keys being the categories (Package, Collection, etc.) +# and values being refs to another hash. The subhash's keys are the +# file types (run bin doc ...) with values being refs to an array of +# patterns for that type. +# +sub find_default_patterns { + my ($tlroot) = @_; + # %autopatterns is global. + return %autopatterns if keys %autopatterns; # only compute once + + my $apfile = "$tlroot/tlpkg/tlpsrc/00texlive.autopatterns.tlpsrc"; + die "No autopatterns file found: $apfile" if ! -r $apfile; + + my $tlsrc = new TeXLive::TLPSRC; + $tlsrc->from_file ($apfile); + if ($tlsrc->binpatterns) { + for my $p ($tlsrc->binpatterns) { + my ($cat, @rest) = split ' ', $p; + push @{$autopatterns{$cat}{"bin"}}, join(' ', @rest); + } + } + if ($tlsrc->srcpatterns) { + for my $p ($tlsrc->srcpatterns) { + my ($cat, @rest) = split ' ', $p; + push @{$autopatterns{$cat}{"src"}}, join(' ', @rest); + } + } + if ($tlsrc->docpatterns) { + for my $p ($tlsrc->docpatterns) { + my ($cat, @rest) = split ' ', $p; + push @{$autopatterns{$cat}{"doc"}}, join(' ', @rest); + } + } + if ($tlsrc->runpatterns) { + for my $p ($tlsrc->runpatterns) { + my ($cat, @rest) = split ' ', $p; + push @{$autopatterns{$cat}{"run"}}, join(' ', @rest); + } + } + + for my $cat (keys %autopatterns) { + ddebug ("Category $cat\n"); + for my $d (@{$autopatterns{$cat}{"bin"}}) { + ddebug ("auto bin pattern $d\n"); + } + for my $d (@{$autopatterns{$cat}{"src"}}) { + ddebug ("auto src pattern $d\n"); + } + for my $d (@{$autopatterns{$cat}{"doc"}}) { + ddebug ("auto doc pattern $d\n"); + } + for my $d (@{$autopatterns{$cat}{"run"}}) { + ddebug ("auto run pattern $d\n"); + } + } + + return %autopatterns; +} + + +# member access functions +# +sub _srcfile { + my $self = shift; + if (@_) { $self->{'_srcfile'} = shift } + return $self->{'_srcfile'}; +} +sub name { + my $self = shift; + if (@_) { $self->{'name'} = shift } + return $self->{'name'}; +} +sub category { + my $self = shift; + if (@_) { $self->{'category'} = shift } + return $self->{'category'}; +} +sub shortdesc { + my $self = shift; + if (@_) { $self->{'shortdesc'} = shift } + return $self->{'shortdesc'}; +} +sub longdesc { + my $self = shift; + if (@_) { $self->{'longdesc'} = shift } + return $self->{'longdesc'}; +} +sub catalogue { + my $self = shift; + if (@_) { $self->{'catalogue'} = shift } + return $self->{'catalogue'}; +} +sub srcpatterns { + my $self = shift; + if (@_) { @{ $self->{'srcpatterns'} } = @_ } + if (defined($self->{'srcpatterns'})) { + return @{ $self->{'srcpatterns'} }; + } else { + return; + } +} +sub docpatterns { + my $self = shift; + if (@_) { @{ $self->{'docpatterns'} } = @_ } + if (defined($self->{'docpatterns'})) { + return @{ $self->{'docpatterns'} }; + } else { + return; + } +} +sub binpatterns { + my $self = shift; + if (@_) { @{ $self->{'binpatterns'} } = @_ } + if (defined($self->{'binpatterns'})) { + return @{ $self->{'binpatterns'} }; + } else { + return; + } +} +sub depends { + my $self = shift; + if (@_) { @{ $self->{'depends'} } = @_ } + return @{ $self->{'depends'} }; +} +sub runpatterns { + my $self = shift; + if (@_) { @{ $self->{'runpatterns'} } = @_ } + if (defined($self->{'runpatterns'})) { + return @{ $self->{'runpatterns'} }; + } else { + return; + } +} +sub executes { + my $self = shift; + if (@_) { @{ $self->{'executes'} } = @_ } + return @{ $self->{'executes'} }; +} +sub postactions { + my $self = shift; + if (@_) { @{ $self->{'postactions'} } = @_ } + return @{ $self->{'postactions'} }; +} + +1; +__END__ + + +=head1 NAME + +C<TeXLive::TLPSRC> -- TeX Live Package Source module + +=head1 SYNOPSIS + + use TeXLive::TLPSRC; + + my $tlpsrc = TeXLive::TLPSRC->new(name => "foobar"); + $tlpsrc->from_file("/some/tlpsrc/package.tlpsrc"); + $tlpsrc->from_file("package"); + $tlpsrc->writeout; + $tlpsrc->writeout(\*FILEHANDLE); + +=head1 DESCRIPTION + +The C<TeXLive::TLPSRC> module handles TeX Live Package Source +(C<.tlpsrc>) files, which contain all (and only) the information which +cannot be automatically derived from other sources, notably the TeX Live +directory tree and the TeX Catalogue. In other words, C<.tlpsrc> files +are hand-maintained. + +=head1 FILE SPECIFICATION + +A C<tlpsrc> file consists of lines of the form: + +I<key> I<value> + +where I<key> can be C<name>, C<category>, C<shortdesc>, C<longdesc>, +C<catalogue>, C<runpattern>, C<srcpattern>, C<docpattern>, C<binpattern>, +C<execute>, C<postaction>, or C<depend>. + +Continuation lines are supported via a trailing backslash. That is, if +the C<.tlpsrc> file contains two physical lines like this: + + foo\ + bar + +they are concatenated into C<foobar>. The backslash and the newline are +removed; no other whitespace is added or removed. + +Comment lines begin with a # and continue to the end of the line. + +Blank lines are ignored. + +The meaning of the I<key>s: + +=over 4 + +=item C<name> + +identifies the package; C<value> must consist only of C<[-_a-zA-Z0-9]>, +i.e., with what Perl considers a C<\w>. + +There are three exceptions to this rule: + +=over 8 + +=item B<name.ARCH> + +where B<ARCH> is a supported architecture-os combination. This has two +uses. First, packages are split (automatically) into containers for the +different architectures to make possible installations including only +the necessary binaries. Second, one can add 'one-arch-only' packages, +often used to deal with Windows peculiarities. + +=item B<00texlive>I<something> + +These packages are used for internal operation and storage containers +for settings. I<00texlive> packages are never be split into separate +arch-packages, and containers are never generated for these packages. + +The full list of currently used packages of this type is: + +=over 8 + +=item B<00texlive.config> + +This package contains configuration options for the TeX Live archive. +If container_split_{doc,src}_files occurs in the depend lines the +{doc,src} files are split into separate containers (.tar.xz) +during container build time. Note that this has NO effect on the +appearance within the texlive.tlpdb. It is only on container level. +The container_format/XXXXX specifies the format, currently allowed +is only "xz", which generates .tar.xz files. zip can be supported. +release/NNNN specifies the release number as used in the installer. + +=item B<00texlive.installation> + +This package serves a double purpose: + +1. at installation time the present values are taken as default for +the installer + +2. on an installed system it serves as configuration file. Since +we have to remember these settings for additional package +installation, removal, etc. + +=item B<00texlive.image> + +This package collects some files which are not caught by any of the +other TL packages. Its primary purpose is to make the file coverage +check happy. The files here are not copied by the installer +and containers are not built; they exist only in the +TeX Live Master tree. + +=item B<00texlive.installer> + +This package defines the files to go into the installer +archives (install-tl-unx.tar.gz, install-tl.zip) built +by the tl-make-installer script. Most of what's here is also +included in the texlive.infra package -- ordinarily duplicates +are not allowed, but in this case, 00texlive.installer is never +used *except* to build the installer archives, so it's ok. + +=back + +=item B<texlive>I<some.thing> + +(notice the dot in the package name) These packages are central TeX Live +internal packages and are treated as usual packages in (more or less) +all respects, but have that extra dot to be sure they will never clash +with any package that can possibly appear on CTAN. The only such +package currently is C<texlive.infra>, which contains L<tlmgr> and other +basic infrastructure functionality. + +=back + +=item C<category> + +identifies the category into which this package belongs. This determines +the default patterns applied. Possible categories are defined in +C<TeXLive::TLConfig>, currently C<Collection>, C<Scheme>, C<TLCore>, +C<Package>, C<ConTeXt>. Most packages will fall into the C<Package> +category. + +=item C<catalogue> + +identifies the name under which this package can be found in the TeX +Catalogue. + +=item C<shortdesc> + +gives a one line description of the package. Subsequent entries will +overwrite the former ones. In TeX Live primarily used for collections and +schemes. + +=item C<longdesc> + +gives a long description of the package. Susequent entries are +concatenated into a long text. In TeX Live only used for collections and +schemes. + +=item C<depend> + +gives the list of dependencies, which are just other package names. +All the C<depend> lines contribute to the dependencies of the package. +Examples: + + depend cm + depend plain + depend collection-basic + +=item C<execute> + +gives a free form entry of install time jobs to be executed. Currently +the following possible values are understood by the installers: + +=over 4 + +=item C<execute addMap> I<font>C<.map> + +enables the font map file I<font>C<.map> in the C<updmap.cfg> file. + +=item C<execute addMixedMap> I<font>C<.map> + +enables the font map file I<font>C<.map> for Mixed mode in the +C<updmap.cfg> file. + +=item C<execute AddHyphen name=I<texlang> file=I<file> [I<var>...]> + +activates the hyphenation pattern with name I<texlang> and load the file +I<file> for that language. The additional variables I<var> are: +C<lefthyphenmin>, C<righthyphenmin> (both integers), C<synonyms> (a +comma-separated list of alias names for that hyphenation), C<databases> +(a comma-separated list of databases the entry should go in; currently +recognized are: C<dat> (C<language.dat>), C<def> (C<language.def>) and +C<lua> (C<language.dat.lua>)), C<file_patterns> and C<file_exceptions> +(files with the patterns (resp. exceptions) in plain txt), and +C<luaspecial> (string). + +The variable C<databases> defaults to C<dat,def>, or C<dat,def,lua> if +one of the keys C<file_patterns>, C<file_exceptions> or C<luaspecial> is +used. + +=item C<execute AddFormat name=I<fmt> engine=I<eng> [I<var>...]> + +activates the format with name I<fmt> based on the engine I<eng>. The +additional variables I<var> are: +C<mode> which can only be equal to C<disable> in which case the format +will only be mentioned but disabled (prefixed with C<#!>; +C<patterns> which gives the patterns file, if not present C<-> is used; +C<options> which gives the additional options for the C<fmtutil.cnf> file. + +=back + +=item C<postaction> + +gives a free from entry of post install and removal actions to be +executed. The difference to the C<execute> statement is that +C<postaction> is concerned with system integration, i.e., adjusting +things outside the installation directory, while C<execute> touches +only things within the installation. + +Currently the following C<postaction>s are understood: + +=over 4 + +=item C<postaction shortcut name=I<name> type=menu|desktop icon=I<path> cmd=I<cmd> args=I<args> hide=0|1> + +On W32 creates a shortcut either in the main TeX Live menu or on the +desktop. Please see the documentation of TeXLive::TLWinGoo for details +on the parameters. + +=item C<postaction filetype name=I<name> cmd=I<cmd>> + +On W32 associates the file type I<name> with the command I<cmd>. + +=item C<postaction fileassoc extension=I<.ext> filetype=I<name>> + +On W32 declares files with the extenstion I<.ext> of file type I<name>. + +=item C<postaction script file=I<file> [filew32=I<filew32>]> + +This postaction executes the given I<file> with two arguments, the first +being the root of the installation, the second being either the string +C<install> or C<remove>. + +If the C<filew32> argument is given this script is run on Windows systems +instead of the one given via C<file>. + +=back + +=item C<tlpsetvar> I<var> I<val> + +sets variable I<var> to I<val>, for use within the current C<.tlpsrc> +only. Order matters. The variable can be expanded with +C<${>I<var>C<}> (after it is defined). Characters allowed in the I<var> +name are C<-_a-zA-Z0-9>. + +=item C<(src|run|doc|bin)pattern> I<pattern> + +adds a pattern (next section) to the respective list of patterns. + +=back + +=head1 PATTERNS + +Patterns specify which files are to be included into a C<tlpobj> at +expansion time. Patterns are of the form + + [PREFIX]TYPE[/[!]ARCHSPEC] PAT + +where + + PREFIX = + | +! | ! + TYPE = t | f | d | r + ARCHSPEC = <list of architectures separated by comma> + +Simple patterns without PREFIX and ARCHSPEC specifications are explained +first. + +=over 4 + +=item C<f> I<path> + +includes all files which match C<path> where B<only> the last component +of C<path> can contain the usual glob characters C<*> and C<?> (but no +others!). + +=item C<d> I<path> + +includes all the files in and below the directory specified as C<path>. + +=item C<t> I<word1 ... wordN wordL> + +includes all the files in and below all directories of the form + + word1/word2/.../wordN/.../any/dirs/.../wordL/ + +i.e., all the first words but the last form the prefix of the path, then +there can be an arbitrary number of subdirectories, followed by C<wordL> +as the final directory. A real life example from C<omega.tlpsrc>: + + runpattern t texmf-dist fonts omega + +matches C<texmf-dist/fonts/**/omega>, where C<**> matches any number of +intervening subdirectories, e.g.: + + texmf-dist/fonts/ofm/public/omega + texmf-dist/fonts/tfm/public/omega + texmf-dist/fonts/type1/public/omega + +=item C<r> I<regexp> + +includes all files matching the regexp C</^regexp$/> + +=item C<a> I<name1> [<name2> ...] + +includes auto generated patterns for each I<nameN> as if the package +itself would be named I<nameN>. That is useful if a package (like venturisadf) +contains toplevel directories named after different fonts. + +=back + +=head2 Special patterns + +=over 4 + +=item PREFIX + +If the C<PREFIX> contains the symbol C<!> the meaning of the pattern is +reversed, i.e., files matching this pattern are removed from the list of +included files. + +The prefix C<+> means to append to the list of automatically synthesized +patterns, instead of replacing them. + +The C<+> and C<!> prefixes can be combined. This is useful to exclude +directories from the automatic pattern list. For example, +C<graphics.tlpsrc> contains this line: + + docpattern +!d texmf-dist/doc/latex/tufte-latex/graphics + +so that this subdirectory of the C<tufte-latex> package that happens to +be named `graphics' is not mistakenly included in the C<graphics> +package. + +=item Auto-generated patterns + +If a given pattern section is empty or B<all> the provided patterns have +the prefix C<+> (e.g., C<+f ...>), then the following patterns, listed +by type are I<automatically> added at expansion time. Note that this list +is not definitive, but is taken from the patterns of tlpsrc files +named C<00texlive.autopatterns.>I<Category>C<.tlpsrc>. + +=over 4 + +=item C<runpattern> + +For category C<Package>: + + t texmf-dist topdir $name + +where C<topdir> is one of: C<bibtex>, C<context>, C<dvips>, C<fonts>, +C<makeindex>, C<metafont>, C<metapost>, C<mft>, C<omega>, C<scripts>, +C<tex>, C<vtex>. + +For category C<ConTeXt>: + + d texmf-dist/tex/context/third/%context-:NAME% + d texmf-dist/metapost/context/third/%context-:NAME% + f texmf-dist/tex/context/interface/third/*%context-:NAME%.xml + +(where C<%context-:NAME%> is replaced by the package name with an initial +C<context-> is removed. E.g., if the package is called C<context-foobar> +the replacement in the above rules will be C<foobar>.) + +For other categories B<no> patterns are automatically added to the +list of C<runpattern>s. + +=item C<docpattern> + +for category C<Package>: + + t texmf-dist doc $name + +for category C<ConTeXt>: + + d texmf-dist/doc/context/third/%context-:NAME% + +(see above for the C<NAME> construct) + +=item C<srcpattern> + +for category C<Package>: + + t texmf-dist source $name + +for category C<ConTeXt>: + + d texmf-dist/source/context/third/%context-:NAME% + +(see above for the C<NAME> construct) + +=item C<binpattern> + +No C<binpattern>s are ever automatically added. + +=back + +=item Special treatment of binpatterns + +The binpatterns have to deal with all the different architectures. To +ease the writing of patterns, we have the following: + +=over 4 + +=item Architecture expansion + +Within a binpattern, the string C<${ARCH}> is automatically expanded to +all available architectures. + +=item C<bat/exe/dll/texlua> for Windows + +C<binpattern>s that match Windows, e.g., C<f bin/win32/foobar> or C<f +bin/${ARCH}/foobar>, also match the files C<foobar.bat>, C<foobar.cmd>, +C<foobar.dll>, C<foobar.exe>, and C<foobar.texlua>. + +In addition, C<foobar.exe.manifest> and C<foobar.dll.manifest> are matched. + +The above two properties allows to capture the binaries for all +architectures in one binpattern + + binpattern f bin/${ARCH}/dvips + +and would get C<bin/win32/dvips.exe> into the runfiles for C<arch=win32>. + +This C<bat>/C<exe>/etc. expansion I<only> works for patterns of the C<f> +type. + +=item ARCHSPEC specification of a pattern + +Sometimes files should be included into the list of binfiles of a +package only for some architectures, or for all but some architectures. +This can be done by specifying the list of architectures for which this +pattern should be matched after the pattern specifier using a C</>: + + binpattern f/win32 tlpkg/bin/perl.exe + +will include the file C<tlpkg/bin/perl.exe> only in the binfiles for +the architecture C<win32>. Another example: + + binpattern f/arch1,arch2,arch3 path/$ARCH/foo/bar + +This will only try to match this pattern for arch1, arch2, and arch3. + +Normally, a binpattern is matched against all possible architectures. If +you want to exclude some architectures, instead of listing all the ones +you want to include as above, you can prefix the list of architectures +with a ! and these architectures will not be tested. Example: + + binpattern f/!arch1,arch2 path/$ARCH/foo/bar + +will be matched against all architectures I<except> arch1 and arch2. + +=back + +=back + + +=head1 MEMBER ACCESS FUNCTIONS + +For any of the above I<key>s a function + + $tlpsrc->key + +is available, which returns the current value when called without an argument, +and sets the respective value when called with an argument. + +Arguments and return values for C<name>, C<category>, C<shortdesc>, +C<longdesc>, C<catalogue> are single scalars. Arguments and return values +for C<depends>, C<executes>, and the various C<patterns> are lists. + +In addition, the C<_srcfile> member refers to the filename for this +C<TLPSRC> object, if set (normally by C<from_file>). + +=head1 OTHER FUNCTIONS + +The following functions can be called for a C<TLPSRC> object: + +=over 4 + +=item C<new> + +The constructor C<new> returns a new C<TLPSRC> object. The arguments +to the C<new> constructor can be in the usual hash representation for +the different keys above: + + $tlpsrc = TLPSRC->new (name => "foobar", + shortdesc => "The foobar package"); + +=item C<from_file("filename")> + +reads a C<tlpsrc> file from disk. C<filename> can either be a full path +(if it's readable, it's used), or just a package identifier such as +C<plain>. In the latter case, the directory searched is the C<tlpsrc> +sibling of the C<TeXLive> package directory where C<TLPSRC.pm> was found. + + $tlpsrc=new TeXLive::TLPSRC; + $tlpsrc->from_file("/path/to/the/tlpsrc/somepkg.tlpsrc"); + $tlpsrc->from_file("somepkg"); + +=item C<writeout> + +writes the textual representation of a C<TLPSRC> object to stdout, or the +filehandle if given: + + $tlpsrc->writeout; + $tlpsrc->writeout(\*FILEHANDLE); + +=item C<make_tlpobj($tltree)> + +creates a C<TLPOBJ> object from a C<TLPSRC> object and a C<TLTREE> object. +This function does the necessary work to expand the manual data and +enrich it which the actual content from C<$tltree> to a C<TLPOBJ> object. + +=back + +=head1 SEE ALSO + +The modules L<TeXLive::TLConfig>, L<TeXLive::TLUtils>, L<TeXLive::TLPOBJ>, +L<TeXLive::TLPDB>, L<TeXLive::TLTREE>. + +The programs L<tlpsrc2tlpdb> and L<tlpsrc2tlpobj>. + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLPaper.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLPaper.pm new file mode 100644 index 0000000000..09bb0c021f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLPaper.pm @@ -0,0 +1,972 @@ +# $Id: TLPaper.pm 45795 2017-11-14 08:49:25Z preining $ +# TeXLive::TLPaper.pm - query/modify paper sizes for our various programs +# Copyright 2008-2017 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLPaper; + +my $svnrev = '$Revision: 45795 $'; +my $_modulerevision; +if ($svnrev =~ m/: ([0-9]+) /) { + $_modulerevision = $1; +} else { + $_modulerevision = "unknown"; +} +sub module_revision { + return $_modulerevision; +} + +BEGIN { + use Exporter (); + use vars qw( @ISA @EXPORT_OK @EXPORT ); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + %paper_config_path_component + %paper_config_name + ); + @EXPORT = @EXPORT_OK; +} + +my $prg = ($::prg ? $::prg : TeXLive::TLUtils::basename($0)); + +=pod + +=head1 NAME + +C<TeXLive::TLPaper> -- TeX Live paper size setting module + +=head1 SYNOPSIS + + use TeXLive::TLPaper; + +=head1 DESCRIPTION + +=over 4 + +=cut + +use TeXLive::TLUtils qw(:DEFAULT dirname merge_into mkdirhier); +use TeXLive::TLConfig; + + +# +# paper data +# +our %paper = ( + "xdvi" => { + sub => \&paper_xdvi, + default_component => "xdvi", + default_file => "XDvi", + pkg => "xdvi", + }, + "pdftex" => { + sub => \&paper_pdftex, + default_component => "tex/generic/config", + default_file => "pdftexconfig.tex", + pkg => "pdftex", + }, + "dvips" => { + sub => \&paper_dvips, + default_component => "dvips/config", + default_file => "config.ps", + pkg => "dvips", + }, + "dvipdfmx" => { + sub => \&paper_dvipdfmx, + default_component => "dvipdfmx", + default_file => "dvipdfmx.cfg", + pkg => "dvipdfmx", + }, + "context" => { + sub => \&paper_context, + default_component => "tex/context/user", + default_file => "cont-sys.tex", + pkg => "context", + }, + "psutils" => { + sub => \&paper_psutils, + default_component => "psutils", + default_file => "paper.cfg", + pkg => "psutils", + }, +); + +# Output is done to the components in this hash. +# If a value is undefined, we take the one from %default_... +# +our %paper_config_path_component; +our %paper_config_name; + + +my %xdvi_papersize = ( + a0 => '841x1189mm', + a1 => '594x841mm', + a2 => '420x594mm', + a3 => '297x420mm', + a4 => '210x297mm', + a5 => '148x210mm', + a6 => '105x148mm', + a7 => '74x105mm', + a8 => '52x74mm', + a9 => '37x52mm', + a10 => '26x37mm', + a0r => '1189x841mm', + a1r => '841x594mm', + a2r => '594x420mm', + a3r => '420x297mm', + a4r => '297x210mm', + a5r => '210x148mm', + a6r => '148x105mm', + a7r => '105x74mm', + a8r => '74x52mm', + a9r => '52x37mm', + a10r => '37x26mm', + b0 => '1000x1414mm', + b1 => '707x1000mm', + b2 => '500x707mm', + b3 => '353x500mm', + b4 => '250x353mm', + b5 => '176x250mm', + b6 => '125x176mm', + b7 => '88x125mm', + b8 => '62x88mm', + b9 => '44x62mm', + b10 => '31x44mm', + b0r => '1414x1000mm', + b1r => '1000x707mm', + b2r => '707x500mm', + b3r => '500x353mm', + b4r => '353x250mm', + b5r => '250x176mm', + b6r => '176x125mm', + b7r => '125x88mm', + b8r => '88x62mm', + b9r => '62x44mm', + b10r => '44x31mm', + c0 => '917x1297mm', + c1 => '648x917mm', + c2 => '458x648mm', + c3 => '324x458mm', + c4 => '229x324mm', + c5 => '162x229mm', + c6 => '114x162mm', + c7 => '81x114mm', + c8 => '57x81mm', + c9 => '40x57mm', + c10 => '28x40mm', + c0r => '1297x917mm', + c1r => '917x648mm', + c2r => '648x458mm', + c3r => '458x324mm', + c4r => '324x229mm', + c5r => '229x162mm', + c6r => '162x114mm', + c7r => '114x81mm', + c8r => '81x57mm', + c9r => '57x40mm', + c10r => '40x28mm', + us => '8.5x11', + letter => '8.5x11', + ledger => '17x11', + tabloid => '11x17', + usr => '11x8.5', + legal => '8.5x14', + legalr => '14x8.5', + foolscap => '13.5x17.0', + foolscapr => '17.0x13.5', +); + +my %pdftex_papersize = ( + "a4" => [ '210 true mm', '297 true mm' ], + "letter" => [ '8.5 true in', '11 true in' ], +); + +my %dvipdfm_papersize = ( + "a3" => 1, + "a4" => 1, + "ledger" => 1, + "legal" => 1, + "letter" => 1, + "tabloid" => 1, +); + +my %psutils_papersize = ( "a4" => 1, "letter" => 1, ); + + + + +=item C<get_paper_list($prog)> + +Returns the list of supported paper sizes with the first entry being +the currently selected one. + +=cut + +sub get_paper_list { + my $prog = shift; + return ( &{$paper{$prog}{'sub'}} ( "/dummy", "--returnlist" ) ); +} + +=item C<get_paper($prog)> + +Returns the currently selected paper size for program C<$prog>. + +=cut + +sub get_paper { + my $pps = get_paper_list(shift); + return $pps->[0]; +} + +=item C<do_paper($prog,$texmfsysconfig,@args)> + +Call the paper subroutine for C<$prog>, passing args. + +Returns a reference to a list of papers if called with C<--returnlist>, +otherwise one of the standard flags (see TeXLive::TLConfig). + +=cut + +sub do_paper { + my ($prog,$texmfsysconfig,@args) = @_; + if (exists $paper{$prog}{'sub'}) { + my $sub = $paper{$prog}{'sub'}; + return(&$sub($texmfsysconfig, @args)); + } else { + tlwarn("$prg: unknown paper program $prog ($texmfsysconfig,@args)\n"); + return($F_ERROR); + } + return ($F_OK); # not reached +} + + +=item C<paper_all($texmfsysconfig, $newpaper)> + +Pass all C<@args> to each paper subroutine in turn, thus setting the +paper size for all supported programs. Returns the bit-mapped return +values of the single subroutine returns. + +=cut + +sub paper_all { + my $ret = $F_OK; + for my $p (sort keys %paper) { + $ret |= &{$paper{$p}{'sub'}} (@_); + } + return($ret); +} + + +# return the config file to look in by running kpsewhich with the +# specified PROGNAME, FORMAT, and @FILENAMES. If no result, give a +# warning and return the empty string. +# +sub find_paper_file { + my ($progname, $format, @filenames) = @_; + my $ret = ""; + + my $cmd; + for my $filename (@filenames) { + $cmd = qq!kpsewhich --progname=$progname --format="$format" $filename!; + chomp($ret = `$cmd`); + if ($ret) { + debug("paper file for $progname ($format) $filename: $ret\n"); + last; + } + } + + debug("$prg: found no paper file for $progname (from $cmd)\n") if ! $ret; + return $ret; +} + +sub setup_names { + my $prog = shift; + my $outcomp = $paper_config_path_component{$prog} + || $paper{$prog}{'default_component'}; + my $filecomp = $paper_config_name{$prog} + || $paper{$prog}{'default_file'}; + return ($outcomp, $filecomp); +} + + +# xdvi format: +# /--- XDvi --- +# |... +# |*paper: <NAME> +# |... +# \------------ +# +# Reading is done via --progname=xdvi --format='other text files' XDvi +# Writing is done to TEXMFSYSCONFIG/xdvi/XDvi +# +sub paper_xdvi { + my $outtree = shift; + my $newpaper = shift; + + my ($outcomp, $filecomp) = setup_names("xdvi"); + my $dftfile = $paper{'xdvi'}{'default_file'}; + my $outfile = "$outtree/$outcomp/$filecomp"; + my $inp = &find_paper_file("xdvi", "other text files", $filecomp, $dftfile); + + return($F_ERROR) unless $inp; + + + my @sizes = keys %xdvi_papersize; + return &paper_do_simple($inp, "xdvi", '^\*paper: ', '^\*paper:\s+(\w+)\s*$', + sub { + my ($ll,$np) = @_; + $ll =~ s/^\*paper:\s+(\w+)\s*$/\*paper: $np\n/; + return($ll); + }, $outfile, \@sizes, '(undefined)', '*paper: a4', $newpaper); +} + + +# pdftex pdftexconfig.dat format +# /--- pdftexconfig.tex --- +# |... +# |\pdfpageheight = 297 true mm +# |\pdfpagewidth = 210 true mm +# |... +# \------------------------ +# +# Reading is done via --progname=pdftex --format='tex' pdftexconfig.tex +# Writing is done to TEXMFSYSCONFIG/tex/generic/config/pdftexconfig.tex +# +sub paper_pdftex { + my $outtree = shift; + my $newpaper = shift; + my ($outcomp, $filecomp) = setup_names("pdftex"); + my $dftfile = $paper{'pdftex'}{'default_file'}; + my $outfile = "$outtree/$outcomp/$filecomp"; + my $inp = &find_paper_file("pdftex", "tex", $filecomp, $dftfile); + + return($F_ERROR) unless $inp; + + open(FOO, "<$inp") || die "$prg: open($inp) failed: $!"; + my @lines = <FOO>; + close(FOO); + + my @cpwidx; + my @cphidx; + my ($cpw, $cph); + my $endinputidx; + # read the lines and the last pdfpageswidth/height wins + for my $idx (0..$#lines) { + my $l = $lines[$idx]; + if ($l =~ m/^\s*\\pdfpagewidth\s*=\s*([0-9.,]+\s*true\s*[^\s]*)/) { + if (defined($cpw) && $cpw ne $1) { + tl_warn("TLPaper: inconsistent paper sizes in $inp for page width! Please fix that.\n"); + return $F_ERROR; + } + $cpw = $1; + push @cpwidx, $idx; + next; + } + if ($l =~ m/^\s*\\pdfpageheight\s*=\s*([0-9.,]+\s*true\s*[^\s]*)/) { + if (defined($cph) && $cph ne $1) { + tl_warn("TLPaper: inconsistent paper sizes in $inp for page height! Please fix that.\n"); + return $F_ERROR; + } + $cph = $1; + push @cphidx, $idx; + next; + } + if ($l =~ m/^\s*\\endinput\s*/) { + $endinputidx = $idx; + next; + } + } + # trying to find the right papersize + # + my $currentpaper; + if (defined($cpw) && defined($cph)) { + for my $pname (keys %pdftex_papersize) { + my ($w, $h) = @{$pdftex_papersize{$pname}}; + if (($w eq $cpw) && ($h eq $cph)) { + $currentpaper = $pname; + last; + } + } + } else { + $currentpaper = "(undefined)"; + } + $currentpaper || ($currentpaper = "$cpw x $cph"); + if (defined($newpaper)) { + if ($newpaper eq "--list") { + info("$currentpaper\n"); + for my $p (keys %pdftex_papersize) { + info("$p\n") unless ($p eq $currentpaper); + } + } elsif ($newpaper eq "--json") { + my @ret = (); + push @ret, "$currentpaper"; + for my $p (keys %pdftex_papersize) { + push @ret, $p unless ($p eq $currentpaper); + } + my %foo; + $foo{'program'} = "pdftex"; + $foo{'file'} = $inp; + $foo{'options'} = \@ret; + return \%foo; + } elsif ($newpaper eq "--returnlist") { + my @ret = (); + push @ret, "$currentpaper"; + for my $p (keys %pdftex_papersize) { + push @ret, $p unless ($p eq $currentpaper); + } + return \@ret; + } else { + my $found = 0; + for my $p (keys %pdftex_papersize) { + if ($p eq $newpaper) { + $found = 1; + last; + } + } + if ($found) { + my $newwidth = ${$pdftex_papersize{$newpaper}}[0]; + my $newheight = ${$pdftex_papersize{$newpaper}}[1]; + if (@cpwidx) { + for my $idx (@cpwidx) { + ddebug("TLPaper: before line: $lines[$idx]"); + ddebug("TLPaper: replacement: $newwidth\n"); + $lines[$idx] =~ s/^\s*\\pdfpagewidth\s*=\s*[0-9.,]+\s*true\s*[^\s]*/\\pdfpagewidth = $newwidth/; + ddebug("TLPaper: after line : $lines[$idx]"); + } + } else { + my $addlines = "\\pdfpagewidth = $newwidth\n"; + if (defined($endinputidx)) { + $lines[$endinputidx] = $addlines . $lines[$endinputidx]; + } else { + $lines[$#lines] = $addlines; + } + } + if (@cphidx) { + for my $idx (@cphidx) { + ddebug("TLPaper: before line: $lines[$idx]"); + ddebug("TLPaper: replacement: $newheight\n"); + $lines[$idx] =~ s/^\s*\\pdfpageheight\s*=\s*[0-9.,]+\s*true\s*[^\s]*/\\pdfpageheight = $newheight/; + ddebug("TLPaper: after line : $lines[$idx]"); + } + } else { + my $addlines = "\\pdfpageheight = $newheight"; + if (defined($endinputidx)) { + $lines[$endinputidx] = $addlines . $lines[$endinputidx]; + } else { + $lines[$#lines] = $addlines; + } + } + info("$prg: setting paper size for pdftex to $newpaper: $outfile\n"); + mkdirhier(dirname($outfile)); + # if we create the outfile we have to call mktexlsr + TeXLive::TLUtils::announce_execute_actions("files-changed") + unless (-r $outfile); + if (!open(TMP, ">$outfile")) { + tlwarn("$prg: Cannot write to $outfile: $!\n"); + tlwarn("Not setting paper size for pdftex.\n"); + return($F_ERROR); + } + for (@lines) { print TMP; } + close(TMP) || warn "$prg: close(>$outfile) failed: $!"; + TeXLive::TLUtils::announce_execute_actions("regenerate-formats"); + # TODO should we return the value of announce_execute action? + return($F_OK); + } else { + tlwarn("$prg: Not a valid paper size for pdftex: $newpaper\n"); + return($F_WARNING); + } + } + } else { + info("Current pdftex paper size (from $inp): $currentpaper\n"); + } + return($F_OK); +} + + +# dvips config.ps format: +# /--- config.ps --- +# |... +# |stuff not related to paper sizes +# |... +# | <empty line> +# |% some comments +# |% more comments +# |@ <NAME> <WIDTH> <HEIGHT> +# |@+ ...definition line +# |@+ ...definition line +# |... more definition lines +# |@+ %%EndPaperSize +# | +# |@ <NAME> <WIDTH> <HEIGHT> +# |... +# \------------ +# +# the first paper definition is the default +# selecting paper is done like with texconfig which used ed to move the +# selected part between @ $selected_paper .... @ /-1 (the line before the +# next @ line) to the line before the first @ line. +# (what a tricky ed invocation te created there, impressive!!!) +# +# Reading is done via --progname=dvips --format='dvips config' config.ps +# Writing is done to TEXMFSYSCONFIG/dvips/config/config.ps +# +sub paper_dvips { + my $outtree = shift; + my $newpaper = shift; + + my ($outcomp, $filecomp) = setup_names("dvips"); + my $dftfile = $paper{'dvips'}{'default_file'}; + my $outfile = "$outtree/$outcomp/$filecomp"; + my $inp = &find_paper_file("dvips", "dvips config", $filecomp, $dftfile); + + return($F_ERROR) unless $inp; + + open(FOO, "<$inp") || die "$prg: open($inp) failed: $!"; + my @lines = <FOO>; + close(FOO); + + my @papersizes; + my $firstpaperidx; + my %startidx; + my %endidx; + my $in_block = ""; + my $idx = 0; + for my $idx (0 .. $#lines) { + if ($lines[$idx] =~ m/^@ (\w+)/) { + $startidx{$1} = $idx; + $firstpaperidx || ($firstpaperidx = $idx-1); + $in_block = $1; + push @papersizes, $1; + next; + } + # empty lines or comments stop a block + if ($in_block) { + if ($lines[$idx] =~ m/^\s*(%.*)?\s*$/) { + $endidx{$in_block} = $idx-1; + $in_block = ""; + } + next; + } + } + + if (defined($newpaper)) { + if ($newpaper eq "--list") { + for my $p (@papersizes) { + info("$p\n"); # first is already the selected one + } + } elsif ($newpaper eq "--json") { + my %foo; + $foo{'program'} = "dvips"; + $foo{'file'} = $inp; + $foo{'options'} = \@papersizes; + return \%foo; + } elsif ($newpaper eq "--returnlist") { + return(\@papersizes); + } else { + my $found = 0; + for my $p (@papersizes) { + if ($p eq $newpaper) { + $found = 1; + last; + } + } + if ($found) { + my @newlines; + for my $idx (0..$#lines) { + if ($idx < $firstpaperidx) { + push @newlines, $lines[$idx]; + next; + } + if ($idx == $firstpaperidx) { + # insert the selected paper definition + push @newlines, @lines[$startidx{$newpaper}..$endidx{$newpaper}]; + push @newlines, $lines[$idx]; + next; + } + if ($idx >= $startidx{$newpaper} && $idx <= $endidx{$newpaper}) { + next; + } + push @newlines, $lines[$idx]; + } + info("$prg: setting paper size for dvips to $newpaper: $outfile\n"); + mkdirhier(dirname($outfile)); + # if we create the outfile we have to call mktexlsr + TeXLive::TLUtils::announce_execute_actions("files-changed") + unless (-r $outfile); + if (!open(TMP, ">$outfile")) { + tlwarn("$prg: Cannot write to $outfile: $!\n"); + tlwarn("Not setting paper size for dvips.\n"); + return ($F_ERROR); + } + for (@newlines) { print TMP; } + close(TMP) || warn "$prg: close(>$outfile) failed: $!"; + } else { + tlwarn("$prg: Not a valid paper size for dvips: $newpaper\n"); + return($F_WARNING); + } + } + } else { + info("Current dvips paper size (from $inp): $papersizes[0]\n"); + } + return($F_OK); +} + + +# dvipdfm(x) format: +# /--- dvipdfm/config, dvipdfmx/dvipdfmx.cfg --- +# |... +# |p <NAME> +# |... +# \------------ +# +# Reading is done +# for dvipdfm via --progname=dvipdfm --format='other text files' config +# for dvipdfmx via --progname=dvipdfmx --format='other text files' dvipdfmx.cfg +# Writing is done to TEXMFSYSCONFIG/dvipdfm/config/config +# and /dvipdfmx/dvipdfmx.cfg +# +# +sub do_dvipdfm_and_x { + my ($inp,$prog,$outtree,$paplist,$newpaper) = @_; + + my ($outcomp, $filecomp) = setup_names($prog); + my $outfile = "$outtree/$outcomp/$filecomp"; + + return &paper_do_simple($inp, $prog, '^p\s+', '^p\s+(\w+)\s*$', + sub { + my ($ll,$np) = @_; + $ll =~ s/^p\s+(\w+)\s*$/p $np\n/; + return($ll); + }, $outfile, $paplist, '(undefined)', 'p a4', $newpaper); +} + +sub paper_dvipdfm { + my $outtree = shift; + my $newpaper = shift; + + my ($outcomp, $filecomp) = setup_names("dvipdfm"); + my $dftfile = $paper{'dvipdfm'}{'default_file'}; + my $inp = &find_paper_file("dvipdfm", "other text files", $filecomp, $dftfile); + return ($F_ERROR) unless $inp; + + my @sizes = keys %dvipdfm_papersize; + return &do_dvipdfm_and_x($inp, "dvipdfm", $outtree, \@sizes, $newpaper); +} + +sub paper_dvipdfmx { + my $outtree = shift; + my $newpaper = shift; + + my ($outcomp, $filecomp) = setup_names("dvipdfmx"); + my $dftfile = $paper{'dvipdfmx'}{'default_file'}; + + my $inp = &find_paper_file("dvipdfmx", "other text files", $filecomp, $dftfile); + return ($F_ERROR) unless $inp; + + my @sizes = keys %dvipdfm_papersize; + return &do_dvipdfm_and_x($inp, "dvipdfmx", $outtree, \@sizes, $newpaper); +} + + +# context format: +# /--- cont-sys.{tex,rme} +# |... +# |\setuppapersize[letter][letter] +# |... +# \------------ +# +sub paper_context { + my $outtree = shift; + my $newpaper = shift; + my ($outcomp, $filecomp) = setup_names("context"); + my $dftfile = $paper{'context'}{'default_file'}; + my $outfile = "$outtree/$outcomp/$filecomp"; + my $inp = &find_paper_file("context", "tex", $filecomp, "cont-sys.rme", $dftfile); + + return($F_ERROR) unless $inp; + + open(FOO, "<$inp") || die "$prg: open($inp) failed: $!"; + my @lines = <FOO>; + close(FOO); + + my @idx; + my $idxlast; + my $endinputidx = -1; + my $currentpaper; + # read the lines and the last setuppapersize before the endinput wins + for my $idx (0..$#lines) { + my $l = $lines[$idx]; + if ($l =~ m/^[^%]*\\endinput/) { + $endinputidx = $idx; + last; + } + if ($l =~ m/^\s*\\setuppapersize\s*\[([^][]*)\].*$/) { + if (defined($currentpaper) && $currentpaper ne $1) { + tl_warn("TLPaper: inconsistent paper sizes in $inp! Please fix that.\n"); + return $F_ERROR; + } + $currentpaper = $1; + $idxlast = $idx; + push @idx, $idx; + next; + } + } + # if we haven't found a paper line, assume a4 + $currentpaper || ($currentpaper = "a4"); + # trying to find the right papersize + # + if (defined($newpaper)) { + if ($newpaper eq "--list") { + info("$currentpaper\n"); + for my $p (keys %pdftex_papersize) { + info("$p\n") unless ($p eq $currentpaper); + } + } elsif ($newpaper eq "--json") { + my @ret = (); + push @ret, "$currentpaper"; + for my $p (keys %pdftex_papersize) { + push @ret, $p unless ($p eq $currentpaper); + } + my %foo; + $foo{'program'} = "context"; + $foo{'file'} = $inp; + $foo{'options'} = \@ret; + return \%foo; + } elsif ($newpaper eq "--returnlist") { + my @ret = (); + push @ret, "$currentpaper"; + for my $p (keys %pdftex_papersize) { + push @ret, $p unless ($p eq $currentpaper); + } + return \@ret; + } else { + my $found = 0; + for my $p (keys %pdftex_papersize) { + if ($p eq $newpaper) { + $found = 1; + last; + } + } + if ($found) { + if (@idx) { + for my $idx (@idx) { + ddebug("TLPaper: before line: $lines[$idx]"); + ddebug("TLPaper: replacement: $newpaper\n"); + $lines[$idx] =~ s/setuppapersize\s*\[([^][]*)\]\[([^][]*)\]/setuppapersize[$newpaper][$newpaper]/; + ddebug("TLPaper: after line : $lines[$idx]"); + } + } else { + my $addlines = "\\setuppapersize[$newpaper][$newpaper]\n"; + if (defined($endinputidx)) { + $lines[$endinputidx] = $addlines . $lines[$endinputidx]; + } else { + $lines[$#lines] = $addlines; + } + } + info("$prg: setting paper size for context to $newpaper: $outfile\n"); + mkdirhier(dirname($outfile)); + # if we create the outfile we have to call mktexlsr + TeXLive::TLUtils::announce_execute_actions("files-changed") + unless (-r $outfile); + if (!open(TMP, ">$outfile")) { + tlwarn("$prg: Cannot write to $outfile: $!\n"); + tlwarn("Not setting paper size for context.\n"); + return($F_ERROR); + } + for (@lines) { print TMP; } + close(TMP) || warn "$prg: close(>$outfile) failed: $!"; + TeXLive::TLUtils::announce_execute_actions("regenerate-formats"); + # TODO should we return the value of announce_execute action? + return($F_OK); + } else { + tlwarn("$prg: Not a valid paper size for context: $newpaper\n"); + return($F_WARNING); + } + } + } else { + info("Current context paper size (from $inp): $currentpaper\n"); + } + return($F_OK); +} + +sub paper_context_old { + my $outtree = shift; + my $newpaper = shift; + + my ($outcomp, $filecomp) = setup_names("context"); + my $dftfile = $paper{'context'}{'default_file'}; + my $outfile = "$outtree/$outcomp/$filecomp"; + my $inp = &find_paper_file("context", "tex", $filecomp, "cont-sys.rme", $dftfile); + return ($F_ERROR) unless $inp; + + my @sizes = keys %pdftex_papersize; + # take care here, the \\\\ are necessary in some places and not in + # some others because there is no intermediate evaluation + return &paper_do_simple($inp, "context", '^\s*%?\s*\\\\setuppapersize\s*', + '^\s*%?\s*\\\\setuppapersize\s*\[([^][]*)\].*$', + sub { + my ($ll,$np) = @_; + if ($ll =~ m/^\s*%?\s*\\setuppapersize\s*/) { + return("\\setuppapersize[$np][$np]\n"); + } else { + return($ll); + } + }, + $outfile, \@sizes, 'a4', '\setuppapersize[a4][a4]', $newpaper); +} + + +# psutils +# config file "psutils/paper.cfg" only contains two words: +# p <papersize> +# +sub paper_psutils { + my $outtree = shift; + my $newpaper = shift; + + my ($outcomp, $filecomp) = setup_names("psutils"); + my $dftfile = $paper{'psutils'}{'default_file'}; + my $outfile = "$outtree/$outcomp/$filecomp"; + my $inp = &find_paper_file("psutils", "other text files", $filecomp, $dftfile); + + return ($F_ERROR) unless $inp; + + + my @sizes = keys %psutils_papersize; + return &paper_do_simple($inp, "psutils", '^\s*p', '^\s*p\s+(\w+)\s*$', + sub { + my ($ll,$np) = @_; + $ll =~ s/^\s*p\s+(\w+)\s*$/p $np\n/; + return($ll); + }, + $outfile, \@sizes, '(undefined)', 'p a4', $newpaper); +} + + +# paper_do_simple does the work for single line config files +# (xdvi, dvipdfm, ...) +# arguments: +# $inp, $prog, $firstre, $secondre, $bl, $outp, $paplist, $newpaper +# with +# $inp .. input file location +# $prog .. program name +# $firstre .. re that searches for paper lines +# $secondre .. re that extracts the paper from a paper line +# $bl .. block/sub taking two args, one paper line and the new paper, and +# returns the line with the paper configured, only lines mathing +# $firstre are shipped over to $bl +# $outp .. location of the output file +# $paplist .. ref to an array with the list of admissible paper sizes +# $defaultpaper .. default papersize (arbitrary string) if the $firstre is +# not found in the config file +# $defaultline .. the line to be added at the bottom of the file if +# no line has been found +# $newpaper .. --list, new paper, or undef +sub paper_do_simple { + my ($inp, $prog, $firstre, $secondre, $bl, $outp, $paplist, $defaultpaper, $defaultline, $newpaper) = @_; + + debug("file used for $prog: $inp\n"); + + open(FOO, "<$inp") or die("cannot open file $inp: $!"); + my @lines = <FOO>; + close(FOO); + + my $currentpaper; + my @paperlines = grep (m/$firstre/,@lines); + if (!@paperlines) { + $currentpaper = $defaultpaper; + } else { + if ($#paperlines > 0) { + warn "Strange, more than one paper definition, using the first one in\n$inp\n"; + } + $currentpaper = $paperlines[0]; + chomp($currentpaper); + $currentpaper =~ s/$secondre/$1/; + } + + # change value + if (defined($newpaper)) { + if ($newpaper eq "--list") { + info("$currentpaper\n"); + for my $p (@$paplist) { + info("$p\n") unless ($p eq $currentpaper); + } + } elsif ($newpaper eq "--json") { + my @ret = (); + push @ret, "$currentpaper"; + for my $p (@$paplist) { + push @ret, $p unless ($p eq $currentpaper); + } + my %foo; + $foo{'program'} = $prog; + $foo{'file'} = $inp; + $foo{'options'} = \@ret; + return \%foo; + } elsif ($newpaper eq "--returnlist") { + my @ret = (); + push @ret, $currentpaper; + for my $p (@$paplist) { + push @ret, $p unless ($p eq $currentpaper); + } + return(\@ret); + } else { + my $found = 0; + for my $p (@$paplist) { + if ($p eq $newpaper) { + $found = 1; + last; + } + } + if ($found) { + my @newlines; + my $foundcfg = 0; + for my $l (@lines) { + if ($l =~ m/$firstre/) { + push @newlines, &$bl($l, $newpaper); + $foundcfg = 1; + } else { + push @newlines, $l; + } + } + # what to do if no default line found??? + if (!$foundcfg) { + push @newlines, &$bl($defaultline, $newpaper); + } + info("$prg: setting paper size for $prog to $newpaper: $outp\n"); + mkdirhier(dirname($outp)); + # if we create the outfile we have to call mktexlsr + TeXLive::TLUtils::announce_execute_actions("files-changed") + unless (-r $outp); + if (!open(TMP, ">$outp")) { + tlwarn("$prg: Cannot write to $outp: $!\n"); + tlwarn("Not setting paper size for $prog.\n"); + return ($F_ERROR); + } + for (@newlines) { print TMP; } + close(TMP) || warn "$prg: close(>$outp) failed: $!"; + TeXLive::TLUtils::announce_execute_actions("regenerate-formats") + if ($prog eq "context"); + return($F_OK); + } else { + tlwarn("$prg: Not a valid paper size for $prog: $newpaper\n"); + return($F_WARNING); + } + } + } else { + # return the current value + info("Current $prog paper size (from $inp): $currentpaper\n"); + } + return($F_OK); +} + +=back +=cut +1; + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLTREE.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLTREE.pm new file mode 100644 index 0000000000..5a37f52a85 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLTREE.pm @@ -0,0 +1,541 @@ +# $Id: TLTREE.pm 48520 2018-08-31 03:41:13Z preining $ +# TeXLive::TLTREE.pm - work with the tree of all files +# Copyright 2007-2018 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLTREE; + +my $svnrev = '$Revision: 48520 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +use TeXLive::TLUtils; + +sub new { + my $class = shift; + my %params = @_; + my $self = { + svnroot => $params{'svnroot'}, + archs => $params{'archs'}, + revision => $params{'revision'}, + # private stuff + _allfiles => {}, + _dirtree => {}, + _dirnames => {}, + _filesofdir => {}, + _subdirsofdir => {}, + }; + bless $self, $class; + return $self; +} + +sub init_from_svn { + my $self = shift; + die "undefined svn root" if !defined($self->{'svnroot'}); + my @lines = `cd $self->{'svnroot'} && svn status -v`; + my $retval = $?; + if ($retval != 0) { + $retval /= 256 if $retval > 0; + tldie("TLTree: svn status -v returned $retval, stopping.\n"); + } + $self->_initialize_lines(@lines); +} + +sub init_from_statusfile { + my $self = shift; + die "need filename of svn status file" if (@_ != 1); + open(TMP,"<$_[0]") || die "open of svn status file($_[0]) failed: $!"; + my @lines = <TMP>; + close(TMP); + $self->_initialize_lines(@lines); +} +sub init_from_files { + my $self = shift; + my $svnroot = $self->{'svnroot'}; + my @lines = `find $svnroot`; + my $retval = $?; + if ($retval != 0) { + $retval /= 256 if $retval > 0; + tldie("TLTree: find $svnroot returned $retval, stopping.\n"); + } + @lines = grep(!/\/\.svn/ , @lines); + @lines = map { s@^$svnroot@@; s@^/@@; " 1 1 dummy $_" } @lines; + $self->{'revision'} = 1; + $self->_initialize_lines(@lines); +} + + +sub init_from_git { + my $self = shift; + my $svnroot = $self->{'svnroot'}; + my $retval = $?; + my %files; + my %deletedfiles; + my @lines; + + my @foo = `cd $svnroot; git log --pretty=format:COMMIT=%h --no-renames --name-status`; + if ($retval != 0) { + $retval /= 256 if $retval > 0; + tldie("TLTree: git log in $svnroot returned $retval, stopping.\n"); + } + chomp(@foo); + + my $curcom = ""; + my $rev = 0; + for my $l (@foo) { + if ($l eq "") { + $curcom = ""; + next; + } elsif ($l =~ m/^COMMIT=([[:xdigit:]]*)$/) { + $curcom = $1; + $rev++; + next; + } else { + # output is + # STATUS FILENAME + # where STATUS is as follows: + # Added (A), Copied (C), Deleted (D), Modified (M), Renamed (R), have their type (i.e. regular file, + # symlink, submodule, ...) changed (T), are Unmerged (U), are Unknown (X), or have had their pairing Broken (B). + if ($l =~ m/^(A|C|D|M|R|T|U|X|B)\S*\s+(.*)$/) { + my $status = $1; + my $curfile = $2; + # + # check whether the file was already removed + if (!defined($files{$curfile}) && !defined($deletedfiles{$curfile})) { + # first occurrence of that file + if ($status eq "D") { + $deletedfiles{$curfile} = 1; + } else { + $files{$curfile} = $rev; + } + } + } else { + print STDERR "Unknown line in git output: >>$l<<\n"; + } + } + } + + # now reverse the order + for my $f (keys %files) { + my $n = - ( $files{$f} - $rev ) + 1; + # special case for TL: remove Master if it is present + $f =~ s!^Master/!!; + push @lines, " $n $n dummy $f" + } + # debug(join("\n", @lines)); + # TODO needs to be made better! + $self->{'revision'} = $rev; + $self->_initialize_lines(@lines); +} + +sub init_from_gitsvn { + my $self = shift; + my $svnroot = $self->{'svnroot'}; + my @foo = `cd $svnroot; git log --pretty=format:%h --name-only`; + chomp(@foo); + my $retval = $?; + if ($retval != 0) { + $retval /= 256 if $retval > 0; + tldie("TLTree: git log in $svnroot returned $retval, stopping.\n"); + } + my %com2rev; + my @lines; + my $curcom = ""; + my $currev = ""; + for my $l (@foo) { + if ($l eq "") { + $currev = ""; + $curcom = ""; + next; + } + if ($curcom eq "") { + # now we should get a commit! + # we could also pattern match on 8 hex digits, but that costs time! + $curcom = $l; + $currev = `git svn find-rev $curcom`; + chomp($currev); + if (!$currev) { + # found a commit without svn rev, try to find it under the parents + my $foo = $curcom; + my $nr = 0; + while (1) { + $foo .= "^"; + $nr++; + my $tr = `git svn find-rev $foo`; + chomp($tr); + if ($tr) { + # we add the number of parents to the currev + $currev = $tr + $nr; + last; + } + } + } + $com2rev{$curcom} = $currev; + } else { + # we got a file name + push @lines, " $currev $currev dummy $l" + } + } + # TODO needs to be made better! + $self->{'revision'} = 1; + $self->_initialize_lines(@lines); +} + +sub _initialize_lines { + my $self = shift; + my @lines = @_; + my %archs; + # we first chdir to the svn root, we need it for file tests + chomp (my $oldpwd = `pwd`); + chdir($self->svnroot) || die "chdir($self->{svnroot}) failed: $!"; + foreach my $l (@lines) { + chomp($l); + next if $l =~ /^\?/; # ignore files not under version control + if ($l =~ /^(.)(.)(.)(.)(.)(.)..\s*(\d+)\s+([\d\?]+)\s+([\w\?]+)\s+(.+)$/){ + $self->{'revision'} = $7 unless defined($self->{'revision'}); + my $lastchanged = ($8 eq "?" ? 1 : $8); + my $entry = "$10"; + next if ($1 eq "D"); # ignore files which are removed + next if -d $entry && ! -l $entry; # keep symlinks to dirs (bin/*/man), + # ignore normal dirs. + # collect architectures, assuming nothing is in bin/ but arch subdirs. + if ($entry =~ m,^bin/([^/]*)/,) { + $archs{$1} = 1; + } + $self->{'_allfiles'}{$entry}{'lastchangedrev'} = $lastchanged; + $self->{'_allfiles'}{$entry}{'size'} = (lstat $entry)[7]; + my $fn = TeXLive::TLUtils::basename($entry); + my $dn = TeXLive::TLUtils::dirname($entry); + add_path_to_tree($self->{'_dirtree'}, split("[/\\\\]", $dn)); + push @{$self->{'_filesofdir'}{$dn}}, $fn; + } elsif ($l ne ' 1 1 dummy ') { + tlwarn("Ignoring svn status output line:\n $l\n"); + } + } + # save list of architectures + $self->architectures(keys(%archs)); + # now do some magic + # - create list of top level dirs with a list of full path names of + # the respective dir attached + $self->walk_tree(\&find_alldirs); + + chdir($oldpwd) || die "chdir($oldpwd) failed: $!"; +} + +sub print { + my $self = shift; + $self->walk_tree(\&print_node); +} + +sub find_alldirs { + my ($self,$node, @stackdir) = @_; + my $tl = $stackdir[-1]; + push @{$self->{'_dirnames'}{$tl}}, join("/", @stackdir); + if (keys(%{$node})) { + my $pa = join("/", @stackdir); + push @{$self->{'_subdirsofdir'}{$pa}}, keys(%{$node}); + } +} + +sub print_node { + my ($self,$node, @stackdir) = @_; + my $dp = join("/", @stackdir); + if ($self->{'_filesofdir'}{$dp}) { + foreach my $f (@{$self->{'_filesofdir'}{$dp}}) { + print "dp=$dp file=$f\n"; + } + } + if (! keys(%{$node})) { + print join("/", @stackdir) . "\n"; + } +} + +sub walk_tree { + my $self = shift; + my (@stack_dir); + $self->_walk_tree1($self->{'_dirtree'},@_, @stack_dir); +} + +sub _walk_tree1 { + my $self = shift; + my ($node,$pre_proc, $post_proc, @stack_dir) = @_; + my $v; + for my $k (keys(%{$node})) { + push @stack_dir, $k; + $v = $node->{$k}; + if ($pre_proc) { &{$pre_proc}($self, $v, @stack_dir) } + $self->_walk_tree1 (\%{$v}, $pre_proc, $post_proc, @stack_dir); + $v = $node->{$k}; + if ($post_proc) { &{$post_proc}($self, $v, @stack_dir) } + pop @stack_dir; + } +} + +sub add_path_to_tree { + my ($node, @path) = @_; + my ($current); + + while (@path) { + $current = shift @path; + if ($$node{$current}) { + $node = $$node{$current}; + } else { + $$node{$current} = { }; + $node = $$node{$current}; + } + } + return $node; +} + +sub file_svn_lastrevision { + my $self = shift; + my $fn = shift; + if (defined($self->{'_allfiles'}{$fn})) { + return($self->{'_allfiles'}{$fn}{'lastchangedrev'}); + } else { + return(undef); + } +} + +sub size_of { + my ($self,$f) = @_; + if (defined($self->{'_allfiles'}{$f})) { + return($self->{'_allfiles'}{$f}{'size'}); + } else { + return(undef); + } +} + +# return a per-architecture hash ref for TYPE eq "bin", +# list ref for all others. +# +=pod + +The function B<get_matching_files> takes as arguments the type of the pattern +(bin, src, doc, run), the pattern itself, the package name (without +.ARCH specifications), and an optional architecture. +It returns a list of files matching that pattern (in the case +of bin patterns for that arch). + +=cut + +sub get_matching_files { + my ($self, $type, $p, $pkg, $arch) = @_; + my $ARCH = $arch; + my $newp; + { + my $warnstr = ""; + local $SIG{__WARN__} = sub { $warnstr = $_[0]; }; + eval "\$newp = \"$p\""; + if (!defined($newp)) { + die "cannot set newp from p: p=$p, pkg=$pkg, arch=$arch, type=$type"; + } + if ($warnstr) { + tlwarn("Warning `$warnstr' while evaluating: $p " + . "(pkg=$pkg, arch=$arch, type=$type), returning empty list\n"); + return (); + } + } + return $self->_get_matching_files($type,$newp); +} + + +sub _get_matching_files { + my ($self, $type, $p) = @_; + my ($pattype,$patdata,@rest) = split ' ',$p; + my @matchfiles; + if ($pattype eq "t") { + @matchfiles = $self->_get_files_matching_dir_pattern($type,$patdata,@rest); + } elsif ($pattype eq "f") { + @matchfiles = $self->_get_files_matching_glob_pattern($type,$patdata); + } elsif ($pattype eq "r") { + @matchfiles = $self->_get_files_matching_regexp_pattern($type,$patdata); + } elsif ($pattype eq "d") { + @matchfiles = $self->files_under_path($patdata); + } else { + die "Unknown pattern type `$pattype' in $p"; + } + ddebug("p=$p; matchfiles=@matchfiles\n"); + return @matchfiles; +} + +# +# we transform a glob pattern to a regexp pattern: +# currently supported globs: ? * +# +# sequences of subsitutions: +# . -> \. +# * -> .* +# ? -> . +# + -> \+ +sub _get_files_matching_glob_pattern +{ + my $self = shift; + my ($type,$globline) = @_; + my @returnfiles; + + my $dirpart = TeXLive::TLUtils::dirname($globline); + my $basepart = TeXLive::TLUtils::basename($globline); + $basepart =~ s/\./\\./g; + $basepart =~ s/\*/.*/g; + $basepart =~ s/\?/./g; + $basepart =~ s/\+/\\+/g; + return unless (defined($self->{'_filesofdir'}{$dirpart})); + + my @candfiles = @{$self->{'_filesofdir'}{$dirpart}}; + for my $f (@candfiles) { + ddebug("matching $f in $dirpart via glob $globline\n"); + if ($f =~ /^$basepart$/) { + ddebug("hit: globline=$globline, $dirpart/$f\n"); + if ("$dirpart" eq ".") { + push @returnfiles, "$f"; + } else { + push @returnfiles, "$dirpart/$f"; + } + } + } + + if ($dirpart =~ m,^bin/(win[0-9]|.*-cygwin), + || $dirpart =~ m,tlpkg/installer,) { + # for windows-ish we want to automatch more extensions. + foreach my $f (@candfiles) { + my $w32_binext; + if ($dirpart =~ m,^bin/.*-cygwin,) { + $w32_binext = "exe"; # cygwin has .exe but nothing else + } else { + $w32_binext = "(exe|dll)(.manifest)?|texlua|bat|cmd"; + } + ddebug("matching $f in $dirpart via glob $globline.($w32_binext)\n"); + if ($f =~ /^$basepart\.($w32_binext)$/) { + ddebug("hit: globline=$globline, $dirpart/$f\n"); + if ("$dirpart" eq ".") { + push @returnfiles, "$f"; + } else { + push @returnfiles, "$dirpart/$f"; + } + } + } + } + return @returnfiles; +} + +sub _get_files_matching_regexp_pattern { + my $self = shift; + my ($type,$regexp) = @_; + my @returnfiles; + FILELABEL: foreach my $f (keys(%{$self->{'_allfiles'}})) { + if ($f =~ /^$regexp$/) { + TeXLive::TLUtils::push_uniq(\@returnfiles,$f); + next FILELABEL; + } + } + return(@returnfiles); +} + +# +# go through all dir names in the TLTREE such that +# which are named like the last entry of @patwords, +# and which have initial path component of the +# rest of @patwords +# +# This is not optimal, because many subsetted +# dirs are found, example package graphics contains +# the following exception line to make sure that +# these files are not included. +# docpattern +!d texmf-dist/doc/latex/graphicxbox/examples/graphics +# +# We don't need *arbitrary* depth, because what can happen is +# that the autopattern +# docpattern Package t texmf-dist doc %NAME% +# can match at one of the following +# texmf-dist/doc/%NAME +# texmf-dist/doc/<SOMETHING>/%NAME +# but not deeper. +# Same for the others. +# +# Lets say that we try that <SOMETHING> contains at *most* +# one (1) / (forward slash/path separator) +# +# only for fonts we need a special treatment with 3 +# +sub _get_files_matching_dir_pattern { + my ($self,$type,@patwords) = @_; + my $tl = pop @patwords; + my $maxintermediate = 1; + if (($#patwords >= 1 && $patwords[1] eq 'fonts') + || + ($#patwords >= 2 && $patwords[2] eq 'context')) { + $maxintermediate = 2; + } + my @returnfiles; + if (defined($self->{'_dirnames'}{$tl})) { + foreach my $tld (@{$self->{'_dirnames'}{$tl}}) { + my $startstr = join("/",@patwords)."/"; + if (index($tld, $startstr) == 0) { + my $middlepart = $tld; + $middlepart =~ s/\Q$startstr\E//; + $middlepart =~ s!/$tl/!!; + # put match into list context returns + # all matches, which is than coerced to + # an integer which gives the number! + my $number = () = $middlepart =~ m!/!g; + #printf STDERR "DEBUG: maxint=$maxintermediate, number=$number, patwords=@patwords\n"; + if ($number <= $maxintermediate) { + my @files = $self->files_under_path($tld); + TeXLive::TLUtils::push_uniq(\@returnfiles, @files); + } + } + } + } + return(@returnfiles); +} + +sub files_under_path { + my $self = shift; + my $p = shift; + my @files = (); + foreach my $aa (@{$self->{'_filesofdir'}{$p}}) { + TeXLive::TLUtils::push_uniq(\@files, $p . "/" . $aa); + } + if (defined($self->{'_subdirsofdir'}{$p})) { + foreach my $sd (@{$self->{'_subdirsofdir'}{$p}}) { + my @sdf = $self->files_under_path($p . "/" . $sd); + TeXLive::TLUtils::push_uniq (\@files, @sdf); + } + } + return @files; +} + + +# +# member access functions +# +sub svnroot { + my $self = shift; + if (@_) { $self->{'svnroot'} = shift }; + return $self->{'svnroot'}; +} + +sub revision { + my $self = shift; + if (@_) { $self->{'revision'} = shift }; + return $self->{'revision'}; +} + + +sub architectures { + my $self = shift; + if (@_) { @{ $self->{'archs'} } = @_ } + return defined $self->{'archs'} ? @{ $self->{'archs'} } : (); +} + + +1; + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm new file mode 100644 index 0000000000..08c146a9a3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm @@ -0,0 +1,4578 @@ +# $Id: TLUtils.pm 50493 2019-03-20 22:57:54Z karl $ +# TeXLive::TLUtils.pm - the inevitable utilities for TeX Live. +# Copyright 2007-2019 Norbert Preining, Reinhard Kotucha +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLUtils; + +my $svnrev = '$Revision: 50493 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +=pod + +=head1 NAME + +C<TeXLive::TLUtils> -- utilities used in TeX Live infrastructure + +=head1 SYNOPSIS + + use TeXLive::TLUtils; + +=head2 Platform detection + + TeXLive::TLUtils::platform(); + TeXLive::TLUtils::platform_name($canonical_host); + TeXLive::TLUtils::platform_desc($platform); + TeXLive::TLUtils::win32(); + TeXLive::TLUtils::unix(); + +=head2 System tools + + TeXLive::TLUtils::getenv($string); + TeXLive::TLUtils::which($string); + TeXLive::TLUtils::initialize_global_tmpdir(); + TeXLive::TLUtils::tl_tmpdir(); + TeXLive::TLUtils::tl_tmpfile(); + TeXLive::TLUtils::xchdir($dir); + TeXLive::TLUtils::wsystem($msg,@args); + TeXLive::TLUtils::xsystem(@args); + TeXLive::TLUtils::run_cmd($cmd); + TeXLive::TLUtils::system_pipe($prog, $infile, $outfile, $removeIn, @extraargs); + +=head2 File utilities + + TeXLive::TLUtils::dirname($path); + TeXLive::TLUtils::basename($path); + TeXLive::TLUtils::dirname_and_basename($path); + TeXLive::TLUtils::tl_abs_path($path); + TeXLive::TLUtils::dir_writable($path); + TeXLive::TLUtils::dir_creatable($path); + TeXLive::TLUtils::mkdirhier($path); + TeXLive::TLUtils::rmtree($root, $verbose, $safe); + TeXLive::TLUtils::copy($file, $target_dir); + TeXLive::TLUtils::touch(@files); + TeXLive::TLUtils::collapse_dirs(@files); + TeXLive::TLUtils::removed_dirs(@files); + TeXLive::TLUtils::download_file($path, $destination); + TeXLive::TLUtils::setup_programs($bindir, $platform); + TeXLive::TLUtils::tlcmp($file, $file); + TeXLive::TLUtils::nulldev(); + TeXLive::TLUtils::get_full_line($fh); + +=head2 Installer functions + + TeXLive::TLUtils::make_var_skeleton($path); + TeXLive::TLUtils::make_local_skeleton($path); + TeXLive::TLUtils::create_fmtutil($tlpdb,$dest); + TeXLive::TLUtils::create_updmap($tlpdb,$dest); + TeXLive::TLUtils::create_language_dat($tlpdb,$dest,$localconf); + TeXLive::TLUtils::create_language_def($tlpdb,$dest,$localconf); + TeXLive::TLUtils::create_language_lua($tlpdb,$dest,$localconf); + TeXLive::TLUtils::time_estimate($totalsize, $donesize, $starttime) + TeXLive::TLUtils::install_packages($from_tlpdb,$media,$to_tlpdb,$what,$opt_src, $opt_doc)>); + TeXLive::TLUtils::do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script); + TeXLive::TLUtils::announce_execute_actions($how, @executes, $what); + TeXLive::TLUtils::add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info); + TeXLive::TLUtils::remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info); + TeXLive::TLUtils::w32_add_to_path($bindir, $multiuser); + TeXLive::TLUtils::w32_remove_from_path($bindir, $multiuser); + TeXLive::TLUtils::setup_persistent_downloads(); + +=head2 Miscellaneous + + TeXLive::TLUtils::sort_uniq(@list); + TeXLive::TLUtils::push_uniq(\@list, @items); + TeXLive::TLUtils::member($item, @list); + TeXLive::TLUtils::merge_into(\%to, \%from); + TeXLive::TLUtils::texdir_check($texdir); + TeXLive::TLUtils::quotify_path_with_spaces($path); + TeXLive::TLUtils::conv_to_w32_path($path); + TeXLive::TLUtils::native_slashify($internal_path); + TeXLive::TLUtils::forward_slashify($path_from_user); + TeXLive::TLUtils::give_ctan_mirror(); + TeXLive::TLUtils::give_ctan_mirror_base(); + TeXLive::TLUtils::compare_tlpobjs($tlpA, $tlpB); + TeXLive::TLUtils::compare_tlpdbs($tlpdbA, $tlpdbB); + TeXLive::TLUtils::report_tlpdb_differences(\%ret); + TeXLive::TLUtils::tlnet_disabled_packages($root); + TeXLive::TLUtils::mktexupd(); + TeXLive::TLUtils::setup_sys_user_mode($optsref,$tmfc, $tmfsc, $tmfv, $tmfsv); + TeXLive::TLUtils::prepend_own_path(); + TeXLive::TLUtils::repository_to_array($str); + +=head2 JSON + + TeXLive::TLUtils::encode_json($ref); + TeXLive::TLUtils::True(); + TeXLive::TLUtils::False(); + +=head1 DESCRIPTION + +=cut + +# avoid -warnings. +our $PERL_SINGLE_QUOTE; # we steal code from Text::ParseWords +use vars qw( + $::LOGFILENAME @::LOGLINES + @::debug_hook @::ddebug_hook @::dddebug_hook @::info_hook + @::install_packages_hook @::warn_hook + $TeXLive::TLDownload::net_lib_avail + $::checksum_method $::gui_mode $::machinereadable $::no_execute_actions + $::regenerate_all_formats + $JSON::false $JSON::true +); + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT_OK @EXPORT); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + &platform + &platform_name + &platform_desc + &unix + &getenv + &which + &initialize_global_tmpdir + &dirname + &basename + &dirname_and_basename + &tl_abs_path + &dir_writable + &dir_creatable + &mkdirhier + &rmtree + © + &touch + &collapse_dirs + &removed_dirs + &install_package + &install_packages + &make_var_skeleton + &make_local_skeleton + &create_fmtutil + &create_updmap + &create_language_dat + &create_language_def + &create_language_lua + &parse_AddFormat_line + &parse_AddHyphen_line + &sort_uniq + &push_uniq + &texdir_check + &member + "ewords + "ify_path_with_spaces + &conv_to_w32_path + &native_slashify + &forward_slashify + &untar + &unpack + &merge_into + &give_ctan_mirror + &give_ctan_mirror_base + &create_mirror_list + &extract_mirror_entry + &wsystem + &xsystem + &run_cmd + &system_pipe + &announce_execute_actions + &add_symlinks + &remove_symlinks + &w32_add_to_path + &w32_remove_from_path + &tlcmp + &time_estimate + &compare_tlpobjs + &compare_tlpdbs + &report_tlpdb_differences + &setup_persistent_downloads + &mktexupd + &setup_sys_user_mode + &prepend_own_path + &nulldev + &get_full_line + &sort_archs + &repository_to_array + &encode_json + &True + &False + &SshURIRegex + ); + @EXPORT = qw(setup_programs download_file process_logging_options + tldie tlwarn info log debug ddebug dddebug debug_hash + win32 xchdir xsystem run_cmd system_pipe sort_archs); +} + +use Cwd; +use Getopt::Long; +use File::Temp; +use File::Copy qw//; + +use TeXLive::TLConfig; + +$::opt_verbosity = 0; # see process_logging_options + +our $SshURIRegex = '^((ssh|scp)://([^@]*)@([^/]*)/|([^@]*)@([^:]*):).*$'; + +=head2 Platform detection + +=over 4 + +=item C<platform> + +If C<$^O =~ /MSWin/i> is true we know that we're on +Windows and we set the global variable C<$::_platform_> to C<win32>. +Otherwise we call C<platform_name> with the output of C<config.guess> +as argument. + +The result is stored in a global variable C<$::_platform_>, and +subsequent calls just return that value. + +=cut + +sub platform { + unless (defined $::_platform_) { + if ($^O =~ /^MSWin/i) { + $::_platform_ = "win32"; + } else { + my $config_guess = "$::installerdir/tlpkg/installer/config.guess"; + + # We cannot rely on #! in config.guess but have to call /bin/sh + # explicitly because sometimes the 'noexec' flag is set in + # /etc/fstab for ISO9660 file systems. + chomp (my $guessed_platform = `/bin/sh '$config_guess'`); + + # For example, if the disc or reader has hardware problems. + die "$0: could not run $config_guess, cannot proceed, sorry" + if ! $guessed_platform; + + $::_platform_ = platform_name($guessed_platform); + } + } + return $::_platform_; +} + + +=item C<platform_name($canonical_host)> + +Convert a canonical host names as returned by C<config.guess> into +TeX Live platform names. + +CPU type is determined by a regexp, and any C</^i.86/> name is replaced +by C<i386>. + +For OS we need a list because what's returned is not likely to match our +historical names, e.g., C<config.guess> returns C<linux-gnu> but we need +C<linux>. This list might/should contain OSs which are not currently +supported. + +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. + +=cut + +sub platform_name { + my ($guessed_platform) = @_; + + $guessed_platform =~ s/^x86_64-(.*-k?)(free|net)bsd/amd64-$1$2bsd/; + my $CPU; # CPU type as reported by config.guess. + my $OS; # O/S type as reported by config.guess. + ($CPU = $guessed_platform) =~ s/(.*?)-.*/$1/; + $CPU =~ s/^alpha(.*)/alpha/; # alphaev whatever + $CPU =~ s/mips64el/mipsel/; # don't distinguish mips64 and 32 el + $CPU =~ s/powerpc64/powerpc/; # don't distinguish ppc64 + $CPU =~ s/sparc64/sparc/; # don't distinguish sparc64 + + # armv6l-unknown-linux-gnueabihf -> armhf-linux (RPi) + # armv7l-unknown-linux-gnueabi -> armel-linux (Android) + if ($CPU =~ /^arm/) { + $CPU = $guessed_platform =~ /hf$/ ? "armhf" : "armel"; + } + + my @OSs = qw(aix cygwin darwin freebsd hpux irix + kfreebsd linux netbsd openbsd solaris); + for my $os (@OSs) { + # Match word boundary at the beginning of the os name so that + # freebsd and kfreebsd are distinguished. + # Do not match word boundary at the end of the os so that + # solaris2 is matched. + $OS = $os if $guessed_platform =~ /\b$os/; + } + + if ($OS eq "linux") { + # deal with the special case of musl based distributions + # config.guess returns + # x86_64-pc-linux-musl + # i386-pc-linux-musl + $OS = "linuxmusl" if $guessed_platform =~ /\blinux-musl/; + } + + if ($OS eq "darwin") { + # We have two versions of Mac binary sets. + # 10.10/Yosemite and newer (Yosemite specially left over): + # -> x86_64-darwin [MacTeX] + # 10.6/Snow Leopard through 10.10/Yosemite: + # -> x86_64-darwinlegacy if 64-bit + # + # (BTW, uname -r numbers are larger by 4 than the Mac minor version. + # We don't use uname numbers here.) + # + # this changes each year, per above: + my $mactex_darwin = 12; # lowest minor rev supported by x86_64-darwin. + # + # Most robust approach is apparently to check sw_vers (os version, + # returns "10.x" values), and sysctl (processor hardware). + chomp (my $sw_vers = `sw_vers -productVersion`); + my ($os_major,$os_minor) = split (/\./, $sw_vers); + if ($os_major != 10) { + warn "$0: only MacOSX is supported, not $OS $os_major.$os_minor " + . " (from sw_vers -productVersion: $sw_vers)\n"; + return "unknown-unknown"; + } + if ($os_minor >= $mactex_darwin) { + ; # current version, default is ok (x86_64-darwin). + } elsif ($os_minor >= 6 && $os_minor < $mactex_darwin) { + # in between, x86 hardware only. On 10.6 only, must check if 64-bit, + # since if later than that, always 64-bit. + my $is64 = $os_minor == 6 + ? `/usr/sbin/sysctl -n hw.cpu64bit_capable` >= 1 + : 1; + if ($is64) { + $CPU = "x86_64"; + $OS = "darwinlegacy"; + } # if not 64-bit, default is ok (i386-darwin). + } else { + ; # older version, default is ok (i386-darwin, powerpc-darwin). + } + + } elsif ($CPU =~ /^i.86$/) { + $CPU = "i386"; # 586, 686, whatever + } + + if (! defined $OS) { + ($OS = $guessed_platform) =~ s/.*-(.*)/$1/; + } + + return "$CPU-$OS"; +} + +=item C<platform_desc($platform)> + +Return a string which describes a particular platform identifier, e.g., +given C<i386-linux> we return C<Intel x86 with GNU/Linux>. + +=cut + +sub platform_desc { + my ($platform) = @_; + + my %platform_name = ( + 'aarch64-linux' => 'GNU/Linux on ARM64', + 'alpha-linux' => 'GNU/Linux on DEC Alpha', + 'amd64-freebsd' => 'FreeBSD on x86_64', + 'amd64-kfreebsd' => 'GNU/kFreeBSD on x86_64', + 'amd64-netbsd' => 'NetBSD on x86_64', + 'armel-linux' => 'GNU/Linux on ARM', + 'armhf-linux' => 'GNU/Linux on ARMv6/RPi', + 'hppa-hpux' => 'HP-UX', + 'i386-cygwin' => 'Cygwin on Intel x86', + 'i386-darwin' => 'MacOSX legacy (10.5-10.6) on Intel x86', + 'i386-freebsd' => 'FreeBSD on Intel x86', + 'i386-kfreebsd' => 'GNU/kFreeBSD on Intel x86', + 'i386-linux' => 'GNU/Linux on Intel x86', + 'i386-linuxmusl' => 'GNU/Linux on Intel x86 with musl', + 'i386-netbsd' => 'NetBSD on Intel x86', + 'i386-openbsd' => 'OpenBSD on Intel x86', + 'i386-solaris' => 'Solaris on Intel x86', + 'mips-irix' => 'SGI IRIX', + 'mipsel-linux' => 'GNU/Linux on MIPSel', + 'powerpc-aix' => 'AIX on PowerPC', + 'powerpc-darwin' => 'MacOSX legacy (10.5) on PowerPC', + 'powerpc-linux' => 'GNU/Linux on PowerPC', + 'sparc-linux' => 'GNU/Linux on Sparc', + 'sparc-solaris' => 'Solaris on Sparc', + 'universal-darwin' => 'MacOSX universal binaries', + 'win32' => 'Windows', + 'x86_64-cygwin' => 'Cygwin on x86_64', + 'x86_64-darwin' => 'MacOSX current (10.12-) on x86_64', + 'x86_64-darwinlegacy' => 'MacOSX legacy (10.6-) on x86_64', + 'x86_64-linux' => 'GNU/Linux on x86_64', + 'x86_64-linuxmusl' => 'GNU/Linux on x86_64 with musl', + 'x86_64-solaris' => 'Solaris on x86_64', + ); + + # the inconsistency between amd64-freebsd and x86_64-linux is + # unfortunate (it's the same hardware), but the os people say those + # are the conventional names on the respective os's, so we follow suit. + + if (exists $platform_name{$platform}) { + return "$platform_name{$platform}"; + } else { + my ($CPU,$OS) = split ('-', $platform); + return "$CPU with " . ucfirst "$OS"; + } +} + + +=item C<win32> + +Return C<1> if platform is Windows and C<0> otherwise. The test is +currently based on the value of Perl's C<$^O> variable. + +=cut + +sub win32 { + if ($^O =~ /^MSWin/i) { + return 1; + } else { + return 0; + } + # the following needs config.guess, which is quite bad ... + # return (&platform eq "win32")? 1:0; +} + + +=item C<unix> + +Return C<1> if platform is UNIX and C<0> otherwise. + +=cut + +sub unix { + return (&platform eq "win32")? 0:1; +} + + +=back + +=head2 System Tools + +=over 4 + +=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"; +} + + +=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 already be present. + +=cut + +sub which { + my ($prog) = @_; + my @PATH; + my $PATH = getenv('PATH'); + + if (&win32) { + my @PATHEXT = split (';', getenv('PATHEXT')); + push (@PATHEXT, ''); # in case 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 { # not windows + @PATH = split (':', $PATH); + for my $dir (@PATH) { + if (-x "$dir/$prog") { + return "$dir/$prog"; + } + } + } + return 0; +} + +=item C<initialize_global_tmpdir();> + +Initializes a directory for all temporary files. This uses C<File::Temp> +and thus honors various env variables like C<TMPDIR>, C<TMP>, and C<TEMP>. + +=cut + +sub initialize_global_tmpdir { + $::tl_tmpdir = File::Temp::tempdir(CLEANUP => 1); + ddebug("tl_tempdir: creating global tempdir $::tl_tmpdir\n"); + return ($::tl_tmpdir); +} + +=item C<tl_tmpdir> + +Create a temporary directory which is removed when the program +is terminated. + +=cut + +sub tl_tmpdir { + initialize_global_tmpdir() if (!defined($::tl_tmpdir)); + my $tmp = File::Temp::tempdir(DIR => $::tl_tmpdir, CLEANUP => 1); + ddebug("tl_tempdir: creating tempdir $tmp\n"); + return ($tmp); +} + +=item C<tl_tmpfile> + +Create a temporary file which is removed when the program +is terminated. Returns file handle and file name. +Arguments are passed on to C<File::Temp::tempfile>. + +=cut + +sub tl_tmpfile { + initialize_global_tmpdir() if (!defined($::tl_tmpdir)); + my ($fh, $fn) = File::Temp::tempfile(@_, DIR => $::tl_tmpdir, UNLINK => 1); + ddebug("tl_tempfile: creating tempfile $fn\n"); + return ($fh, $fn); +} + + +=item C<xchdir($dir)> + +C<chdir($dir)> or die. + +=cut + +sub xchdir { + my ($dir) = @_; + chdir($dir) || die "$0: chdir($dir) failed: $!"; + ddebug("xchdir($dir) ok\n"); +} + + +=item C<wsystem($msg, @args)> + +Call C<info> about what is being done starting with C<$msg>, then run +C<system(@args)>; C<tlwarn> if unsuccessful and return the exit status. + +=cut + +sub wsystem { + my ($msg,@args) = @_; + info("$msg @args ...\n"); + my $retval = system(@args); + if ($retval != 0) { + $retval /= 256 if $retval > 0; + tlwarn("$0: command failed (status $retval): @args: $!\n"); + } + return $retval; +} + + +=item C<xsystem(@args)> + +Call C<ddebug> about what is being done, then run C<system(@args)>, and +die if unsuccessful. + +=cut + +sub xsystem { + my (@args) = @_; + ddebug("running system(@args)\n"); + my $retval = system(@args); + if ($retval != 0) { + $retval /= 256 if $retval > 0; + my $pwd = cwd (); + die "$0: system(@args) failed in $pwd, status $retval"; + } + return $retval; +} + +=item C<run_cmd($cmd)> + +Run shell command C<$cmd> and captures its output. Returns a list with CMD's +output as the first element and the return value (exit code) as second. + +=cut + +sub run_cmd { + my $cmd = shift; + my $output = `$cmd`; + $output = "" if ! defined ($output); # don't return undef + + my $retval = $?; + if ($retval != 0) { + $retval /= 256 if $retval > 0; + } + return ($output,$retval); +} + +=item C<system_pipe($prog, $infile, $outfile, $removeIn, @extraargs)> + +Runs C<$prog> with C<@extraargs> redirecting stdin from C<$infile>, stdout to C<$outfile>. +Removes C<$infile> if C<$removeIn> is true. + +=cut + +sub system_pipe { + my ($prog, $infile, $outfile, $removeIn, @extraargs) = @_; + + my $progQuote = quotify_path_with_spaces($prog); + if (win32()) { + $infile =~ s!/!\\!g; + $outfile =~ s!/!\\!g; + } + my $infileQuote = "\"$infile\""; + my $outfileQuote = "\"$outfile\""; + debug("TLUtils::system_pipe: calling $progQuote @extraargs < $infileQuote > $outfileQuote\n"); + my $retval = system("$progQuote @extraargs < $infileQuote > $outfileQuote"); + if ($retval != 0) { + $retval /= 256 if $retval > 0; + debug("TLUtils::system_pipe: system exit code = $retval\n"); + return 0; + } else { + if ($removeIn) { + debug("TLUtils::system_pipe: removing $infile\n"); + unlink($infile); + } + return 1; + } +} + +=back + +=head2 File utilities + +=over 4 + +=item C<dirname_and_basename($path)> + +Return both C<dirname> and C<basename>. Example: + + ($dirpart,$filepart) = dirname_and_basename ($path); + +=cut + +sub dirname_and_basename { + my $path=shift; + my ($share, $base) = ("", ""); + if (win32) { + $path=~s!\\!/!g; + } + # do not try to make sense of paths ending with /.. + return (undef, undef) if $path =~ m!/\.\.$!; + if ($path=~m!/!) { # dirname("foo/bar/baz") -> "foo/bar" + # eliminate `/.' path components + while ($path =~ s!/\./!/!) {}; + # UNC path? => first split in $share = //xxx/yy and $path = /zzzz + if (win32() and $path =~ m!^(//[^/]+/[^/]+)(.*)$!) { + ($share, $path) = ($1, $2); + if ($path =~ m!^/?$!) { + $path = $share; + $base = ""; + } elsif ($path =~ m!(/.*)/(.*)!) { + $path = $share.$1; + $base = $2; + } else { + $base = $path; + $path = $share; + } + return ($path, $base); + } + # not a UNC path + $path=~m!(.*)/(.*)!; # works because of greedy matching + return ((($1 eq '') ? '/' : $1), $2); + } else { # dirname("ignore") -> "." + return (".", $path); + } +} + + +=item C<dirname($path)> + +Return C<$path> with its trailing C</component> removed. + +=cut + +sub dirname { + my $path = shift; + my ($dirname, $basename) = dirname_and_basename($path); + return $dirname; +} + + +=item C<basename($path)> + +Return C<$path> with any leading directory components removed. + +=cut + +sub basename { + my $path = shift; + my ($dirname, $basename) = dirname_and_basename($path); + return $basename; +} + + +=item C<tl_abs_path($path)> + +# Other than Cwd::abs_path, tl_abs_path also works if the argument does not +# yet exist as long as the path does not contain '..' components. + +=cut + +sub tl_abs_path { + my $path = shift; + if (win32) { + $path=~s!\\!/!g; + } + if (-e $path) { + $path = Cwd::abs_path($path); + } elsif ($path eq '.') { + $path = Cwd::getcwd(); + } else{ + # collapse /./ components + $path =~ s!/\./!/!g; + # no support for .. path components or for win32 long-path syntax + # (//?/ path prefix) + die "Unsupported path syntax" if $path =~ m!/\.\./! || $path =~ m!/\.\.$! + || $path =~ m!^\.\.!; + die "Unsupported path syntax" if win32() && $path =~ m!^//\?/!; + if ($path !~ m!^(.:)?/!) { # relative path + if (win32() && $path =~ /^.:/) { # drive letter + my $dcwd; + # starts with drive letter: current dir on drive + $dcwd = Cwd::getdcwd ($1); + $dcwd .= '/' unless $dcwd =~ m!/$!; + return $dcwd.$path; + } else { # relative path without drive letter + my $cwd = Cwd::getcwd(); + $cwd .= '/' unless $cwd =~ m!/$!; + return $cwd . $path; + } + } # else absolute path + } + $path =~ s!/$!! unless $path =~ m!^(.:)?/$!; + return $path; +} + + +=item C<dir_creatable($path)> + +Tests whether its argument is a directory where we can create a directory. + +=cut + +sub dir_slash { + my $d = shift; + $d = "$d/" unless $d =~ m!/!; + return $d; +} + +# test whether subdirectories can be created in the argument +sub dir_creatable { + my $path=shift; + #print STDERR "testing $path\n"; + $path =~ s!\\!/!g if win32; + return 0 unless -d $path; + $path .= '/' unless $path =~ m!/$!; + #print STDERR "testing $path\n"; + my $d; + for my $i (1..100) { + $d = ""; + # find a non-existent dirname + $d = $path . int(rand(1000000)); + last unless -e $d; + } + if (!$d) { + tlwarn("Cannot find available testdir name\n"); + return 0; + } + #print STDERR "creating $d\n"; + return 0 unless mkdir $d; + return 0 unless -d $d; + rmdir $d; + return 1; +} + + +=item C<dir_writable($path)> + +Tests whether its argument is writable by trying to write to +it. This function is necessary because the built-in C<-w> test just +looks at mode and uid/guid, which on Windows always returns true and +even on Unix is not always good enough for directories mounted from +a fileserver. + +=cut + +# The Unix test gives the wrong answer when used under Windows Vista +# with one of the `virtualized' directories such as Program Files: +# lacking administrative permissions, it would write successfully to +# the virtualized Program Files rather than fail to write to the +# real Program Files. Ugh. + +sub dir_writable { + my ($path) = @_; + return 0 unless -d $path; + $path =~ s!\\!/!g if win32; + $path .= '/' unless $path =~ m!/$!; + my $i = 0; + my $f; + for my $i (1..100) { + $f = ""; + # find a non-existent filename + $f = $path . int(rand(1000000)); + last unless -e $f; + } + if (!$f) { + tlwarn("Cannot find available testfile name\n"); + return 0; + } + return 0 if ! open (TEST, ">$f"); + my $written = 0; + $written = (print TEST "\n"); + close (TEST); + unlink ($f); + return $written; +} + + +=item C<mkdirhier($path, [$mode])> + +The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>. +It behaves differently depending on the context in which it is called: +If called in void context it will die on failure. If called in +scalar context, it will return 1/0 on sucess/failure. If called in +list context, it returns 1/0 as first element and an error message +as second, if an error occurred (and no second element in case of +success). The optional parameter sets the permission bits. + +=cut + +sub mkdirhier { + my ($tree,$mode) = @_; + my $ret = 1; + my $reterror; + + if (-d "$tree") { + $ret = 1; + } else { + my $subdir = ""; + # win32 is special as usual: we need to separate //servername/ part + # from the UNC path, since (! -d //servername/) tests true + $subdir = $& if ( win32() && ($tree =~ s!^//[^/]+/!!) ); + + @dirs = split (/[\/\\]/, $tree); + for my $dir (@dirs) { + $subdir .= "$dir/"; + if (! -d $subdir) { + if (defined $mode) { + if (! mkdir ($subdir, $mode)) { + $ret = 0; + $reterror = "mkdir($subdir,$mode) failed: $!"; + last; + } + } else { + if (! mkdir ($subdir)) { + $ret = 0; + $reterror = "mkdir($subdir) failed for tree $tree: $!"; + last; + } + } + } + } + } + if ($ret) { + return(1); # nothing bad here returning 1 in any case, will + # be ignored in void context, and give 1 in list context + } else { + if (wantarray) { + return(0, $reterror); + } elsif (defined wantarray) { + return(0); + } else { + die "$0: $reterror"; + } + } +} + + +=item C<rmtree($root, $verbose, $safe)> + +The C<rmtree> function provides a convenient way to delete a +subtree from the directory structure, much like the Unix command C<rm -r>. +C<rmtree> takes three arguments: + +=over 4 + +=item * + +the root of the subtree to delete, or a reference to +a list of roots. All of the files and directories +below each root, as well as the roots themselves, +will be deleted. + +=item * + +a boolean value, which if TRUE will cause C<rmtree> to +print a message each time it examines a file, giving the +name of the file, and indicating whether it's using C<rmdir> +or C<unlink> to remove it, or that it's skipping it. +(defaults to FALSE) + +=item * + +a boolean value, which if TRUE will cause C<rmtree> to +skip any files to which you do not have delete access +(if running under VMS) or write access (if running +under another OS). This will change in the future when +a criterion for 'delete permission' under OSs other +than VMS is settled. (defaults to FALSE) + +=back + +It returns the number of files successfully deleted. Symlinks are +simply deleted and not followed. + +B<NOTE:> There are race conditions internal to the implementation of +C<rmtree> making it unsafe to use on directory trees which may be +altered or moved while C<rmtree> is running, and in particular on any +directory trees with any path components or subdirectories potentially +writable by untrusted users. + +Additionally, if the third parameter is not TRUE and C<rmtree> is +interrupted, it may leave files and directories with permissions altered +to allow deletion (and older versions of this module would even set +files and directories to world-read/writable!) + +Note also that the occurrence of errors in C<rmtree> can be determined I<only> +by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent +from the return value. + +=cut + +#taken from File/Path.pm +# +my $Is_VMS = $^O eq 'VMS'; +my $Is_MacOS = $^O eq 'MacOS'; + +# These OSes complain if you want to remove a file that you have no +# write permission to: +my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || + $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); + +sub rmtree { + my($roots, $verbose, $safe) = @_; + my(@files); + my($count) = 0; + $verbose ||= 0; + $safe ||= 0; + + if ( defined($roots) && length($roots) ) { + $roots = [$roots] unless ref $roots; + } else { + warn "No root path(s) specified"; + return 0; + } + + my($root); + foreach $root (@{$roots}) { + if ($Is_MacOS) { + $root = ":$root" if $root !~ /:/; + $root =~ s#([^:])\z#$1:#; + } else { + $root =~ s#/\z##; + } + (undef, undef, my $rp) = lstat $root or next; + $rp &= 07777; # don't forget setuid, setgid, sticky bits + if ( -d _ ) { + # notabene: 0700 is for making readable in the first place, + # it's also intended to change it to writable in case we have + # to recurse in which case we are better than rm -rf for + # subtrees with strange permissions + chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or warn "Can't make directory $root read+writeable: $!" + unless $safe; + + if (opendir my $d, $root) { + no strict 'refs'; + if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { + # Blindly untaint dir names + @files = map { /^(.*)$/s ; $1 } readdir $d; + } else { + @files = readdir $d; + } + closedir $d; + } else { + warn "Can't read $root: $!"; + @files = (); + } + # Deleting large numbers of files from VMS Files-11 filesystems + # is faster if done in reverse ASCIIbetical order + @files = reverse @files if $Is_VMS; + ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; + if ($Is_MacOS) { + @files = map("$root$_", @files); + } else { + @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); + } + $count += rmtree(\@files,$verbose,$safe); + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $verbose; + next; + } + chmod $rp | 0700, $root + or warn "Can't make directory $root writeable: $!" + if $force_writeable; + print "rmdir $root\n" if $verbose; + if (rmdir $root) { + ++$count; + } else { + warn "Can't remove directory $root: $!"; + chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or warn("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + } else { + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root))) + { + print "skipped $root\n" if $verbose; + next; + } + chmod $rp | 0600, $root + or warn "Can't make file $root writeable: $!" + if $force_writeable; + print "unlink $root\n" if $verbose; + # delete all versions under VMS + for (;;) { + unless (unlink $root) { + warn "Can't unlink file $root: $!"; + if ($force_writeable) { + chmod $rp, $root + or warn("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + last; + } + ++$count; + last unless $Is_VMS && lstat $root; + } + } + } + $count; +} + + +=item C<copy($file, $target_dir)> + +=item C<copy("-f", $file, $destfile)> + +Copy file C<$file> to directory C<$target_dir>, or to the C<$destfile> +in the second case. No external programs are involved. Since we need +C<sysopen()>, the Perl module C<Fcntl.pm> is required. The time stamps +are preserved and symlinks are created on Unix systems. On Windows, +C<(-l $file)> will never return 'C<true>' and so symlinks will be +(uselessly) copied as regular files. + +C<copy> invokes C<mkdirhier> if target directories do not exist. Files +have mode C<0777> if they are executable and C<0666> otherwise, with +the set bits in I<umask> cleared in each case. + +C<$file> can begin with a file:/ prefix. + +If C<$file> is not readable, we return without copying anything. (This +can happen when the database and files are not in perfect sync.) On the +other file, if the destination is not writable, or the writing fails, +that is a fatal error. + +=cut + +sub copy { + my $infile = shift; + my $filemode = 0; + if ($infile eq "-f") { # second argument is a file + $filemode = 1; + $infile = shift; + } + my $destdir=shift; + + my $outfile; + my @stat; + my $mode; + my $buffer; + my $offset; + my $filename; + my $dirmode = 0755; + my $blocksize = $TeXLive::TLConfig::BlockSize; + + $infile =~ s!^file://*!/!i; # remove file:/ url prefix + $filename = basename "$infile"; + if ($filemode) { + # given a destination file + $outfile = $destdir; + $destdir = dirname($outfile); + } else { + $outfile = "$destdir/$filename"; + } + + if (! -d $destdir) { + my ($ret,$err) = mkdirhier ($destdir); + die "mkdirhier($destdir) failed: $err\n" if ! $ret; + } + + if (-l "$infile") { + symlink (readlink $infile, "$destdir/$filename") + || die "symlink(readlink $infile, $destdir/$filename) failed: $!"; + } else { + if (! open (IN, $infile)) { + warn "open($infile) failed, not copying: $!"; + return; + } + binmode IN; + + $mode = (-x $infile) ? oct("0777") : oct("0666"); + $mode &= ~umask; + + open (OUT, ">$outfile") || die "open(>$outfile) failed: $!"; + binmode OUT; + + chmod ($mode, $outfile) || warn "chmod($mode,$outfile) failed: $!"; + + while ($read = sysread (IN, $buffer, $blocksize)) { + die "read($infile) failed: $!" unless defined $read; + $offset = 0; + while ($read) { + $written = syswrite (OUT, $buffer, $read, $offset); + die "write($outfile) failed: $!" unless defined $written; + $read -= $written; + $offset += $written; + } + } + close (OUT) || warn "close($outfile) failed: $!"; + close (IN) || warn "close($infile) failed: $!";; + @stat = lstat ($infile); + die "lstat($infile) failed: $!" if ! @stat; + utime ($stat[8], $stat[9], $outfile); + } +} + + +=item C<touch(@files)> + +Update modification and access time of C<@files>. Non-existent files +are created. + +=cut + +sub touch { + my @files=@_; + + foreach my $file (@_) { + if (-e $file) { + utime time, time, $file; + } else { + if (open( TMP, ">$file")) { + close(TMP); + } else { + warn "Can't create file $file: $!\n"; + } + } + } +} + + +=item C<collapse_dirs(@files)> + +Return a (more or less) minimal list of directories and files, given an +original list of files C<@files>. That is, if every file within a given +directory is included in C<@files>, replace all of those files with the +absolute directory name in the return list. Any files which have +sibling files not included are retained and made absolute. + +We try to walk up the tree so that the highest-level directory +containing only directories or files that are in C<@files> is returned. +(This logic may not be perfect, though.) + +This is not just a string function; we check for other directory entries +existing on disk within the directories of C<@files>. Therefore, if the +entries are relative pathnames, the current directory must be set by the +caller so that file tests work. + +As mentioned above, the returned list is absolute paths to directories +and files. + +For example, suppose the input list is + + dir1/subdir1/file1 + dir1/subdir2/file2 + dir1/file3 + +If there are no other entries under C<dir1/>, the result will be +C</absolute/path/to/dir1>. + +=cut + +sub collapse_dirs { + my (@files) = @_; + my @ret = (); + my %by_dir; + + # construct hash of all directories mentioned, values are lists of the + # files in that directory. + for my $f (@files) { + my $abs_f = Cwd::abs_path ($f); + die ("oops, no abs_path($f) from " . `pwd`) unless $abs_f; + (my $d = $abs_f) =~ s,/[^/]*$,,; + my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : (); + push (@a, $abs_f); + $by_dir{$d} = \@a; + } + + # for each of our directories, see if we are given everything in + # the directory. if so, return the directory; else return the + # individual files. + for my $d (sort keys %by_dir) { + opendir (DIR, $d) || die "opendir($d) failed: $!"; + my @dirents = readdir (DIR); + closedir (DIR) || warn "closedir($d) failed: $!"; + + # initialize test hash with all the files we saw in this dir. + # (These idioms are due to "Finding Elements in One Array and Not + # Another" in the Perl Cookbook.) + my %seen; + my @rmfiles = @{$by_dir{$d}}; + @seen{@rmfiles} = (); + + # see if everything is the same. + my $ok_to_collapse = 1; + for my $dirent (@dirents) { + next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn + + my $item = "$d/$dirent"; # prepend directory for comparison + if (! exists $seen{$item}) { + $ok_to_collapse = 0; + last; # no need to keep looking after the first. + } + } + + push (@ret, $ok_to_collapse ? $d : @{$by_dir{$d}}); + } + + if (@ret != @files) { + @ret = &collapse_dirs (@ret); + } + return @ret; +} + +=item C<removed_dirs(@files)> + +returns all the directories from which all content will be removed + +=cut + +# return all the directories from which all content will be removed +# +# idea: +# - create a hashes by_dir listing all files that should be removed +# by directory, i.e., key = dir, value is list of files +# - for each of the dirs (keys of by_dir and ordered deepest first) +# check that all actually contained files are removed +# and all the contained dirs are in the removal list. If this is the +# case put that directory into the removal list +# - return this removal list +# +sub removed_dirs { + my (@files) = @_; + my %removed_dirs; + my %by_dir; + + # construct hash of all directories mentioned, values are lists of the + # files/dirs in that directory. + for my $f (@files) { + # what should we do with not existing entries???? + next if (! -r "$f"); + my $abs_f = Cwd::abs_path ($f); + # the following is necessary because on win32, + # abs_path("tl-portable") + # returns + # c:\tl test\... + # and not forward slashes, while, if there is already a forward / + # in the path, also the rest is done with forward slashes. + $abs_f =~ s!\\!/!g if win32(); + if (!$abs_f) { + warn ("oops, no abs_path($f) from " . `pwd`); + next; + } + (my $d = $abs_f) =~ s,/[^/]*$,,; + my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : (); + push (@a, $abs_f); + $by_dir{$d} = \@a; + } + + # for each of our directories, see if we are removing everything in + # the directory. if so, return the directory; else return the + # individual files. + for my $d (reverse sort keys %by_dir) { + opendir (DIR, $d) || die "opendir($d) failed: $!"; + my @dirents = readdir (DIR); + closedir (DIR) || warn "closedir($d) failed: $!"; + + # initialize test hash with all the files we saw in this dir. + # (These idioms are due to "Finding Elements in One Array and Not + # Another" in the Perl Cookbook.) + my %seen; + my @rmfiles = @{$by_dir{$d}}; + @seen{@rmfiles} = (); + + # see if everything is the same. + my $cleandir = 1; + for my $dirent (@dirents) { + next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn + my $item = "$d/$dirent"; # prepend directory for comparison + if ( + ((-d $item) && (defined($removed_dirs{$item}))) + || + (exists $seen{$item}) + ) { + # do nothing + } else { + $cleandir = 0; + last; + } + } + if ($cleandir) { + $removed_dirs{$d} = 1; + } + } + return keys %removed_dirs; +} + +=item C<time_estimate($totalsize, $donesize, $starttime)> + +Returns the current running time and the estimated total time +based on the total size, the already done size, and the start time. + +=cut + +sub time_estimate { + my ($totalsize, $donesize, $starttime) = @_; + if ($donesize <= 0) { + return ("??:??", "??:??"); + } + my $curtime = time(); + my $passedtime = $curtime - $starttime; + my $esttotalsecs = int ( ( $passedtime * $totalsize ) / $donesize ); + # + # we change the display to show that passed time instead of the + # estimated remaining time. We keep the old code and naming and + # only initialize the $remsecs to the $passedtime instead. + # my $remsecs = $esttotalsecs - $passedtime; + my $remsecs = $passedtime; + my $min = int($remsecs/60); + my $hour; + if ($min >= 60) { + $hour = int($min/60); + $min %= 60; + } + my $sec = $remsecs % 60; + $remtime = sprintf("%02d:%02d", $min, $sec); + if ($hour) { + $remtime = sprintf("%02d:$remtime", $hour); + } + my $tmin = int($esttotalsecs/60); + my $thour; + if ($tmin >= 60) { + $thour = int($tmin/60); + $tmin %= 60; + } + my $tsec = $esttotalsecs % 60; + $tottime = sprintf("%02d:%02d", $tmin, $tsec); + if ($thour) { + $tottime = sprintf("%02d:$tottime", $thour); + } + return($remtime, $tottime); +} + + +=item C<install_packages($from_tlpdb, $media, $to_tlpdb, $what, $opt_src, $opt_doc)> + +Installs the list of packages found in C<@$what> (a ref to a list) into +the TLPDB given by C<$to_tlpdb>. Information on files are taken from +the TLPDB C<$from_tlpdb>. + +C<$opt_src> and C<$opt_doc> specify whether srcfiles and docfiles should be +installed (currently implemented only for installation from uncompressed media). + +Returns 1 on success and 0 on error. + +=cut + +sub install_packages { + my ($fromtlpdb,$media,$totlpdb,$what,$opt_src,$opt_doc) = @_; + my $container_src_split = $fromtlpdb->config_src_container; + my $container_doc_split = $fromtlpdb->config_doc_container; + my $root = $fromtlpdb->root; + my @packs = @$what; + my $totalnr = $#packs + 1; + my $td = length("$totalnr"); + my $n = 0; + my %tlpobjs; + my $totalsize = 0; + my $donesize = 0; + my %tlpsizes; + foreach my $p (@packs) { + $tlpobjs{$p} = $fromtlpdb->get_package($p); + if (!defined($tlpobjs{$p})) { + die "STRANGE: $p not to be found in ", $fromtlpdb->root; + } + if ($media ne 'local_uncompressed') { + # we use the container size as the measuring unit since probably + # downloading will be the limiting factor + $tlpsizes{$p} = $tlpobjs{$p}->containersize; + $tlpsizes{$p} += $tlpobjs{$p}->srccontainersize if $opt_src; + $tlpsizes{$p} += $tlpobjs{$p}->doccontainersize if $opt_doc; + } else { + # we have to add the respective sizes, that is checking for + # installation of src and doc file + $tlpsizes{$p} = $tlpobjs{$p}->runsize; + $tlpsizes{$p} += $tlpobjs{$p}->srcsize if $opt_src; + $tlpsizes{$p} += $tlpobjs{$p}->docsize if $opt_doc; + my %foo = %{$tlpobjs{$p}->binsize}; + for my $k (keys %foo) { $tlpsizes{$p} += $foo{$k}; } + # all the packages sizes are in blocks, so transfer that to bytes + $tlpsizes{$p} *= $TeXLive::TLConfig::BlockSize; + } + $totalsize += $tlpsizes{$p}; + } + my $starttime = time(); + foreach my $package (@packs) { + my $tlpobj = $tlpobjs{$package}; + my $reloc = $tlpobj->relocated; + $n++; + my ($estrem, $esttot) = time_estimate($totalsize, $donesize, $starttime); + my $infostr = sprintf("Installing [%0${td}d/$totalnr, " + . "time/total: $estrem/$esttot]: $package [%dk]", + $n, int($tlpsizes{$package}/1024) + 1); + info("$infostr\n"); + foreach my $h (@::install_packages_hook) { + &$h($n,$totalnr); + } + # return false if something went wrong + if (!$fromtlpdb->install_package($package, $totlpdb)) { + return 0; + } + $donesize += $tlpsizes{$package}; + } + my $totaltime = time() - $starttime; + my $totmin = int ($totaltime/60); + my $totsec = $totaltime % 60; + info(sprintf("Time used for installing the packages: %02d:%02d\n", + $totmin, $totsec)); + $totlpdb->save; + return 1; +} + +=item C<do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script)> + +Evaluates the C<postaction> fields in the C<$tlpobj>. The first parameter +can be either C<install> or C<remove>. The second gives the TLPOBJ whos +postactions should be evaluated, and the last four arguments specify +what type of postactions should (or shouldn't) be evaluated. + +Returns 1 on success, and 0 on failure. + +=cut + +sub do_postaction { + my ($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script) = @_; + my $ret = 1; + if (!defined($tlpobj)) { + tlwarn("do_postaction: didn't get a tlpobj\n"); + return 0; + } + debug("running postaction=$how for " . $tlpobj->name . "\n") + if $tlpobj->postactions; + for my $pa ($tlpobj->postactions) { + if ($pa =~ m/^\s*shortcut\s+(.*)\s*$/) { + $ret &&= _do_postaction_shortcut($how, $tlpobj, $do_menu, $do_desktop, $1); + } elsif ($pa =~ m/\s*filetype\s+(.*)\s*$/) { + next unless $do_fileassocs; + $ret &&= _do_postaction_filetype($how, $tlpobj, $1); + } elsif ($pa =~ m/\s*fileassoc\s+(.*)\s*$/) { + $ret &&= _do_postaction_fileassoc($how, $do_fileassocs, $tlpobj, $1); + next; + } elsif ($pa =~ m/\s*progid\s+(.*)\s*$/) { + next unless $do_fileassocs; + $ret &&= _do_postaction_progid($how, $tlpobj, $1); + } elsif ($pa =~ m/\s*script\s+(.*)\s*$/) { + next unless $do_script; + $ret &&= _do_postaction_script($how, $tlpobj, $1); + } else { + tlwarn("do_postaction: don't know how to do $pa\n"); + $ret = 0; + } + } + # nothing to do + return $ret; +} + +sub _do_postaction_fileassoc { + my ($how, $mode, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/extension filetype/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # name can be an arbitrary string + if (!defined($keyval{'extension'})) { + tlwarn("extension of fileassoc postaction not given\n"); + return 0; + } + my $extension = $keyval{'extension'}; + + # cmd can be an arbitrary string + if (!defined($keyval{'filetype'})) { + tlwarn("filetype of fileassoc postaction not given\n"); + return 0; + } + my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear; + + &log("postaction $how fileassoc for " . $tlpobj->name . + ": $extension, $filetype\n"); + if ($how eq "install") { + TeXLive::TLWinGoo::register_extension($mode, $extension, $filetype); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::unregister_extension($mode, $extension, $filetype); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub _do_postaction_filetype { + my ($how, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/name cmd/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # name can be an arbitrary string + if (!defined($keyval{'name'})) { + tlwarn("name of filetype postaction not given\n"); + return 0; + } + my $name = $keyval{'name'}.'.'.$ReleaseYear; + + # cmd can be an arbitrary string + if (!defined($keyval{'cmd'})) { + tlwarn("cmd of filetype postaction not given\n"); + return 0; + } + my $cmd = $keyval{'cmd'}; + + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my $texdir_bsl = conv_to_w32_path($texdir); + $cmd =~ s!^("?)TEXDIR/!$1$texdir/!g; + + &log("postaction $how filetype for " . $tlpobj->name . + ": $name, $cmd\n"); + if ($how eq "install") { + TeXLive::TLWinGoo::register_file_type($name, $cmd); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::unregister_file_type($name); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +# alternate filetype (= progid) for an extension; +# associated program shows up in `open with' menu +sub _do_postaction_progid { + my ($how, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/extension filetype/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + if (!defined($keyval{'extension'})) { + tlwarn("extension of progid postaction not given\n"); + return 0; + } + my $extension = $keyval{'extension'}; + + if (!defined($keyval{'filetype'})) { + tlwarn("filetype of progid postaction not given\n"); + return 0; + } + my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear; + + &log("postaction $how progid for " . $tlpobj->name . + ": $extension, $filetype\n"); + if ($how eq "install") { + TeXLive::TLWinGoo::add_to_progids($extension, $filetype); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::remove_from_progids($extension, $filetype); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub _do_postaction_script { + my ($how, $tlpobj, $pa) = @_; + my ($errors, %keyval) = + parse_into_keywords($pa, qw/file filew32/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # file can be an arbitrary string + if (!defined($keyval{'file'})) { + tlwarn("filename of script not given\n"); + return 0; + } + my $file = $keyval{'file'}; + if (win32() && defined($keyval{'filew32'})) { + $file = $keyval{'filew32'}; + } + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my @syscmd; + if ($file =~ m/\.pl$/i) { + # we got a perl script, call it via perl + push @syscmd, "perl", "$texdir/$file"; + } elsif ($file =~ m/\.texlua$/i) { + # we got a texlua script, call it via texlua + push @syscmd, "texlua", "$texdir/$file"; + } else { + # we got anything else, call it directly and hope it is excutable + push @syscmd, "$texdir/$file"; + } + &log("postaction $how script for " . $tlpobj->name . ": @syscmd\n"); + push @syscmd, $how, $texdir; + my $ret = system (@syscmd); + if ($ret != 0) { + $ret /= 256 if $ret > 0; + my $pwd = cwd (); + warn "$0: calling post action script $file did not succeed in $pwd, status $ret"; + return 0; + } + return 1; +} + +sub _do_postaction_shortcut { + my ($how, $tlpobj, $do_menu, $do_desktop, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/type name icon cmd args hide/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # type can be either menu or desktop + if (!defined($keyval{'type'})) { + tlwarn("type of shortcut postaction not given\n"); + return 0; + } + my $type = $keyval{'type'}; + if (($type ne "menu") && ($type ne "desktop")) { + tlwarn("type of shortcut postaction $type is unknown (menu, desktop)\n"); + return 0; + } + + if (($type eq "menu") && !$do_menu) { + return 1; + } + if (($type eq "desktop") && !$do_desktop) { + return 1; + } + + # name can be an arbitrary string + if (!defined($keyval{'name'})) { + tlwarn("name of shortcut postaction not given\n"); + return 0; + } + my $name = $keyval{'name'}; + + # icon, cmd, args is optional + my $icon = (defined($keyval{'icon'}) ? $keyval{'icon'} : ''); + my $cmd = (defined($keyval{'cmd'}) ? $keyval{'cmd'} : ''); + my $args = (defined($keyval{'args'}) ? $keyval{'args'} : ''); + + # hide can be only 0 or 1, and defaults to 1 + my $hide = (defined($keyval{'hide'}) ? $keyval{'hide'} : 1); + if (($hide ne "0") && ($hide ne "1")) { + tlwarn("hide of shortcut postaction $hide is unknown (0, 1)\n"); + return 0; + } + + &log("postaction $how shortcut for " . $tlpobj->name . "\n"); + if ($how eq "install") { + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my $texdir_bsl = conv_to_w32_path($texdir); + $icon =~ s!^TEXDIR/!$texdir/!; + $cmd =~ s!^TEXDIR/!$texdir/!; + # $cmd can be an URL, in which case we do NOT want to convert it to + # w32 paths! + if ($cmd !~ m!^\s*(https?://|ftp://)!) { + if (!(-e $cmd) or !(-r $cmd)) { + tlwarn("Target of shortcut action does not exist: $cmd\n") + if $cmd =~ /\.(exe|bat|cmd)$/i; + # if not an executable, just omit shortcut silently: no error + return 1; + } + $cmd = conv_to_w32_path($cmd); + } + if ($type eq "menu" ) { + TeXLive::TLWinGoo::add_menu_shortcut( + $TeXLive::TLConfig::WindowsMainMenuName, + $name, $icon, $cmd, $args, $hide); + } elsif ($type eq "desktop") { + TeXLive::TLWinGoo::add_desktop_shortcut( + $name, $icon, $cmd, $args, $hide); + } else { + tlwarn("Unknown type of shortcut: $type\n"); + return 0; + } + } elsif ($how eq "remove") { + if ($type eq "menu") { + TeXLive::TLWinGoo::remove_menu_shortcut( + $TeXLive::TLConfig::WindowsMainMenuName, $name); + } elsif ($type eq "desktop") { + TeXLive::TLWinGoo::remove_desktop_shortcut($name); + } else { + tlwarn("Unknown type of shortcut: $type\n"); + return 0; + } + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub parse_into_keywords { + my ($str, @keys) = @_; + my @words = quotewords('\s+', 0, $str); + my %ret; + my $error = 0; + while (@words) { + $_ = shift @words; + if (/^([^=]+)=(.*)$/) { + $ret{$1} = $2; + } else { + tlwarn("parser found a invalid word in parsing keys: $_\n"); + $error++; + $ret{$_} = ""; + } + } + for my $k (keys %ret) { + if (!member($k, @keys)) { + $error++; + tlwarn("parser found invalid keyword: $k\n"); + } + } + return($error, %ret); +} + +=item C<announce_execute_actions($how, $tlpobj, $what)> + +Announces that the actions given in C<$tlpobj> should be executed +after all packages have been unpacked. C<$what> provides +additional information. + +=cut + +sub announce_execute_actions { + my ($type, $tlp, $what) = @_; + # do simply return immediately if execute actions are suppressed + return if $::no_execute_actions; + + if (defined($type) && ($type eq "regenerate-formats")) { + $::regenerate_all_formats = 1; + return; + } + if (defined($type) && ($type eq "files-changed")) { + $::files_changed = 1; + return; + } + if (defined($type) && ($type eq "rebuild-format")) { + # rebuild-format must feed in a hashref of a parse_AddFormat_line data + # the $tlp argument is not used + $::execute_actions{'enable'}{'formats'}{$what->{'name'}} = $what; + return; + } + if (!defined($type) || (($type ne "enable") && ($type ne "disable"))) { + die "announce_execute_actions: enable or disable, not type $type"; + } + my (@maps, @formats, @dats); + if ($tlp->runfiles || $tlp->srcfiles || $tlp->docfiles) { + $::files_changed = 1; + } + $what = "map format hyphen" if (!defined($what)); + foreach my $e ($tlp->executes) { + if ($e =~ m/^add((Mixed|Kanji)?Map)\s+([^\s]+)\s*$/) { + # save the refs as we have another =~ grep in the following lines + my $a = $1; + my $b = $3; + $::execute_actions{$type}{'maps'}{$b} = $a if ($what =~ m/map/); + } elsif ($e =~ m/^AddFormat\s+(.*)\s*$/) { + my %r = TeXLive::TLUtils::parse_AddFormat_line("$1"); + if (defined($r{"error"})) { + tlwarn ("$r{'error'} in parsing $e for return hash\n"); + } else { + $::execute_actions{$type}{'formats'}{$r{'name'}} = \%r + if ($what =~ m/format/); + } + } elsif ($e =~ m/^AddHyphen\s+(.*)\s*$/) { + my %r = TeXLive::TLUtils::parse_AddHyphen_line("$1"); + if (defined($r{"error"})) { + tlwarn ("$r{'error'} in parsing $e for return hash\n"); + } else { + $::execute_actions{$type}{'hyphens'}{$r{'name'}} = \%r + if ($what =~ m/hyphen/); + } + } else { + tlwarn("Unknown execute $e in ", $tlp->name, "\n"); + } + } +} + + +=pod + +=item C<add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)> + +=item C<remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)> + +These two functions try to create/remove symlinks for binaries, man pages, +and info files as specified by the options $sys_bin, $sys_man, $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) = @_; + my ($ret, $err) = mkdirhier ($to); + if (!$ret) { + tlwarn("$err\n"); + return 0; + } + if (-w $to) { + debug ("linking files from $from to $to\n"); + chomp (@files = `ls "$from"`); + my $ret = 1; + for my $f (@files) { + # don't make a system-dir link to our special "man" link. + if ($f eq "man") { + debug ("not linking `man' into $to.\n"); + next; + } + # + # attempt to remove an existing symlink, but nothing else. + unlink ("$to/$f") if -l "$to/$f"; + # + # if the destination still exists, skip it. + if (-e "$to/$f") { + tlwarn ("add_link_dir_dir: $to/$f exists; not making symlink.\n"); + next; + } + # + # try to make the link. + if (symlink ("$from/$f", "$to/$f") == 0) { + tlwarn ("add_link_dir_dir: symlink of $f from $from to $to failed: $!\n"); + $ret = 0; + } + } + return $ret; + } else { + tlwarn ("add_link_dir_dir: destination $to not writable, " + . "no links from $from.\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 ($f eq "man") { + debug("not considering man in $to, it should not be from us!\n"); + next; + } + 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"); + } + } + # try 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 ($mode, $Master, $arch, $sys_bin, $sys_man, $sys_info) = @_; + my $errors = 0; + my $plat_bindir = "$Master/bin/$arch"; + + # nothing to do with symlinks on Windows, of course. + return if win32(); + + my $info_dir = "$Master/texmf-dist/doc/info"; + if ($mode eq "add") { + $errors++ unless add_link_dir_dir($plat_bindir, $sys_bin); # bin + if (-d $info_dir) { + $errors++ unless add_link_dir_dir($info_dir, $sys_info); + } + } elsif ($mode eq "remove") { + $errors++ unless remove_link_dir_dir($plat_bindir, $sys_bin); # bin + if (-d $info_dir) { + $errors++ unless remove_link_dir_dir($info_dir, $sys_info); + } + } else { + die ("should not happen, unknown mode $mode in add_remove_symlinks!"); + } + + # man + my $top_man_dir = "$Master/texmf-dist/doc/man"; + debug("$mode symlinks for man pages to $sys_man from $top_man_dir\n"); + if (! -d $top_man_dir) { + ; # better to be silent? + #info("skipping add of man symlinks, no source directory $top_man_dir\n"); + } else { + my $man_doable = 1; + if ($mode eq "add") { + my ($ret, $err) = mkdirhier $sys_man; + if (!$ret) { + $man_doable = 0; + tlwarn("$err\n"); + $errors++; + } + } + if ($man_doable) { + if (-w $sys_man) { + my $foo = `(cd "$top_man_dir" && echo *)`; + my @mans = split (' ', $foo); + chomp (@mans); + foreach my $m (@mans) { + my $mandir = "$top_man_dir/$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("man symlink destination ($sys_man) not writable, " + . "cannot $mode symlinks.\n"); + $errors++; + } + } + } + + # we collected errors in $errors, so return the negation of it + if ($errors) { + info("$mode of symlinks had $errors error(s), see messages above.\n"); + return $F_ERROR; + } else { + return $F_OK; + } +} + +sub add_symlinks { return (add_remove_symlinks("add", @_)); } +sub remove_symlinks { return (add_remove_symlinks("remove", @_)); } + +=pod + +=item C<w32_add_to_path($bindir, $multiuser)> +=item C<w32_remove_from_path($bindir, $multiuser)> + +These two functions try to add/remove the binary directory $bindir +on Windows to the registry PATH variable. + +If running as admin user and $multiuser is set, the system path will +be adjusted, otherwise the user path. + +After calling these functions TeXLive::TLWinGoo::broadcast_env() should +be called to make the changes immediately visible. + +=cut + +sub w32_add_to_path { + my ($bindir, $multiuser) = @_; + return if (!win32()); + + my $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'}; + $path =~ s/[\s\x00]+$//; + &log("Old system path: $path\n"); + $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'}; + if ($path) { + $path =~ s/[\s\x00]+$//; + &log("Old user path: $path\n"); + } else { + &log("Old user path: none\n"); + } + my $mode = 'user'; + if (TeXLive::TLWinGoo::admin() && $multiuser) { + $mode = 'system'; + } + debug("TLUtils:w32_add_to_path: calling adjust_reg_path_for_texlive add $bindir $mode\n"); + TeXLive::TLWinGoo::adjust_reg_path_for_texlive('add', $bindir, $mode); + $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'}; + $path =~ s/[\s\x00]+$//; + &log("New system path: $path\n"); + $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'}; + if ($path) { + $path =~ s/[\s\x00]+$//; + &log("New user path: $path\n"); + } else { + &log("New user path: none\n"); + } +} + +sub w32_remove_from_path { + my ($bindir, $multiuser) = @_; + my $mode = 'user'; + if (TeXLive::TLWinGoo::admin() && $multiuser) { + $mode = 'system'; + } + debug("w32_remove_from_path: trying to remove $bindir in $mode\n"); + TeXLive::TLWinGoo::adjust_reg_path_for_texlive('remove', $bindir, $mode); +} + +=pod + +=item C<check_file($what, $checksum, $checksize> + +Remove C<$what> if either the given C<$checksum> or C<$checksize> does +not agree. If a check argument is not given, that check is not performed. + +=cut + +sub check_file { + my ($xzfile, $checksum, $checksize) = @_; + debug("check_file $xzfile, $checksum, $checksize\n"); + if (!$checksum && !$checksize) { + tlwarn("TLUtils::check_file: neither checksum nor checksize " . + "available for $xzfile, cannot check integrity"); + return; + } + # only run checksum tests if we can actually compute the checksum + if ($checksum && ($checksum ne "-1") && $::checksum_method) { + my $tlchecksum = TeXLive::TLCrypto::tlchecksum($xzfile); + if ($tlchecksum ne $checksum) { + tlwarn("TLUtils::check_file: removing $xzfile, checksums differ:\n"); + tlwarn("TLUtils::check_file: TL=$tlchecksum, arg=$checksum\n"); + unlink($xzfile); + return; + } else { + debug("TLUtils::check_file: checksums for $xzfile agree\n"); + # if we have checked the checksum, we don't need to check the size, too + return; + } + } + if ($checksize && ($checksize ne "-1")) { + my $filesize = (stat $xzfile)[7]; + if ($filesize != $checksize) { + tlwarn("TLUtils::check_file: removing $xzfile, sizes differ:\n"); + tlwarn("TLUtils::check_file: TL=$filesize, arg=$checksize\n"); + unlink($xzfile); + return; + } + } + # We cannot remove the file here, otherwise restoring of backups + # or unwind packages might die. +} + +=pod + +=item C<unpack($what, $targetdir, @opts> + +If necessary, downloads C$what>, and then unpacks it into C<$targetdir>. +C<@opts> is assigned to a hash and can contain the following +options: C<tmpdir> (use this directory for downloaded files), +C<checksum> (check downloaded file against this checksum), +C<size> (check downloaded file against this size), +C<remove> (remove temporary files after operation). +Returns a pair of values: in case of error return 0 and an additional +explanation, in case of success return 1 and the name of the package. + +If C<checksum> or C<size> is C<-1>, no warnings about missing checksum/size +is printed. This is used during restore and unwinding of failed updates. + +=cut + +sub unpack { + my ($what, $target, %opts) = @_; + # remove by default + my $remove = (defined($opts{'remove'}) ? $opts{'remove'} : 1); + my $tempdir = (defined($opts{'tmpdir'}) ? $opts{'tmpdir'} : tl_tmpdir()); + my $checksum = (defined($opts{'checksum'}) ? $opts{'checksum'} : 0); + my $size = (defined($opts{'size'}) ? $opts{'size'} : 0); + + if (!defined($what)) { + return (0, "nothing to unpack"); + } + + my $decompressorType; + my $compressorextension; + if ($what =~ m/\.tar\.$CompressorExtRegexp$/) { + $compressorextension = $1; + $decompressorType = $1 eq "gz" ? "gzip" : $1; + } + if (!$decompressorType) { + return(0, "don't know how to unpack"); + } + # make sure that the found uncompressor type is also available + if (!member($decompressorType, @{$::progs{'working_compressors'}})) { + return(0, "unsupported container format $decompressorType"); + } + + # only check the necessary compressor program + my $decompressor = $::progs{$decompressorType}; + my @decompressorArgs = @{$Compressors{$decompressorType}{'decompress_args'}}; + + my $fn = basename($what); + my $pkg = $fn; + $pkg =~ s/\.tar\.$compressorextension$//; + my $remove_containerfile = $remove; + my $containerfile = "$tempdir/$fn"; + my $tarfile = "$tempdir/$fn"; + $tarfile =~ s/\.$compressorextension$//; + if ($what =~ m,^(https?|ftp)://, || $what =~ m!$SshURIRegex!) { + # we are installing from the NET + # check for the presence of $what in $tempdir + if (-r $containerfile) { + check_file($containerfile, $checksum, $size); + } + # if the file is now not present, we can use it + if (! -r $containerfile) { + # try download the file and put it into temp + if (!download_file($what, $containerfile)) { + return(0, "downloading did not succeed"); + } + # remove false downloads + check_file($containerfile, $checksum, $size); + if ( ! -r $containerfile ) { + return(0, "downloading did not succeed"); + } + } + } else { + # we are installing from local compressed files + # copy it to temp + TeXLive::TLUtils::copy($what, $tempdir); + + check_file($containerfile, $checksum, $size); + if (! -r $containerfile) { + return (0, "consistency checks failed"); + } + # we can remove it afterwards + $remove_containerfile = 1; + } + if (!system_pipe($decompressor, $containerfile, $tarfile, + $remove_containerfile, @decompressorArgs) + || + ! -f $tarfile) { + unlink($tarfile, $containerfile); + return(0, "Decompressing $containerfile failed"); + } + if (untar($tarfile, $target, 1)) { + return (1, "$pkg"); + } else { + return (0, "untar failed"); + } +} + +=pod + +=item C<untar($tarfile, $targetdir, $remove_tarfile)> + +Unpacks C<$tarfile> in C<$targetdir> (changing directories to +C<$targetdir> and then back to the original directory). If +C<$remove_tarfile> is true, unlink C<$tarfile> after unpacking. + +Assumes the global C<$::progs{"tar"}> has been set up. + +=cut + +# return 1 if success, 0 if failure. +sub untar { + my ($tarfile, $targetdir, $remove_tarfile) = @_; + my $ret; + + my $tar = $::progs{'tar'}; # assume it's been set up + + # don't use the -C option to tar since Solaris tar et al. don't support it. + # don't use system("cd ... && $tar ...") since that opens us up to + # quoting issues. + # so fall back on chdir in Perl. + # + debug("unpacking $tarfile in $targetdir\n"); + my $cwd = cwd(); + chdir($targetdir) || die "chdir($targetdir) failed: $!"; + + # on w32 don't extract file modified time, because AV soft can open + # files in the mean time causing time stamp modification to fail + my $taropt = win32() ? "xmf" : "xf"; + if (system($tar, $taropt, $tarfile) != 0) { + tlwarn("TLUtils::untar: $tar $taropt $tarfile failed (in $targetdir)\n"); + $ret = 0; + } else { + $ret = 1; + } + unlink($tarfile) if $remove_tarfile; + + chdir($cwd) || die "chdir($cwd) failed: $!"; + return $ret; +} + + +=item C<tlcmp($file, $file)> + +Compare two files considering CR, LF, and CRLF as equivalent. +Returns 1 if different, 0 if the same. + +=cut + +sub tlcmp { + my ($filea, $fileb) = @_; + if (!defined($fileb)) { + die <<END_USAGE; +tlcmp needs two arguments FILE1 FILE2. +Compare as text files, ignoring line endings. +Exit status is zero if the same, 1 if different, something else if trouble. +END_USAGE + } + my $file1 = &read_file_ignore_cr ($filea); + my $file2 = &read_file_ignore_cr ($fileb); + + return $file1 eq $file2 ? 0 : 1; +} + + +=item C<read_file_ignore_cr($file)> + +Return contents of FILE as a string, converting all of CR, LF, and +CRLF to just LF. + +=cut + +sub read_file_ignore_cr { + my ($fname) = @_; + my $ret = ""; + + local *FILE; + open (FILE, $fname) || die "open($fname) failed: $!"; + while (<FILE>) { + s/\r\n?/\n/g; + #warn "line is |$_|"; + $ret .= $_; + } + close (FILE) || warn "close($fname) failed: $!"; + + return $ret; +} + + +=item C<setup_programs($bindir, $platform, $tlfirst)> + +Populate the global C<$::progs> hash containing the paths to the +programs C<lz4>, C<tar>, C<wget>, C<xz>. The C<$bindir> argument specifies +the path to the location of the C<xz> binaries, the C<$platform> +gives the TeX Live platform name, used as the extension on our +executables. If a program is not present in the TeX Live tree, we also +check along PATH (without the platform extension.) + +If the C<$tlfirst> argument or the C<TEXLIVE_PREFER_OWN> envvar is set, +prefer TL versions; else prefer system versions (except for Windows +C<tar.exe>, where we always use ours). + +Check many different downloads and compressors to determine what is +working. + +Return 0 if failure, nonzero if success. + +=cut + +sub setup_programs { + my ($bindir, $platform, $tlfirst) = @_; + my $ok = 1; + + # tlfirst is (currently) not passed in by either the installer or + # tlmgr, so it will be always false. + # If it is not defined, we check for the env variable + # TEXLIVE_PREFER_OWN + # + if (!defined($tlfirst)) { + if ($ENV{'TEXLIVE_PREFER_OWN'}) { + debug("setup_programs: TEXLIVE_PREFER_OWN is set!\n"); + $tlfirst = 1; + } + } + + debug("setup_programs: preferring " . ($tlfirst ? "TL" : "system") . " versions\n"); + + my $isWin = ($^O =~ /^MSWin/i); + + if ($isWin) { + # we need to make sure that we use our own tar, since + # Windows system tar is stupid bsdtar ... + setup_one("w32", 'tar', "$bindir/tar.exe", "--version", 1); + $platform = "exe"; + } else { + # tar needs to be provided by the system, we not even check! + $::progs{'tar'} = "tar"; + + if (!defined($platform) || ($platform eq "")) { + # we assume that we run from uncompressed media, so we can call + # platform() and thus also the config.guess script but we have to + # setup $::installerdir because the platform script relies on it + $::installerdir = "$bindir/../.."; + $platform = platform(); + } + } + + # setup of the fallback downloaders + my @working_downloaders; + for my $dltype (@AcceptedFallbackDownloaders) { + my $defprog = $FallbackDownloaderProgram{$dltype}; + # do not warn on errors + push @working_downloaders, $dltype if + setup_one(($isWin ? "w32" : "unix"), $defprog, + "$bindir/$dltype/$defprog.$platform", "--version", $tlfirst); + } + $::progs{'working_downloaders'} = [ @working_downloaders ]; + my @working_compressors; + for my $defprog (sort + { $Compressors{$a}{'priority'} <=> $Compressors{$b}{'priority'} } + keys %Compressors) { + # do not warn on errors + if (setup_one(($isWin ? "w32" : "unix"), $defprog, + "$bindir/$defprog/$defprog.$platform", "--version", + $tlfirst)) { + push @working_compressors, $defprog; + # also set up $::{'compressor'} if not already done + # this selects the first one, but we might reset this depending on + # TEXLIVE_COMPRESSOR setting, see below + defined($::progs{'compressor'}) || ($::progs{'compressor'} = $defprog); + } + } + $::progs{'working_compressors'} = [ @working_compressors ]; + + # check whether selected downloader/compressor is working + # for downloader we allow 'lwp' as setting, too + if ($ENV{'TEXLIVE_DOWNLOADER'} + && $ENV{'TEXLIVE_DOWNLOADER'} ne 'lwp' + && !TeXLive::TLUtils::member($ENV{'TEXLIVE_DOWNLOADER'}, + @{$::progs{'working_downloaders'}})) { + tlwarn(<<END_DOWNLOADER_BAD); +Selected download program TEXLIVE_DOWNLOADER=$ENV{'TEXLIVE_DOWNLOADER'} +is not working! +Please choose a different downloader or don't set TEXLIVE_DOWNLOADER. +Detected working downloaders: @{$::progs{'working_downloaders'}}. +END_DOWNLOADER_BAD + $ok = 0; + } + if ($ENV{'TEXLIVE_COMPRESSOR'} + && !TeXLive::TLUtils::member($ENV{'TEXLIVE_COMPRESSOR'}, + @{$::progs{'working_compressors'}})) { + tlwarn(<<END_COMPRESSOR_BAD); +Selected compression program TEXLIVE_COMPRESSOR=$ENV{'TEXLIVE_COMPRESSOR'} +is not working! +Please choose a different compressor or don't set TEXLIVE_COMPRESSOR. +Detected working compressors: @{$::progs{'working_compressors'}}. +END_COMPRESSOR_BAD + $ok = 0; + } + # setup default compressor $::progs{'compressor'} which is used in + # tlmgr in the calls to make_container. By default we have already + # chosen the first that is actually working from our list of + # @AcceptableCompressors, but let the user override this. + if ($ENV{'TEXLIVE_COMPRESSOR'}) { + $::progs{'compressor'} = $ENV{'TEXLIVE_COMPRESSOR'}; + } + + if ($::opt_verbosity >= 1) { + require Data::Dumper; + use vars qw($Data::Dumper::Indent $Data::Dumper::Sortkeys + $Data::Dumper::Purity); # -w pain + $Data::Dumper::Indent = 1; + $Data::Dumper::Sortkeys = 1; # stable output + $Data::Dumper::Purity = 1; # recursive structures must be safe + print STDERR "DD:dumping "; + print STDERR Data::Dumper->Dump([\%::progs], [qw(::progs)]); + } + return $ok; +} + +sub setup_one { + my ($what, $p, $def, $arg, $tlfirst) = @_; + my $setupfunc = ($what eq "unix") ? \&setup_unix_tl_one : \&setup_windows_tl_one ; + if ($tlfirst) { + if (&$setupfunc($p, $def, $arg)) { + return(1); + } else { + return(setup_system_one($p, $arg)); + } + } else { + if (setup_system_one($p, $arg)) { + return(1); + } else { + return(&$setupfunc($p, $def, $arg)); + } + } +} + +sub setup_system_one { + my ($p, $arg) = @_; + my $nulldev = nulldev(); + debug("trying to set up system $p, arg $arg\n"); + my $ret = system("$p $arg >$nulldev 2>&1"); + if ($ret == 0) { + debug("program $p found in the path\n"); + $::progs{$p} = $p; + return(1); + } else { + debug("program $p not usable from path\n"); + return(0); + } +} + +sub setup_windows_tl_one { + my ($p, $def, $arg) = @_; + debug("(w32) trying to set up $p, default $def, arg $arg\n"); + + if (-r $def) { + my $prog = conv_to_w32_path($def); + my $ret = system("$prog $arg >nul 2>&1"); # on windows + if ($ret == 0) { + debug("Using shipped $def for $p (tested).\n"); + $::progs{$p} = $prog; + return(1); + } else { + tlwarn("Setting up $p with $def as $prog didn't work\n"); + system("$prog $arg"); + return(0); + } + } else { + debug("Default program $def not readable?\n"); + return(0); + } +} + + +# setup one prog on unix using the following logic: +# - if the shipped one is -x and can be executed, use it +# - if the shipped one is -x but cannot be executed, copy it. set -x +# . if the copy is -x and executable, use it +# - if the shipped one is not -x, copy it, set -x +# . if the copy is -x and executable, use it +sub setup_unix_tl_one { + my ($p, $def, $arg) = @_; + our $tmp; + debug("(unix) trying to set up $p, default $def, arg $arg\n"); + if (-r $def) { + if (-x $def) { + ddebug("default $def has executable permissions\n"); + # we have to check for actual "executability" since a "noexec" + # mount option may interfere, which is not taken into account by -x. + my $ret = system("'$def' $arg >/dev/null 2>&1" ); # we are on Unix + if ($ret == 0) { + $::progs{$p} = $def; + debug("Using shipped $def for $p (tested).\n"); + return(1); + } else { + ddebug("Shipped $def has -x but cannot be executed, " + . "trying tmp copy.\n"); + } + } + # we are still here + # out of some reasons we couldn't execute the shipped program + # try to copy it to a temp directory and make it executable + # + # create tmp dir only when necessary + $tmp = TeXLive::TLUtils::tl_tmpdir() unless defined($tmp); + # probably we are running from uncompressed media and want to copy it to + # some temporary location + copy($def, $tmp); + my $bn = basename($def); + my $tmpprog = "$tmp/$bn"; + chmod(0755,$tmpprog); + # we do not check the return value of chmod, but check whether + # the -x bit is now set, the only thing that counts + if (! -x $tmpprog) { + # hmm, something is going really bad, not even the copy is + # executable. Fall back to normal path element + ddebug("Copied $p $tmpprog does not have -x bit, strange!\n"); + return(0); + } else { + # check again for executability + my $ret = system("$tmpprog $arg > /dev/null 2>&1"); + if ($ret == 0) { + # ok, the copy works + debug("Using copied $tmpprog for $p (tested).\n"); + $::progs{$p} = $tmpprog; + return(1); + } else { + # even the copied prog is not executable, strange + ddebug("Copied $p $tmpprog has x bit but not executable?!\n"); + return(0); + } + } + } else { + # default program is not readable + return(0); + } +} + + +=item C<download_file( $relpath, $destination )> + +Try to download the file given in C<$relpath> from C<$TeXLiveURL> +into C<$destination>, which can be either +a filename of simply C<|>. In the latter case a file handle is returned. + +Downloading first checks for the environment variable C<TEXLIVE_DOWNLOADER>, +which takes various built-in values. If not set, the next check is for +C<TL_DOWNLOAD_PROGRAM> and C<TL_DOWNLOAD_ARGS>. The former overrides the +above specification devolving to C<wget>, and the latter overrides the +default wget arguments. + +C<TL_DOWNLOAD_ARGS> must be defined so that the file the output goes to +is the first argument after the C<TL_DOWNLOAD_ARGS>. Thus, for wget it +would end in C<-O>. Use with care. + +=cut + +sub download_file { + my ($relpath, $dest) = @_; + # create output dir if necessary + my $par; + if ($dest ne "|") { + $par = dirname($dest); + mkdirhier ($par) unless -d "$par"; + } + my $url; + if ($relpath =~ m;^file://*(.*)$;) { + my $filetoopen = "/$1"; + # $dest is a file name, we have to get the respective dirname + if ($dest eq "|") { + open(RETFH, "<$filetoopen") or + die("Cannot open $filetoopen for reading"); + # opening to a pipe always succeeds, so we return immediately + return \*RETFH; + } else { + if (-r $filetoopen) { + copy ($filetoopen, $par); + return 1; + } + return 0; + } + } + + if ($relpath =~ m!$SshURIRegex!) { + my $downdest; + if ($dest eq "|") { + my ($fh, $fn) = TeXLive::TLUtils::tl_tmpfile(); + $downdest = $fn; + } else { + $downdest = $dest; + } + # massage ssh:// into the scp-acceptable scp:// + $relpath =~ s!^ssh://!scp://!; + my $retval = system("scp", "-q", $relpath, $downdest); + if ($retval != 0) { + $retval /= 256 if $retval > 0; + my $pwd = cwd (); + tlwarn("$0: system(scp -q $relpath $downdest) failed in $pwd, status $retval"); + return 0; + } + if ($dest eq "|") { + open(RETFH, "<$downdest") or + die("Cannot open $downdest for reading"); + # opening to a pipe always succeeds, so we return immediately + return \*RETFH; + } else { + return 1; + } + } + + if ($relpath =~ /^(https?|ftp):\/\//) { + $url = $relpath; + } else { + $url = "$TeXLiveURL/$relpath"; + } + + my @downloader_trials; + if ($ENV{'TEXLIVE_DOWNLOADER'}) { + push @downloader_trials, $ENV{'TEXLIVE_DOWNLOADER'}; + } elsif ($ENV{"TL_DOWNLOAD_PROGRAM"}) { + push @downloader_trials, 'custom'; + } else { + @downloader_trials = qw/lwp curl wget/; + } + + my $success = 0; + for my $downtype (@downloader_trials) { + if ($downtype eq 'lwp') { + if (_download_file_lwp($url, $dest)) { + $success = $downtype; + last; + } + } + if ($downtype eq "custom" || TeXLive::TLUtils::member($downtype, @{$::progs{'working_downloaders'}})) { + if (_download_file_program($url, $dest, $downtype)) { + $success = $downtype; + last; + } + } + } + if ($success) { + debug("TLUtils::download_file: downloading using $success succeeded\n"); + return(1); + } else { + debug("TLUtils::download_file: tried to download using @downloader_trials, none succeeded\n"); + return(0); + } +} + +sub _download_file_lwp { + my ($url, $dest) = @_; + if (defined($::tldownload_server) && $::tldownload_server->enabled) { + debug("persistent connection set up, trying to get $url (for $dest)\n"); + my $ret = $::tldownload_server->get_file($url, $dest); + if ($ret) { + ddebug("downloading file via persistent connection succeeded\n"); + return $ret; + } else { + debug("TLUtils::download_file: persistent connection ok," + . " but download failed: $url\n"); + debug("TLUtils::download_file: retrying with wget.\n"); + } + } else { + if (!defined($::tldownload_server)) { + ddebug("::tldownload_server not defined\n"); + } else { + ddebug("::tldownload_server->enabled is not set\n"); + } + debug("persistent connection not set up\n"); + } + # if we are still here, download with LWP didn't succeed. + return(0); +} + +sub _download_file_program { + my ($url, $dest, $type) = @_; + if (win32()) { + $dest =~ s!/!\\!g; + } + + debug("TLUtils::_download_file_program: $type $url $dest\n"); + my $downloader; + my $downloaderargs; + my @downloaderargs; + if ($type eq 'custom') { + $downloader = $ENV{"TL_DOWNLOAD_PROGRAM"}; + if ($ENV{"TL_DOWNLOAD_ARGS"}) { + $downloaderargs = $ENV{"TL_DOWNLOAD_ARGS"}; + @downloaderargs = split(' ', $downloaderargs); + } + } else { + $downloader = $::progs{$FallbackDownloaderProgram{$type}}; + @downloaderargs = @{$FallbackDownloaderArgs{$type}}; + $downloaderargs = join(' ',@downloaderargs); + } + + debug("downloading $url using $downloader $downloaderargs\n"); + my $ret; + if ($dest eq "|") { + open(RETFH, "$downloader $downloaderargs - $url|") + || die "open($url) via $downloader $downloaderargs failed: $!"; + # opening to a pipe always succeeds, so we return immediately + return \*RETFH; + } else { + $ret = system ($downloader, @downloaderargs, $dest, $url); + # we have to reverse the meaning of ret because system has 0=success. + $ret = ($ret ? 0 : 1); + } + # return false/undef in case the download did not succeed. + return ($ret) unless $ret; + debug("download of $url succeeded\n"); + if ($dest eq "|") { + return \*RETFH; + } else { + return 1; + } +} + +=item C<nulldev ()> + +Return C</dev/null> on Unix and C<nul> on Windows. + +=cut + +sub nulldev { + return (&win32)? 'nul' : '/dev/null'; +} + +=item C<get_full_line ($fh)> + +returns the next line from the file handle $fh, taking +continuation lines into account (last character of a line is \, and +no quoting is parsed). + +=cut + +# open my $f, '<', $file_name or die; +# while (my $l = get_full_line($f)) { ... } +# close $f or die; +sub get_full_line { + my ($fh) = @_; + my $line = <$fh>; + return undef unless defined $line; + return $line unless $line =~ s/\\\r?\n$//; + my $cont = get_full_line($fh); + if (!defined($cont)) { + tlwarn('Continuation disallowed at end of file'); + $cont = ""; + } + $cont =~ s/^\s*//; + return $line . $cont; +} + + +=back + +=head2 Installer Functions + +=over 4 + +=item C<make_var_skeleton($prefix)> + +Generate a skeleton of empty directories in the C<TEXMFSYSVAR> tree. + +=cut + +sub make_var_skeleton { + my ($prefix) = @_; + + mkdirhier "$prefix/tex/generic/config"; + mkdirhier "$prefix/fonts/map/dvipdfmx/updmap"; + mkdirhier "$prefix/fonts/map/dvips/updmap"; + mkdirhier "$prefix/fonts/map/pdftex/updmap"; + mkdirhier "$prefix/fonts/pk"; + mkdirhier "$prefix/fonts/tfm"; + mkdirhier "$prefix/web2c"; + mkdirhier "$prefix/xdvi"; + mkdirhier "$prefix/tex/context/config"; +} + + +=item C<make_local_skeleton($prefix)> + +Generate a skeleton of empty directories in the C<TEXMFLOCAL> tree, +unless C<TEXMFLOCAL> already exists. + +=cut + +sub make_local_skeleton { + my ($prefix) = @_; + + return if (-d $prefix); + + mkdirhier "$prefix/bibtex/bib/local"; + mkdirhier "$prefix/bibtex/bst/local"; + mkdirhier "$prefix/doc/local"; + mkdirhier "$prefix/dvips/local"; + mkdirhier "$prefix/fonts/source/local"; + mkdirhier "$prefix/fonts/tfm/local"; + mkdirhier "$prefix/fonts/type1/local"; + mkdirhier "$prefix/fonts/vf/local"; + mkdirhier "$prefix/metapost/local"; + mkdirhier "$prefix/tex/latex/local"; + mkdirhier "$prefix/tex/plain/local"; + mkdirhier "$prefix/tlpkg"; + mkdirhier "$prefix/web2c"; +} + + +=item C<create_fmtutil($tlpdb, $dest)> + +=item C<create_updmap($tlpdb, $dest)> + +=item C<create_language_dat($tlpdb, $dest, $localconf)> + +=item C<create_language_def($tlpdb, $dest, $localconf)> + +=item C<create_language_lua($tlpdb, $dest, $localconf)> + +These five functions create C<fmtutil.cnf>, C<updmap.cfg>, C<language.dat>, +C<language.def>, and C<language.dat.lua> respectively, in C<$dest> (which by +default is below C<$TEXMFSYSVAR>). These functions merge the information +present in the TLPDB C<$tlpdb> (formats, maps, hyphenations) with local +configuration additions: C<$localconf>. + +Currently the merging is done by omitting disabled entries specified +in the local file, and then appending the content of the local +configuration files at the end of the file. We should also check for +duplicates, maybe even error checking. + +=cut + +# +# get_disabled_local_configs +# returns the list of disabled formats/hyphenpatterns/maps +# disabling is done by putting +# #!NAME +# or +# %!NAME +# into the respective foo-local.cnf/cfg file +# +sub get_disabled_local_configs { + my $localconf = shift; + my $cc = shift; + my @disabled = (); + if ($localconf && -r $localconf) { + open (FOO, "<$localconf") + || die "strange, -r ok but open($localconf) failed: $!"; + my @tmp = <FOO>; + close(FOO) || warn("close($localconf) failed: $!"); + @disabled = map { if (m/^$cc!(\S+)\s*$/) { $1 } else { } } @tmp; + } + return @disabled; +} + +sub create_fmtutil { + my ($tlpdb,$dest) = @_; + my @lines = $tlpdb->fmtutil_cnf_lines(); + _create_config_files($tlpdb, "texmf-dist/web2c/fmtutil-hdr.cnf", $dest, + undef, 0, '#', \@lines); +} + +sub create_updmap { + my ($tlpdb,$dest) = @_; + check_for_old_updmap_cfg(); + my @tlpdblines = $tlpdb->updmap_cfg_lines(); + _create_config_files($tlpdb, "texmf-dist/web2c/updmap-hdr.cfg", $dest, + undef, 0, '#', \@tlpdblines); +} + +sub check_for_old_updmap_cfg { + chomp( my $tmfsysconf = `kpsewhich -var-value=TEXMFSYSCONFIG` ) ; + my $oldupd = "$tmfsysconf/web2c/updmap.cfg"; + return unless -r $oldupd; # if no such file, good. + + open (OLDUPD, "<$oldupd") || die "open($oldupd) failed: $!"; + my $firstline = <OLDUPD>; + close(OLDUPD); + # cygwin returns undef when reading from an empty file, we have + # to make sure that this is anyway initialized + $firstline = "" if (!defined($firstline)); + chomp ($firstline); + # + if ($firstline =~ m/^# Generated by (install-tl|.*\/tlmgr) on/) { + # assume it was our doing, rename it. + my $nn = "$oldupd.DISABLED"; + if (-r $nn) { + my $fh; + ($fh, $nn) = tl_tmpfile( + "updmap.cfg.DISABLED.XXXXXX", DIR => "$tmfsysconf/web2c"); + } + print "Renaming old config file from + $oldupd +to + $nn +"; + if (rename($oldupd, $nn)) { + if (system("mktexlsr", $tmfsysconf) != 0) { + die "mktexlsr $tmfsysconf failed after updmap.cfg rename, fix fix: $!"; + } + print "No further action should be necessary.\n"; + } else { + print STDERR " +Renaming of + $oldupd +did not succeed. This config file should not be used anymore, +so please do what's necessary to eliminate it. +See the documentation for updmap. +"; + } + + } else { # first line did not match + # that is NOT a good idea, because updmap creates updmap.cfg in + # TEXMFSYSCONFIG when called with --enable Map etc, so we should + # NOT warn here + # print STDERR "Apparently +# $oldupd +# was created by hand. This config file should not be used anymore, +# so please do what's necessary to eliminate it. +# See the documentation for updmap. +# "; + } +} + +sub check_updmap_config_value { + my ($k, $v, $f) = @_; + return 0 if !defined($k); + return 0 if !defined($v); + if (member( $k, qw/dvipsPreferOutline dvipsDownloadBase35 + pdftexDownloadBase14 dvipdfmDownloadBase14/)) { + if ($v eq "true" || $v eq "false") { + return 1; + } else { + tlwarn("Unknown setting for $k in $f: $v\n"); + return 0; + } + } elsif ($k eq "LW35") { + if (member($v, qw/URW URWkb ADOBE ADOBEkb/)) { + return 1; + } else { + tlwarn("Unknown setting for LW35 in $f: $v\n"); + return 0; + } + } elsif ($k eq "kanjiEmbed") { + # any string is fine + return 1; + } else { + return 0; + } +} + +sub create_language_dat { + my ($tlpdb,$dest,$localconf) = @_; + # no checking for disabled stuff for language.dat and .def + my @lines = $tlpdb->language_dat_lines( + get_disabled_local_configs($localconf, '%')); + _create_config_files($tlpdb, "texmf-dist/tex/generic/config/language.us", + $dest, $localconf, 0, '%', \@lines); +} + +sub create_language_def { + my ($tlpdb,$dest,$localconf) = @_; + # no checking for disabled stuff for language.dat and .def + my @lines = $tlpdb->language_def_lines( + get_disabled_local_configs($localconf, '%')); + my @postlines; + push @postlines, "%%% No changes may be made beyond this point.\n"; + push @postlines, "\n"; + push @postlines, "\\uselanguage {USenglish} %%% This MUST be the last line of the file.\n"; + _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.def", + $dest, $localconf, 1, '%', \@lines, @postlines); +} + +sub create_language_lua { + my ($tlpdb,$dest,$localconf) = @_; + # no checking for disabled stuff for language.dat and .lua + my @lines = $tlpdb->language_lua_lines( + get_disabled_local_configs($localconf, '--')); + my @postlines = ("}\n"); + _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.lua", + $dest, $localconf, 0, '--', \@lines, @postlines); +} + +sub _create_config_files { + my ($tlpdb, $headfile, $dest,$localconf, $keepfirstline, $cc, + $tlpdblinesref, @postlines) = @_; + my $root = $tlpdb->root; + my @lines = (); + my $usermode = $tlpdb->setting( "usertree" ); + if (-r "$root/$headfile") { + open (INFILE, "<$root/$headfile") + || die "open($root/$headfile) failed, but -r ok: $!"; + @lines = <INFILE>; + close (INFILE); + } elsif (!$usermode) { + # we might be in user mode and then do *not* want the generation + # of the configuration file to just bail out. + tldie ("TLUtils::_create_config_files: giving up, unreadable: " + . "$root/$headfile\n") + } + push @lines, @$tlpdblinesref; + if (defined($localconf) && -r $localconf) { + # + # this should be done more intelligently, but for now only add those + # lines without any duplication check ... + open (FOO, "<$localconf") + || die "strange, -r ok but cannot open $localconf: $!"; + my @tmp = <FOO>; + close (FOO); + push @lines, @tmp; + } + if (@postlines) { + push @lines, @postlines; + } + if ($usermode && -e $dest) { + tlwarn("Updating $dest, backup copy in $dest.backup\n"); + File::Copy::copy($dest, "$dest.backup"); + } + open(OUTFILE,">$dest") + or die("Cannot open $dest for writing: $!"); + + if (!$keepfirstline) { + print OUTFILE $cc; + printf OUTFILE " Generated by %s on %s\n", "$0", scalar localtime; + } + print OUTFILE @lines; + close(OUTFILE) || warn "close(>$dest) failed: $!"; +} + +sub parse_AddHyphen_line { + my $line = shift; + my %ret; + # default values + my $default_lefthyphenmin = 2; + my $default_righthyphenmin = 3; + $ret{"lefthyphenmin"} = $default_lefthyphenmin; + $ret{"righthyphenmin"} = $default_righthyphenmin; + $ret{"synonyms"} = []; + for my $p (quotewords('\s+', 0, "$line")) { + my ($a, $b) = split /=/, $p; + if ($a eq "name") { + if (!$b) { + $ret{"error"} = "AddHyphen line needs name=something"; + return %ret; + } + $ret{"name"} = $b; + next; + } + if ($a eq "lefthyphenmin") { + $ret{"lefthyphenmin"} = ( $b ? $b : $default_lefthyphenmin ); + next; + } + if ($a eq "righthyphenmin") { + $ret{"righthyphenmin"} = ( $b ? $b : $default_righthyphenmin ); + next; + } + if ($a eq "file") { + if (!$b) { + $ret{"error"} = "AddHyphen line needs file=something"; + return %ret; + } + $ret{"file"} = $b; + next; + } + if ($a eq "file_patterns") { + $ret{"file_patterns"} = $b; + next; + } + if ($a eq "file_exceptions") { + $ret{"file_exceptions"} = $b; + next; + } + if ($a eq "luaspecial") { + $ret{"luaspecial"} = $b; + next; + } + if ($a eq "databases") { + @{$ret{"databases"}} = split /,/, $b; + next; + } + if ($a eq "synonyms") { + @{$ret{"synonyms"}} = split /,/, $b; + next; + } + if ($a eq "comment") { + $ret{"comment"} = $b; + next; + } + # should not be reached at all + $ret{"error"} = "Unknown language directive $a"; + return %ret; + } + # this default value couldn't be set earlier + if (not defined($ret{"databases"})) { + if (defined $ret{"file_patterns"} or defined $ret{"file_exceptions"} + or defined $ret{"luaspecial"}) { + @{$ret{"databases"}} = qw(dat def lua); + } else { + @{$ret{"databases"}} = qw(dat def); + } + } + return %ret; +} + +# +# return hash of items on AddFormat line LINE (which must not have the +# leading "execute AddFormat"). If parse fails, hash will contain a key +# "error" with a message. +# +sub parse_AddFormat_line { + my $line = shift; + my %ret; + $ret{"options"} = ""; + $ret{"patterns"} = "-"; + $ret{"mode"} = 1; + for my $p (quotewords('\s+', 0, "$line")) { + my ($a, $b); + if ($p =~ m/^(name|engine|mode|patterns|options|fmttriggers)=(.*)$/) { + $a = $1; + $b = $2; + } else { + $ret{"error"} = "Unknown format directive $p"; + return %ret; + } + if ($a eq "name") { + if (!$b) { + $ret{"error"} = "AddFormat line needs name=something"; + return %ret; + } + $ret{"name"} = $b; + next; + } + if ($a eq "engine") { + if (!$b) { + $ret{"error"} = "AddFormat line needs engine=something"; + return %ret; + } + $ret{"engine"} = $b; + next; + } + if ($a eq "patterns") { + $ret{"patterns"} = ( $b ? $b : "-" ); + next; + } + if ($a eq "mode") { + $ret{"mode"} = ( $b eq "disabled" ? 0 : 1 ); + next; + } + if ($a eq "options") { + $ret{"options"} = ( $b ? $b : "" ); + next; + } + if ($a eq "fmttriggers") { + my @tl = split(',',$b); + $ret{"fmttriggers"} = \@tl ; + next; + } + # should not be reached at all + $ret{"error"} = "Unknown format directive $p"; + return %ret; + } + return %ret; +} + + +=back + +=head2 Miscellaneous + +Ideas from Fabrice Popineau's C<FileUtils.pm>. + +=over 4 + +=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. + +=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; +} + + +=item C<push_uniq(\@list, @new_items)> + +The C<push_uniq> function pushes the last argument @ITEMS to the $LIST +referenced by the first argument, if they are not already in the list. + +=cut + +sub push_uniq { + my ($l, @new_items) = @_; + for my $e (@new_items) { + if (! &member($e, @$l)) { + push (@$l, $e); + } + } +} + +=item C<member($item, @list)> + +The C<member> function returns true if the first argument +is also inclued in the list of the remaining arguments. + +=cut + +sub member { + my $what = shift; + return scalar grep($_ eq $what, @_); +} + + +=item C<merge_into(\%to, \%from)> + +Merges the keys of %from into %to. + +=cut + +sub merge_into { + my ($to, $from) = @_; + foreach my $k (keys %$from) { + if (defined($to->{$k})) { + push @{$to->{$k}}, @{$from->{$k}}; + } else { + $to->{$k} = [ @{$from->{$k}} ]; + } + } +} + + +=item C<texdir_check($texdir)> + +Test whether installation with TEXDIR set to $texdir would succeed due to +writing permissions. + +Writable or not, we will not allow installation to the root +directory (Unix) or the root of a drive (Windows). + +=cut + +sub texdir_check { + my $texdir = shift; + return 0 unless defined $texdir; + # convert to absolute, for safer parsing. + # The return value may still contain symlinks, + # but no unnecessary terminating '/'. + $texdir = tl_abs_path($texdir); + return 0 unless defined $texdir; + # also reject the root of a drive, + # assuming that only the canonical form of the root ends with / + return 0 if $texdir =~ m!/$!; + # win32: for now, reject the root of a samba share + return 0 if win32() && $texdir =~ m!^//[^/]+/[^/]+$!; + my $texdirparent; + my $texdirpparent; + + return dir_writable($texdir) if (-d $texdir); + ($texdirparent = $texdir) =~ s!/[^/]*$!!; + #print STDERR "Checking $texdirparent".'[/]'."\n"; + return dir_creatable($texdirparent) if -d dir_slash($texdirparent); + # try another level up the tree + ($texdirpparent = $texdirparent) =~ s!/[^/]*$!!; + #print STDERR "Checking $texdirpparent".'[/]'."\n"; + return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent); + return 0; +} + + +# no newlines or spaces are added, multiple args are just concatenated. +# +sub logit { + my ($out, $level, @rest) = @_; + _logit($out, $level, @rest) unless $::opt_quiet; + _logit('file', $level, @rest); +} + +sub _logit { + my ($out, $level, @rest) = @_; + if ($::opt_verbosity >= $level) { + # if $out is a ref/glob to STDOUT or STDERR, print it there + if (ref($out) eq "GLOB") { + print $out @rest; + } else { + # we should log it into the logfile, but that might be not initialized + # so either print it to the filehandle $::LOGFILE, or push it onto + # the to be printed log lines @::LOGLINES + if (defined($::LOGFILE)) { + print $::LOGFILE @rest; + } else { + push (@::LOGLINES, join ("", @rest)); + } + } + } +} + + +=item C<info ($str1, $str2, ...)> + +Write a normal informational message, the concatenation of the argument +strings. The message will be written unless C<-q> was specified. If +the global C<$::machinereadable> is set (the C<--machine-readable> +option to C<tlmgr>), then output is written to stderr, else to stdout. +If the log file (see L<process_logging_options>) is defined, it also +writes there. + +It is best to use this sparingly, mainly to give feedback during lengthy +operations and for final results. + +=cut + +sub info { + my $str = join("", @_); + my $fh = ($::machinereadable ? \*STDERR : \*STDOUT); + logit($fh, 0, $str); + for my $i (@::info_hook) { + &{$i}($str); + } +} + + +=item C<debug ($str1, $str2, ...)> + +Write a debugging message, the concatenation of the argument strings. +The message will be omitted unless C<-v> was specified. If the log +file (see L<process_logging_options>) is defined, it also writes there. + +This first level debugging message reports on the overall flow of +work, but does not include repeated messages about processing of each +package. + +=cut + +sub debug { + my $str = "D:" . join("", @_); + return if ($::opt_verbosity < 1); + logit(\*STDERR, 1, $str); + for my $i (@::debug_hook) { + &{$i}($str); + } +} + + +=item C<ddebug ($str1, $str2, ...)> + +Write a deep debugging message, the concatenation of the argument +strings. The message will be omitted unless C<-v -v> (or higher) was +specified. If the log file (see L<process_logging_options>) is defined, +it also writes there. + +This second level debugging message reports messages about processing +each package, in addition to the first level. + +=cut + +sub ddebug { + my $str = "DD:" . join("", @_); + return if ($::opt_verbosity < 2); + logit(\*STDERR, 2, $str); + for my $i (@::ddebug_hook) { + &{$i}($str); + } +} + +=item C<dddebug ($str1, $str2, ...)> + +Write the deepest debugging message, the concatenation of the argument +strings. The message will be omitted unless C<-v -v -v> was specified. +If the log file (see L<process_logging_options>) is defined, it also +writes there. + +This third level debugging message reports messages about processing +each line of any tlpdb files read, in addition to the first and second +levels. + +=cut + +sub dddebug { + my $str = "DDD:" . join("", @_); + return if ($::opt_verbosity < 3); + logit(\*STDERR, 3, $str); + for my $i (@::dddebug_hook) { + &{$i}($str); + } +} + +=item C<log ($str1, $str2, ...)> + +Write a message to the log file (and nowhere else), the concatenation of +the argument strings. The log file may not ever be defined (e.g., the +C<-logfile> option isn't given), in which case the message will never be +written anywhere. + +=cut + +sub log { + my $savequiet = $::opt_quiet; + $::opt_quiet = 0; + _logit('file', -100, @_); + $::opt_quiet = $savequiet; +} + +=item C<tlwarn ($str1, $str2, ...)> + +Write a warning message, the concatenation of the argument strings. +This always and unconditionally writes the message to standard error; if +the log file (see L<process_logging_options>) is defined, it also writes +there. + +=cut + +sub tlwarn { + my $savequiet = $::opt_quiet; + my $str = join("", @_); + $::opt_quiet = 0; + logit (\*STDERR, -100, $str); + $::opt_quiet = $savequiet; + for my $i (@::warn_hook) { + &{$i}($str); + } +} + +=item C<tldie ($str1, $str2, ...)> + +Uses C<tlwarn> to issue a warning for @_ preceded by a newline, then +exits with exit code 1. + +=cut + +sub tldie { + tlwarn("\n", @_); + if ($::gui_mode) { + Tk::exit(1); + } else { + exit(1); + } +} + +=item C<debug_hash ($label, hash))> + +Write LABEL followed by HASH elements, all on one line, to stderr. +If HASH is a reference, it is followed. + +=cut + +sub debug_hash { + my ($label) = shift; + my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_; + + my $str = "$label: {"; + my @items = (); + for my $key (sort keys %hash) { + my $val = $hash{$key}; + $key =~ s/\n/\\n/g; + $val =~ s/\n/\\n/g; + push (@items, "$key:$val"); + } + $str .= join (",", @items); + $str .= "}"; + + warn "$str\n"; +} + + +=item C<process_logging_options ($texdir)> + +This function handles the common logging options for TeX Live scripts. +It should be called before C<GetOptions> for any program-specific option +handling. For our conventional calling sequence, see (for example) the +L<tlpfiles> script. + +These are the options handled here: + +=over 4 + +=item B<-q> + +Omit normal informational messages. + +=item B<-v> + +Include debugging messages. With one C<-v>, reports overall flow; with +C<-v -v> (or C<-vv>), also reports per-package processing; with C<-v -v +-v> (or C<-vvv>), also reports each line read from any tlpdb files. +Further repeats of C<-v>, as in C<-v -v -v -v>, are accepted but +ignored. C<-vvvv> is an error. + +The idea behind these levels is to be able to specify C<-v> to get an +overall idea of what is going on, but avoid terribly voluminous output +when processing many packages, as we often are. When debugging a +specific problem with a specific package, C<-vv> can help. When +debugging problems with parsing tlpdb files, C<-vvv> gives that too. + +=item B<-logfile> I<file> + +Write all messages (informational, debugging, warnings) to I<file>, in +addition to standard output or standard error. In TeX Live, only the +installer sets a log file by default; none of the other standard TeX +Live scripts use this feature, but you can specify it explicitly. + +=back + +See also the L<info>, L<debug>, L<ddebug>, and L<tlwarn> functions, +which actually write the messages. + +=cut + +sub process_logging_options { + $::opt_verbosity = 0; + $::opt_quiet = 0; + my $opt_logfile; + my $opt_Verbosity = 0; + my $opt_VERBOSITY = 0; + # check all the command line options for occurrences of -q and -v; + # do not report errors. + my $oldconfig = Getopt::Long::Configure(qw(pass_through permute)); + GetOptions("logfile=s" => \$opt_logfile, + "v+" => \$::opt_verbosity, + "vv" => \$opt_Verbosity, + "vvv" => \$opt_VERBOSITY, + "q" => \$::opt_quiet); + Getopt::Long::Configure($oldconfig); + + # verbosity level, forcing -v -v instead of -vv is too annoying. + $::opt_verbosity = 2 if $opt_Verbosity; + $::opt_verbosity = 3 if $opt_VERBOSITY; + + # open log file if one was requested. + if ($opt_logfile) { + open(TLUTILS_LOGFILE, ">$opt_logfile") + || die "open(>$opt_logfile) failed: $!\n"; + $::LOGFILE = \*TLUTILS_LOGFILE; + $::LOGFILENAME = $opt_logfile; + } +} + +=pod + +This function takes a single argument I<path> and returns it with +C<"> chars surrounding it on Unix. On Windows, the C<"> chars are only +added if I<path> contains special characters, since unconditional quoting +leads to errors there. In all cases, any C<"> chars in I<path> itself +are (erroneously) eradicated. + +=cut + +sub quotify_path_with_spaces { + my $p = shift; + my $m = win32() ? '[+=^&();,!%\s]' : '.'; + if ( $p =~ m/$m/ ) { + $p =~ s/"//g; # remove any existing double quotes + $p = "\"$p\""; + } + return($p); +} + +=pod + +This function returns a "Windows-ized" version of its single argument +I<path>, i.e., replaces all forward slashes with backslashes, and adds +an additional C<"> at the beginning and end if I<path> contains any +spaces. It also makes the path absolute. So if $path does not start +with one (arbitrary) characer followed by C<:>, we add the output of +C<`cd`>. + +The result is suitable for running in shell commands, but not file tests +or other manipulations, since in such internal Perl contexts, the quotes +would be considered part of the filename. + +=cut + +sub conv_to_w32_path { + my $p = shift; + # we need absolute paths, too + my $pabs = tl_abs_path($p); + if (not $pabs) { + $pabs = $p; + tlwarn ("sorry, could not determine absolute path of $p!\n". + "using original path instead"); + } + $pabs =~ s!/!\\!g; + $pabs = quotify_path_with_spaces($pabs); + return($pabs); +} + +=pod + +The next two functions are meant for user input/output in installer menus. +They help making the windows user happy by turning slashes into backslashes +before displaying a path, and our code happy by turning backslashes into forwars +slashes after reading a path. They both are no-ops on Unix. + +=cut + +sub native_slashify { + my ($r) = @_; + $r =~ s!/!\\!g if win32(); + return $r; +} + +sub forward_slashify { + my ($r) = @_; + $r =~ s!\\!/!g if win32(); + return $r; +} + +=item C<setup_persistent_downloads()> + +Set up to use persistent connections using LWP/TLDownload, that is look +for a download server. Return the TLDownload object if successful, else +false. + +=cut + +sub setup_persistent_downloads { + if ($TeXLive::TLDownload::net_lib_avail) { + ddebug("setup_persistent_downloads has net_lib_avail set\n"); + $::tldownload_server = TeXLive::TLDownload->new; + if (!defined($::tldownload_server)) { + ddebug("TLUtils:setup_persistent_downloads: failed to get ::tldownload_server\n"); + } else { + ddebug("TLUtils:setup_persistent_downloads: got ::tldownload_server\n"); + } + return $::tldownload_server; + } + return 0; +} + + +=item C<query_ctan_mirror()> + +Return a particular mirror given by the generic CTAN auto-redirecting +default (specified in L<$TLConfig::TexLiveServerURL>) if we get a +response, else the empty string. + +Neither C<TL_DOWNLOAD_PROGRAM> nor <TL_DOWNLOAD_ARGS> is honored (see +L<download_file>), since certain options have to be set to do the job +and the program has to be C<wget> since we parse the output. + +=cut + +sub query_ctan_mirror { + my $wget = $::progs{'wget'}; + if (!defined ($wget)) { + tlwarn("query_ctan_mirror: Programs not set up, trying wget\n"); + $wget = "wget"; + } + + # we need the verbose output, so no -q. + # do not reduce retries here, but timeout still seems desirable. + my $mirror = $TeXLiveServerURL; + my $cmd = "$wget $mirror --timeout=$NetworkTimeout -O " + . (win32() ? "nul" : "/dev/null") . " 2>&1"; + + # + # since we are reading the output of wget to find a mirror + # we have to make sure that the locale is unset + my $saved_lcall; + if (defined($ENV{'LC_ALL'})) { + $saved_lcall = $ENV{'LC_ALL'}; + } + $ENV{'LC_ALL'} = "C"; + # we try 3 times to get a mirror from mirror.ctan.org in case we have + # bad luck with what gets returned. + my $max_trial = 3; + my $mhost; + for (my $i = 1; $i <= $max_trial; $i++) { + my @out = `$cmd`; + # analyze the output for the mirror actually selected. + foreach (@out) { + if (m/^Location: (\S*)\s*.*$/) { + (my $mhost = $1) =~ s,/*$,,; # remove trailing slashes since we add it + return $mhost; + } + } + sleep(1); + } + + # reset LC_ALL to undefined or the previous value + if (defined($saved_lcall)) { + $ENV{'LC_ALL'} = $saved_lcall; + } else { + delete($ENV{'LC_ALL'}); + } + + # we are still here, so three times we didn't get a mirror, give up + # and return undefined + return; +} + +=item C<check_on_working_mirror($mirror)> + +Check if MIRROR is functional. + +=cut + +sub check_on_working_mirror { + my $mirror = shift; + + my $wget = $::progs{'wget'}; + if (!defined ($wget)) { + tlwarn ("check_on_working_mirror: Programs not set up, trying wget\n"); + $wget = "wget"; + } + $wget = quotify_path_with_spaces($wget); + # + # the test is currently not completely correct, because we do not + # use the LWP if it is set up for it, but I am currently too lazy + # to program it, + # so try wget and only check for the return value + # please KEEP the / after $mirror, some ftp mirrors do give back + # an error if the / is missing after ../CTAN/ + my $cmd = "$wget $mirror/ --timeout=$NetworkTimeout -O " + . (win32() ? "nul" : "/dev/null") + . " 2>" . (win32() ? "nul" : "/dev/null"); + my $ret = system($cmd); + # if return value is not zero it is a failure, so switch the meanings + return ($ret ? 0 : 1); +} + +=item C<give_ctan_mirror_base()> + + 1. get a mirror (retries 3 times to contact mirror.ctan.org) + - if no mirror found, use one of the backbone servers + - if it is an http server return it (no test is done) + - if it is a ftp server, continue + 2. if the ftp mirror is good, return it + 3. if the ftp mirror is bad, search for http mirror (5 times) + 4. if http mirror is found, return it (again, no test,) + 5. if no http mirror is found, return one of the backbone servers + +=cut + +sub give_ctan_mirror_base { + # only one backbone has existed for a while (2018). + my @backbone = qw!http://www.ctan.org/tex-archive!; + + # start by selecting a mirror and test its operationality + my $mirror = query_ctan_mirror(); + if (!defined($mirror)) { + # three times calling mirror.ctan.org did not give anything useful, + # return one of the backbone servers + tlwarn("cannot contact mirror.ctan.org, returning a backbone server!\n"); + return $backbone[int(rand($#backbone + 1))]; + } + + if ($mirror =~ m!^https?://!) { # if http mirror, assume good and return. + return $mirror; + } + + # we are still here, so we got a ftp mirror from mirror.ctan.org + if (check_on_working_mirror($mirror)) { + return $mirror; # ftp mirror is working, return. + } + + # we are still here, so the ftp mirror failed, retry and hope for http. + # theory is that if one ftp fails, probably all ftp is broken. + my $max_mirror_trial = 5; + for (my $try = 1; $try <= $max_mirror_trial; $try++) { + my $m = query_ctan_mirror(); + debug("querying mirror, got " . (defined($m) ? $m : "(nothing)") . "\n"); + if (defined($m) && $m =~ m!^https?://!) { + return $m; # got http this time, assume ok. + } + # sleep to make mirror happy, but only if we are not ready to return + sleep(1) if $try < $max_mirror_trial; + } + + # 5 times contacting the mirror service did not return a http server, + # use one of the backbone servers. + debug("no mirror found ... randomly selecting backbone\n"); + return $backbone[int(rand($#backbone + 1))]; +} + + +sub give_ctan_mirror { + return (give_ctan_mirror_base(@_) . "/$TeXLiveServerPath"); +} + +=item C<create_mirror_list()> + +=item C<extract_mirror_entry($listentry)> + +C<create_mirror_list> returns the lists of viable mirrors according to +ctan-mirrors.pl, in a list which also contains continents, and country headers. + +C<extract_mirror_entry> extracts the actual repository data from one +of these entries. + +# KEEP THESE TWO FUNCTIONS IN SYNC!!! + +=cut + +sub create_mirror_list { + our $mirrors; + my @ret = (); + require("installer/ctan-mirrors.pl"); + my @continents = sort keys %$mirrors; + for my $continent (@continents) { + # first push the name of the continent + push @ret, uc($continent); + my @countries = sort keys %{$mirrors->{$continent}}; + for my $country (@countries) { + my @mirrors = sort keys %{$mirrors->{$continent}{$country}}; + my $first = 1; + for my $mirror (@mirrors) { + my $mfull = $mirror; + $mfull =~ s!/$!!; + # do not append the server path part here, but add + # it down there in the extract mirror entry + #$mfull .= "/" . $TeXLive::TLConfig::TeXLiveServerPath; + #if ($first) { + my $country_str = sprintf "%-12s", $country; + push @ret, " $country_str $mfull"; + # $first = 0; + #} else { + # push @ret, " $mfull"; + #} + } + } + } + return @ret; +} + +# extract_mirror_entry is not very intelligent, it assumes that +# the last "word" is the URL +sub extract_mirror_entry { + my $ent = shift; + my @foo = split ' ', $ent; + return $foo[$#foo] . "/" . $TeXLive::TLConfig::TeXLiveServerPath; +} + +=pod + +=item C<< slurp_file($file) >> + +Reads the whole file and returns the content in a scalar. + +=cut + +sub slurp_file { + my $file = shift; + my $file_data = do { + local $/ = undef; + open my $fh, "<", $file || die "open($file) failed: $!"; + <$fh>; + }; + return($file_data); +} + +=pod + +=item C<< download_to_temp_or_file($url) >> + +If C<$url> is a url, tries to download the file into a temporary file. +Otherwise assume that C<$url> is a local file. +In both cases returns the local file. + +Returns the local file name if succeeded, otherwise undef. + +=cut + +sub download_to_temp_or_file { + my $url = shift; + my ($url_fh, $url_file); + if ($url =~ m,^(https?|ftp|file)://, || $url =~ m!$SshURIRegex!) { + ($url_fh, $url_file) = tl_tmpfile(); + # now $url_fh filehandle is open, the file created + # TLUtils::download_file will just overwrite what is there + # on windows that doesn't work, so we close the fh immediately + # this creates a short loophole, but much better than before anyway + close($url_fh); + $ret = download_file($url, $url_file); + } else { + $url_file = $url; + $ret = 1; + } + if ($ret && (-r "$url_file")) { + return $url_file; + } + return; +} + +# compare_tlpobjs +# returns a hash +# $ret{'revision'} = "leftRev:rightRev" if revision differ +# $ret{'removed'} = \[ list of files removed from A to B ] +# $ret{'added'} = \[ list of files added from A to B ] +# +sub compare_tlpobjs { + my ($tlpA, $tlpB) = @_; + my %ret; + my @rem; + my @add; + + my $rA = $tlpA->revision; + my $rB = $tlpB->revision; + if ($rA != $rB) { + $ret{'revision'} = "$rA:$rB"; + } + if ($tlpA->relocated) { + $tlpA->replace_reloc_prefix; + } + if ($tlpB->relocated) { + $tlpB->replace_reloc_prefix; + } + my @fA = $tlpA->all_files; + my @fB = $tlpB->all_files; + my %removed; + my %added; + for my $f (@fA) { $removed{$f} = 1; } + for my $f (@fB) { delete($removed{$f}); $added{$f} = 1; } + for my $f (@fA) { delete($added{$f}); } + @rem = sort keys %removed; + @add = sort keys %added; + $ret{'removed'} = \@rem if @rem; + $ret{'added'} = \@add if @add; + return %ret; +} + +# +# compare_tlpdbs +# return several hashes +# @{$ret{'removed_packages'}} = list of removed packages from A to B +# @{$ret{'added_packages'}} = list of added packages from A to B +# $ret{'different_packages'}->{$package} = output of compare_tlpobjs +# +sub compare_tlpdbs { + my ($tlpdbA, $tlpdbB, @add_ignored_packs) = @_; + my @ignored_packs = qw/00texlive.installer 00texlive.image/; + push @ignored_packs, @add_ignored_packs; + + my @inAnotinB; + my @inBnotinA; + my %diffpacks; + my %do_compare; + my %ret; + + for my $p ($tlpdbA->list_packages()) { + my $is_ignored = 0; + for my $ign (@ignored_packs) { + if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) { + $is_ignored = 1; + last; + } + } + next if $is_ignored; + my $tlpB = $tlpdbB->get_package($p); + if (!defined($tlpB)) { + push @inAnotinB, $p; + } else { + $do_compare{$p} = 1; + } + } + $ret{'removed_packages'} = \@inAnotinB if @inAnotinB; + + for my $p ($tlpdbB->list_packages()) { + my $is_ignored = 0; + for my $ign (@ignored_packs) { + if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) { + $is_ignored = 1; + last; + } + } + next if $is_ignored; + my $tlpA = $tlpdbA->get_package($p); + if (!defined($tlpA)) { + push @inBnotinA, $p; + } else { + $do_compare{$p} = 1; + } + } + $ret{'added_packages'} = \@inBnotinA if @inBnotinA; + + for my $p (sort keys %do_compare) { + my $tlpA = $tlpdbA->get_package($p); + my $tlpB = $tlpdbB->get_package($p); + my %foo = compare_tlpobjs($tlpA, $tlpB); + if (keys %foo) { + # some diffs were found + $diffpacks{$p} = \%foo; + } + } + $ret{'different_packages'} = \%diffpacks if (keys %diffpacks); + + return %ret; +} + +sub tlnet_disabled_packages { + my ($root) = @_; + my $disabled_pkgs = "$root/tlpkg/dev/tlnet-disabled-packages.txt"; + my @ret; + if (-r $disabled_pkgs) { + open (DISABLED, "<$disabled_pkgs") || die "Huu, -r but cannot open: $?"; + while (<DISABLED>) { + chomp; + next if /^\s*#/; + next if /^\s*$/; + $_ =~ s/^\s*//; + $_ =~ s/\s*$//; + push @ret, $_; + } + close(DISABLED) || warn ("Cannot close tlnet-disabled-packages.txt: $?"); + } + return @ret; +} + +sub report_tlpdb_differences { + my $rret = shift; + my %ret = %$rret; + + if (defined($ret{'removed_packages'})) { + info ("removed packages from A to B:\n"); + for my $f (@{$ret{'removed_packages'}}) { + info (" $f\n"); + } + } + if (defined($ret{'added_packages'})) { + info ("added packages from A to B:\n"); + for my $f (@{$ret{'added_packages'}}) { + info (" $f\n"); + } + } + if (defined($ret{'different_packages'})) { + info ("different packages from A to B:\n"); + for my $p (keys %{$ret{'different_packages'}}) { + info (" $p\n"); + for my $k (keys %{$ret{'different_packages'}->{$p}}) { + if ($k eq "revision") { + info(" revision differ: $ret{'different_packages'}->{$p}->{$k}\n"); + } elsif ($k eq "removed" || $k eq "added") { + info(" $k files:\n"); + for my $f (@{$ret{'different_packages'}->{$p}->{$k}}) { + info(" $f\n"); + } + } else { + info(" unknown differ $k\n"); + } + } + } + } +} + +sub sort_archs ($$) { + my $aa = $_[0]; + my $bb = $_[1]; + $aa =~ s/^(.*)-(.*)$/$2-$1/; + $bb =~ s/^(.*)-(.*)$/$2-$1/; + $aa cmp $bb ; +} + +# Taken from Text::ParseWords +# +sub quotewords { + my($delim, $keep, @lines) = @_; + my($line, @words, @allwords); + + foreach $line (@lines) { + @words = parse_line($delim, $keep, $line); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} + +sub parse_line { + my($delimiter, $keep, $line) = @_; + my($word, @pieces); + + no warnings 'uninitialized'; # we will be testing undef strings + + $line =~ s/\s+$//; # kill trailing whitespace + while (length($line)) { + $line =~ s/^(["']) # a $quote + ((?:\\.|(?!\1)[^\\])*) # and $quoted text + \1 # followed by the same quote + | # --OR-- + ^((?:\\.|[^\\"'])*?) # an $unquoted text + (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["'])) + # plus EOL, delimiter, or quote + //xs or return; # extended layout + my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4); + return() unless( defined($quote) || length($unquoted) || length($delim)); + + if ($keep) { + $quoted = "$quote$quoted$quote"; + } else { + $unquoted =~ s/\\(.)/$1/sg; + if (defined $quote) { + $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); + $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); + } + } + $word .= substr($line, 0, 0); # leave results tainted + $word .= defined $quote ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); + } + } + return(@pieces); +} + +=item C<mktexupd ()> + +Append entries to C<ls-R> files. Usage example: + + my $updLSR=&mktexupd(); + $updLSR->{mustexist}(1); + $updLSR->{add}(file1); + $updLSR->{add}(file2); + $updLSR->{add}(file3); + $updLSR->{exec}(); + +The first line creates a new object. Only one such object should be +created in a program in order to avoid duplicate entries in C<ls-R> files. + +C<add> pushes a filename or a list of filenames to a hash encapsulated +in a closure. Filenames must be specified with the full (absolute) path. +Duplicate entries are ignored. + +C<exec> checks for each component of C<$TEXMFDBS> whether there are files +in the hash which have to be appended to the corresponding C<ls-R> files +and eventually updates the corresponding C<ls-R> files. Files which are +in directories not stated in C<$TEXMFDBS> are silently ignored. + +If the flag C<mustexist> is set, C<exec> aborts with an error message +if a file supposed to be appended to an C<ls-R> file doesn't exist physically +on the file system. This option was added for compatibility with the +C<mktexupd> shell script. This option shouldn't be enabled in scripts, +except for testing, because it degrades performance on non-cached file +systems. + +=cut + +sub mktexupd { + my %files; + my $mustexist=0; + + my $hash={ + "add" => sub { + foreach my $file (@_) { + $file =~ s|\\|/|g; + $files{$file}=1; + } + }, + "reset" => sub { + %files=(); + }, + "mustexist" => sub { + $mustexist=shift; + }, + "exec" => sub { + # check whether files exist + if ($mustexist) { + foreach my $file (keys %files) { + die "mktexupd: exec file does not exist: $file" if (! -f $file); + } + } + my $delim= (&win32)? ';' : ':'; + my $TEXMFDBS; + chomp($TEXMFDBS=`kpsewhich --show-path="ls-R"`); + + my @texmfdbs=split ($delim, "$TEXMFDBS"); + my %dbs; + + foreach my $path (keys %files) { + foreach my $db (@texmfdbs) { + $db=substr($db, -1) if ($db=~m|/$|); # strip leading / + $db = lc($db) if win32(); + $up = (win32() ? lc($path) : $path); + if (substr($up, 0, length("$db/")) eq "$db/") { + # we appended a / because otherwise "texmf" is recognized as a + # substring of "texmf-dist". + my $np = './' . substr($up, length("$db/")); + my ($dir, $file); + $_=$np; + ($dir, $file) = m|(.*)/(.*)|; + $dbs{$db}{$dir}{$file}=1; + } + } + } + foreach my $db (keys %dbs) { + if (! -f "$db" || ! -w "$db/ls-R") { + &mkdirhier ($db); + } + open LSR, ">>$db/ls-R"; + foreach my $dir (keys %{$dbs{$db}}) { + print LSR "\n$dir:\n"; + foreach my $file (keys %{$dbs{$db}{$dir}}) { + print LSR "$file\n"; + } + } + close LSR; + } + } + }; + return $hash; +} + + +=item C<check_sys_user_mode($user,$sys,$tmfc, $tmfsc, $tmfv, $tmfsv)> + +=cut + +sub setup_sys_user_mode { + my ($prg, $optsref, $TEXMFCONFIG, $TEXMFSYSCONFIG, + $TEXMFVAR, $TEXMFSYSVAR) = @_; + + if ($optsref->{'user'} && $optsref->{'sys'}) { + print STDERR "$prg [ERROR]: only one of -sys or -user can be used.\n"; + exit(1); + } + + # check if we are in *hidden* sys mode, in which case we switch + # to sys mode + # Nowdays we use -sys switch instead of simply overriding TEXMFVAR + # and TEXMFCONFIG + # This is used to warn users when they run updmap in usermode the first time. + # But it might happen that this script is called via another wrapper that + # sets TEXMFCONFIG and TEXMFVAR, and does not pass on the -sys option. + # for this case we check whether the SYS and non-SYS variants agree, + # and if, then switch to sys mode (with a warning) + if (($TEXMFSYSCONFIG eq $TEXMFCONFIG) && ($TEXMFSYSVAR eq $TEXMFVAR)) { + if ($optsref->{'user'}) { + print STDERR "$prg [ERROR]: -user mode but path setup is -sys type, bailing out.\n"; + exit(1); + } + if (!$optsref->{'sys'}) { + print STDERR "$prg [WARNING]: hidden sys mode found, switching to sys mode.\n" if (!$optsref->{'quiet'}); + $optsref->{'sys'} = 1; + } + } + + my ($texmfconfig, $texmfvar); + if ($optsref->{'sys'}) { + # we are running as updmap-sys, make sure that the right tree is used + $texmfconfig = $TEXMFSYSCONFIG; + $texmfvar = $TEXMFSYSVAR; + } elsif ($optsref->{'user'}) { + $texmfconfig = $TEXMFCONFIG; + $texmfvar = $TEXMFVAR; + } else { + print STDERR "" . + "$prg [ERROR]: Either -sys or -user mode is required.\n" . + "$prg [ERROR]: In nearly all cases you should use $prg -sys.\n" . + "$prg [ERROR]: For special cases see http://tug.org/texlive/scripts-sys-user.html\n" ; + exit(1); + } + return ($texmfconfig, $texmfvar); +} + +=item C<prepend_own_path()> + +Prepend the location of the TeX Live binaries to the PATH environment +variable. This is used by (e.g.) C<fmtutil>. The location is found by +calling C<Cwd::abs_path> on C<which('kpsewhich')>. We use kpsewhich +because it is known to be a true binary executable; C<$0> could be a +symlink into (say) C<texmf-dist/scripts/>, which is not a useful +directory for PATH. + +=cut + +sub prepend_own_path { + my $bindir = dirname(Cwd::abs_path(which('kpsewhich'))); + if (win32()) { + $bindir =~ s!\\!/!g; + $ENV{'PATH'} = "$bindir;$ENV{PATH}"; + } else { + $ENV{'PATH'} = "$bindir:$ENV{PATH}"; + } +} + + +=item C<repository_to_array($r)> + +Return hash of tags to urls for space-separated list of repositories +passed in C<$r>. If passed undef or empty string, die. + +=cut + +sub repository_to_array { + my $r = shift; + my %r; + if (!$r) { + # either empty string or undef was passed + # before 20181023 we die here, now we return + # an empty array + return %r; + } + #die "internal error, repository_to_array passed nothing (caller=" + # . caller . ")" if (!$r); + my @repos = split (' ', $r); + if ($#repos == 0) { + # only one repo, this is the main one! + $r{'main'} = $repos[0]; + return %r; + } + for my $rr (@repos) { + my $tag; + my $url; + # decode spaces and % in reverse order + $rr =~ s/%20/ /g; + $rr =~ s/%25/%/g; + $tag = $url = $rr; + if ($rr =~ m/^([^#]+)#(.*)$/) { + $tag = $2; + $url = $1; + } + $r{$tag} = $url; + } + return %r; +} + +=item C<encode_json($ref)> + +Returns the JSON representation of the object C<$ref> is pointing at. +This tries to load the C<JSON> Perl module, and uses it if available, +otherwise falls back to module internal conversion. + +The used backend can be selected by setting the environment variable +C<TL_JSONMODE> to either C<json> or C<texlive> (all other values are +ignored). If C<json> is requested and the C<JSON> module cannot be loaded +the program terminates. + +=cut + +my $TLTrueValue = 1; +my $TLFalseValue = 0; +my $TLTrue = \$TLTrueValue; +my $TLFalse = \$TLFalseValue; +bless $TLTrue, 'TLBOOLEAN'; +bless $TLFalse, 'TLBOOLEAN'; + +our $jsonmode = ""; + +=item C<True()> +=item C<False()> + +these two function must be used to get proper JSON C<true> and C<false> +in the output independent of the backend used. + +=cut + +sub True { + ensure_json_available(); + if ($jsonmode eq "json") { + return($JSON::true); + } else { + return($TLTrue); + } +} +sub False { + ensure_json_available(); + if ($jsonmode eq "json") { + return($JSON::false); + } else { + return($TLFalse); + } +} + +sub ensure_json_available { + return if ($jsonmode); + # check the environment for mode to use: + # $ENV{'TL_JSONMODE'} = texlive | json + my $envdefined = 0; + if ($ENV{'TL_JSONMODE'}) { + $envdefined = 1; + if ($ENV{'TL_JSONMODE'} eq "texlive") { + $jsonmode = "texlive"; + debug("texlive json module used!\n"); + return; + } elsif ($ENV{'TL_JSONMODE'} eq "json") { + # nothing to do + } else { + tlwarn("Unsupported mode \'$ENV{TL_JSONMODE}\' set in TL_JSONMODE, ignoring it!"); + $envdefined = 0; + } + } + return if ($jsonmode); # was set to texlive + eval { require JSON; }; + if ($@) { + # that didn't work out, use home-grown json + if ($envdefined) { + # environment asks for JSON but cannot be loaded, die! + tldie("envvar TL_JSONMODE request JSON module but cannot be loaded!\n"); + } + $jsonmode = "texlive"; + debug("texlive json module used!\n"); + } else { + $jsonmode = "json"; + my $json = JSON->new; + debug("JSON " . $json->backend . " used!\n"); + } +} + +sub encode_json { + my $val = shift; + ensure_json_available(); + if ($jsonmode eq "json") { + my $utf8_encoded_json_text = JSON::encode_json($val); + return $utf8_encoded_json_text; + } else { + my $type = ref($val); + if ($type eq "") { + tldie("encode_json: accept only refs: $val"); + } elsif ($type eq 'SCALAR') { + return(scalar_to_json($$val)); + } elsif ($type eq 'ARRAY') { + return(array_to_json($val)); + } elsif ($type eq 'HASH') { + return(hash_to_json($val)); + } elsif ($type eq 'REF') { + return(encode_json($$val)); + } elsif (Scalar::Util::blessed($val)) { + if ($type eq "TLBOOLEAN") { + return($$val ? "true" : "false"); + } else { + tldie("encode_json: unsupported blessed object"); + } + } else { + tldie("encode_json: unsupported format $type"); + } + } +} + +sub scalar_to_json { + sub looks_like_numeric { + # code from JSON/backportPP.pm + my $value = shift; + no warnings 'numeric'; + # detect numbers + # string & "" -> "" + # number & "" -> 0 (with warning) + # nan and inf can detect as numbers, so check with * 0 + return unless length((my $dummy = "") & $value); + return unless 0 + $value eq $value; + return 1 if $value * 0 == 0; + return -1; # inf/nan + } + my $val = shift; + if (defined($val)) { + if (looks_like_numeric($val)) { + return("$val"); + } else { + return(string_to_json($val)); + } + } else { + return("null"); + } +} + +sub string_to_json { + my $val = shift; + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + $val =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; + return("\"$val\""); +} + +sub hash_to_json { + my $hr = shift; + my @retvals; + for my $k (keys(%$hr)) { + my $val = $hr->{$k}; + push @retvals, "\"$k\":" . encode_json(\$val); + } + my $ret = "{" . join(",", @retvals) . "}"; + return($ret); +} + +sub array_to_json { + my $hr = shift; + my $ret = "[" . join(",", map { encode_json(\$_) } @$hr) . "]"; + return($ret); +} + + + +=back +=cut + +1; +__END__ + +=head1 SEE ALSO + +The modules L<TeXLive::TLConfig>, L<TeXLive::TLCrypto>, +L<TeXLive::TLDownload>, L<TeXLive::TLWinGoo>, etc., and the +documentation in the repository: C<Master/tlpkg/doc/>. + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm new file mode 100644 index 0000000000..d39d0b37a4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLWinGoo.pm @@ -0,0 +1,1444 @@ +# $Id: TLWinGoo.pm 47907 2018-06-03 18:09:29Z karl $ +# TeXLive::TLWinGoo.pm - Windows goop. +# Copyright 2008-2018 Siep Kroonenberg, Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +# code for broadcast_env adapted from Win32::Env: +# Copyright 2006 Oleg "Rowaa[SR13]" V. Volkov, all rights reserved. +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. + +package TeXLive::TLWinGoo; + +my $svnrev = '$Revision: 47907 $'; +my $_modulerevision; +if ($svnrev =~ m/: ([0-9]+) /) { + $_modulerevision = $1; +} else { + $_modulerevision = "unknown"; +} +sub module_revision { return $_modulerevision; } + +=pod + +=head1 NAME + +C<TeXLive::TLWinGoo> -- Additional utilities for Windows + +=head2 SYNOPSIS + + use TeXLive::TLWinGoo; + +=head2 DIAGNOSTICS + + TeXLive::TLWinGoo::is_vista; + TeXLive::TLWinGoo::is_seven; + TeXLive::TLWinGoo::is_ten; + TeXLive::TLWinGoo::admin; + TeXLive::TLWinGoo::non_admin; + TeXLive::TLWinGoo::reg_country; + +=head2 ENVIRONMENT AND REGISTRY + + TeXLive::TLWinGoo::expand_string($s); + TeXLive::TLWinGoo::get_system_path; + TeXLive::TLWinGoo::get_user_path; + TeXLive::TLWinGoo::setenv_reg($env_var, $env_data); + TeXLive::TLWinGoo::unsetenv_reg($env_var); + TeXLive::TLWinGoo::adjust_reg_path_for_texlive($action, $texbindir, $mode); + TeXLive::TLWinGoo::add_to_progids($ext, $filetype); + TeXLive::TLWinGoo::remove_from_progids($ext, $filetype); + TeXLive::TLWinGoo::register_extension($mode, $extension, $file_type); + TeXLive::TLWinGoo::unregister_extension($mode, $extension); + TeXLive::TLWinGoo::register_file_type($file_type, $command); + TeXLive::TLWinGoo::unregister_file_type($file_type); + +=head2 ACTIVATING CHANGES IMMEDIATELY + + TeXLive::TLWinGoo::broadcast_env; + TeXLive::TLWinGoo::update_assocs; + +=head2 SHORTCUTS + + TeXLive::TLWinGoo::desktop_path; + TeXLive::TLWinGoo::add_desktop_shortcut($texdir, $name, $icon, + $prog, $args, $batgui); + TeXLive::TLWinGoo::add_menu_shortcut($place, $name, $icon, + $prog, $args, $batgui); + TeXLive::TLWinGoo::remove_desktop_shortcut($name); + TeXLive::TLWinGoo::remove_menu_shortcut($place, $name); + +=head2 UNINSTALLER + + TeXLive::TLWinGoo::create_uninstaller; + TeXLive::TLWinGoo::unregister_uninstaller; + +=head2 ADMIN: MAKE INSTALLATION DIRECTORIES READ-ONLY + + TeXLive::TLWinGoo::maybe_make_ro($dir); + +All exported functions return forward slashes. + +=head2 DESCRIPTION + +=over 4 + +=cut + +BEGIN { + use Exporter; + use vars qw( @ISA @EXPORT $Registry); + @ISA = qw( Exporter ); + @EXPORT = qw( + &is_vista + &is_seven + &is_ten + &admin + &non_admin + ); + @EXPORT_OK = qw( + &admin_again + ®_country + &broadcast_env + &update_assocs + &expand_string + &get_system_path + &get_user_path + &setenv_reg + &unsetenv_reg + &adjust_reg_path_for_texlive + &add_to_progids + &remove_from_progids + ®ister_extension + &unregister_extension + ®ister_file_type + &unregister_file_type + &shell_folder + &desktop_path + &add_desktop_shortcut + &add_menu_shortcut + &remove_desktop_shortcut + &remove_menu_shortcut + &create_uninstaller + &unregister_uninstaller + &maybe_make_ro + &get_system_env + &get_user_env + &is_a_texdir + &tex_dirs_on_path + ); + if ($^O=~/^MSWin/i) { + require Win32; + require Win32::API; + require Win32API::File; + require File::Spec; + require Win32::TieRegistry; + Win32::TieRegistry->import( qw( $Registry + REG_SZ REG_EXPAND_SZ REG_NONE KEY_READ KEY_WRITE KEY_ALL_ACCESS + KEY_ENUMERATE_SUB_KEYS ) ); + $Registry->Delimiter('/'); + $Registry->ArrayValues(0); + $Registry->FixSzNulls(1); + require Win32::OLE::NLS; + require Win32::Shortcut; + Win32::Shortcut->import( qw( SW_SHOWNORMAL SW_SHOWMINNOACTIVE ) ); + require Time::HiRes; + } +} # end BEGIN + +use TeXLive::TLConfig; +use TeXLive::TLUtils; +TeXLive::TLUtils->import( qw( mkdirhier ) ); + +sub reg_debug { + return if ($::opt_verbosity < 1); + my $mess = shift; + my $regerr = Win32API::Registry::regLastError(); + if ($regerr) { + debug("$regerr\n$mess"); + } +} + +my $is_win = ($^O =~ /^MSWin/i); + +# Win32: import some wrappers for API functions +# failed to get Win32::API::More to work with raw API functions; +# for now, use a tiny dll with perl-friendly wrappers + +# import failures return a null result; +# call imported functions only if true/non-null + +my $SendMessage = 0; +my $update_fu = 0; +if ($is_win) { + $SendMessage = new Win32::API('user32', 'SendMessageTimeout', 'LLPPLLP', 'L'); + debug ("Import failure SendMessage\n") unless $SendMessage; + $update_fu = new Win32::API('shell32', 'SHChangeNotify', 'LIPP', 'V'); + debug ("Import failure assoc_notify\n") unless $update_fu; +} + +=pod + +=back + +=head2 DIAGNOSTICS + +=over 4 + +=item C<win_version> + +C<win_version> returns the Windows version number as stored in the +registry: 5.0 for Windows 2000, 5.1 for Windows XP and 6.0 for Vista. + +=cut + +my $windows_version = 0; +my $windows_subversion = 0; + +if ($is_win) { + #my @osver = Win32::GetOSVersion(); # deprecated + #$windows_version = $osver[1]; + #debug "Windows version $osver[0], major version $osver[1]\n"; + my $ver = `ver`; + chomp $ver; + $ver =~ s/^[^0-9]*//; + $ver =~ s/[^0-9.]*$//; + ($windows_version = $ver) =~ s/\..*$//; + ($windows_subversion = $ver) =~ s/^[^\.]*\.//; + $windows_subversion =~ s/\..*$//; +} + +=item C<is_vista> + +C<is_vista> returns 1 if windows version is >= 6.0, otherwise 0. + +=cut + +sub is_vista { return $windows_version >= 6; } + +=item C<is_seven> + +C<is_seven> returns 1 if windows version is >= 6.1, otherwise 0. + +=cut + +sub is_seven { + return (($windows_version == 6 && $windows_subversion >= 1) || + ($windows_version > 6)); +} + +=item C<is_ten> + +C<is_ten> returns 1 if windows version is >= 10.0, otherwise 0. + +=cut + +sub is_ten { return $windows_version >= 10; } + +# permissions with which we try to access the system environment + +my $is_admin = 1; + +if ($is_win) { + $is_admin = 0 unless Win32::IsAdminUser(); +} + +sub KEY_FULL_ACCESS() { + return KEY_WRITE() | KEY_READ(); +} + +sub sys_access_permissions { + return $is_admin ? KEY_FULL_ACCESS() : KEY_READ(); +} + +sub get_system_env { + return $Registry -> Open( + "LMachine/system/currentcontrolset/control/session manager/Environment/", + {Access => sys_access_permissions()}); +} + +sub get_user_env { + return $Registry -> Open("CUser/Environment", {Access => KEY_FULL_ACCESS()}); +} + +=pod + +=item C<admin> + +Returns admin status, admin implying having full read-write access +to the system environment. + +=cut + +# during processing of this source, $is_admin will get its correct value + +sub admin { return $is_admin; } + +=pod + +=item C<non_admin> + +Pretend not to have admin privileges, to enforce a user- rather than +a system install. + +Currently only used for testing. + +=cut + +sub non_admin { + debug("TLWinGoo: switching to user mode\n"); + $is_admin = 0; +} + +# just for testing; doesn't check actual user permissions +sub admin_again { + debug("TLWinGoo: switching to admin mode\n"); + $is_admin = 1; +} + +=pod + +=item C<reg_country> + +Two-letter country code representing the locale of the current user + +=cut + +sub reg_country { + my $value = Win32::OLE::NLS::GetUserDefaultLangID(); + return unless $value; + $value = sprintf ("%04x", $value); + my $lmkey = $Registry -> Open("HKEY_CLASSES_ROOT/MIME/Database/Rfc1766/", + {Access => KEY_READ()}); + return unless $lmkey; + $lm = $lmkey->{"/$value"}; + return unless $lm; + debug("found lang codes value = $value, lm = $lm...\n"); + if ($lm) { + if ($lm =~ m/^zh-(tw|hk)$/i) { + return ("zh", "tw"); + } elsif ($lm =~ m/^zh/) { + # for anything else starting with zh return, that is zh, zh-cn, zh-sg + # and maybe something else + return ("zh", "cn"); + } else { + my $lang = lc(substr $lm, 0, 2); + my $area = lc(substr $lm, 3, 2); + return($lang, $area); + } + } +} + + +=pod + +=back + +=head2 ENVIRONMENT AND REGISTRY + +Most settings can be made for a user and for the system. User +settings override system settings. + +For admin users, the functions below affect both user- and system +settings. For non-admin users, only user settings are changed. + +An exception is the search path: the effective searchpath consists +of the system searchpath in front concatenated with the user +searchpath at the back. + +Note that in a roaming profile network setup, users take only user +settings with them to other systems, not system settings. In this +case, with a TeXLive on the network, a nonadmin install makes the +most sense. + +=over 4 + +=item C<expand_string($s)> + +This function replaces substrings C<%env_var%> with their current +values as environment variable and returns the result. + +=cut + +sub expand_string { + my ($s) = @_; + return Win32::ExpandEnvironmentStrings($s); +} + +my $global_tmp = $is_win ? expand_string(get_system_env()->{'TEMP'}) : "/tmp"; + +sub is_a_texdir { + my $d = shift; + $d =~ s/\\/\//g; + $d = $d . '/' unless $d =~ m!/$!; + # don't consider anything under %systemroot% a texdir + my $sr = uc($ENV{'SystemRoot'}); + $sr =~ s/\\/\//g; + $sr = $sr . '/' unless $sr =~ m!/$!; + return 0 if index($d, $sr)==0; + foreach $p (qw(luatex.exe mktexlsr.exe pdftex.exe tex.exe xetex.exe)) { + return 1 if (-e $d.$p); + } + return 0; +} + +=pod + +=item C<get_system_path> + +Returns unexpanded system path, as stored in the registry, but with +forward slashes. + +=cut + +sub get_system_path { + my $value = get_system_env() -> {'/Path'}; + # Remove terminating zero bytes; there may be several, at least + # under w2k, and the FixSzNulls option only removes one. + $value =~ s/[\s\x00]+$//; + return $value; +} + +=pod + +=item C<get_user_path> + +Returns unexpanded user path, as stored in the registry, but with +forward slashes. The user path often does not exist, and is rarely +expandable. + +=cut + +sub get_user_path { + my $value = get_user_env() -> {'/Path'}; + return "" if not $value; + $value =~ s/[\s\x00]+$//; + return $value; +} + +=pod + +=item C<setenv_reg($env_var, $env_data[, $mode]);> + +Set an environment variable $env_var to $env_data. + +$mode="user": set for current user. $mode="system": set for all +users. Default: both if admin, current user otherwise. + +=cut + +sub setenv_reg { + my $env_var = shift; + my $env_data = shift; + my $mode = @_ ? shift : "default"; + die "setenv_reg: Invalid mode $mode" + if ($mode ne "user" and $mode ne "system" and $mode ne "default"); + die "setenv_reg: mode 'system' only available for admin" + if ($mode eq "system" and !$is_admin); + my $env; + if ($mode ne "system") { + $env = get_user_env(); + $env->ArrayValues(1); + $env->{'/'.$env_var} = + [ $env_data, ($env_data =~ /%/) ? REG_EXPAND_SZ : REG_SZ ]; + } + if ($mode ne "user" and $is_admin) { + $env = get_system_env(); + $env->ArrayValues(1); + $env->{'/'.$env_var} = + [ $env_data, ($env_data =~ /%/) ? REG_EXPAND_SZ : REG_SZ ]; + } +} + +=pod + +=item C<unsetenv_reg($env_var[, $mode]);> + +Unset an environment variable $env_var + +=cut + +sub unsetenv_reg { + my $env_var = shift; + my $env = get_user_env(); + my $mode = @_ ? shift : "default"; + #print "Unsetenv_reg: unset $env_var with mode $mode\n"; + die "unsetenv_reg: Invalid mode $mode" + if ($mode ne "user" and $mode ne "system" and $mode ne "default"); + die "unsetenv_reg: mode 'system' only available for admin" + if ($mode eq "system" and !$is_admin); + delete get_user_env()->{'/'.$env_var} if $mode ne "system"; + delete get_system_env()->{'/'.$env_var} if ($mode ne "user" and $is_admin); +} + +=pod + +=item C<tex_dirs_on_path($path)> + +Returns tex directories found on the search path. +A directory is a TeX directory if it contains tex.exe or +pdftex.exe. + +=cut + +sub tex_dirs_on_path { + my ($path) = @_; + my ($d, $d_exp); + my @texdirs = (); + foreach $d (split (';', $path)) { + $d_exp = expand_string($d); + if (is_a_texdir($d_exp)) { + # tlwarn("Possibly conflicting [pdf]TeX program found at $d_exp\n"); + push(@texdirs, $d_exp); + }; + } + return @texdirs; +} + +=pod + +=item C<adjust_reg_path_for_texlive($action, $tlbindir, $mode)> + +Edit system or user PATH variable in the registry. +Adds or removes (depending on $action) $tlbindir directory +to system or user PATH variable in the registry (depending on $mode). + +=cut + +# short path names should be unique + +sub short_name { + my ($fname) = @_; + return $fname unless $is_win; + # GetShortPathName may return undefined, e.g. if $fname does not exist, + # e.g. because of temporary unavailability of a network- or portable drive, + # which should not be considered a real error + my $shname = Win32::GetShortPathName ($fname); + return (defined $shname) ? $shname : $fname; +} + +sub adjust_reg_path_for_texlive { + my ($action, $tlbindir, $mode) = @_; + die("Unknown path action: $action\n") + if ($action ne 'add') && ($action ne 'remove'); + die("Unknown path mode: $mode\n") + if ($mode ne 'system') && ($mode ne 'user'); + debug("Warning: [pdf]tex program not found in $tlbindir\n") + if (!is_a_texdir($tlbindir)); + my $path = ($mode eq 'system') ? get_system_path() : get_user_path(); + $tlbindir =~ s!/!\\!g; + my $tlbindir_short = uc(short_name($tlbindir)); + my ($d, $d_short, @newpath); + my $tex_dir_conflict = 0; + my @texdirs; + foreach $d (split (';', $path)) { + $d_short = uc(short_name(expand_string($d))); + $d_short =~ s!/!\\!g; + ddebug("adjust_reg: compare $d_short with $tlbindir_short\n"); + if ($d_short ne $tlbindir_short) { + push(@newpath, $d); + if (is_a_texdir($d)) { + $tex_dir_conflict++; + push(@texdirs, $d); + } + } + } + if ($action eq 'add') { + if ($tex_dir_conflict) { + log("Warning: conflicting [pdf]tex program found on the $mode path ", + "in @texdirs; appending $tlbindir to the front of the path.\n"); + unshift(@newpath, $tlbindir); + } else { + push(@newpath, $tlbindir); + } + } + if (@newpath) { + debug("TLWinGoo: adjust_reg_path_for_texlive: calling setenv_reg in $mode\n"); + setenv_reg("Path", join(';', @newpath), $mode); + } else { + debug("TLWinGoo: adjust_reg_path_for_texlive: calling unsetenv_reg in $mode\n"); + unsetenv_reg("Path", $mode); + } + if ( ($action eq 'add') && ($mode eq 'user') ) { + @texdirs = tex_dirs_on_path( get_system_path() ); + return 0 unless (@texdirs); + tlwarn("Warning: conflicting [pdf]tex program found on the system path ", + "in @texdirs; not fixable in user mode.\n"); + return 1; + } + return 0; +} + +### File types ### + +# Refactored from 2010 edition. New functionality: +# add_to_progids for defining alternate filetypes for an extension. +# Their associated programs show up in the `open with' right-click menu. + +### helper subs ### + +# merge recursive hash refs such as occur in the registry + +sub hash_merge { + my $target = shift; # the recursive hash ref to be modified by $mods + my $mods = shift; # the recursive hash ref to be merged into $target + my $k; + foreach $k (keys %$mods) { + if (ref($target->{$k}) eq 'HASH' and ref($mods->{$k}) eq 'HASH') { + hash_merge($target->{$k}, $mods->{$k}); + } else { + $target->{$k} = $mods->{$k}; + reg_debug ("at hash merge\n"); + $target->Flush(); + reg_debug ("at hash merge\n"); + } + } +} + +# prevent catastrophies during testing; not to be used in production code + +sub getans { + my $prompt = shift; + my $ans; + print STDERR "$prompt "; + $ans = <STDIN>; + if ($ans =~ /^y/i) {print STDERR "\n"; return 1;} + die "Aborting as requested"; +} + +# delete a registry key recursively. +# the key parameter should be a string, not a registry object. + +sub reg_delete_recurse { + my $parent = shift; + my $childname = shift; + my $parentpath = $parent->Path; + ddebug("Deleting $parentpath$childname\n"); + my $child; + if ($childname !~ '^/') { # subkey + $child = $parent->Open ($childname, {Access => KEY_FULL_ACCESS()}); + reg_debug ("at open $childname for all access\n"); + return 1 unless defined($child); + foreach my $v (keys %$child) { + if ($v =~ '^/') { # value + delete $child->{$v}; + reg_debug ("at delete $childname/$v\n"); + $child->Flush(); + reg_debug ("at delete $childname/$v\n"); + Time::HiRes::usleep(20000); + } else { # subkey + return 0 unless reg_delete_recurse ($child, $v); + } + } + #delete $child->{'/'}; + } + delete $parent->{$childname}; + reg_debug ("at delete $parentpath$childname\n"); + $parent->Flush(); + reg_debug ("at delete $parentpath$childname\n"); + Time::HiRes::usleep(20000); + return 1; +} + +sub cu_root { + my $k = $Registry -> Open("CUser", { + Access => KEY_FULL_ACCESS(), Delimiter => '/' + }); + reg_debug ("at open HKCU for all access\n"); + die "Cannot open HKCU for writing" unless $k; + return $k; +} + +sub lm_root { + my $k = $Registry -> Open("LMachine", { + Access => ($is_admin ? KEY_FULL_ACCESS() : KEY_READ()), + Delimiter => '/' + }); + reg_debug ("at open HKLM\n"); + die "Cannot open HKLM for ".($is_admin ? "writing" : "reading") + unless $k; + return $k; +} + +sub do_write_regkey { + my $keypath = shift; # modulo cu/lm + my $keyhash = shift; # ref to a possibly nested hash; empty hash allowed + my $remove_cu = shift; + die "No regkey specified" unless $keypath && defined($keyhash); + # for error reporting: + my $hivename = $is_admin ? 'HKLM' : 'HKCU'; + + # split into parent and final subkey + # remove initial slash from parent + # ensure subkey ends with slash + my ($parentpath, $keyname); + if ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) { + ($parentpath, $keyname) = ($1, $2); + $keyname .= '/'; + debug ("key - $hivename - $parentpath - $keyname\n"); + } else { + die "Cannot determine final component of $keypath"; + } + + my $cu_key = cu_root(); + my $lm_key = lm_root(); + # cu_root() and lm_root() already die upon failure + my $parentkey; + + # make sure parent exists + if ($is_admin) { + $parentkey = $lm_key->Open($parentpath); + reg_debug ("at open $parentpath; creating...\n"); + if (!$parentkey) { + # in most cases, this probably shouldn't happen for lm + $parentkey = $lm_key->CreateKey($parentpath); + reg_debug ("at creating $parentpath\n"); + } + } else { + $parentkey = $cu_key->Open($parentpath); + reg_debug ("at open $parentpath; creating...\n"); + if (!$parentkey) { + $parentkey = $cu_key->CreateKey($parentpath); + reg_debug ("at creating $parentpath\n"); + } + } + if (!$parentkey) { + tlwarn "Cannot create parent of $hivename/$keypath\n"; + return 0; + } + + # create or merge key + if ($parentkey->{$keyname}) { + hash_merge($parentkey->{$keyname}, $keyhash); + } else { + $parentkey->{$keyname} = $keyhash; + reg_debug ("at creating $keyname\n"); + } + if (!$parentkey->{$keyname}) { + tlwarn "Failure to create $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$keypath} and $remove_cu) { + # delete possibly conflicting cu key + tlwarn "Failure to delete $hivename/$keypath key\n" unless + reg_delete_recurse ($cu_key->{$parentpath}, $keyname); + } + return 1; +} + +# remove a registry key under HKCU or HKLM, depending on privilege level + +sub do_remove_regkey { + my $keypath = shift; # key or value + my $remove_cu = shift; + my $hivename = $is_admin ? 'HKLM' : 'HKCU'; + + my $parentpath = ""; + my $keyname = ""; + my $valname = ""; + # two successive delimiters: value. + # *? = non-greedy match: want FIRST double delimiter + if ($keypath =~ /^(.*?\/)(\/.*)$/) { + ($parentpath, $valname) = ($1, $2); + $parentpath =~ s!^/!!; # remove leading delimiter + } elsif ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) { + ($parentpath, $keyname) = ($1, $2); + $keyname .= '/'; + } else { + die "Cannot determine final component of $keypath"; + } + + my $cu_key = cu_root(); + my $lm_key = lm_root(); + my ($parentkey, $k, $skv, $d); + if ($is_admin) { + $parentkey = $lm_key->Open($parentpath); + } else { + $parentkey = $cu_key->Open($parentpath); + } + reg_debug ("at opening $parentpath\n"); + if (!$parentkey) { + debug ("$hivename/$parentpath not present or not writable". + " so $keypath not removed\n"); + return 1; + } + if ($keyname) { + #getans("Deleting $parentpath$keyname regkey? "); + reg_delete_recurse($parentkey, $keyname); + if ($parentkey->{$keyname}) { + tlwarn "Failure to delete $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$parentpath}) { + reg_delete_recurse($cu_key->{$parentpath}, $keyname); + if ($cu_key->{$parentpath}->{$keyname}) { + tlwarn "Failure to delete HKCU/$keypath\n"; + return 0; + } + } + } else { + delete $parentkey->{$valname}; + reg_debug ("at deleting $valname\n"); + if ($parentkey->{$valname}) { + tlwarn "Failure to delete $hivename/$keypath\n"; + return 0; + } + if ($is_admin and $cu_key->{$parentpath}) { + delete $cu_key->{$parentpath}->{$valname}; + reg_debug ("at deleting $valname\n"); + if ($cu_key->{$parentpath}->{$valname}) { + tlwarn "Failure to delete HKCU/$keypath\n"; + return 0; + } + } + } + return 1; +} + +############################# +# not overwriting an existing file association + +# read error is sometimes access_denied, +# therefore we ONLY decide that a value does not exist if +# an attempt to read it errors out with file_not_found. + +# windows error codes +my $file_not_found = 2; # ERROR_FILE_NOT_FOUND +my $reg_ok = 0; # ERROR_SUCCESS + +# inaccessible value (note. actual filetypes shound not have spaces) +my $reg_unknown = 'not accessible'; + +# Effective default value of any key under Classes. +# admin: HKLM; user: HKCU or otherwise HKLM +sub current_filetype { + my $extension = shift; + my $filetype; + my $regerror; + + if ($is_admin) { + $regerror = $reg_ok; + $filetype = lm_root()->{"Software/Classes/$extension//"} # REG_SZ + or $regerror = Win32API::Registry::regLastError(); + if ($regerror != $reg_ok and $regerror != $file_not_found) { + return $reg_unknown; + } + } else { + # Mysterious failures on w7_64 => merge HKLM/HKCU info explicitly + # rather than checking HKCR + $regerror = $reg_ok; + $filetype = cu_root()->{"Software/Classes/$extension//"} or + $regerror = Win32API::Registry::regLastError(); + if ($regerror != $reg_ok and $regerror != $file_not_found) { + return $reg_unknown; + } + if (!defined($filetype) or ($filetype eq "")) { + $regerror = $reg_ok; + $filetype = lm_root()->{"Software/Classes/$extension//"} or + $regerror = Win32API::Registry::regLastError(); + if ($regerror != $reg_ok and $regerror != $file_not_found) { + return $reg_unknown; + } + }; + } + $filetype = "" unless defined($filetype); + return $filetype; +} + +### now the exported file type functions ### + +=pod + +=item C<add_to_progids($ext, $filetype)> + +Add $filetype to the list of alternate progids/filetypes of extension $ext. +The associated program shows up in the `open with' right-click menu. + +=cut + +sub add_to_progids { + my $ext = shift; + my $filetype = shift; + #$Registry->ArrayValues(1); + #do_write_regkey("Software/Classes/$ext/OpenWithProgIds/", + # {"/$filetype" => [0, REG_NONE()]}); + #$Registry->ArrayValues(0); + do_write_regkey("Software/Classes/$ext/OpenWithProgIds/", + {"/$filetype" => ""}); +} + +=pod + +=item C<remove_from_progids($ext, $filetype)> + +Remove $filetype from the list of alternate filetypes for $ext + +=cut + +sub remove_from_progids { + my $ext = shift; + my $filetype = shift; + do_remove_regkey("Software/Classes/$ext/OpenWithProgIds//$filetype"); +} + +=pod + +=item C<register_extension($mode, $extension, $file_type)> + +Add registry entry to associate $extension with $file_type. Slashes +are flipped where necessary. + +If $mode is 0, nothing is actually done. + +For $mode 1, the filetype for the extension is preserved, but only +if there is a registry key under Classes for it. For $mode>0, +the new filetype is always added to the openwithprogids list. + +For $mode 2, the filetype is always overwritten. The old filetype +moves to the openwithprogids list if necessary. + +=cut + +sub register_extension { + my $mode = shift; + return 1 if $mode == 0; + my $extension = shift; + # ensure leading dot + $extension = '.'.$extension unless $extension =~ /^\./; + $extension = lc($extension); + my $file_type = shift; + my $regkey; + + my $old_file_type = current_filetype($extension); + if ($old_file_type and $old_file_type ne $reg_unknown) { + if ($is_admin) { + if (not lm_root()->{"Software/Classes/$old_file_type/"}) { + $old_file_type = ""; + } + } else { + if ((not cu_root()->{"Software/Classes/$old_file_type/"}) and + (not lm_root()->{"Software/Classes/$old_file_type/"})) { + $old_file_type = ""; + } + } + } + # admin: whether to remove HKCU entry. admin never _writes_ to HKCU + my $remove_cu = ($mode == 2) && admin(); + + # can do the following safely: + debug ("Adding $file_type to OpenWithProgIds of $extension\n"); + add_to_progids ($extension, $file_type); + + if ($old_file_type and $old_file_type ne $file_type) { + if ($mode == 1) { + debug ("Not overwriting $old_file_type with $file_type for $extension\n"); + } else { # $mode ==2, overwrite + debug("Linking $extension to $file_type\n"); + if ($old_file_type ne $reg_unknown) { + debug ("Moving $old_file_type to OpenWithProgIds\n"); + add_to_progids ($extension, $old_file_type); + } + $regkey = {'/' => $file_type}; + do_write_regkey("Software/Classes/$extension/", $regkey, $remove_cu); + } + } else { + $regkey = {'/' => $file_type}; + do_write_regkey("Software/Classes/$extension/", $regkey, $remove_cu); + } +} + +=pod + +=item C<unregister_extension($mode, $extension, $file_type)> + +Reversal of register_extension. + +=cut + +sub unregister_extension { + # we don't error check; we just do the best we can. + my $mode = shift; + return 1 if $mode == 0; + # mode 1 and 2 treated identically: + # only unregister if the current value is as expected + my $extension = shift; + my $file_type = shift; + $extension = '.'.$extension unless $extension =~ /^\./; + remove_from_progids($extension, $file_type); + my $old_file_type = current_filetype("$extension"); + if ($old_file_type ne $file_type) { + debug("Filetype $extension now $old_file_type; not ours, so not removed\n"); + return 1; + } else { + debug("unregistering extension $extension\n"); + do_remove_regkey("Software/Classes/$extension//"); + } +} + +=pod + +=item C<register_file_type($file_type, $command)> + +Add registry entries to associate $file_type with $command. Slashes +are flipped where necessary. Double quotes should be added by the +caller if necessary. + +=cut + +sub register_file_type { + my $file_type = shift; + my $command = shift; + tlwarn "register_file_type called with empty command\n" unless $command; + $command =~s!/!\\!g; + debug ("Linking $file_type to $command\n"); + my $keyhash = { + "shell/" => { + "open/" => { + "command/" => { + "/" => $command + } + } + } + }; + do_write_regkey("Software/Classes/$file_type", $keyhash); +} + +=pod + +=item C<unregister_file_type($file_type)> + +Reversal of register_file_type. + +=cut + +sub unregister_file_type { + # we don't error check; we just do the best we can. + # All our filetypes start with 'TL.' so we consider them + # our own even if they have been tampered with. + my $file_type = shift; + debug ("unregistering $file_type\n"); + do_remove_regkey("Software/Classes/$file_type/"); +} + +=pod + +=back + +=head2 ACTIVATING CHANGES IMMEDIATELY + +=over 4 + +=item C<broadcast_env> + +Broadcasts system message that enviroment has changed. This only has +an effect on newly-started programs, not on running programs and the +processes they spawn. + +=cut + +sub broadcast_env() { + if ($SendMessage) { + use constant HWND_BROADCAST => 0xffff; + use constant WM_SETTINGCHANGE => 0x001A; + my $result = ""; + my $ans = "12345678"; # room for dword + $result = $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE, + 0, 'Environment', 0, 2000, $ans) if $SendMessage; + debug("Broadcast complete; result: $result.\n"); + } else { + debug("No SendMessage available\n"); + } +} + +=pod + +=item C<update_assocs> + +Notifies the system that filetypes have changed. + +=cut + +sub update_assocs() { + use constant SHCNE_ASSOCCHANGED => 0x8000000; + use constant SHCNF_IDLIST => 0; + if ($update_fu) { + debug("Notifying changes in filetypes...\n"); + $update_fu->Call (SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0); + debug("Done notifying\n"); + } else { + debug("No update_fu\n"); + } +} + +=pod + +=back + +=head2 SHORTCUTS + +=over 4 + +=item C<add_shortcut($dir, $name, $icon, $prog, $args, $batgui)> + +Add a shortcut, with name $name and icon $icon, pointing to +program $prog with parameters $args (a string). Use a non-null +batgui parameter if the shortcut starts a gui program via a +batchfile. Then the inevitable command prompt will be hidden +rightaway, leaving only the gui program visible. + +=item C<add_desktop_shortcut($name, $icon, $prog, $args, $batgui)> + +Add a shortcut on the desktop. + +=item C<add_menu_shortcut($place, $name, $icon, + $prog, $args, $batgui)> + +Add a menu shortcut at place $place, relative to Start/Programs. + +=cut + +sub add_shortcut { + my ($dir, $name, $icon, $prog, $args, $batgui) = @_; + + # make sure $dir exists + if ((not -e $dir) and (not -d $dir)) { + mkdirhier($dir); + } + if (not -d $dir) { + tlwarn ("Failed to create directory $dir for shortcut\n"); + return; + } + # create shortcut + debug "Creating shortcut $name for $prog in $dir\n"; + my ($shc, $shpath, $shfile); + $shc = new Win32::Shortcut(); + $shc->{'IconLocation'} = $icon if -f $icon; + $shc->{'Path'} = $prog; + $shc->{'Arguments'} = $args; + $shc->{'ShowCmd'} = $batgui ? SW_SHOWMINNOACTIVE : SW_SHOWNORMAL; + $shc->{'WorkingDirectory'} = '%USERPROFILE%'; + $shfile = $dir; + $shfile =~ s!\\!/!g; + $shfile .= ($shfile =~ m!/$! ? '' : '/') . $name . '.lnk'; + $shc->Save($shfile); +} + +sub desktop_path() { + return Win32::GetFolderPath( + (admin() ? Win32::CSIDL_COMMON_DESKTOPDIRECTORY : + Win32::CSIDL_DESKTOPDIRECTORY), CREATE); +} + +sub menu_path() { + return Win32::GetFolderPath( + (admin() ? Win32::CSIDL_COMMON_PROGRAMS : Win32::CSIDL_PROGRAMS), CREATE); +} + +sub add_desktop_shortcut { + my ($name, $icon, $prog, $args, $batgui) = @_; + add_shortcut (desktop_path(), $name, $icon, $prog, $args, $batgui); +} + +sub add_menu_shortcut { + my ($place, $name, $icon, $prog, $args, $batgui) = @_; + $place =~ s!\\!/!g; + my $shdir = menu_path() . ($place =~ m!^/!=~ '/' ? '' : '/') . $place; + add_shortcut ($shdir, $name, $icon, $prog, $args, $batgui); +} + + +=pod + +=item C<remove_desktop_shortcut($name)> + +For uninstallation of an individual package. + +=item C<remove_menu_shortcut($place, $name)> + +For uninstallation of an individual package. + +=cut + +sub remove_desktop_shortcut { + my $name = shift; + unlink desktop_path().'/'.$name.'.lnk'; +} + +sub remove_menu_shortcut { + my $place = shift; + my $name = shift; + $place =~ s!\\!/!g; + $place = '/'.$place unless $place =~ m!^/!; + unlink menu_path().$place.'/'.$name.'.lnk'; +} + +=pod + +=back + +=head2 UNINSTALLER + +=over 4 + +=item C<create_uninstaller> + +Writes registry entries for add/remove programs which reference +the uninstaller script and creates uninstaller batchfiles to finish +the job. + +=cut + +sub create_uninstaller { + # TEXDIR + &log("Creating uninstaller\n"); + my $td_fw = shift; + $td_fw =~ s!\\!/!; + my $td = $td_fw; + $td =~ s!/!\\!g; + + my $tdmain = `"$td\\bin\\win32\\kpsewhich" -var-value=TEXMFMAIN`; + $tdmain =~ s!/!\\!g; + chomp $tdmain; + + my $uninst_fw = "$td_fw/tlpkg/installer"; + my $uninst_dir = $uninst_fw; + $uninst_dir =~ s!/!\\!g; + mkdirhier("$uninst_fw"); # wasn't this done yet? + if (! (open UNINST, ">", "$uninst_fw/uninst.bat")) { + tlwarn("Failed to create uninstaller\n"); + return 0; + } + print UNINST <<UNEND; +rem \@echo off +setlocal +path $td\\tlpkg\\tlperl\\bin;$td\\bin\\win32;%path% +set PERL5LIB=$td\\tlpkg\\tlperl\\lib +rem Clean environment from other Perl variables +set PERL5OPT= +set PERLIO= +set PERLIO_DEBUG= +set PERLLIB= +set PERL5DB= +set PERL5DB_THREADED= +set PERL5SHELL= +set PERL_ALLOW_NON_IFS_LSP= +set PERL_DEBUG_MSTATS= +set PERL_DESTRUCT_LEVEL= +set PERL_DL_NONLAZY= +set PERL_ENCODING= +set PERL_HASH_SEED= +set PERL_HASH_SEED_DEBUG= +set PERL_ROOT= +set PERL_SIGNALS= +set PERL_UNICODE= + +perl.exe \"$tdmain\\scripts\\texlive\\uninstall-win32.pl\" +if errorlevel 1 goto :eof +rem test for taskkill and try to stop exit tray menu +taskkill /? >nul 2>&1 +if not errorlevel 1 1>nul 2>&1 taskkill /IM tl-tray-menu.exe /f +copy \"$uninst_dir\\uninst2.bat\" \"\%TEMP\%\" +rem pause +\"\%TEMP\%\\uninst2.bat\" +UNEND +; + close UNINST; + + # We could simply delete everything under the root at one go, + # but this might be catastrophic if TL doesn't have its own root. + if (! (open UNINST2, ">$uninst_fw/uninst2.bat")) { + tlwarn("Failed to complete creating uninstaller\n"); + return 0; + } + print UNINST2 <<UNEND2; +rmdir /s /q \"$td\\bin\" +rmdir /s /q \"$td\\readme-html.dir\" +rmdir /s /q \"$td\\readme-txt.dir\" +if exist \"$td\\temp\" rmdir /s /q \"$td\\temp\" +rmdir /s /q \"$td\\texmf-dist\" +rmdir /s /q \"$td\\tlpkg\" +del /q \"$td\\README.*\" +del /q \"$td\\LICENSE.*\" +if exist \"$td\\doc.html\" del /q \"$td\\doc.html\" +del /q \"$td\\index.html\" +del /q \"$td\\texmf.cnf\" +del /q \"$td\\texmfcnf.lua\" +del /q \"$td\\install-tl*.*\" +del /q \"$td\\tl-tray-menu.exe\" +rem del /q \"$td\\texlive.profile\" +del /q \"$td\\release-texlive.txt\" +UNEND2 +; + for my $d ('TEXMFSYSVAR', 'TEXMFSYSCONFIG') { + my $kd = `"$td\\bin\\win32\\kpsewhich" -var-value=$d`; + chomp $kd; + print UNINST2 "rmdir /s /q \"", $kd, "\"\r\n"; + } + if ($td !~ /^.:$/) { # not root of drive; remove directory if empty + print UNINST2 <<UNEND3; +for \%\%f in (\"$td\\*\") do goto :done +for /d \%\%f in (\"$td\\*\") do goto :done +rd \"$td\" +:done +\@echo Done uninstalling TeXLive. +\@pause +del \"%0\" +UNEND3 +; + } + close UNINST2; + # user install: create uninstaller shortcut + # admin install: no shortcut because it would be visible to + # users who are not authorized to run it + if (!admin()) { + &log("Creating shortcut for uninstaller\n"); + TeXLive::TLWinGoo::add_menu_shortcut( + $TeXLive::TLConfig::WindowsMainMenuName, "Uninstall TeX Live", "", + "$uninst_dir\\uninst.bat", "", 0); + } + # register uninstaller + # but not for a user install under win10 because then + # it shows up in Settings / Apps / Apps & features, + # where it will trigger an inappropriate UAC prompt + if (admin() || !is_ten()) { + &log("Registering uninstaller\n"); + my $k; + my $uninst_key = $Registry -> Open((admin() ? "LMachine" : "CUser") . + "/software/microsoft/windows/currentversion/", + {Access => KEY_FULL_ACCESS()}); + if ($uninst_key) { + $k = $uninst_key->CreateKey( + "uninstall/TeXLive$::TeXLive::TLConfig::ReleaseYear/"); + if ($k) { + $k->{"/DisplayName"} = "TeX Live $::TeXLive::TLConfig::ReleaseYear"; + $k->{"/UninstallString"} = "\"$td\\tlpkg\\installer\\uninst.bat\""; + $k->{'/DisplayVersion'} = $::TeXLive::TLConfig::ReleaseYear; + $k->{'/Publisher'} = 'TeX Live'; + $k->{'/URLInfoAbout'} = "http://www.tug.org/texlive"; + } + } + if (!$k and admin()) { + tlwarn("Failed to register uninstaller\n". + "You can still run $td\\tlpkg\\installer\\uninst.bat manually.\n"); + return 0; + } + } +} + +=pod + +=item C<unregister_uninstaller> + +Removes TeXLive from Add/Remove Programs. + +=cut + +sub unregister_uninstaller { + my ($w32_multi_user) = @_; + my $regkey_uninst_path = ($w32_multi_user ? "LMachine" : "CUser") . + "/software/microsoft/windows/currentversion/uninstall/"; + my $regkey_uninst = $Registry->Open($regkey_uninst_path, + {Access => KEY_FULL_ACCESS()}); + reg_delete_recurse( + $regkey_uninst, "TeXLive$::TeXLive::TLConfig::ReleaseYear/") + if $regkey_uninst; + tlwarn "Failure to unregister uninstaller\n" if + $regkey_uninst->{"TeXLive$::TeXLive::TLConfig::ReleaseYear/"}; +} + +=pod + +=item C<TeXLive::TLWinGoo::maybe_make_ro($dir)> + +Write-protects a directory $dir recursively, using ACLs, but only if +we are a multi-user install, and only if $dir is on an +NTFS-formatted local fixed disk, and only on Windows Vista and +later. It writes a log message what it does and why. + +=cut + +sub maybe_make_ro { + my $dir = shift; + debug ("Calling maybe_make_ro on $dir\n"); + tldie "$dir not a directory\n" unless -d $dir; + if (!admin()) { + log "Not an admin install; not making read-only\n"; + return 1; + } + if (!is_vista()) { + log "Windows version $windows_version earlier than Vista;". + " not making read-only\n"; + return 1; + } + + $dir = Cwd::abs_path($dir); + + # GetDriveType: check that $dir is on local fixed disk + # need to feed GetDriveType the drive root + my ($volume,$dirs,$file) = File::Spec->splitpath($dir); + debug "Split path: | $volume | $dirs | $file\n"; + # GetDriveType won't handle UNC paths so handle this case separately + if ($volume =~ m!^[\\/][\\/]!) { + log "$dir on UNC network path; not making read-only\n"; + return 1; + } + my $dt = Win32API::File::GetDriveType($volume); + debug "Drive type $dt\n"; + if ($dt ne Win32API::File::DRIVE_FIXED) { + log "Not a local fixed drive; not making read-only\n"; + return 1; + } + + # FsType: test for NTFS, or, better, check whether ACLs are supported + # FsType needs to be called for the current directory + my $curdir = Cwd::getcwd(); + debug "Current directory $curdir\n"; + chdir $dir; + my $newdir = Cwd::getcwd(); + debug "New current directory $newdir\n"; + tldie "Cannot cd to $dir, current dir is $newdir\n" unless + lc($newdir) eq lc($dir); + my ($fstype, $flags, $maxl) = Win32::FsType(); # of current drive + if (!($flags & 0x00000008)) { + log "$dir does not supports ACLs; not making read-only\n"; + # go back to original directory + chdir $curdir; + return 1; + } + + # ran out of excuses: do it + # we use cmd /c + # $dir now being the current directory, we can save ourselves + # some quoting troubles by using . for $dir. + + # some 'well-known sids': + # S-1-5-11 Authenticated users + # S-1-5-32-545 Users + # S-1-5-32-544 administrators + # S-1-3-0 creator owner + # S-1-3-1 creator group + + # useful explanations at http://timbolton.net/2010/06/23/ + # /icacls-changing-permissions-on-files-and-folders + + # /reset is necessary for removing non-standard existing permissions + my $cmd = 'cmd /c "icacls . /reset && icacls . /inheritance:r'. + ' /grant:r *S-1-5-32-544:(OI)(CI)F /grant *S-1-3-0:(OI)(CI)F'. + ' /grant *S-1-5-11:(OI)(CI)RX"'; + log "Making read-only\n".`$cmd`."\n"; + + # go back to original directory + chdir $curdir; + return 1; +} + +# needs a terminal 1 for require to succeed! +1; + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TeXCatalogue.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TeXCatalogue.pm new file mode 100644 index 0000000000..4f6721dc17 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TeXCatalogue.pm @@ -0,0 +1,340 @@ +# $Id: TeXCatalogue.pm 48521 2018-08-31 03:41:21Z preining $ +# TeXLive::TeXCatalogue - module for accessing the TeX Catalogue +# Copyright 2007-2018 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. +# +# Loads of code taken from the catalogue checking script of Robin Fairbairns. + +use XML::Parser; +use XML::XPath; +use XML::XPath::XMLParser; +use Text::Unidecode; + +package TeXLive::TeXCatalogue::Entry; + +my $svnrev = '$Revision: 48521 $'; +my $_modulerevision; +if ($svnrev =~ m/: ([0-9]+) /) { + $_modulerevision = $1; +} else { + $_modulerevision = "unknown"; +} +sub module_revision { + return $_modulerevision; +} + +my $_parser = XML::Parser->new( + ErrorContext => 2, + ParseParamEnt => 1, + NoLWP => 1 +); + +sub new { + my $class = shift; + my %params = @_; + my $self = { + ioref => $params{'ioref'}, + entry => defined($params{'entry'}) ? $params{'entry'} : {}, + docs => defined($params{'docs'}) ? $params{'docs'} : {}, + name => $params{'name'}, + caption => $params{'caption'}, + description => $params{'description'}, + license => $params{'license'}, + ctan => $params{'ctan'}, + texlive => $params{'texlive'}, + miktex => $params{'miktex'}, + version => $params{'version'}, + also => defined($params{'also'}) ? $params{'also'} : [], + topic => defined($params{'topic'}) ? $params{'topic'} : [], + alias => defined($params{'alias'}) ? $params{'alias'} : [], + contact => defined($params{'contact'}) ? $params{'contact'} : {}, + }; + bless $self, $class; + if (defined($self->{'ioref'})) { + $self->initialize(); + } + return $self; +} + +sub initialize { + my $self = shift; + # parse all the files + my $parser + = new XML::XPath->new(ioref => $self->{'ioref'}, parser => $_parser) + || die "Failed to parse given ioref"; + $self->{'entry'}{'id'} = $parser->findvalue('/entry/@id')->value(); + $self->{'entry'}{'date'} = $parser->findvalue('/entry/@datestamp')->value(); + $self->{'entry'}{'modder'} = $parser->findvalue('/entry/@modifier')->value(); + $self->{'name'} = $parser->findvalue("/entry/name")->value(); + $self->{'caption'} = beautify($parser->findvalue("/entry/caption")->value()); + $self->{'description'} = beautify($parser->findvalue("/entry/description")->value()); + $self->{'license'} = $parser->findvalue('/entry/license/@type')->value(); + $self->{'version'} = Text::Unidecode::unidecode( + $parser->findvalue('/entry/version/@number')->value()); + $self->{'ctan'} = $parser->findvalue('/entry/ctan/@path')->value(); + if ($parser->findvalue('/entry/texlive/@location') ne "") { + $self->{'texlive'} = $parser->findvalue('/entry/texlive/@location')->value(); + } + if ($parser->findvalue('/entry/miktex/@location') ne "") { + $self->{'miktex'} = $parser->findvalue('/entry/miktex/@location')->value(); + } + # parse all alias entries + my $alset = $parser->find('/entry/alias'); + for my $node ($alset->get_nodelist) { + my $id = $parser->find('./@id', $node); + push @{$self->{'alias'}}, "$id"; + } + # parse the documentation entries + my $docset = $parser->find('/entry/documentation'); + foreach my $node ($docset->get_nodelist) { + my $docfileparse = $parser->find('./@href',$node); + # convert to string + my $docfile = "$docfileparse"; + # see comments at end of beautify() + my $details + = Text::Unidecode::unidecode($parser->find('./@details',$node)); + my $language = $parser->find('./@language',$node); + $self->{'docs'}{$docfile}{'available'} = 1; + if ($details) { $self->{'docs'}{$docfile}{'details'} = "$details"; } + if ($language) { $self->{'docs'}{$docfile}{'language'} = "$language"; } + } + # parse the also entries + foreach my $node ($parser->find('/entry/also')->get_nodelist) { + my $alsoid = $parser->find('./@refid',$node); + push @{$self->{'also'}}, "$alsoid"; + } + # parse the contact entries + foreach my $node ($parser->find('/entry/contact')->get_nodelist) { + my $contacttype = $parser->find('./@type',$node); + my $contacthref = $parser->find('./@href',$node); + if ($contacttype && $contacthref) { + $self->{'contact'}{$contacttype} = $contacthref; + } + } + # parse the keyval/topic entries + foreach my $node ($parser->find('/entry/keyval')->get_nodelist) { + my $k = $parser->find('./@key',$node); + my $v = $parser->find('./@value',$node); + # for now we only support evaluating the 'topic' key + if ("$k" eq 'topic') { + push @{$self->{'topic'}}, "$v"; + } + } +} + +sub beautify { + my ($txt) = @_; + $txt =~ s/\n/ /g; # make one line + $txt =~ s/^\s+//g; # rm leading whitespace + $txt =~ s/\s+$//g; # rm trailing whitespace + $txt =~ s/\s\s+/ /g; # multiple spaces to one + # transliterate to ascii: it allows the final tlpdb to be pure ascii, + # avoiding problems since we don't control the user's terminal encoding + return Text::Unidecode::unidecode($txt); +} + +sub name { + my $self = shift; + if (@_) { $self->{'name'} = shift } + return $self->{'name'}; +} +sub license { + my $self = shift; + if (@_) { $self->{'license'} = shift } + return $self->{'license'}; +} +sub version { + my $self = shift; + if (@_) { $self->{'version'} = shift } + return $self->{'version'}; +} +sub caption { + my $self = shift; + if (@_) { $self->{'caption'} = shift } + return $self->{'caption'}; +} +sub description { + my $self = shift; + if (@_) { $self->{'description'} = shift } + return $self->{'description'}; +} +sub ctan { + my $self = shift; + if (@_) { $self->{'ctan'} = shift } + return $self->{'ctan'}; +} +sub texlive { + my $self = shift; + if (@_) { $self->{'texlive'} = shift } + return $self->{'texlive'}; +} +sub miktex { + my $self = shift; + if (@_) { $self->{'miktex'} = shift } + return $self->{'miktex'}; +} +sub docs { + my $self = shift; + my %newdocs = @_; + if (@_) { $self->{'docs'} = \%newdocs } + return $self->{'docs'}; +} +sub entry { + my $self = shift; + my %newentry = @_; + if (@_) { $self->{'entry'} = \%newentry } + return $self->{'entry'}; +} +sub alias { + my $self = shift; + my @newalias = @_; + if (@_) { $self->{'alias'} = \@newalias } + return $self->{'alias'}; +} +sub also { + my $self = shift; + my @newalso = @_; + if (@_) { $self->{'also'} = \@newalso } + return $self->{'also'}; +} +sub topics { + my $self = shift; + my @newtopics = @_; + if (@_) { $self->{'topic'} = \@newtopics } + return $self->{'topic'}; +} +sub contact { + my $self = shift; + my %newcontact = @_; + if (@_) { $self->{'contact'} = \%newcontact } + return $self->{'contact'}; +} + + +################################################################ +# +# TeXLive::TeXCatalogue +# +################################################################ +package TeXLive::TeXCatalogue; + +sub new { + my $class = shift; + my %params = @_; + my $self = { + location => $params{'location'}, + entries => defined($params{'entries'}) ? $params{'entries'} : {}, + }; + bless $self, $class; + if (defined($self->{'location'})) { + $self->initialize(); + $self->quest4texlive(); + } + return $self; +} + +sub initialize { + my $self = shift; + # chdir to the location of the DTD file, otherwise it cannot be found + # furthermore we have to open the xml file from a file handle otherwise + # the catalogue.dtd is searched in a/catalogue.dtd etc, see above + my $cwd = `pwd`; + chomp($cwd); + chdir($self->{'location'} . "/entries") + || die "chdir($self->{location}/entries failed: $!"; + # parse all the files + foreach (glob("?/*.xml")) { + # for debugging, nice to skip everything but: next unless /pst-node/; + open(my $io,"<$_") or die "open($_) failed: $!"; + our $tce; + # the XML parser die's on malformed xml entries, so we catch + # that and continue, simply skipping the entry + eval { $tce = TeXLive::TeXCatalogue::Entry->new( 'ioref' => $io ); }; + if ($@) { + warn "TeXCatalogue.pm:$_: cannot parse, skipping: $@\n"; + close($io); + next; + } + close($io); + $self->{'entries'}{lc($tce->{'entry'}{'id'})} = $tce; + } + chdir($cwd) || die ("Cannot change back to $cwd: $!"); +} + +# Copy every catalogue $entry under the name $entry->{'texlive'} +# if it makes sense. +# +sub quest4texlive { + my $self = shift; + + # The catalogue has a partial mapping from catalogue entries to + # texlive packages: $id --> $texcat->{$id}{'texlive'} + my $texcat = $self->{'entries'}; + + # Try to build the inverse mapping: + my (%inv, %count); + for my $id (keys %{$texcat}) { + my $tl = $texcat->{$id}{'texlive'}; + if (defined($tl)) { + $tl =~ s/^bin-//; + $count{$tl}++; + $inv{$tl} = $id; + } + } + # Go through texlive names + for my $name (keys %inv) { + # If this name is free and there is only one corresponding catalogue + # entry then copy the entry under this name + if (!exists($texcat->{$name}) && $count{$name} == 1) { + $texcat->{$name} = $texcat->{$inv{$name}}; + } + } +} + +sub location { + my $self = shift; + if (@_) { $self->{'location'} = shift } + return $self->{'location'}; +} + +sub entries { + my $self = shift; + my %newentries = @_; + if (@_) { $self->{'entries'} = \%newentries } + return $self->{'entries'}; +} + +1; +__END__ + + +=head1 NAME + +TeXLive::TeXCatalogue - Accessing the TeX Catalogue + +=head1 SYNOPSIS + +missing + +=head1 DESCRIPTION + +The L<TeXLive::TeXCatalogue> module provides access to the data stored +in the TeX Catalogue. + +DOCUMENTATION MISSING, SORRY!!! + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/trans.pl b/systems/texlive/tlnet/tlpkg/TeXLive/trans.pl new file mode 100644 index 0000000000..0a905254b4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/trans.pl @@ -0,0 +1,219 @@ +#!/usr/bin/env perl +# $Id: trans.pl 41176 2016-05-16 00:42:28Z preining $ +# Copyright 2009-2016 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. +# +# translation infrastructure for TeX Live programs +# if $::lang is set then that one is used +# if $::lang is unset try to auto-deduce it from LC_MESSAGES/Registry +# if $::opt_lang is set use that instead +# +# this module implements parsing .po files, but no specialities of .po +# files are supported. Only reading of msgstr and msgid and concatenating +# multiple lines. Furthermore, strings replacements are done: +# \n -> <newline> +# \" -> " +# \\ -> \ +# + +use strict; +$^W = 1; + +use utf8; +no utf8; + +if (defined($::opt_lang)) { + $::lang = $::opt_lang; + if ($::lang eq "zh") { + # set language to simplified chinese + $::lang = "zh_CN"; + } +} else { + if ($^O =~ /^MSWin/i) { + # trying to deduce automatically the country code + my ($lang, $area) = TeXLive::TLWinGoo::reg_country(); + if ($lang) { + $::lang = $lang; + $::area = uc($area); + } else { + debug("Didn't get any usuful code from reg_country.\n"); + } + } else { + # we load POSIX and locale stuff + require POSIX; + import POSIX qw/locale_h/; + # now we try to deduce $::lang + my $loc = setlocale(&POSIX::LC_MESSAGES); + my ($lang,$area,$codeset); + if ($loc =~ m/^([^_.]*)(_([^.]*))?(\.([^@]*))?(@.*)?$/) { + $lang = defined($1)?$1:""; + # lower case the area code + $area = defined($3)?uc($3):""; + if ($lang eq "zh") { + if ($area =~ m/^(TW|HK)$/i) { + $lang = "zh"; + $area = "TW"; + } else { + # fallback to zh-cn for anything else, that is + # zh-cn, zh-sg, zh, and maybe something else + $lang = "zh"; + $area = "CN"; + } + } + } + $::lang = $lang if ($lang); + $::area = $area if ($area); + } +} + + +our %TRANS; + +# +# __ takes a string argument and checks that it +sub __ ($@) { + my $key = shift; + my $ret; + # if no $::lang is set just return without anything + if (!defined($::lang)) { + $ret = $key; + } else { + $ret = $key; + $key =~ s/\\/\\\\/g; + $key =~ s/\n/\\n/g; + $key =~ s/"/\\"/g; + # if the translation is defined return it + if (defined($TRANS{$::lang}->{$key})) { + $ret = $TRANS{$::lang}->{$key}; + if ($::debug_translation && ($key eq $ret)) { + print STDERR "probably untranslated in $::lang: >>>$key<<<\n"; + } + } else { + # if we cannot find it, return $s itself + if ($::debug_translation && $::lang ne "en") { + print STDERR "no translation in $::lang: >>>$key<<<\n"; + } + # $ret is already set initially + } + } + # translate back $ret: + $ret =~ s/\\n/\n/g; + $ret =~ s/\\"/"/g; + $ret =~ s/\\\\/\\/g; + return sprintf($ret, @_); +} + +sub load_translations() { + if (($::lang ne "en") && ($::lang ne "C")) { + my $code = $::lang; + my @files_to_check; + if (defined($::area)) { + $code .= "_$::area"; + push @files_to_check, + $::lang . "_" . $::area, "$::lang-$::area", + $::lang . "_" . lc($::area), "$::lang-" . lc($::area), + # try also without area code, even if it is given! + $::lang; + } else { + push @files_to_check, $::lang; + } + my $found = 0; + for my $f (@files_to_check) { + if (-r "$::installerdir/tlpkg/translations/$f.po") { + $found = 1; + $::lang = $f; + last; + } + } + if (!$found) { + tlwarn ("\n Sorry, no translations available for $code (nor $::lang); falling back to English. + Make sure that you have the package \"texlive-msg-translations\" installed. + (If you'd like to help translate the installer's messages, please see + http://tug.org/texlive/doc.html#install-tl-xlate for information.)\n\n"); + } else { + # merge the translated strings into the text string + open(LANG, "<$::installerdir/tlpkg/translations/$::lang.po"); + my $msgid; + my $msgstr; + my $inmsgid; + my $inmsgstr; + while (<LANG>) { + chomp; + next if m/^\s*#/; + if (m/^\s*$/) { + if ($inmsgid) { + debug("msgid $msgid without msgstr in $::lang.po\n"); + $inmsgid = 0; + $inmsgstr = 0; + $msgid = ""; + $msgstr = ""; + next; + } + if ($inmsgstr) { + if ($msgstr) { + if (!utf8::decode($msgstr)) { + warn("decoding string to utf8 didn't work: $msgstr\n"); + } + # we decode msgid too to get \\ and not \ + if (!utf8::decode($msgid)) { + warn("decoding string to utf8 didn't work: $msgid\n"); + } + $TRANS{$::lang}{$msgid} = $msgstr; + } else { + ddebug("untranslated $::lang: ...$msgid...\n"); + } + $inmsgid = 0; + $inmsgstr = 0; + $msgid = ""; + $msgstr = ""; + next; + } + next; + } + if (m/^msgid\s+"(.*)"\s*$/) { + if ($msgid) { + warn("stray msgid line: $_"); + next; + } + $inmsgid = 1; + $msgid = $1; + next; + } + if (m/^"(.*)"\s*$/) { + if ($inmsgid) { + $msgid .= $1; + } elsif ($inmsgstr) { + $msgstr .= $1; + } else { + tlwarn("cannot parse $::lang.po line: $_\n"); + } + next; + } + if (m/^msgstr\s+"(.*)"\s*$/) { + if (!$inmsgid) { + tlwarn("msgstr $1 without msgid\n"); + next; + } + $msgstr = $1; + $inmsgstr = 1; + $inmsgid = 0; + } + } + close(LANG); + } + } +} + + +1; + +__END__ + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # + |