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 / fs.tcl < prev    next >
Text File  |  2001-11-03  |  13KB  |  654 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: fs.tcl,v 1.4.2.1 2001/11/03 07:26:10 idiscovery Exp $
  4. #
  5. # tixAssert --
  6. #
  7. #    Debugging routine. Evaluates the test script in the context of the
  8. #    caller. The test script is responsible for generating the error.
  9. #    
  10. proc tixAssert {script} {
  11.     uplevel $script
  12. }
  13.  
  14. proc tixAssertNorm {path} {
  15.     if {![tixFSIsNorm $path]} {
  16.     error "\"$path\" is not a normalized path"
  17.     }
  18. }
  19.  
  20. proc tixAssertVPath {vpath} {
  21.     if {![tixFSIsVPath $vpath]} {
  22.     error "\"$vpath\" is not a VPATH"
  23.     }
  24. }
  25.  
  26. # tixFSAbsPath --
  27. #
  28. #    Converts $path into an normalized absolute path
  29. #
  30. proc tixFSAbsPath {path} {
  31.     return [lindex [tixFSNorm [tixFSVPWD] $path] 0]
  32. }
  33.  
  34. # tixFSVPWD --
  35. #
  36. #    Returns the VPATH of the current directory.
  37. #
  38. proc tixFSVPWD {} {
  39.     return [tixFSVPath [tixFSPWD]]
  40. }
  41.  
  42. if {![info exists tcl_platform] || $tcl_platform(platform) == "unix"} {
  43.  
  44. # tixFSPWD --
  45. #
  46. #    Return the current directory
  47. #
  48. proc tixFSPWD {} {
  49.     return [pwd]
  50. }
  51.  
  52. # tixFSDisplayName --
  53. #
  54. #    Returns the name of a normalized path which is usually displayed by
  55. #    the OS
  56. #
  57. proc tixFSDisplayName {normpath} {
  58.     tixAssert {
  59.     tixAssertNorm $normpath
  60.     }
  61.     return $normpath
  62. }
  63.  
  64. proc tixFSIsAbsPath {path} {
  65.     return [tixStrEq [string index $path 0] /]
  66. }
  67.  
  68. # tixFSIsNorm_os --
  69. #
  70. #    Returns true iff this pathname is normalized, in the OS native name
  71. #    format
  72. #
  73. proc tixFSIsNorm_os {path} {
  74.     return [tixFSIsNorm $path]
  75. }
  76.  
  77. proc tixFSIsNorm {path} {
  78.     if {[tixStrEq $path /]} {
  79.     return 1
  80.     }
  81.  
  82.     # relative path
  83.     #
  84.     if {![regexp -- {^/} $path]} {
  85.     return 0
  86.     }
  87.  
  88.     if {[regexp -- {/[.]$} $path]} {
  89.     return 0
  90.     }
  91.     if {[regexp -- {/[.][.]$} $path]} {
  92.     return 0
  93.     }
  94.     if {[regexp -- {/[.]/} $path]} {
  95.     return 0
  96.     }
  97.     if {[regexp -- {/[.][.]/} $path]} {
  98.     return 0
  99.     }
  100.     if {[tixStrEq $path .]} {
  101.     return 0
  102.     }
  103.     if {[tixStrEq $path ..]} {
  104.     return 0
  105.     }
  106.  
  107.     # Tilde
  108.     #
  109.     if {[regexp -- {^~} $path]} {
  110.     return 0
  111.     }
  112.  
  113.     # Double slashes
  114.     #
  115.     if {[regexp -- {//} $path]} {
  116.     return 0
  117.     }
  118.  
  119.     # Trailing slashes
  120.     #
  121.     if {[regexp -- {/$} $path]} {
  122.     return 0
  123.     }
  124.  
  125.     return 1
  126. }
  127.  
  128. # tixFSIsValid --
  129. #
  130. #    Checks whether a native pathname contains invalid characters.
  131. #
  132. proc tixFSIsValid {path} {
  133.     return 1
  134. }
  135.  
  136. proc tixFSIsVPath {vpath} {
  137.     return [tixFSIsNorm $vpath]
  138. }
  139.  
  140. # tixFSVPath --
  141. #
  142. #    Converts a native pathname to its VPATH
  143. #
  144. proc tixFSVPath {path} {
  145.     tixAssert {
  146.     tixAssertNorm $path
  147.     }
  148.     return $path
  149. }
  150.  
  151. # tixFSPath --
  152. #
  153. #    Converts a vpath to a native pathname
  154. proc tixFSPath {vpath} {
  155.     tixAssert {
  156.     tixAssertVPath $vpath
  157.     }
  158.     return $vpath
  159. }
  160.  
  161. # tixFSTildeSubst -- [Unix only]
  162. #
  163. #    Substitutes any leading tilde characters if possible. No error is
  164. #    generated if the user doesn't exist.
  165. #
  166. proc tixFSTildeSubst {text} {
  167.     if {[tixStrEq [string index $text 0] ~]} {
  168.     # The following will report if the user doesn't exist
  169.     if {[catch {
  170.         file isdir $text
  171.     }]} {
  172.         return ./$text
  173.     }
  174.     return [tixFile tilde $text]
  175.     } else {
  176.     return $text
  177.     }
  178. }
  179.  
  180. # tixFSNorm --
  181. #
  182. #    Interprets the user's input and return file information about this
  183. #    input.
  184. #
  185. # Arguments:
  186. #    See documentation (docs/Files.txt)
  187. #
  188. proc tixFSNorm {context text {defFile ""} {flagsVar ""} {errorMsgVar ""}} {
  189.     tixAssert {
  190.     tixAssertVPath $context
  191.     }
  192.  
  193.     if {![tixStrEq $errorMsgVar ""]} {
  194.     upvar $errorMsgVar errorMsg
  195.     }
  196.     if {![tixStrEq $flagsVar ""]} {
  197.     upvar $flagsVar flags
  198.     }
  199.  
  200.     set hasDirSuffix [regexp -- {/$} $text]
  201.     set text [tixFSTildeSubst $text]
  202.     set text [_tixJoin $context $text]
  203.  
  204.     if {$hasDirSuffix || [file isdir $text]} {
  205.     set dir $text
  206.     set tail $defFile
  207.     } else {
  208.     set dir [file dirname $text]
  209.     set tail [file tail $text]
  210.     }
  211.  
  212.     set norm $dir/$tail
  213.     regsub -all -- /+ $norm / norm
  214.     if {![tixStrEq $norm /]} {
  215.     regsub -- {/$} $norm "" norm
  216.     }
  217.  
  218.     if {![info exists flag(noPattern)]} {
  219.     set isPat 0
  220.     foreach char [split $tail ""] {
  221.         if {$char == "*" || $char == "?"} {
  222.         set isPat 1
  223.         break
  224.         }
  225.     }
  226.     if {$isPat} {
  227.         return [list $norm $dir "" $tail]
  228.     }
  229.     }
  230.  
  231.     return [list $norm $dir $tail ""]
  232. }
  233.  
  234. # _tixJoin -- [Internal]
  235. # 
  236. #    Joins two native pathnames.
  237. #
  238. proc _tixJoin {p1 p2} {
  239.     if {[tixStrEq [string index $p2 0] /]} {
  240.     return [_tixNormalize $p2]
  241.     } else {
  242.     return [_tixNormalize $p1/$p2]
  243.     }
  244. }
  245.  
  246. # tixFSNormDir --
  247. #
  248. #    Normalizes an absolute path.
  249. #
  250. proc tixFSNormDir {dir} {
  251.     set dir [tixFile tilde $dir]
  252.     if {![tixStrEq [string index $dir 0] /]} {
  253.     error "\"$dir\" must be an absolute pathname"
  254.     }
  255.     if {![file isdir $dir]} {
  256.     error "\"$dir\" is not a directory"
  257.     }
  258.     return [_tixNormalize $dir]
  259. }
  260.  
  261. # _tixNormalize --
  262. #
  263. #    Normalizes an absolute pathname.
  264. #
  265. #     $dir must be an absolute pathname
  266. #
  267. proc _tixNormalize {path} {
  268.     tixAssert {
  269.     if {![tixStrEq [string index $path 0] /]} {
  270.         error "\"$path\" must be an absolute pathname"
  271.     }
  272.     }
  273.  
  274.     # Don't be fooled: $path doesn't need to be a directory. The following
  275.     # code just makes it easy to get rid of trailing . and ..
  276.     #
  277.     set path $path/
  278.     regsub -all -- /+ $path / path
  279.     while {1} {
  280.     if {![regsub -- {/\./} $path "/" path]} {break}
  281.     }
  282.     while {1} {
  283.     if {![regsub -- {/\.$} $path "" path]} {break}
  284.     }
  285.  
  286.     while {1} {
  287.     if {![regsub -- {/[^/]+/\.\./} $path "/" path]} {break}
  288.     while {1} {
  289.         if {![regsub -- {^/\.\./} $path "/" path]} {break}
  290.     }
  291.     }
  292.     while {1} {
  293.     if {![regsub -- {^/\.\./} $path "/" path]} {break}
  294.     }
  295.  
  296.     regsub -- {/$} $path "" path
  297.     if {[tixStrEq $path ""]} {
  298.     return /
  299.     } else {
  300.     return $path
  301.     }
  302. }
  303.  
  304. # tixFSCreateDirs
  305. #
  306. #
  307. # 
  308. proc tixFSCreateDirs {path} {
  309.     tixAssert {
  310.     error "Procedure tixFSCreateDirs not implemented on all platforms"
  311.     }
  312.     if {[tixStrEq $path /]} {
  313.     return 1
  314.     }
  315.     if {[file exists $path]} {
  316.     return 1
  317.     }
  318.     if {![tixFSCreateDirs [file dirname $path]]} {
  319.     return 0
  320.     }
  321.     if {[catch {exec mkdir $path}]} {
  322.     return 0
  323.     }
  324.     return 1
  325. }
  326.  
  327. } else {
  328.  
  329. #-Win--------------------------------------------------------------------
  330.  
  331. # (Win) tixFSPWD --
  332. #
  333. #    Return the current directory
  334. #
  335. proc tixFSPWD {} {
  336.     set p [pwd]
  337.     regsub -all -- / $p \\ p
  338.     return $p
  339. }
  340. # Win
  341. #
  342. proc tixFSIsNorm {path} {
  343.  
  344.     # Drive root directory
  345.     # CYGNUS: drive can be immediately followed by directory separator.
  346.     #
  347.     if {[regexp -- {^[A-z]:\\?$} $path]} {
  348.     return 1
  349.     }
  350.  
  351.     # If it is not a drive root directory, it must
  352.     # have a leading [drive letter:]\\[non empty string]
  353.     # CYGNUS: A UNC path (\\host\dir) is also OK.
  354.     if {![regexp -- {^[A-z]:\\.} $path]} {
  355.     if {![regexp -- {^\\\\.*\\.} $path]} {
  356.     return 0
  357.     }
  358.     }
  359.  
  360.     # relative path
  361.     #
  362.     if {[regexp -- {\\[.]$} $path]} {
  363.     return 0
  364.     }
  365.     if {[regexp -- {\\[.][.]$} $path]} {
  366.     return 0
  367.     }
  368.     if {[regexp -- {\\[.]\\} $path]} {
  369.     return 0
  370.     }
  371.     if {[regexp -- {\\[.][.]\\} $path]} {
  372.     return 0
  373.     }
  374.     if {[tixStrEq $path .]} {
  375.     return 0
  376.     }
  377.     if {[tixStrEq $path ..]} {
  378.     return 0
  379.     }
  380.  
  381.     # Double slashes
  382.     # CYGNUS: Double slashes at the front are OK.
  383.     #
  384.     if {[regexp -- {.\\\\} $path]} {
  385.     return 0
  386.     }
  387.  
  388.     # Trailing slashes
  389.     #
  390.     if {[regexp -- {[\\]$} $path]} {
  391.     return 0
  392.     }
  393.  
  394.     return 1
  395. }
  396.  
  397. # (Win) tixFSNorm --
  398. #
  399. #    Interprets the user's input and return file information about this
  400. #    input.
  401. #
  402. # Arguments:
  403. #    See documentation (docs/Files.txt)
  404. #
  405. proc tixFSNorm {context text {defFile ""} {flagsVar ""} {errorMsgVar ""}} {
  406.     tixAssert {
  407.     tixAssertVPath $context
  408.     }
  409.  
  410.     if {![tixStrEq $errorMsgVar ""]} {
  411.     upvar $errorMsgVar errorMsg
  412.     }
  413.     if {![tixStrEq $flagsVar ""]} {
  414.     upvar $flagsVar flags
  415.     }
  416.  
  417.     set isDir [regexp -- {[\\]$} $text]
  418.     set text [_tixJoin $context $text]
  419.     set path [tixFSPath $text]
  420.  
  421.     if {$isDir || [file isdir $path]} {
  422.     set vpath $text
  423.     set tail $defFile
  424.     } else {
  425.     set list [split $text \\]
  426.     set tail [lindex $list end]
  427.     set len [string length $tail]
  428.     set vpath [string range $text 0 [expr [string len $text]-$len-1]]
  429.     regsub -- {[\\]$} $vpath "" vpath
  430.     }
  431.  
  432.     set path [tixFSPath $vpath]
  433.  
  434.     if {![info exists flag(noPattern)]} {
  435.     set isPat 0
  436.     foreach char [split $tail ""] {
  437.         if {$char == "*" || $char == "?"} {
  438.         set isPat 1
  439.         break
  440.         }
  441.     }
  442.     if {$isPat} {
  443.         return [list $path $vpath "" $tail]
  444.     }
  445.     }
  446.  
  447.     return [list $path $vpath $tail ""]
  448. }
  449.  
  450. # Win
  451. #
  452. # _tixJoin -- [internal]
  453. #
  454. #    Joins a pathname to a VPATH
  455. #
  456. proc _tixJoin {vp1 p2} {
  457.     if {[tixFSIsAbsPath $p2]} {
  458.     return [tixFSVPath [_tixNormalize $p2]]
  459.     } else {
  460.     return [tixFSVPath [_tixNormalize [tixFSPath $vp1]\\$p2]]
  461.     }
  462. }
  463.  
  464. # (Win) tixFSIsAbsPath
  465. #
  466. #    The Tcl "file pathtype" is buggy. E.g. C:\.\..\. is absolute, but
  467. #    "file pathtype" thinks that it isn't
  468. #
  469.  
  470. proc tixFSIsAbsPath {path} {
  471.     # CYGNUS: Handle a UNC path (\\host\dir)
  472.     if {[regexp -- {^\\\\.*\\.} $path]} {
  473.     return 1
  474.     }
  475.     return [regexp -- {^[A-z]:\\} $path]
  476. }
  477.  
  478. # (Win) tixFSIsNorm_os
  479. #
  480. #    Returns true iff this pathname is normalized, in the OS native name
  481. #    format
  482. #
  483. proc tixFSIsNorm_os {path} {
  484.     if {[regexp -- {^[A-z]:[\\]$} $path]} {
  485.     return 1
  486.     }
  487.     if {[regexp -- {^[A-z]:$} $path]} {
  488.     return 0
  489.     }
  490.  
  491.     return [tixFSIsNorm $path]
  492.  
  493. }
  494.  
  495. # Win
  496. #
  497. # _tixNormalize --
  498. #
  499. #    Normalizes an absolute pathname.
  500. #
  501. #     $dir must be an absolute native pathname
  502. #
  503. proc _tixNormalize {abpath} {
  504.     tixAssert {
  505.     if {![tixFSIsAbsPath $abpath]} {
  506.         error "\"$abpath\" must be an absolute pathname"
  507.     }
  508.     }
  509.  
  510.     if {![regexp -- {^[A-z]:} $abpath drive]} {
  511.     tixPanic "\"$abpath\" does not contain a drive letter"
  512.     }
  513.     set drive [string toupper $drive]
  514.  
  515.     # CYGNUS: Handle UNC paths (\\host\dir)
  516.     if {[regexp -- {^\\\\.*\\.} $abpath]} {
  517.     set drive "\\"
  518.     regsub -- {^\\} $abpath "" path
  519.     } else {
  520.     if {![regexp -- {^[A-z]:} $abpath drive]} {
  521.         tixPanic "\"$abpath\" does not contain a drive letter"
  522.     }
  523.     set drive [string toupper $drive]
  524.  
  525.     regsub -- {^[A-z]:} $abpath "" path
  526.     }
  527.  
  528.     # Don't be fooled: $path doesn't need to be a directory. The following
  529.     # code "set path $path\\" just makes it easy to get rid of trailing
  530.     # . and ..
  531.     #
  532.     set path $path\\
  533.     regsub -all -- {[\\]+} $path \\ path
  534.     while {1} {
  535.     if {![regsub -- {\\[.]\\} $path "\\" path]} {break}
  536.     }
  537.     while {1} {
  538.     if {![regsub -- {\\[.]$} $path "" path]} {break}
  539.     }
  540.  
  541.     while {1} {
  542.     if {![regsub -- {\\[^\\]+\\[.][.]\\} $path "\\" path]} {break}
  543.     while {1} {
  544.         if {![regsub -- {^\\[.][.]\\} $path "\\" path]} {break}
  545.     }
  546.     }
  547.     while {1} {
  548.     if {![regsub -- {^\\[.][.]\\} $path "\\" path]} {break}
  549.     }
  550.  
  551.     regsub -- {[\\]+$} $path "" path
  552.     return $drive$path
  553. }
  554.  
  555. # Win
  556. #
  557. # tixFSNormDir --
  558. #
  559. #    Normalizes a directory
  560. #
  561. proc tixFSNormDir {dir} {
  562.     if {![tixFSIsAbsPath $dir]} {
  563.     error "\"$dir\" must be an absolute pathname"
  564.     }
  565.     if {![file isdir $dir]} {
  566.     error "\"$dir\" is not a directory"
  567.     }
  568.     return [_tixNormalize $dir]
  569. }
  570.  
  571.  
  572. proc tixPanic {message} {
  573.     error $message
  574. }
  575.  
  576. # tixFSIsValid --
  577. #
  578. #    Checks whether a native pathname contains invalid characters.
  579. #
  580. proc tixFSIsValid {path} {
  581.     return 1
  582. }
  583.  
  584. # Win
  585. #
  586. #
  587. proc tixFSIsVPath {vpath} {
  588.     global tixPriv
  589.     if {$tixPriv(isWin95)} {
  590.     # CYGNUS: Accept UNC path (\\host\dir)
  591.     if {[string match {xx\\xx\\\\\\*\\*} $vpath]} {
  592.         return 1
  593.     }
  594.     return [string match {xx\\xx\\[A-z]:*} $vpath]
  595.     } else {
  596.     return [string match {xx\\[A-z]:*} $vpath]
  597.     }
  598. }
  599.  
  600. # Win
  601. #
  602. # tixFSVPath --
  603. #
  604. #    Converts a normalized native pathname to its VPATH
  605. #
  606. proc tixFSVPath {path} {
  607.     global tixPriv
  608.  
  609.     tixAssert {
  610.     tixAssertNorm $path
  611.     }
  612.     return $tixPriv(WinPrefix)\\$path
  613. }
  614.  
  615. # tixFSPath --
  616. #
  617. #    Converts a vpath to a native pathname
  618. proc tixFSPath {vpath} {
  619.     global tixPriv
  620.     tixAssert {
  621.     tixAssertVPath $vpath
  622.     }
  623.     if {$tixPriv(isWin95)} {
  624.     set path [string range $vpath 6 end]
  625.     } else {
  626.     set path [string range $vpath 3 end]
  627.     }
  628.     regsub -- {:$} $path :\\ path
  629.  
  630.     return $path
  631. }
  632.  
  633. # tixFSDisplayName --
  634. #
  635. #    Returns the name of a normalized path which is usually displayed by
  636. #    the OS
  637. #
  638. proc tixFSDisplayName {normpath} {
  639.     tixAssert {
  640.     tixAssertNorm $normpath
  641.     }
  642.  
  643.     if {[regexp -- {^[A-z]:$} $normpath]} {
  644.     return $normpath\\
  645.     } else {
  646.     return $normpath
  647.     }
  648. }
  649.  
  650.  
  651. tixInitFileCmpt:Win 
  652.  
  653. }
  654.