diff options
Diffstat (limited to 'Build/source/texk/tests/TeXLive/TLUtils.pm')
-rw-r--r-- | Build/source/texk/tests/TeXLive/TLUtils.pm | 357 |
1 files changed, 88 insertions, 269 deletions
diff --git a/Build/source/texk/tests/TeXLive/TLUtils.pm b/Build/source/texk/tests/TeXLive/TLUtils.pm index bc4ab402d9d..432011f09e0 100644 --- a/Build/source/texk/tests/TeXLive/TLUtils.pm +++ b/Build/source/texk/tests/TeXLive/TLUtils.pm @@ -5,16 +5,9 @@ package TeXLive::TLUtils; -my $svnrev = '$Revision: 40460 $'; -my $_modulerevision; -if ($svnrev =~ m/: ([0-9]+) /) { - $_modulerevision = $1; -} else { - $_modulerevision = "unknown"; -} -sub module_revision { - return $_modulerevision; -} +my $svnrev = '$Revision: 40652 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } =pod @@ -97,11 +90,6 @@ C<TeXLive::TLUtils> -- utilities used in TeX Live infrastructure TeXLive::TLUtils::forward_slashify($path_from_user); TeXLive::TLUtils::give_ctan_mirror(); TeXLive::TLUtils::give_ctan_mirror_base(); - TeXLive::TLUtils::tlmd5($path); - TeXLive::TLUtils::tlchecksum($path); - TeXLive::TLUtils::setup_gpg(); - TeXLive::TLUtils::verify_checksum($file, $url); - TeXLive::TLUtils::verify_signature($file, $url); TeXLive::TLUtils::compare_tlpobjs($tlpA, $tlpB); TeXLive::TLUtils::compare_tlpdbs($tlpdbA, $tlpdbB); TeXLive::TLUtils::report_tlpdb_differences(\%ret); @@ -175,11 +163,6 @@ BEGIN { &give_ctan_mirror_base &create_mirror_list &extract_mirror_entry - &tlmd5 - &tlchecksum - &setup_gpg - &verify_checksum - &verify_signature &wsystem &xsystem &run_cmd @@ -205,8 +188,6 @@ BEGIN { } use Cwd; -use Digest::MD5; -use Digest::SHA; use Getopt::Long; use File::Temp; @@ -221,7 +202,7 @@ $::opt_verbosity = 0; # see process_logging_options =item C<platform> -If C<$^O=~/MSWin(32|64)$/i> is true we know that we're on +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. @@ -570,7 +551,7 @@ sub run_cmd { =back -=head2 File Utilities +=head2 File utilities =over 4 @@ -645,8 +626,8 @@ sub basename { =item C<tl_abs_path($path)> -# Other than Cwd::abs_path, tl_abs_path also works -# if only the grandparent exists. +# 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 @@ -655,33 +636,34 @@ sub tl_abs_path { if (win32) { $path=~s!\\!/!g; } - my $ret; - eval {$ret = Cwd::abs_path($path);}; # eval needed for w32 - return $ret if defined $ret; - # $ret undefined: probably the parent does not exist. - # But we also want an answer if only the grandparent exists. - my ($parent, $base) = dirname_and_basename($path); - return undef unless defined $parent; - eval {$ret = Cwd::abs_path($parent);}; - if (defined $ret) { - if ($ret =~ m!/$! or $base =~ m!^/!) { - $ret = "$ret$base"; - } else { - $ret = "$ret/$base"; - } - return $ret; - } else { - my ($pparent, $pbase) = dirname_and_basename($parent); - return undef unless defined $pparent; - eval {$ret = Cwd::abs_path($pparent);}; - return undef unless defined $ret; - if ($ret =~ m!/$!) { - $ret = "$ret$pbase/$base"; - } else { - $ret = "$ret/$pbase/$base"; - } - return $ret; + 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; } @@ -703,13 +685,19 @@ sub dir_creatable { #print STDERR "testing $path\n"; $path =~ s!\\!/!g if win32; return 0 unless -d $path; - $path =~ s!/$!!; + $path .= '/' unless $path =~ m!/$!; #print STDERR "testing $path\n"; - my $i = 0; - my $too_large = 100000; - while ((-e $path . "/" . $i) and $i<$too_large) { $i++; } - return 0 if $i>=$too_large; - my $d = $path."/".$i; + 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; @@ -728,10 +716,6 @@ a fileserver. =cut -# Theoretically, the test below, which uses numbers as names, might -# lead to a race condition. OTOH, it should work even on a very -# broken Perl. - # 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 @@ -742,14 +726,19 @@ sub dir_writable { my ($path) = @_; return 0 unless -d $path; $path =~ s!\\!/!g if win32; - $path =~ s!/$!!; + $path .= '/' unless $path =~ m!/$!; my $i = 0; - my $too_large = 100000; - while ((-e "$path/$i") && $i < $too_large) { - $i++; + 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 $ i >= $too_large; - my $f = "$path/$i"; return 0 if ! open (TEST, ">$f"); my $written = 0; $written = (print TEST "\n"); @@ -1959,23 +1948,26 @@ sub w32_remove_from_path { =item C<check_file($what, $checksum, $checksize> Remove C<$what> if either the given C<$checksum> or C<$checksize> does -not agree. Does nothing if neither of the check arguments is given. +not agree. If a check argument is not given, that check is not performed. =cut sub check_file { - my ($xzfile, $checksum, $size) = @_; + my ($xzfile, $checksum, $checksize) = @_; if ($checksum) { - if (tlchecksum($xzfile) ne $checksum) { - tlwarn("TLUtils::check_file: found $xzfile, but hashsums differ, removing it.\n"); + 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; } } - if ($size) { + if ($checksize) { my $filesize = (stat $xzfile)[7]; - if ($filesize != $size) { - tlwarn("TLUtils::check_file: found $xzfile, but sizes differ, removing it.\n"); + if ($filesize != $checksize) { + tlwarn("TLUtils::check_file: removing $xzfile, sizes differ:\n"); + tlwarn("TLUtils::check_file: TL=$filesize, arg=$checksize\n"); unlink($xzfile); return; } @@ -2195,7 +2187,7 @@ sub setup_programs { $::progs{'xz'} = "xz"; $::progs{'tar'} = "tar"; - if ($^O =~ /^MSWin(32|64)$/i) { + if ($^O =~ /^MSWin/i) { $::progs{'wget'} = conv_to_w32_path("$bindir/wget/wget.exe"); $::progs{'tar'} = conv_to_w32_path("$bindir/tar.exe"); $::progs{'xzdec'} = conv_to_w32_path("$bindir/xz/xzdec.exe"); @@ -2251,9 +2243,11 @@ sub setup_unix_one { my ($p, $def, $arg, $donotwarn) = @_; our $tmp; my $test_fallback = 0; + ddebug("trying to set up $p, default $def, arg $arg\n"); if (-r $def) { my $ready = 0; if (-x $def) { + ddebug("default $def is readable and executable!\n"); # checking only for the executable bit is not enough, we have # to check for actualy "executability" since a "noexec" mount # option may interfere, which is not taken into account by @@ -2739,8 +2733,11 @@ sub _create_config_files { @lines = <INFILE>; close (INFILE); } else { - tlwarn("TLUtils::_create_config_files: $root/$headfile: " - . " head file not found, ok in user mode"); + tlwarn("TLUtils::_create_config_files: $root/$headfile missing!\n"); + # TODO + # if we allow tlmgr generate to generate language.* file in usermode + # we need to remove the die here! + die ("Giving up."); } push @lines, @$tlpdblinesref; if (defined($localconf) && -r $localconf) { @@ -2997,13 +2994,16 @@ directory (Unix) or the root of a drive (Windows). sub texdir_check { my $texdir = shift; return 0 unless defined $texdir; - # convert to absolute/canonical, for safer parsing - # tl_abs_path should work as long as grandparent exists + # 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/volume, + # 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; @@ -3136,11 +3136,12 @@ sub dddebug { } } - =item C<log ($str1, $str2, ...)> Write a message to the log file (and nowhere else), the concatenation of -the argument strings. +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 @@ -3151,7 +3152,6 @@ sub log { $::opt_quiet = $savequiet; } - =item C<tlwarn ($str1, $str2, ...)> Write a warning message, the concatenation of the argument strings. @@ -3284,7 +3284,7 @@ sub process_logging_options { 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> a few special characters, since unconditional quoting +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. @@ -3577,81 +3577,6 @@ sub extract_mirror_entry { return $foo[$#foo] . "/" . $TeXLive::TLConfig::TeXLiveServerPath; } -sub tlmd5 { - my ($file) = @_; - if (-r $file) { - open(FILE, $file) || die "open($file) failed: $!"; - binmode(FILE); - my $md5hash = Digest::MD5->new->addfile(*FILE)->hexdigest; - close(FILE); - return $md5hash; - } else { - tlwarn("tlmd5, given file not readable: $file\n"); - return ""; - } -} - -sub tldigest { - return (Digest::SHA::sha512_hex(shift)); -} -sub tl_short_digest { - return (Digest::MD5::md5_hex(shift)); -} - -sub tlchecksum { - my ($file) = @_; - if (-r $file) { - open(FILE, $file) || die "open($file) failed: $!"; - binmode(FILE); - my $cshash = Digest::SHA->new(512)->addfile(*FILE)->hexdigest; - close(FILE); - return $cshash; - } else { - tlwarn("tlchecksum: given file not readable: $file\n"); - return ""; - } -} - -sub tlchecksum_data { - my ($data) = @_; - my $cshash = Digest::SHA->new(512)->add($data)->hexdigest; - return $cshash; -} - - -=pod - -=item C<< setup_gpg() >> - -Tries to set up gpg command line C<$::gpg> used for -verification of downloads. - -Returns 1/0 on success/failure. - -=cut - -sub setup_gpg { - my $master = shift; - # first search for a gpg binary - return 0 if (!setup_unix_one( 'gpg' , '/no/such/path', '--version', 1)); - # ok, we found one - # Set up the gpg invocation: - $::gpg = "$::progs{'gpg'} "; - 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 .= "--homedir $gpghome_quote "; - if ($ENV{'TL_GNUPGARGS'}) { - $::gpg .= $ENV{'TL_GNUPGARGS'}; - } else { - $::gpg .= "--no-secmem-warning --no-permission-warning "; - } - debug("gpg command line: $::gpg\n"); - return 1; -} - =pod =item C<< slurp_file($file) >> @@ -3670,51 +3595,6 @@ sub slurp_file { return($file_data); } - -=pod - -=item C<< verify_checksum($file, $checksum_url) >> - -Verifies that C<$file> has checksum C<$checksum_url>. - -Returns 0 on success, -1 on connection error, 1 on checksum error. -In case of errors returns an informal message as second argument. - -=cut - -sub verify_checksum { - my ($file, $checksum_url) = @_; - my $checksum_file = 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) { - return(-1, "download did not succeed: $checksum_url"); - } - # check the signature - my ($ret, $msg) = verify_signature($checksum_file, $checksum_url); - return ($ret, $msg) if ($ret != 0); - - # verify local data - open $cs_fh, "<$checksum_file" or die("cannot read file: $!"); - if (read ($cs_fh, $remote_digest, $ChecksumLength) != $ChecksumLength) { - close($cs_fh); - return(1, "incomplete read from $checksum_file"); - } else { - close($cs_fh); - ddebug("found remote digest: $remote_digest\n"); - } - $local_digest = tlchecksum($file); - ddebug("local_digest = $local_digest\n"); - if ($local_digest ne $remote_digest) { - return(1, "digest disagree"); - } - - # we are still here, so checksum also succeeded - debug("checksum of local copy identical with remote hash\n"); - - return(0); -} - =pod =item C<< download_to_temp_or_file($url) >> @@ -3747,66 +3627,6 @@ sub download_to_temp_or_file { return; } -=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 0 on success, -1 on connection error, 1 on checksum error. -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 = download_to_temp_or_file($signature_url); - if ($signature_file) { - if (TeXLive::TLUtils::gpg_verify_signature($file, $signature_file)) { - info("cryptographic signature of $url verified\n"); - } else { - return(1, <<GPGERROR); -cryptograpic verification of - $file -against - $signature_url -failed. Please report to texlive\@tug.org -GPGERROR - } - } else { - debug("no access to cryptographic signature $signature_url\n"); - } - } else { - debug("gpg prog not defined, no checking of signatures\n"); - } - return (0); -} - -sub gpg_verify_signature { - my ($file, $sig) = @_; - my ($file_quote, $sig_quote); - if (win32()) { - $file =~ s!/!\\!g; - $sig =~ s!/!\\!g; - } - $file_quote = "\"$file\""; - $sig_quote = "\"$sig\""; - my ($out, $ret) = run_cmd("$::gpg --verify $sig_quote $file_quote 2>&1"); - if ($ret == 0) { - debug("verification succeeded, output:\n$out\n"); - return 1; - } else { - tlwarn("verification failed, output:\n$out\n"); - return 0; - } -} - -# # compare_tlpobjs # returns a hash # $ret{'revision'} = "leftRev:rightRev" if revision differ @@ -4136,10 +3956,9 @@ __END__ =head1 SEE ALSO -The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, -L<TeXLive::TLPDB>, L<TeXLive::TLTREE>, and the -document L<Perl-API.txt> and the specification in the TeX Live -repository trunk/Master/tlpkg/doc/. +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 |