diff options
author | Karl Berry <karl@freefriends.org> | 2013-05-10 22:11:44 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2013-05-10 22:11:44 +0000 |
commit | 442d318f6f2f4413d16524ede4f2878c284b3c59 (patch) | |
tree | 910b5853dc3ab9932496d777e9cd4bfdc1ce5ffc /Build/source/utils/biber | |
parent | e78f14b73e415f95e7980c1b721c6ade613e4f93 (diff) |
sync
git-svn-id: svn://tug.org/texlive/trunk@30386 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/utils/biber')
-rw-r--r-- | Build/source/utils/biber/TeXLive/TLUtils.pm | 159 |
1 files changed, 110 insertions, 49 deletions
diff --git a/Build/source/utils/biber/TeXLive/TLUtils.pm b/Build/source/utils/biber/TeXLive/TLUtils.pm index fdcd482f5ba..fdc594d2c2c 100644 --- a/Build/source/utils/biber/TeXLive/TLUtils.pm +++ b/Build/source/utils/biber/TeXLive/TLUtils.pm @@ -5,7 +5,7 @@ package TeXLive::TLUtils; -my $svnrev = '$Revision: 30127 $'; +my $svnrev = '$Revision: 30367 $'; my $_modulerevision; if ($svnrev =~ m/: ([0-9]+) /) { $_modulerevision = $1; @@ -49,6 +49,7 @@ C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure 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); @@ -136,6 +137,7 @@ BEGIN { &dirname &basename &dirname_and_basename + &tl_abs_path &dir_writable &dir_creatable &mkdirhier @@ -542,26 +544,62 @@ sub run_cmd { =over 4 -=item C<dirname($path)> +=item C<dirname_and_basename($path)> -Return C<$path> with its trailing C</component> removed. +Return both C<dirname> and C<basename>. Example: + + ($dirpart,$filepart) = dirname_and_basename ($path); =cut -sub dirname { +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" - $path=~m!(.*)/.*!; # works because of greedy matching - return $1; + # 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 "."; + 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. @@ -569,34 +607,51 @@ Return C<$path> with any leading directory components removed. =cut sub basename { - my $path=shift; - if (win32) { - $path=~s!\\!/!g; - } - if ($path=~m!/!) { # basename("foo/bar") -> "bar" - $path=~m!.*/(.*)!; - return $1; - } else { # basename("ignore") -> "ignore" - return $path; - } + my $path = shift; + my ($dirname, $basename) = dirname_and_basename($path); + return $basename; } -=item C<dirname_and_basename($path)> - -Return both C<dirname> and C<basename>. Example: +=item C<tl_abs_path($path)> - ($dirpart,$filepart) = dirname_and_basename ($path); +# Other than Cwd::abs_path, tl_abs_path also works +# if only the grandparent exists. =cut -sub dirname_and_basename { - my $path=shift; +sub tl_abs_path { + my $path = shift; if (win32) { $path=~s!\\!/!g; } - $path=~/(.*)\/(.*)/; - return ("$1", "$2"); + 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; + } } @@ -614,14 +669,16 @@ sub dir_slash { # test whether subdirectories can be created in the argument sub dir_creatable { - $path=shift; + my $path=shift; #print STDERR "testing $path\n"; $path =~ s!\\!/!g if win32; + return 0 unless -d $path; $path =~ s!/$!!; - return 0 unless -d dir_slash($path); #print STDERR "testing $path\n"; my $i = 0; - while (-e $path . "/" . $i) { $i++; } + my $too_large = 100000; + while ((-e $path . "/" . $i) and $i<$too_large) { $i++; } + return 0 if $i>=$too_large; my $d = $path."/".$i; #print STDERR "creating $d\n"; return 0 unless mkdir $d; @@ -652,12 +709,14 @@ a fileserver. # real Program Files. Ugh. sub dir_writable { - $path=shift; - return 0 unless -d dir_slash($path); + my $path=shift; + return 0 unless -d $path; $path =~ s!\\!/!g if win32; $path =~ s!/$!!; my $i = 0; - while (-e $path . "/" . $i) { $i++; } + my $too_large = 100000; + while ((-e $path . "/" . $i) and $i<$too_large) { $i++; } + return 0 if $i>=$too_large; my $f = $path."/".$i; return 0 unless open TEST, ">".$f; my $written = 0; @@ -3076,22 +3135,24 @@ 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 the system drive (Windows). +directory (Unix) or the root of a drive (Windows). =cut 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 + $texdir = tl_abs_path($texdir); + return 0 unless defined $texdir; + # also reject the root of a drive/volume, + # assuming that only the canonical form of the root ends with / + return 0 if $texdir =~ m!/$!; my $texdirparent; my $texdirpparent; - $texdir =~ s!/$!!; # remove final slash - #print STDERR "Checking $texdir".'[/]'."\n"; - # disallow unix root - return 0 if $texdir eq ""; - # disallow w32 systemdrive root - return 0 if (win32() and $texdir eq $ENV{SystemDrive}); - - return dir_writable($texdir) if (-d dir_slash($texdir)); + + return dir_writable($texdir) if (-d $texdir); ($texdirparent = $texdir) =~ s!/[^/]*$!!; #print STDERR "Checking $texdirparent".'[/]'."\n"; return dir_creatable($texdirparent) if -d dir_slash($texdirparent); @@ -3401,16 +3462,16 @@ would be considered part of the filename. sub conv_to_w32_path { my $p = shift; - $p =~ s!/!\\!g; # we need absolute paths, too - if ($p !~ m!^.:!) { - my $cwd = `cd`; - die "sorry, could not find current working directory via cd?!" if ! $cwd; - chomp($cwd); - $p = "$cwd\\$p"; - } - $p = quotify_path_with_spaces($p); - return($p); + my $pabs = tl_abs_path($p); + if (not defined $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 |