URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [tags/] [start/] [insight/] [tix/] [library/] [UnixFile.tcl] - Blame information for rev 1765

Details | Compare with Previous | View Log


# UnixFile.tcl --
#
#       Unix file access portibility routines.
#
# Copyright (c) 1996, Expert Interface Technologies
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
 
proc tixInitFileCmpt:Unix {} {
 
# tixFSSplit --
# 
# Splits a directory into its hierarchical components
#
# "hlist-type hierachical path"         <- "vpath"
# "name"
# "directory name"                      <- "path"
#
proc tixFSSplit {dir} {
    if [string compare [tixFSPathType $dir] "absolute"] {
        error "$dir must be an absolute path"
    }
 
    set path ""
    set p ""
    foreach d [tixFileSplit $dir] {
        set p [tixFSJoin $p $d]
        lappend path [list $p $d $p]
    }
    return $path
}
 
# returns true if $dir is an valid path (always true in Unix)
#
proc tixFSValid {dir} {
    return 1
}
 
# Directory separator
#
proc tixFSSep {} {
    return "/"
}
 
# tixFSIntName
#
#       Returns the "virtual path" of a filename
#
proc tixFSIntName {dir} {
    if [string compare [tixFSPathType $dir] "absolute"] {
        error "$dir must be an absolute path"
    }
 
    return $dir
}
 
proc tixFSResolveName {p} {
    return $p
}
 
 
# These subcommands of "file" only exist in Tcl 7.5+. We define the following
# wrappers so that the code also works under Tcl 7.4
#
global tcl_version
if ![string compare $tcl_version 7.4] {
 
    proc tixFSPathType {dir} {
        if ![string compare [string index $dir 0] /] {
            return "absolute"
        }
        if ![string compare [string index $dir 0] ~] {
            return "absolute"
        }
        return "relative"
    }
 
    proc tixFSJoin {dir sub} {
        set joined $dir/$sub
 
        regsub -all {[/]+} $joined / joined
        return $joined
    }
 
} else {
    proc tixFSPathType {dir} {
        return [file pathtype $dir]
    }
 
    proc tixFSJoin {dir sub} {
        return [file join $dir $sub]
    }
}
 
# 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?
#
# return value: a list of files and/or subdirectories
#
proc tixFSListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} {
    set appPWD [pwd]
 
    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 == ""} {
        if $showHidden {
            set pattern "* .*"
        } else {
            set pattern *
        }
    } elseif {$pattern == "*"} {
        if $showHidden {
            set pattern "* .*"
        }
    }
 
    set list ""
    foreach pat $pattern {
        if [catch {set names [lsort [glob -nocomplain $pat]]} err] {
            # Cannot read directory
            # %% todo: show directory permission denied
            continue
        }
 
        catch {
            # We are catch'ing, just in case the "file" command
            # returns unexpected errors
            #
            foreach fname $names {
                if {![string compare . $fname]} {
                    continue
                }
                if [file isdirectory $fname] {
                    if {![string compare ".." $fname] && !$showPrevDir} {
                        continue
                    }
                    if $showSubDir {
                        lappend list [file tail $fname]
                    }
                } else {
                    if $showFile {
                        lappend list [file tail $fname]
                    }
                }
            }
        }
    }
 
    cd $appPWD
 
    if {[llength $pattern] > 1} {
        # get rid of duplicated names
        #
        set list1 ""
        set oldfile ""
        foreach name [lsort $list] {
            if {$name == $oldfile} {
                continue
            }
            lappend list1 $name
            set oldfile $name
        }
        return [_tixFSMakeList $dir $list1]
    } else {
        return [_tixFSMakeList $dir $list]
    }
}
 
# _tixFSMakeList -
#
#       Internal procedure. Used only by tixFSListDir
proc _tixFSMakeList {dir list} {
    set l ""
    foreach file $list {
        set path [tixFSJoin $dir $file]
        lappend l [list $path $file $path]
    }
 
    return $l
}
 
# Directory separator
#
proc tixDirSep {} {
    return "/"
}
 
 
# tixFSInfo --
#
#       Returns information about the file system of this OS
#
# hasdrives: Boolean
#       Does this file system support seperate disk drives?
#
proc tixFSInfo {args} {
    case [lindex $args 0] {
        hasdrives {
            return 0
        }
    }
}
 
#----------------------------------------------------------------------
# Obsolete
#----------------------------------------------------------------------
 
# nativeName:   native filename used in this OS, comes from the user or
#               application programmer
# defParent:    if the filename is not an absolute path, treat it as a
#               subfolder of $defParent
proc tixFileIntName {nativeName {defParent ""}} {
    if {![tixIsAbsPath $nativeName]} {
        if {$defParent != ""} {
            set path [tixSubFolder $defParent $nativeName]
        } else {
            set path $nativeName
        }
    } else {
        set path $nativeName
    }
 
    set intName ""
    set path [tixFile trimslash [tixFile tildesubst $path]]
    foreach name [tixFileSplit $path] {
        set intName [tixSubFolder $intName $name]
    }
    return $intName
}
 
