Viewing file:  WinFile.tcl (13.86 KB) -rw-r--r--
Select action/file-type:
 (+) |  (+) |  (+) | Code (+) | Session (+) |  (+) | SDB (+) |  (+) |  (+) |  (+) |  (+) |  (+) |
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
#
# $Id: WinFile.tcl,v 1.4.2.1 2001/11/03 07:26:10 idiscovery Exp $
#
# WinFile.tcl --
#
# MS Window file access portibility routines.
#
# Copyright (c) 1993-1999 Ioi Kim Lam.
# Copyright (c) 2000-2001 Tix Project Group.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
proc tixInitFileCmpt:Win {} {
global tixPriv tcl_platform
if {$tcl_platform(osVersion) >= 4.0} {
set tixPriv(isWin95) 1
} else {
set tixPriv(isWin95) 0
}
if {$tixPriv(isWin95)} {
set tixPriv(WinPrefix) xx\\xx
} else {
set tixPriv(WinPrefix) xx
}
#----------------------------------------------------------------------
#
# MS Windows
#
#----------------------------------------------------------------------
# splits a Windows directory into its hierarchical components
#
proc tixFSSplit {vpath} {
global tixPriv
set path ""
if $tixPriv(isWin95) {
if {![string compare $vpath xx]} {
lappend path [list xx "Desktop" "C:\\Windows\\Desktop" ]
return $path
}
if {![string compare $vpath xx\\xx]} {
lappend path [list xx "Desktop" "C:\\Windows\\Desktop" ]
lappend path [list xx\\xx "My Computer" "C:\\"]
return $path
}
set prefix "xx\\xx"
if {![regsub -- {^xx\\xx\\} $vpath "" dir]} {
if {[regsub -- {^xx\\} $vpath "" dir]} {
lappend path [list xx "Desktop" "C:\\Windows\\Desktop" ]
set v "xx"
set p "C:\\Windows\\Desktop"
foreach d [split $dir \\] {
append v \\$d
append p \\$d
lappend path [list $v $d $p]
}
return $path
}
}
regsub -- {:$} $dir :/ dir
lappend path [list xx "Desktop" "C:\\Windows\\Desktop" ]
lappend path [list xx\\xx "My Computer" "C:\\"]
} else {
if {![string compare $vpath xx]} {
lappend path [list xx "My Computer" "C:\\"]
return $path
}
lappend path [list xx "My Computer" "C:\\"]
set prefix xx
regsub -- {^xx\\} $vpath "" dir
regsub -- {:$} $dir :/ dir
}
if {![string compare $dir ""]} {
return $path
}
if {[string compare [file pathtype $dir] "absolute"]} {
error "$dir must be an absolute path"
}
set dirs [file split $dir]
set p ""
foreach d $dirs {
set p [file join $p $d]
regsub -all / $p \\ p
set vpath $prefix\\$p
regsub -- {[\\]$} $vpath "" vpath
regsub -- {:/$} $d ":" d
lappend path [list $vpath $d $p]
}
return $path
}
# returns true if $dir is an valid path (not equal to "")
#
proc tixFSValid {dir} {
return [expr ![string compare $dir ""]]
}
# tixFSIntName
#
# Returns the "virtual path" of a filename
#
proc tixFSIntName {dir} {
global tixPriv
if {![string compare $dir ""]} {
if $tixPriv(isWin95) {
return "xx\\xx"
} else {
return xx
}
}
if {[string compare [file pathtype $dir] "absolute"]} {
error "$dir must be an absolute path"
}
if $tixPriv(isWin95) {
set vpath "xx\\xx\\$dir"
} else {
set vpath "xx\\$dir"
}
regsub -- {:/$} $vpath ":" vpath
regsub -- {[\\]$} $vpath "" vpath
return $vpath
}
proc tixFSIntJoin {dir sub} {
set vpath $dir\\$sub
regsub -all {\\\\} $vpath \\ vpath
regsub -- {:/$} $vpath : vpath
regsub -- {[\\]$} $vpath "" vpath
return $vpath
}
proc tixFSJoin {dir sub} {
set p [file join $dir $sub]
regsub -all / $p \\ p
return $p
}
proc tixFSResolveName {p} {
regsub -all / $p \\ p
if {[regexp -- {:([^\\]|$)} $p]} {
regsub : $p :\\ p
}
return $p
}
# dir: Make a listing of this directory
# showSubDir: Want to list the subdirectories?
# showFile: Want to list the non-directory files in this directory?
# showPrevDir: Want to list ".." as well?
# showHidden: Want to list the hidden files? (%% is ignored)
#
# return value: a list of files and/or subdirectories
#
proc tixFSListDir {vpath showSubDir showFile showPrevDir showHidden {pattern ""}} {
global tixPriv
set appPWD [pwd]
set list ""
if $tixPriv(isWin95) {
if {![string compare $vpath xx]} {
set dir C:\\Windows\\Desktop
if {$showSubDir} {
lappend list xx:
}
} elseif {![string compare $vpath xx\\xx]} {
if {$showSubDir} {
return [tixFSGetDrives]
} else {
return ""
}
} else {
if {![regsub -- {^xx\\xx\\} $vpath "" dir]} {
regsub -- {^xx\\} $vpath C:\\Windows\\Desktop\\ dir
}
regsub -- {:$} $dir :\\ dir
}
} else {
if {![string compare $vpath xx]} {
if {$showSubDir} {
return [tixFSGetDrives]
} else {
return ""
}
}
regsub -- {^xx\\} $vpath "" dir
regsub -- {:$} $dir :\\ dir
}
if {[catch {cd $dir} err]} {
# The user has entered an invalid directory
# %% todo: prompt error, go back to last succeed directory
cd $appPWD
return ""
}
if {$pattern == ""} {
set pattern "*"
}
if {[catch {set names [lsort [eval glob -nocomplain $pattern]]} err]} {
# Cannot read directory
# %% todo: show directory permission denied
cd $appPWD
return ""
}
catch {
# We are catch'ing, just in case the "file" command returns unexpected
# errors
#
foreach fname $names {
if {![string compare . $fname]} {
continue
}
if {![string compare ".." $fname]} {
continue
}
if {[file isdirectory $fname]} {
if $showSubDir {
lappend list [file tail $fname]
}
} else {
if $showFile {
lappend list [file tail $fname]
}
}
}
}
cd $appPWD
if {$showSubDir && $showPrevDir && $dir != "/"} {
return [tixFSMakeList $vpath $dir [lsort [concat .. $list]]]
} else {
return [tixFSMakeList $vpath $dir $list]
}
}
proc tixFSMakeList {vpath dir list} {
global tixPriv
if $tixPriv(isWin95) {
set prefix xx\\xx
} else {
set prefix xx
}
set l ""
foreach file $list {
if {![string compare $file xx:]} {
lappend l [list xx\\xx "My Computer" "C:\\"]
} else {
set path [tixFSJoin $dir $file]
lappend l [list $vpath\\$file $file $path]
}
}
return $l
}
proc tixFSSep {} {
return "\\"
}
proc tixFSGetDrives {} {
global tixPriv
if {[info exists tixPriv(drives)]} {
return $tixPriv(drives)
} else {
set drives [list A: B:]
foreach d {c d e f g h i j k l m n o p q r s t u v w x y z} {
if {[file exists $d:\\]} {
lappend drives [string toupper $d:]
}
}
set tixPriv(drives) ""
foreach d $drives {
lappend tixPriv(drives) [list $tixPriv(WinPrefix)\\$d $d $d\\]
}
}
return $tixPriv(drives)
}
#----------------------------------------------------------------------
#
# OBSOLETE
#
#----------------------------------------------------------------------
# Directory separator
#
proc tixDirSep {} {
return "\\"
}
# returns the "root directory" of this operating system
#
# out: intName
proc tixRootDir {} {
return "/"
}
# is an absoulte path only if it starts with a baclskash
# or starts with "<drive letter>:"
#
# in: nativeName
#
proc tixIsAbsPath {nativeName} {
set c [string index $nativeName 0]
if {$c == "\\"} {
return 1
}
if {[string compare [string toupper $c] A] < 0} {
return 0
}
if {[string compare [string toupper $c] Z] > 0} {
return 0
}
if {[string index $nativeName 1] != ":"} {
return 0
}
return 1
}
# returns <drive>:
#
proc tixWinGetFileDrive {nativeName} {
set c [string index $nativeName 0]
if {$c == "\\"} {
return [string toupper [string range [pwd] 0 1]]
}
if {[string compare [string toupper $c] A] < 0} {
return [string toupper [string range [pwd] 0 1]]
}
if {[string compare [string toupper $c] Z] > 0} {
return [string toupper [string range [pwd] 0 1]]
}
if {[string index $nativeName 1] != ":"} {
return [string toupper [string range [pwd] 0 1]]
}
return [string toupper [string range $nativeName 0 1]]
}
# returns the absolute pathname of the file
# (not including the drive letter or the first backslash)
#
# [tixWinGetFileDrive]\\[tixWinGetFilePath] gives the complete
# drive and pathname
#
proc tixWinGetFilePath {nativeName} {
set c [string index $nativeName 0]
if {$c == "\\"} {
return ""
}
if {[string compare [string toupper $c] A] < 0} {
return [tixWinGetPathFromDrive $nativeName]
}
if {[string compare [string toupper $c] Z] > 0} {
return [tixWinGetPathFromDrive $nativeName]
}
if {[string index $nativeName 1] != ":"} {
return [tixWinGetPathFromDrive $nativeName]
}
if {[string index $nativeName 2] != "\\"} {
regexp -- {[A-z]:} $nativeName drive
regsub -- {[A-z]:} $nativeName "" path
return [tixWinGetPathFromDrive $path $drive]
}
regsub -- {[A-z]:[\\]} $nativeName "" path
return $path
}
proc tixWinCurrentDrive {} {
return [string range [pwd] 0 1]
}
proc tixWinGetPathFromDrive {path {drive ""}} {
if {$drive == ""} {
set drive [tixWinCurrentDrive]
}
#
# %% currently TCL (7.5b3) does not tell what the current path
# on a particular drive is
return $path
}
#
#
# nativeName: native filename used in this OS, comes from the user or
# application programmer
# defParent: (intName) if the filename is not an absolute path,
# treat it as a subfolder of $defParent
# (must be an intName, must be absolute)
proc tixFileIntName {nativeName {defParent ""}} {
if {![tixIsAbsPath $nativeName]} {
if {$defParent != ""} {
if {[string index $defParent 0] != "/"} {
error "Tix toolkit error: \"$defParent\" is not an absolute internal file name"
}
set path [tixSubFolder $defParent $nativeName]
} else {
set path $nativeName
}
} else {
set path /[tixWinGetFileDrive $nativeName]\\[tixWinGetFilePath $nativeName]
}
set intName ""
foreach name [tixFileSplit $path] {
set intName [tixSubFolder $intName $name]
}
return $intName
}
# in: internal name
# out: native name
proc tixNativeName {intName {mustBeAbs 1}} {
if {[string index $intName 0] != "/"} {
if {$mustBeAbs} {
error "Tix internal error: \"$intName\" is not an intName"
} else {
return $intName
}
}
if {$intName == "/"} {
return C:\\
}
regsub -- {/[\\]} $intName "" nativeName
if {[string length $nativeName] == 2} {
return $nativeName\\
} else {
return $nativeName
}
}
# how a filename should be displayed
#
# e.g. /\C: becomes C:\\
# /\ becomes "My Computer"
# /\C:\\Windows is Windows
proc tixFileDisplayName {intName} {
if {[string index $intName 0] != "/"} {
error "Tix internal error: \"$intName\" is not an intName"
}
if {$intName == "/"} {
return "My Computer"
}
regsub -- {/[\\]} $intName "" nativeName
if {[string length $nativeName] == 2} {
return [string toupper $nativeName\\]
} else {
return [file tail $nativeName]
}
}
# in: internal name
# out: a list of paths
proc tixFileSplit {intName} {
set l ""
foreach n [split $intName /\\] {
if {$n == ""} {
continue
}
if {$n == "."} {
continue
}
lappend l $n
}
while {1} {
set idx [lsearch $l ".."]
if {$idx == -1} {
break;
}
set l [lreplace $l [expr $idx -1] $idx]
}
if {[string index $intName 0] == "/"} {
return [concat "/" $l]
} else {
return $l
}
}
# parent, sub: intName
#
proc tixSubFolder {parent sub} {
if {$parent == ""} {
return $sub
}
return $parent\\$sub
}
proc tixWinGetDrives {} {
global tixPriv
if {[info exists tixPriv(drives)]} {
return $tixPriv(drives)
} else {
set tixPriv(drives) {A: B:}
foreach d {c e d f g h i j k l m n o p q r s t u v w x y z} {
if {[file exists $d:]} {
lappend tixPriv(drives) [string toupper $d:]
}
}
}
return $tixPriv(drives)
}
# dir: Make a listing of this directory
# showSubDir: Want to list the subdirectories?
# showFile: Want to list the non-directory files in this directory?
# showPrevDir: Want to list ".." as well?
# showHidden: Want to list the hidden files? (%% is ignored)
#
# return value: a list of files and/or subdirectories
#
proc tixListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} {
set appPWD [pwd]
if {$dir == "/"} {
if {$showSubDir} {
return [tixWinGetDrives]
} else {
return ""
}
}
if {[catch {cd [tixNativeName $dir]} err]} {
# The user has entered an invalid directory
# %% todo: prompt error, go back to last succeed directory
cd $appPWD
return ""
}
if {$pattern == ""} {
set pattern "*"
}
if {[catch {set names [lsort [eval glob -nocomplain $pattern]]} err]} {
# Cannot read directory
# %% todo: show directory permission denied
cd $appPWD
return ""
}
set list ""
catch {
# We are catch'ing, just in case the "file" command returns unexpected
# errors
#
foreach fname $names {
if {![string compare . $fname]} {
continue
}
if {![string compare ".." $fname]} {
continue
}
if {[file isdirectory $fname]} {
if $showSubDir {
lappend list [file tail $fname]
}
} else {
if $showFile {
lappend list [file tail $fname]
}
}
}
}
cd $appPWD
if {$showSubDir && $showPrevDir && $dir != "/"} {
return [lsort [concat .. $list]]
} else {
return $list
}
}
proc tixVerifyFile {file} {
return [tixFileIntName $file]
}
proc tixFilePattern {args} {
if {[lsearch $args allFiles] != -1} {
return *
}
return *
}
}
# tixWinFileEmu --
#
# Emulates a MS Windows file system environemnt inside Unix
#
proc tixWinFileEmu {} {
cd /mnt/c
rename pwd __pwd
rename cd __cd
proc EmuConvert {path} {
if {[regsub ^/mnt/c/ $path c:/ path]} {
return $path
}
if {[regsub ^/mnt/d/ $path d:/ path]} {
return $path
}
if {[regsub ^/mnt/c\$ $path c:/ path]} {
return $path
}
if {[regsub ^/mnt/d\$ $path d:/ path]} {
return $path
}
return c:/windows
}
proc pwd {} {
return [EmuConvert [__pwd]]
}
proc glob {args} {
}
}
|