home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 November / CPNL0711.ISO / beeld / teken / scribus-1.3.3.9-win32-install.exe / tcl / tix8.1 / WinFile.tcl < prev    next >
Text File  |  2001-11-03  |  15KB  |  654 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: WinFile.tcl,v 1.4.2.1 2001/11/03 07:26:10 idiscovery Exp $
  4. #
  5. # WinFile.tcl --
  6. #
  7. #    MS Window file access portibility routines.
  8. #
  9. # Copyright (c) 1993-1999 Ioi Kim Lam.
  10. # Copyright (c) 2000-2001 Tix Project Group.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. proc tixInitFileCmpt:Win {} {
  17.     global tixPriv tcl_platform
  18.  
  19.     if {$tcl_platform(osVersion) >= 4.0} {
  20.     set tixPriv(isWin95) 1
  21.     } else {
  22.     set tixPriv(isWin95) 0
  23.     }
  24.     if {$tixPriv(isWin95)} {
  25.     set tixPriv(WinPrefix) xx\\xx
  26.     } else {
  27.     set tixPriv(WinPrefix) xx
  28.     }
  29.  
  30. #----------------------------------------------------------------------
  31. #
  32. #        MS Windows
  33. #
  34. #----------------------------------------------------------------------
  35.  
  36. # splits a Windows directory into its hierarchical components
  37. #
  38. proc tixFSSplit {vpath} {
  39.     global tixPriv
  40.  
  41.     set path ""
  42.     if $tixPriv(isWin95) {
  43.     if {![string compare $vpath xx]} {
  44.         lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  45.         return $path
  46.     }
  47.     if {![string compare $vpath xx\\xx]} {
  48.         lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  49.         lappend path [list xx\\xx "My Computer" "C:\\"]
  50.         return $path
  51.     }
  52.  
  53.     set prefix "xx\\xx"
  54.     if {![regsub -- {^xx\\xx\\} $vpath "" dir]} {
  55.         if {[regsub -- {^xx\\} $vpath "" dir]} {
  56.         lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  57.         set v "xx"
  58.         set p "C:\\Windows\\Desktop"
  59.         foreach d [split $dir \\] {
  60.             append v \\$d
  61.             append p \\$d
  62.             lappend path [list $v $d $p]
  63.         }
  64.         return $path
  65.         }
  66.     }
  67.     regsub -- {:$} $dir :/ dir
  68.     lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  69.     lappend path [list xx\\xx "My Computer" "C:\\"]
  70.     } else {
  71.     if {![string compare $vpath xx]} {
  72.         lappend path [list xx     "My Computer" "C:\\"]
  73.         return $path
  74.     }
  75.     lappend path [list xx     "My Computer" "C:\\"]
  76.  
  77.     set prefix xx
  78.     regsub -- {^xx\\} $vpath "" dir
  79.     regsub -- {:$} $dir :/ dir
  80.     }
  81.  
  82.     if {![string compare $dir ""]} {
  83.     return $path
  84.     }
  85.     if {[string compare [file pathtype $dir] "absolute"]} {
  86.     error "$dir must be an absolute path"
  87.     }
  88.  
  89.     set dirs [file split $dir]
  90.     set p ""
  91.     foreach d $dirs {
  92.     set p [file join $p $d]
  93.     regsub -all / $p \\ p
  94.     set vpath $prefix\\$p
  95.     regsub -- {[\\]$} $vpath "" vpath
  96.     regsub -- {:/$} $d ":" d
  97.     lappend path [list $vpath $d $p]
  98.     }
  99.  
  100.     return $path
  101. }
  102.  
  103. # returns true if $dir is an valid path (not equal to "")
  104. #
  105. proc tixFSValid {dir} {
  106.     return [expr ![string compare $dir ""]]
  107. }
  108.  
  109. # tixFSIntName
  110. #
  111. #    Returns the "virtual path" of a filename
  112. #
  113. proc tixFSIntName {dir} {
  114.     global tixPriv
  115.  
  116.     if {![string compare $dir ""]} {
  117.     if $tixPriv(isWin95) {
  118.         return "xx\\xx"
  119.     } else {
  120.         return xx
  121.     }
  122.     }
  123.         
  124.     if {[string compare [file pathtype $dir] "absolute"]} {
  125.     error "$dir must be an absolute path"
  126.     }
  127.  
  128.     if $tixPriv(isWin95) {
  129.         set vpath "xx\\xx\\$dir"
  130.     } else {
  131.         set vpath "xx\\$dir"
  132.     }
  133.     regsub -- {:/$} $vpath ":" vpath
  134.     regsub -- {[\\]$} $vpath "" vpath
  135.     return $vpath
  136. }
  137.  
  138. proc tixFSIntJoin {dir sub} {
  139.     set vpath $dir\\$sub
  140.     regsub -all {\\\\} $vpath \\ vpath
  141.     regsub -- {:/$} $vpath : vpath
  142.     regsub -- {[\\]$} $vpath "" vpath
  143.     return $vpath
  144. }
  145.  
  146. proc tixFSJoin {dir sub} {
  147.     set p [file join $dir $sub]
  148.     regsub -all / $p \\ p
  149.     return $p
  150. }
  151.  
  152. proc tixFSResolveName {p} {
  153.     regsub -all / $p \\ p
  154.     if {[regexp -- {:([^\\]|$)} $p]} {
  155.     regsub : $p :\\ p
  156.     }
  157.     return $p
  158. }
  159.  
  160. # dir:        Make a listing of this directory
  161. # showSubDir:    Want to list the subdirectories?
  162. # showFile:    Want to list the non-directory files in this directory?
  163. # showPrevDir:    Want to list ".." as well?
  164. # showHidden:    Want to list the hidden files? (%% is ignored)
  165. #
  166. # return value:    a list of files and/or subdirectories
  167. #
  168. proc tixFSListDir {vpath showSubDir showFile showPrevDir showHidden {pattern ""}} {
  169.     global tixPriv
  170.     set appPWD [pwd]
  171.     set list ""
  172.  
  173.     if $tixPriv(isWin95) {
  174.     if {![string compare $vpath xx]} {
  175.         set dir C:\\Windows\\Desktop
  176.         if {$showSubDir} {
  177.         lappend list xx:
  178.         }
  179.     } elseif {![string compare $vpath xx\\xx]} {
  180.         if {$showSubDir} {
  181.         return [tixFSGetDrives]
  182.         } else {
  183.         return ""
  184.         }
  185.     } else {
  186.         if {![regsub -- {^xx\\xx\\} $vpath "" dir]} {
  187.         regsub -- {^xx\\} $vpath C:\\Windows\\Desktop\\ dir
  188.         }
  189.         regsub -- {:$} $dir :\\ dir
  190.     }
  191.     } else {
  192.     if {![string compare $vpath xx]} {
  193.         if {$showSubDir} {
  194.         return [tixFSGetDrives]
  195.         } else {
  196.         return ""
  197.         }
  198.     }
  199.  
  200.     regsub -- {^xx\\} $vpath "" dir
  201.     regsub -- {:$} $dir :\\ dir
  202.     }
  203.  
  204.     if {[catch {cd $dir} err]} {
  205.     # The user has entered an invalid directory
  206.     # %% todo: prompt error, go back to last succeed directory
  207.     cd $appPWD
  208.     return ""
  209.     }
  210.  
  211.     if {$pattern == ""} {
  212.     set pattern "*"
  213.     }
  214.  
  215.     if {[catch {set names [lsort [eval glob -nocomplain $pattern]]} err]} {
  216.     # Cannot read directory
  217.     # %% todo: show directory permission denied
  218.     cd $appPWD
  219.     return ""
  220.     }
  221.  
  222.     catch {
  223.     # We are catch'ing, just in case the "file" command returns unexpected
  224.     # errors
  225.     #
  226.     foreach fname $names {
  227.         if {![string compare . $fname]} {
  228.         continue
  229.         }
  230.         if {![string compare ".." $fname]} {
  231.         continue
  232.         }
  233.         if {[file isdirectory $fname]} {
  234.         if $showSubDir {
  235.             lappend list [file tail $fname]
  236.         }
  237.         } else {
  238.         if $showFile {
  239.             lappend list [file tail $fname]
  240.         }
  241.         }
  242.     }
  243.     }
  244.     cd $appPWD
  245.  
  246.     if {$showSubDir && $showPrevDir && $dir != "/"} {
  247.     return [tixFSMakeList $vpath $dir [lsort [concat .. $list]]]
  248.     } else {
  249.     return [tixFSMakeList $vpath $dir $list]
  250.     }
  251. }
  252.  
  253. proc tixFSMakeList {vpath dir list} {
  254.     global tixPriv
  255.  
  256.     if $tixPriv(isWin95) {
  257.     set prefix xx\\xx
  258.     } else {
  259.     set prefix xx
  260.     }
  261.     set l ""
  262.     foreach file $list {
  263.     if {![string compare $file xx:]} {
  264.          lappend l [list xx\\xx "My Computer" "C:\\"]
  265.     } else {
  266.         set path [tixFSJoin $dir $file]
  267.         lappend l [list $vpath\\$file $file $path]
  268.     }
  269.     }
  270.  
  271.     return $l
  272. }
  273.  
  274. proc tixFSSep {} {
  275.     return "\\"
  276. }
  277.  
  278. proc tixFSGetDrives {} {
  279.     global tixPriv
  280.  
  281.     if {[info exists tixPriv(drives)]} {
  282.     return $tixPriv(drives)
  283.     } else {
  284.     set drives [list A: B:]
  285.     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} {
  286.         if {[file exists $d:\\]} {
  287.         lappend drives [string toupper $d:]
  288.         }
  289.     }
  290.  
  291.     set tixPriv(drives) ""
  292.     foreach d $drives {
  293.          lappend tixPriv(drives) [list $tixPriv(WinPrefix)\\$d $d $d\\]
  294.     }
  295.     }
  296.     return $tixPriv(drives)
  297. }
  298.  
  299. #----------------------------------------------------------------------
  300. #
  301. #        OBSOLETE
  302. #
  303. #----------------------------------------------------------------------
  304.  
  305.  
  306.  
  307. # Directory separator
  308. #
  309. proc tixDirSep {} {
  310.     return "\\"
  311. }
  312.  
  313. # returns the "root directory" of this operating system
  314. #
  315. # out:    intName
  316. proc tixRootDir {} {
  317.     return "/"
  318. }
  319.  
  320. # is an absoulte path only if it starts with a baclskash
  321. # or starts with "<drive letter>:"
  322. #
  323. # in: nativeName
  324. #
  325. proc tixIsAbsPath {nativeName} {
  326.     set c [string index $nativeName 0]
  327.     if {$c == "\\"} {
  328.     return 1
  329.     }
  330.  
  331.     if {[string compare [string toupper $c] A] < 0} {
  332.     return 0
  333.     }
  334.     if {[string compare [string toupper $c] Z] > 0} {
  335.     return 0
  336.     }
  337.     if {[string index $nativeName 1] != ":"} {
  338.     return 0
  339.     }
  340.     return 1
  341. }
  342.  
  343. # returns <drive>:
  344. #
  345. proc tixWinGetFileDrive {nativeName} {
  346.     set c [string index $nativeName 0]
  347.     if {$c == "\\"} {
  348.     return [string toupper [string range [pwd] 0 1]]
  349.     }
  350.  
  351.     if {[string compare [string toupper $c] A] < 0} {
  352.     return [string toupper [string range [pwd] 0 1]]
  353.     }
  354.     if {[string compare [string toupper $c] Z] > 0} {
  355.     return [string toupper [string range [pwd] 0 1]]
  356.     }
  357.     if {[string index $nativeName 1] != ":"} {
  358.     return [string toupper [string range [pwd] 0 1]]
  359.     }
  360.     return [string toupper [string range $nativeName 0 1]]
  361. }
  362.  
  363. # returns the absolute pathname of the file 
  364. # (not including the drive letter or the first backslash)
  365. #
  366. # [tixWinGetFileDrive]\\[tixWinGetFilePath] gives the complete
  367. # drive and pathname
  368. #
  369. proc tixWinGetFilePath {nativeName} {
  370.     set c [string index $nativeName 0]
  371.     if {$c == "\\"} {
  372.     return ""
  373.     }
  374.  
  375.     if {[string compare [string toupper $c] A] < 0} {
  376.     return [tixWinGetPathFromDrive $nativeName]
  377.     }
  378.     if {[string compare [string toupper $c] Z] > 0} {
  379.     return [tixWinGetPathFromDrive $nativeName]
  380.     }
  381.     if {[string index $nativeName 1] != ":"} {
  382.     return [tixWinGetPathFromDrive $nativeName]
  383.     }
  384.     if {[string index $nativeName 2] != "\\"} {
  385.         regexp -- {[A-z]:} $nativeName drive
  386.     regsub -- {[A-z]:} $nativeName "" path
  387.     return [tixWinGetPathFromDrive $path $drive]
  388.     }
  389.  
  390.     regsub -- {[A-z]:[\\]} $nativeName "" path
  391.     return $path
  392. }
  393.  
  394. proc tixWinCurrentDrive {} {
  395.     return [string range [pwd] 0 1]
  396. }
  397.  
  398. proc tixWinGetPathFromDrive {path {drive ""}} {
  399.     if {$drive == ""} {
  400.         set drive [tixWinCurrentDrive]
  401.     }
  402.  
  403.     #
  404.     # %% currently TCL (7.5b3) does not tell what the current path
  405.     #    on a particular drive is
  406.  
  407.     return $path
  408. }
  409.  
  410. #
  411. #
  412. # nativeName:    native filename used in this OS, comes from the user or
  413. #        application programmer
  414. # defParent:    (intName) if the filename is not an absolute path,
  415. #        treat it as a subfolder of $defParent
  416. #        (must be an intName, must be absolute)
  417. proc tixFileIntName {nativeName {defParent ""}} {
  418.     if {![tixIsAbsPath $nativeName]} {
  419.         if {$defParent != ""} {
  420.         if {[string index $defParent 0] != "/"} {
  421.             error "Tix toolkit error: \"$defParent\" is not an absolute internal file name"
  422.         }
  423.         set path [tixSubFolder $defParent $nativeName]
  424.     } else {
  425.         set path $nativeName
  426.     }
  427.     } else {
  428.     set path /[tixWinGetFileDrive $nativeName]\\[tixWinGetFilePath $nativeName]
  429.     }
  430.  
  431.     set intName ""
  432.     foreach name [tixFileSplit $path] {
  433.     set intName [tixSubFolder $intName $name]
  434.     }
  435.  
  436.     return $intName
  437. }
  438.  
  439. # in:    internal name
  440. # out:    native name
  441. proc tixNativeName {intName {mustBeAbs 1}} {
  442.     if {[string index $intName 0] != "/"} {
  443.         if {$mustBeAbs} {
  444.             error "Tix internal error: \"$intName\" is not an intName"
  445.     } else {
  446.         return $intName
  447.     }
  448.     }
  449.     if {$intName == "/"} {
  450.         return C:\\
  451.     }
  452.     regsub -- {/[\\]} $intName "" nativeName
  453.     if {[string length $nativeName] == 2} {
  454.         return $nativeName\\
  455.     } else {
  456.         return $nativeName
  457.     }
  458. }
  459.  
  460. # how a filename should be displayed
  461. # 
  462. # e.g. /\C: becomes C:\\
  463. #      /\   becomes "My Computer"
  464. #      /\C:\\Windows is Windows
  465. proc tixFileDisplayName {intName} {
  466.     if {[string index $intName 0] != "/"} {
  467.         error "Tix internal error: \"$intName\" is not an intName"
  468.     }
  469.  
  470.     if {$intName == "/"} {
  471.         return "My Computer"
  472.     }
  473.  
  474.     regsub -- {/[\\]} $intName "" nativeName
  475.  
  476.     if {[string length $nativeName] == 2} {
  477.         return [string toupper $nativeName\\]
  478.     } else {
  479.         return [file tail $nativeName]
  480.     }
  481. }
  482.  
  483. # in:    internal name
  484. # out:    a list of paths
  485. proc tixFileSplit {intName} {
  486.  
  487.     set l ""
  488.     foreach n [split $intName /\\] {
  489.     if {$n == ""} {
  490.         continue
  491.     }
  492.     if {$n == "."} {
  493.         continue
  494.     }
  495.  
  496.     lappend l $n
  497.     }
  498.     
  499.  
  500.     while {1} {
  501.     set idx [lsearch $l ".."]
  502.     if {$idx == -1} {
  503.         break;
  504.     }
  505.     set l [lreplace $l [expr $idx -1] $idx]
  506.     }
  507.  
  508.  
  509.     if {[string index $intName 0] == "/"} {
  510.     return [concat "/" $l]
  511.     } else {
  512.     return $l
  513.     }
  514. }
  515.  
  516. # parent, sub:    intName
  517. #
  518. proc tixSubFolder {parent sub} {
  519.     if {$parent == ""} {
  520.     return $sub
  521.     }
  522.     return $parent\\$sub
  523. }
  524.  
  525. proc tixWinGetDrives {} {
  526.     global tixPriv
  527.  
  528.     if {[info exists tixPriv(drives)]} {
  529.     return $tixPriv(drives)
  530.     } else {
  531.     set tixPriv(drives) {A: B:}
  532.         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} {
  533.         if {[file exists $d:]} {
  534.         lappend tixPriv(drives) [string toupper $d:]
  535.         }
  536.         }
  537.     }
  538.     return $tixPriv(drives)
  539. }
  540.  
  541. # dir:        Make a listing of this directory
  542. # showSubDir:    Want to list the subdirectories?
  543. # showFile:    Want to list the non-directory files in this directory?
  544. # showPrevDir:    Want to list ".." as well?
  545. # showHidden:    Want to list the hidden files? (%% is ignored)
  546. #
  547. # return value:    a list of files and/or subdirectories
  548. #
  549. proc tixListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} { 
  550.     set appPWD [pwd]
  551.  
  552.     if {$dir == "/"} {
  553.     if {$showSubDir} {
  554.         return [tixWinGetDrives]
  555.         } else {
  556.         return ""
  557.     }
  558.     }
  559.  
  560.     if {[catch {cd [tixNativeName $dir]} err]} {
  561.     # The user has entered an invalid directory
  562.     # %% todo: prompt error, go back to last succeed directory
  563.     cd $appPWD
  564.     return ""
  565.     }
  566.  
  567.     if {$pattern == ""} {
  568.     set pattern "*"
  569.     }
  570.  
  571.     if {[catch {set names [lsort [eval glob -nocomplain $pattern]]} err]} {
  572.     # Cannot read directory
  573.     # %% todo: show directory permission denied
  574.     cd $appPWD
  575.     return ""
  576.     }
  577.  
  578.     set list ""
  579.     catch {
  580.     # We are catch'ing, just in case the "file" command returns unexpected
  581.     # errors
  582.     #
  583.      foreach fname $names {
  584.         if {![string compare . $fname]} {
  585.         continue
  586.         }
  587.          if {![string compare ".." $fname]} {
  588.             continue
  589.         }
  590.         if {[file isdirectory $fname]} {
  591.         if $showSubDir {
  592.             lappend list [file tail $fname]
  593.         }
  594.         } else {
  595.         if $showFile {
  596.             lappend list [file tail $fname]
  597.         }
  598.         }
  599.     }
  600.     }
  601.     cd $appPWD
  602.  
  603.     if {$showSubDir && $showPrevDir && $dir != "/"} {
  604.     return [lsort [concat .. $list]]
  605.     } else {
  606.         return $list
  607.     }
  608. }
  609.  
  610. proc tixVerifyFile {file} {
  611.     return [tixFileIntName $file]
  612. }
  613.  
  614. proc tixFilePattern {args} {
  615.     if {[lsearch $args allFiles] != -1} {
  616.     return *
  617.     }
  618.     return *
  619. }
  620.  
  621. }
  622.  
  623. # tixWinFileEmu --
  624. #
  625. #    Emulates a MS Windows file system environemnt inside Unix
  626. #
  627. proc tixWinFileEmu {} {
  628.     cd /mnt/c
  629.     rename pwd __pwd
  630.     rename cd  __cd
  631.     proc EmuConvert {path} {
  632.     if {[regsub ^/mnt/c/ $path c:/ path]} {
  633.         return $path
  634.     }
  635.     if {[regsub ^/mnt/d/ $path d:/ path]} {
  636.         return $path
  637.     }
  638.     if {[regsub ^/mnt/c\$ $path c:/ path]} {
  639.         return $path
  640.     }
  641.     if {[regsub ^/mnt/d\$ $path d:/ path]} {
  642.         return $path
  643.     }
  644.     return c:/windows
  645.     }
  646.  
  647.     proc pwd {} {
  648.     return [EmuConvert [__pwd]]
  649.     }
  650.     proc glob {args} {
  651.  
  652.     }
  653. }
  654.