proc tixNativeName {name {mustBeAbs ""}} {
    return $name
}
 
proc tixFileDisplayName {intName} {
    if {$intName == "/"} {
        return "/"
    } else {
        return [file tail $intName]
    }
}
 
 
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
    }
}
 
proc tixSubFolder {parent sub} {
    if {$parent == ""} {
        return $sub
    }
    if {$parent == "/"} {
        return /$sub
    } else {
        return $parent/$sub
    }
}
 
# 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?
#
# return value: a list of files and/or subdirectories
#
proc tixListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} {
 
    set appPWD [pwd]
 
    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 == ""} {
        if $showHidden {
            set pattern "* .*"
        } else {
            set pattern *
        }
    } elseif {$pattern == "*"} {
        if $showHidden {
            set pattern "* .*"
        }
    }
 
    set list ""
    foreach pat $pattern {
        if [catch {set names [lsort [glob -nocomplain $pat]]} err] {
            # Cannot read directory
            # %% todo: show directory permission denied
            continue
        }
 
        catch {
            # We are catch'ing, just in case the "file" command
            # returns unexpected errors
            #
            foreach fname $names {
                if {![string compare . $fname]} {
                    continue
                }
                if [file isdirectory $fname] {
                    if {![string compare ".." $fname] && !$showPrevDir} {
                        continue
                    }
                    if $showSubDir {
                        lappend list [file tail $fname]
                    }
                } else {
                    if $showFile {
                        lappend list [file tail $fname]
                    }
                }
            }
        }
    }
 
    cd $appPWD
 
    if {[llength $pattern] > 1} {
        set list1 ""
        set oldfile ""
        foreach name [lsort $list] {
            if {$name == $oldfile} {
                continue
            }
            lappend list1 $name
            set oldfile $name
        }
        return $list1
    } else {
        return $list
    }
}
 
# returns the "root directory" of this operating system
#
proc tixRootDir {} {
    return "/"
}
 
proc tixIsAbsPath {nativeName} {
    set c [string index $nativeName 0]
    if {$c == "~" || $c == "/"} {
        return 1
    } else {
        return 0
    }
}
 
proc tixVerifyFile {file} {
    return [tixFileIntName $file]
}
 
proc tixFilePattern {args} {
    if {[lsearch $args allFiles] != -1} {
        return *
    }
    return *
}
}
 
 
 
 
 

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [tags/] [start/] [insight/] [tix/] [library/] [UnixFile.tcl] - Blame information for rev 1765

