Tcl Source Code

Artifact e59c56898e814ea06cc049dd3ae3cb8cebeae9c2:

Attachment "test.fileaccess.tcl" to ticket [855923ffff] added by cc_benny 2003-12-09 20:49:48.

---

# ------------------------------------------------------------------------
#	test.fileaccess.tcl
#-------------------------------------------------------------------------
#	$Log: $
#	2003-12-07 benny	Created
# ------------------------------------------------------------------------

# proc cacls
#
# A small proc to encapsulate the NT cacls command-line tool.  A "y"
# is piped into the command to cover a possible question for
# confirmation.  Only one "y", so only one file can be given.
#
# See the output of cacls /? on a command prompt for all I know about
# cacls.
#
# I'm not sure how portable this is to XP.  The tool is also probably
# localized on non-english systems.
#
# In theory the same effect could probably be achieved easier and more
# controlled with the Cygwin tools getfacl and setfacl (be sure to use
# the setting CYGWIN=ntsec).  Those tools seem somewhat incomplete
# though, in my installation I can't see how getfacl represents the
# result of "cacls $fname /E /P $user:N" (deny all access for $user).
proc cacls {fname args} {
	string trim [eval [list exec cacls [file nativename $fname]] $args <<y]
}

# proc getuser
#
# Parses the output of the "dir/q" command to find the owner of a
# file.  I haven't found a specialized tool for this and cacls doesn't
# give this info either.
#
# Example of dir/q output line:
# 2003-11-03  20:36                  598 OCTAVIAN\benny         filename.txt
proc getuser {fname} {
	set tryname $fname
	if {[file isdirectory $fname]} {
		set tryname [file dirname $fname]
	}
	set tail [file tail $tryname]
	set dirtext [exec cmd /c dir /q [file nativename $fname]]
	set owner ""
	foreach line [split $dirtext "\n"] {
		if {[string match -nocase "* $tail" $line]} {
			set attrs [string range $line \
					   0 end-[string length $tail]]
			regexp { [A-Z]+\\.*$} $attrs owner
			set owner [string trim $owner]
		}
	}
	if {"" == "$owner"} {
		error "getuser: Owner not found in output of dir/q"
	}
	return $owner
}

# proc test_read
#
# A test for readablity by actually reading the file. 
proc test_read {fname} {
	if {[catch {set ifs [open $fname r]}]} {
		return 0
	}
	set readfailed [catch {read $ifs}]
	return [expr {![catch {close $ifs}] && !$readfailed}]
}

# proc test_writ
#
# A test for writablity by actually writing the file. 
proc test_writ {fname} {
	if {[catch {set ofs [open $fname w]}]} {
		return 0
	}
	set writefailed [catch {puts $ofs "Hello"}]
	return [expr {![catch {close $ofs}] && !$writefailed}]
}

# proc test_access
#
# Test the readablilty and writability of a file.  Output to stdout,
# if a test does not agree with the parameters "read" or "writ".  This
# tests with [file readable/writable] as well as with [test_read] and
# test_writ].  If any differences between the test and the given
# parameters are detected, cacls is called at the end to output the
# actual rights of the file for diagnosis.
#
# See calls in [test] below.
proc test_access {fname read writ} {
	set problem 0
	foreach type {read writ} {
		if {[set $type] != [file ${type}able $fname]} {
			puts "[set $type] != \[file ${type}able $fname\]"
			set problem 1
		}
		if {[set $type] != [test_${type} $fname]} {
			puts "[set $type] != \[test_${type} $fname\]"
			set problem 1
		}
	}
	if {$problem} {
		puts "Actual rights are:"
		puts [cacls $fname]
	} else {
		puts "OK"
	}
}

# proc test
#
# A bunch of actual test scenarios. 
proc test {} {
	set fname test.dat

	# Create the test file.
	file delete $fname
	close [open $fname w]

	# Determine and print what we know about user and file owner.
	set owner [getuser $fname]
	set user $::env(USERDOMAIN)\\$::env(USERNAME)
	puts "Owner: $owner"
	puts "User: $user"

	# Clean out some ACLs well-known to be added automatically to
	# new files. Deny current user all access.
	catch {cacls $fname /E /R "Everyone"} result
	catch {cacls $fname /E /R $user} result
	catch {cacls $fname /E /R $owner} result
	cacls $fname /E /P $user:N

	# First test: Without more ACLs there should be no access.
	puts "\nTest no access"
	test_access $fname 0 0

	# Add GENERIC_READ ACL for current user.  Now there should be
	# only read access.
	puts "\nTest readable only"
	cacls $fname /E /P $user:N
	cacls $fname /E /G $user:R
	test_access $fname 1 0

	# Remove ACL for current user.  Deny access. Add GENERIC_WRITE
	# ACL.  Now there should be only write access.
	puts "\nTest writable only"
	catch {cacls $fname /E /R $user} result
	cacls $fname /E /P $user:N
	cacls $fname /E /G $user:W
	test_access $fname 0 1

	# Remove ACL for current user.  Deny access.  Add GENERIC_READ
	# ACL and GENERIC_WRITE ACL.  Now there should be both read
	# and write access.
	puts "\nTest read+write"
	catch {cacls $fname /E /R $user} result
	cacls $fname /E /P $user:N
	cacls $fname /E /G $user:R
	cacls $fname /E /G $user:W
	test_access $fname 1 1

	# Remove ACL for current user.  Deny access.  Add GENERIC_ALL
	# (full) ACL.  There should be both read and write access.
	puts "\nTest full access"
	catch {cacls $fname /E /R $user} result
	cacls $fname /E /P $user:N
	cacls $fname /E /G $user:F
	test_access $fname 1 1

	# Cleanup.
	file delete $fname
}

# ------------------------------------------------------------------------
#				eof
# ------------------------------------------------------------------------