From aa7d6384f051efc18575cf16b11b5ba6b0268cb6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 3 Jul 2008 17:22:59 +0000 Subject: * library/package.tcl: Removed [file readable] testing from [tclPkgUnknown] and friends. We find out soon enough whether a file is readable when we try to [source] it, and not testing before allows us to workaround the bugs on some common filesystems where [file readable] lies to us. [Patch 1969717] FossilOrigin-Name: 1ac299248cd770338bbd5a850277060058114daa --- ChangeLog | 8 ++++++++ library/package.tcl | 40 +++++++++++++++++++++++++++++----------- 2 files changed, 37 insertions(+), 11 deletions(-) diff --git a/ChangeLog b/ChangeLog index d480d4c..e8670ba 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2008-07-03 Don Porter + + * library/package.tcl: Removed [file readable] testing from + [tclPkgUnknown] and friends. We find out soon enough whether a + file is readable when we try to [source] it, and not testing + before allows us to workaround the bugs on some common filesystems + where [file readable] lies to us. [Patch 1969717] + 2008-06-29 Don Porter *** 8.5.3 TAGGED FOR RELEASE *** diff --git a/library/package.tcl b/library/package.tcl index 64197f7..6aa8be5 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -3,7 +3,7 @@ # utility procs formerly in init.tcl which can be loaded on demand # for package management. # -# RCS: @(#) $Id: package.tcl,v 1.35 2006/11/03 00:34:52 hobbs Exp $ +# RCS: @(#) $Id: package.tcl,v 1.35.4.1 2008/07/03 17:22:59 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -485,8 +485,15 @@ proc tclPkgUnknown {name args} { foreach file [glob -directory $dir -join -nocomplain \ * pkgIndex.tcl] { set dir [file dirname $file] - if {![info exists procdDirs($dir)] && [file readable $file]} { - if {[catch {source $file} msg]} { + if {![info exists procdDirs($dir)]} { + set code [catch {source $file} msg opt] + if {$code == 1 && + [lindex [dict get $opt -errorcode] 0] eq "POSIX" && + [lindex [dict get $opt -errorcode] 1] eq "EACCES"} { + # $file was not readable; silently ignore + continue + } + if {$code} { tclLog "error reading package index file $file: $msg" } else { set procdDirs($dir) 1 @@ -497,10 +504,16 @@ proc tclPkgUnknown {name args} { set dir [lindex $use_path end] if {![info exists procdDirs($dir)]} { set file [file join $dir pkgIndex.tcl] - # safe interps usually don't have "file readable", - # nor stderr channel - if {([interp issafe] || [file readable $file])} { - if {[catch {source $file} msg] && ![interp issafe]} { + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + set code [catch {source $file} msg opt] + if {$code == 1 && + [lindex [dict get $opt -errorcode] 0] eq "POSIX" && + [lindex [dict get $opt -errorcode] 1] eq "EACCES"} { + # $file was not readable; silently ignore + continue + } + if {$code} { tclLog "error reading package index file $file: $msg" } else { set procdDirs($dir) 1 @@ -546,8 +559,6 @@ proc tclPkgUnknown {name args} { # This procedure extends the "package unknown" function for MacOSX. # It scans the Resources/Scripts directories of the immediate children # of the auto_path directories for pkgIndex files. -# Only installed in interps that are not safe so we don't check -# for [interp issafe] as in tclPkgUnknown. # # Arguments: # original - original [package unknown] procedure @@ -583,8 +594,15 @@ proc tcl::MacOSXPkgUnknown {original name args} { foreach file [glob -directory $dir -join -nocomplain \ * Resources Scripts pkgIndex.tcl] { set dir [file dirname $file] - if {![info exists procdDirs($dir)] && [file readable $file]} { - if {[catch {source $file} msg]} { + if {![info exists procdDirs($dir)]} { + set code [catch {source $file} msg opt] + if {$code == 1 && + [lindex [dict get $opt -errorcode] 0] eq "POSIX" && + [lindex [dict get $opt -errorcode] 1] eq "EACCES"} { + # $file was not readable; silently ignore + continue + } + if {$code} { tclLog "error reading package index file $file: $msg" } else { set procdDirs($dir) 1 -- cgit v0.12