Line No.	Rev	Author	Line
1	578	markom	`# UnixFile.tcl --`
2			`#`
3			`# Unix file access portibility routines.`
4			`#`
5			`# Copyright (c) 1996, Expert Interface Technologies`
6			`#`
7			`# See the file "license.terms" for information on usage and redistribution`
8			`# of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
9			`#`
10
11			`proc tixInitFileCmpt:Unix {} {`
12
13			`# tixFSSplit --`
14			`#`
15			`# Splits a directory into its hierarchical components`
16			`#`
17			`# "hlist-type hierachical path" <- "vpath"`
18			`# "name"`
19			`# "directory name" <- "path"`
20			`#`
21			`proc tixFSSplit {dir} {`
22			`if [string compare [tixFSPathType $dir] "absolute"] {`
23			`error "$dir must be an absolute path"`
24			`}`
25
26			`set path ""`
27			`set p ""`
28			`foreach d [tixFileSplit $dir] {`
29			`set p [tixFSJoin $p $d]`
30			`lappend path [list $p $d $p]`
31			`}`
32			`return $path`
33			`}`
34
35			`# returns true if $dir is an valid path (always true in Unix)`
36			`#`
37			`proc tixFSValid {dir} {`
38			`return 1`
39			`}`
40
41			`# Directory separator`
42			`#`
43			`proc tixFSSep {} {`
44			`return "/"`
45			`}`
46
47			`# tixFSIntName`
48			`#`
49			`# Returns the "virtual path" of a filename`
50			`#`
51			`proc tixFSIntName {dir} {`
52			`if [string compare [tixFSPathType $dir] "absolute"] {`
53			`error "$dir must be an absolute path"`
54			`}`
55
56			`return $dir`
57			`}`
58
59			`proc tixFSResolveName {p} {`
60			`return $p`
61			`}`
62
63
64			`# These subcommands of "file" only exist in Tcl 7.5+. We define the following`
65			`# wrappers so that the code also works under Tcl 7.4`
66			`#`
67			`global tcl_version`
68			`if ![string compare $tcl_version 7.4] {`
69
70			`proc tixFSPathType {dir} {`
71			`if ![string compare [string index $dir 0] /] {`
72			`return "absolute"`
73			`}`
74			`if ![string compare [string index $dir 0] ~] {`
75			`return "absolute"`
76			`}`
77			`return "relative"`
78			`}`
79
80			`proc tixFSJoin {dir sub} {`
81			`set joined $dir/$sub`
82
83			`regsub -all {[/]+} $joined / joined`
84			`return $joined`
85			`}`
86
87			`} else {`
88			`proc tixFSPathType {dir} {`
89			`return [file pathtype $dir]`
90			`}`
91
92			`proc tixFSJoin {dir sub} {`
93			`return [file join $dir $sub]`
94			`}`
95			`}`
96
97			`# dir: Make a listing of this directory`
98			`# showSubDir: Want to list the subdirectories?`
99			`# showFile: Want to list the non-directory files in this directory?`
100			`# showPrevDir: Want to list ".." as well?`
101			`# showHidden: Want to list the hidden files?`
102			`#`
103			`# return value: a list of files and/or subdirectories`
104			`#`
105			`proc tixFSListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} {`
106			`set appPWD [pwd]`
107
108			`if [catch {cd $dir} err] {`
109			`# The user has entered an invalid directory`
110			`# %% todo: prompt error, go back to last succeed directory`
111			`cd $appPWD`
112			`return ""`
113			`}`
114
115			`if {$pattern == ""} {`
116			`if $showHidden {`
117			`set pattern "* .*"`
118			`} else {`
119			`set pattern *`
120			`}`
121			`} elseif {$pattern == "*"} {`
122			`if $showHidden {`
123			`set pattern "* .*"`
124			`}`
125			`}`
126
127			`set list ""`
128			`foreach pat $pattern {`
129			`if [catch {set names [lsort [glob -nocomplain $pat]]} err] {`
130			`# Cannot read directory`
131			`# %% todo: show directory permission denied`
132			`continue`
133			`}`
134
135			`catch {`
136			`# We are catch'ing, just in case the "file" command`
137			`# returns unexpected errors`
138			`#`
139			`foreach fname $names {`
140			`if {![string compare . $fname]} {`
141			`continue`
142			`}`
143			`if [file isdirectory $fname] {`
144			`if {![string compare ".." $fname] && !$showPrevDir} {`
145			`continue`
146			`}`
147			`if $showSubDir {`
148			`lappend list [file tail $fname]`
149			`}`
150			`} else {`
151			`if $showFile {`
152			`lappend list [file tail $fname]`
153			`}`
154			`}`
155			`}`
156			`}`
157			`}`
158
159			`cd $appPWD`
160
161			`if {[llength $pattern] > 1} {`
162			`# get rid of duplicated names`
163			`#`
164			`set list1 ""`
165			`set oldfile ""`
166			`foreach name [lsort $list] {`
167			`if {$name == $oldfile} {`
168			`continue`
169			`}`
170			`lappend list1 $name`
171			`set oldfile $name`
172			`}`
173			`return [_tixFSMakeList $dir $list1]`
174			`} else {`
175			`return [_tixFSMakeList $dir $list]`
176			`}`
177			`}`
178
179			`# _tixFSMakeList -`
180			`#`
181			`# Internal procedure. Used only by tixFSListDir`
182			`proc _tixFSMakeList {dir list} {`
183			`set l ""`
184			`foreach file $list {`
185			`set path [tixFSJoin $dir $file]`
186			`lappend l [list $path $file $path]`
187			`}`
188
189			`return $l`
190			`}`
191
192			`# Directory separator`
193			`#`
194			`proc tixDirSep {} {`
195			`return "/"`
196			`}`
197
198
199			`# tixFSInfo --`
200			`#`
201			`# Returns information about the file system of this OS`
202			`#`
203			`# hasdrives: Boolean`
204			`# Does this file system support seperate disk drives?`
205			`#`
206			`proc tixFSInfo {args} {`
207			`case [lindex $args 0] {`
208			`hasdrives {`
209			`return 0`
210			`}`
211			`}`
212			`}`
213
214			`#----------------------------------------------------------------------`
215			`# Obsolete`
216			`#----------------------------------------------------------------------`
217
218			`# nativeName: native filename used in this OS, comes from the user or`
219			`# application programmer`
220			`# defParent: if the filename is not an absolute path, treat it as a`
221			`# subfolder of $defParent`
222			`proc tixFileIntName {nativeName {defParent ""}} {`
223			`if {![tixIsAbsPath $nativeName]} {`
224			`if {$defParent != ""} {`
225			`set path [tixSubFolder $defParent $nativeName]`
226			`} else {`
227			`set path $nativeName`
228			`}`
229			`} else {`
230			`set path $nativeName`
231			`}`
232
233			`set intName ""`
234			`set path [tixFile trimslash [tixFile tildesubst $path]]`
235			`foreach name [tixFileSplit $path] {`
236			`set intName [tixSubFolder $intName $name]`
237			`}`
238			`return $intName`
239			`}`
240
241			`proc tixNativeName {name {mustBeAbs ""}} {`
242			`return $name`
243			`}`
244
245			`proc tixFileDisplayName {intName} {`
246			`if {$intName == "/"} {`
247			`return "/"`
248			`} else {`
249			`return [file tail $intName]`
250			`}`
251			`}`
252
253
254			`proc tixFileSplit {intName} {`
255
256			`set l ""`
257			`foreach n [split $intName /] {`
258			`if {$n == ""} {`
259			`continue`
260			`}`
261			`if {$n == "."} {`
262			`continue`
263			`}`
264
265			`lappend l $n`
266			`}`
267
268
269			`while 1 {`
270			`set idx [lsearch $l ".."]`
271			`if {$idx == -1} {`
272			`break;`
273			`}`
274			`set l [lreplace $l [expr $idx -1] $idx]`
275			`}`
276
277
278			`if {[string index $intName 0] == "/"} {`
279			`return [concat "/" $l]`
280			`} else {`
281			`return $l`
282			`}`
283			`}`
284
285			`proc tixSubFolder {parent sub} {`
286			`if {$parent == ""} {`
287			`return $sub`
288			`}`
289			`if {$parent == "/"} {`
290			`return /$sub`
291			`} else {`
292			`return $parent/$sub`
293			`}`
294			`}`
295
296			`# dir: Make a listing of this directory`
297			`# showSubDir: Want to list the subdirectories?`
298			`# showFile: Want to list the non-directory files in this directory?`
299			`# showPrevDir: Want to list ".." as well?`
300			`# showHidden: Want to list the hidden files?`
301			`#`
302			`# return value: a list of files and/or subdirectories`
303			`#`
304			`proc tixListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} {`
305
306			`set appPWD [pwd]`
307
308			`if [catch {cd $dir} err] {`
309			`# The user has entered an invalid directory`
310			`# %% todo: prompt error, go back to last succeed directory`
311			`cd $appPWD`
312			`return ""`
313			`}`
314
315			`if {$pattern == ""} {`
316			`if $showHidden {`
317			`set pattern "* .*"`
318			`} else {`
319			`set pattern *`
320			`}`
321			`} elseif {$pattern == "*"} {`
322			`if $showHidden {`
323			`set pattern "* .*"`
324			`}`
325			`}`
326
327			`set list ""`
328			`foreach pat $pattern {`
329			`if [catch {set names [lsort [glob -nocomplain $pat]]} err] {`
330			`# Cannot read directory`
331			`# %% todo: show directory permission denied`
332			`continue`
333			`}`
334
335			`catch {`
336			`# We are catch'ing, just in case the "file" command`
337			`# returns unexpected errors`
338			`#`
339			`foreach fname $names {`
340			`if {![string compare . $fname]} {`
341			`continue`
342			`}`
343			`if [file isdirectory $fname] {`
344			`if {![string compare ".." $fname] && !$showPrevDir} {`
345			`continue`
346			`}`
347			`if $showSubDir {`
348			`lappend list [file tail $fname]`
349			`}`
350			`} else {`
351			`if $showFile {`
352			`lappend list [file tail $fname]`
353			`}`
354			`}`
355			`}`
356			`}`
357			`}`
358
359			`cd $appPWD`
360
361			`if {[llength $pattern] > 1} {`
362			`set list1 ""`
363			`set oldfile ""`
364			`foreach name [lsort $list] {`
365			`if {$name == $oldfile} {`
366			`continue`
367			`}`
368			`lappend list1 $name`
369			`set oldfile $name`
370			`}`
371			`return $list1`
372			`} else {`
373			`return $list`
374			`}`
375			`}`
376
377			`# returns the "root directory" of this operating system`
378			`#`
379			`proc tixRootDir {} {`
380			`return "/"`
381			`}`
382
383			`proc tixIsAbsPath {nativeName} {`
384			`set c [string index $nativeName 0]`
385			`if {$c == "~" \|\| $c == "/"} {`
386			`return 1`
387			`} else {`
388			`return 0`
389			`}`
390			`}`
391
392			`proc tixVerifyFile {file} {`
393			`return [tixFileIntName $file]`
394			`}`
395
396			`proc tixFilePattern {args} {`
397			`if {[lsearch $args allFiles] != -1} {`
398			`return *`
399			`}`
400			`return *`
401			`}`
402			`}`
403
404
405
406
407