home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / fstorage.tcl < prev    next >
Text File  |  1997-11-12  |  15KB  |  556 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1993-1997 by Cayenne Software Inc.
  4. #
  5. # This software is furnished under a license and may be used only in
  6. # accordance with the terms of such license and with the inclusion of
  7. # the above copyright notice. This software or any other copies thereof
  8. # may not be provided or otherwise made available to any other person.
  9. # No title to and ownership of the software is hereby transferred.
  10. #
  11. # The information in this software is subject to change without notice
  12. # and should not be construed as a commitment by Cayenne Software Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #    File        : @(#)fstorage.tcl    /main/titanic/11
  17. #    Author        : frmo, Lex Warners
  18. #    Original date    : 23-2-1994
  19. #    Description    : File storage functions. The functions in this file
  20. #                         define the interface to the VCM system used to
  21. #                         store the files.
  22. #---------------------------------------------------------------------------
  23. #
  24.  
  25. # Start user added include file section
  26. global fstorage::custObjHandler
  27. set fstorage::custObjHandler ""
  28. require caynutil.tcl
  29.  
  30. # ugly but effective hack to make sure we are running in
  31. # otsh, otherwise sourcing these files may have disastrous results
  32. if [isCommand OTShRegister::check] {
  33.     require s_otsh.tcl
  34.     require vss_otsh.tcl
  35. }
  36.  
  37. global fstorage::vsFiles
  38. set fstorage::vsFiles ""
  39.  
  40. global fstorage::cacheValid
  41. set fstorage::cacheValid 0
  42. # End user added include file section
  43.  
  44. Class fstorage : {GCObject} {
  45.         constructor
  46.         method destructor
  47. }
  48.  
  49. constructor fstorage {class this} {
  50.         set this [GCObject::constructor $class $this]
  51.         # Start constructor user section
  52.         # End constructor user section
  53.         return $this
  54. }
  55.  
  56. method fstorage::destructor {this} {
  57.         # Start destructor user section
  58.         # End destructor user section
  59. }
  60.  
  61.  
  62. # internal proc that returns current system
  63. # issues error if not a system level
  64. #
  65. proc fstorage::currentSystem {} {
  66.     set clientContext [ClientContext::global]
  67.     set vsSystem [$clientContext currentSystem]
  68.  
  69.     if [$vsSystem isNil] {
  70.     error "Not at system level"
  71.     }
  72.  
  73.     return $vsSystem
  74. }
  75.  
  76. # Return a list of objects that have a type that is listed in $fileTypes
  77. # $fileTypes == {} means all file types
  78. #
  79. proc fstorage::dir {{fileTypes ""}} {
  80.     set vsSystem [fstorage::currentSystem]
  81.     
  82.     if [$vsSystem isNil] {
  83.     return
  84.     }
  85.    
  86.     global fstorage::cacheValid
  87.     global fstorage::vsFiles
  88.  
  89.     if ${fstorage::cacheValid} {
  90.     set vsFiles ${fstorage::vsFiles}
  91.     } else {
  92.     set vsFiles [$vsSystem vsFiles]
  93.         set fstorage::vsFiles $vsFiles
  94.         set fstorage::cacheValid 1
  95.     }
  96.  
  97.     set fileList ""
  98.     
  99.     foreach vsFile $vsFiles {
  100.     set fileName [$vsFile name]
  101.     set fileType [$vsFile type]
  102.     set fullName ${fileName}.${fileType}
  103.  
  104.     if {$fileTypes == ""} {
  105.         lappend fileList $fullName
  106.     } else {
  107.         foreach type $fileTypes {
  108.         if {$fileType == $type} {
  109.             lappend fileList $fullName
  110.             break;
  111.         }
  112.         }
  113.     }
  114.     }
  115.  
  116.     return $fileList
  117. }
  118.  
  119. proc fstorage::getVSFile {fileSpec} {
  120.     set vsSystem [fstorage::currentSystem]
  121.     if [$vsSystem isNil] {
  122.     return ""
  123.     }
  124.  
  125.     set fileName [nt_get_name $fileSpec]
  126.     set fileType [nt_get_type $fileSpec]
  127.  
  128.     set vsFile [$vsSystem findVSFile $fileName $fileType]
  129.     if { $vsFile == "" } {
  130.     # create VSFile object for this file
  131.     if [$vsSystem fileExists $fileName $fileType] {
  132.         set vsFile [$vsSystem importVSFile $fileName $fileType]
  133.     }
  134.     }
  135.  
  136.     return $vsFile
  137. }
  138.  
  139. # Return whether the file with the given file specification exists in the 
  140. # VCM system. file specification is in the form "name.type" where type
  141. # is a browser type.
  142.  
  143. proc fstorage::exists {fileSpec} {
  144.     set vsSystem [fstorage::currentSystem]
  145.     if [$vsSystem isNil] {
  146.     return 0
  147.     }
  148.  
  149.     set name [nt_get_name $fileSpec]
  150.     set type [nt_get_type $fileSpec]
  151.  
  152.     return [$vsSystem fileExists $name $type]
  153. }
  154.  
  155. proc fstorage::getMakeType {objType} {
  156.     return [[fstorage::getObjectSpec $objType] makeType]
  157. }
  158.  
  159. proc fstorage::getFsExtension {objType} {
  160.     set extension [[fstorage::getObjectSpec $objType] fsExtension]
  161.  
  162.     #
  163.     # Hack for persistent classes with target Gen
  164.     #
  165.  
  166.     if {$extension == "" && $objType == "esqlc++"} {
  167.         return [[fstorage::getObjectSpec c++] fsExtension]
  168.     }
  169.  
  170.     return $extension
  171. }
  172.  
  173. proc fstorage::getObjectSpec {objType} {
  174.     set vsSystem [fstorage::currentSystem]
  175.     if [$vsSystem isNil] {
  176.     return
  177.     }
  178.  
  179.     return [$vsSystem getTypeSpec $objType]
  180. }
  181.  
  182. proc fstorage::isAscii {objType} {
  183.     return [[fstorage::getObjectSpec $objType] isAscii]
  184. }
  185.  
  186. #
  187. # Open $obj for $mode. Mode is one of "r" and "w"
  188. # If $mode == w the object is created if it doesn't exist
  189. # 
  190.  
  191. proc fstorage::open {fileSpec {mode r} {fileClass externalText}} {
  192.     global fstoragePathCache
  193.     global fstorageObjectCache
  194.  
  195.     set vsSystem [fstorage::currentSystem]
  196.  
  197.     if [$vsSystem isNil] {
  198.     return 0
  199.     }
  200.  
  201.     set fileName [nt_get_name $fileSpec]
  202.     set fileType [nt_get_type $fileSpec]
  203.     set vsFile [$vsSystem findVSFile $fileName $fileType]
  204.  
  205.     case $mode {
  206.     r {
  207.         if { $vsFile == "" } {
  208.         # file does not exist in the repository but may exist
  209.         # in VCM system. Do an import in the latter case
  210.         if [$vsSystem fileExists $fileName $fileType] {
  211.             set vsFile [$vsSystem importVSFile $fileName $fileType]
  212.         }
  213.         if { $vsFile == "" } {
  214.             error "Unable to open file '$fileSpec' for read"
  215.             return ""
  216.         }
  217.         }
  218.  
  219.         set filePath [$vsFile getReference]
  220.         set handle [open $filePath r]
  221.         set fstorageObjectCache($handle) $vsFile
  222.         set fstoragePathCache($handle) $filePath
  223.  
  224.         return $handle
  225.     }
  226.     w {
  227.         # Create file if it does not exist
  228.         if { $vsFile == "" } {
  229.         if [$vsSystem fileExists $fileName $fileType] {
  230.             set vsFile [$vsSystem importVSFile $fileName $fileType]
  231.         } else {
  232.             set comment "Created by ObjectTeam"
  233.             set vsFile [$vsSystem createVSFile \
  234.                 $fileName $fileType "$comment"]
  235.         }
  236.         }
  237.  
  238.         if { $vsFile == "" } {
  239.         error "Creation of '$fileSpec' failed"
  240.         return ""
  241.         }
  242.  
  243.         global fstorage::cacheValid
  244.         set fstorage::cacheValid 0
  245.  
  246.         # try to check it out if it is not writable
  247.         set filePath [$vsFile path]
  248.         if { ![$vsFile isCheckedOut] } {
  249.         if {![file writable $filePath]} {
  250.             set comment "Checked out by ObjectTeam"
  251.             if {![$vsFile checkOut $comment]} {
  252.             error "Cannot obtain writable copy of '$fileSpec'"
  253.             }
  254.         } else {
  255.             # there is a writable copy but the file is not checked
  256.             # out: dangerous; let user do something about it
  257.             error "Cannot check out '$fileSpec': a writable copy exists in the user environment"
  258.         }
  259.         }
  260.  
  261.         # we have a writable copy: finish work
  262.         set handle [open $filePath w]
  263.         if { $handle == "" } {
  264.         error "Open file '$fileSpec' for write failed"
  265.         return ""
  266.         }
  267.         set fstorageObjectCache($handle) $vsFile
  268.         return $handle
  269.     }
  270.     default {
  271.         error "Invalid option '$mode' for fstorage::open"
  272.     }
  273.     }
  274. }
  275.  
  276. # Close $handle
  277. #
  278. proc fstorage::close {handle} {
  279.     global fstoragePathCache
  280.     global fstorageObjectCache
  281.  
  282.     if [info exists fstorageObjectCache($handle)] {
  283.     set vsFile $fstorageObjectCache($handle)
  284.     unset fstorageObjectCache($handle)
  285.     if [info exists fstoragePathCache($handle)] {
  286.         $vsFile deleteReference $fstoragePathCache($handle)
  287.         unset fstoragePathCache($handle)
  288.     }
  289.     } else {
  290.         puts "Warning fstorage::close called for unknown handle"
  291.     }
  292.  
  293.     close $handle
  294. }
  295.  
  296. # Return the path of $fileSpec in the "user environment"
  297. # if $is_absolute == absolute the path is absolute, else relative
  298. #
  299. proc fstorage::get_uenv_path {fullName {absolute relative}} {
  300.     set vsFile [fstorage::getVSFile $fullName]
  301.     return [fstorage::getFilePath vsFile $fullName 0 $absolute]
  302. }
  303.  
  304. # Get file system path. If the fileVersion does not exist and newFile is true a
  305. # new fileVersion is created. The absolute parameter can be set to "relative" or
  306. # "absolute" and will determine the kind of path returned.
  307. #
  308. proc fstorage::getFilePath {fileVRef {fullName ""} {newFile 0} {absolute "relative"} {fileClass "externalText"}} {
  309.     upvar $fileVRef vsFile
  310.  
  311.     set fileName [nt_get_name $fullName]
  312.     set fileType [nt_get_type $fullName]
  313.     set vsSystem [fstorage::currentSystem]
  314.     if [$vsSystem isNil] {
  315.     return ""
  316.     }
  317.  
  318.     set filePath [$vsSystem vsFileUserPath $fileName $fileType]
  319.  
  320.     if {$absolute == "absolute"} {
  321.     return $filePath
  322.     }
  323.  
  324.     # make relative path: strip path to system
  325.     set systemPath [$vsSystem path]
  326.     set relativeIndex [expr [string length $systemPath] +1]
  327.     return [string range $filePath $relativeIndex end]    
  328. }
  329.  
  330.  
  331. # Goto "system" $sys in phase $phase
  332. #
  333. proc fstorage::goto_system {sys {phase ""}} {
  334.     set clientCont [ClientContext::global]
  335.     set currentLevel [$clientCont currentLevel]
  336.     if { $currentLevel == "Project" ||  $currentLevel == "Corporate" } {
  337.         puts "invalid level: $currentLevel"
  338.         return
  339.     }
  340.  
  341.     set oldLevelPath [m4_var get M4_levelpath]
  342.     while { [$clientCont currentLevel] != "Phase" } {
  343.         $clientCont upLevel
  344.     }
  345.  
  346.     if {$phase != "" } {
  347.         $clientCont upLevel
  348.         if [catch {$clientCont downLevel $phase} msg] {
  349.         #puts $msg
  350.         $clientCont setLevelPath $oldLevelPath
  351.         return
  352.         }
  353.     }
  354.  
  355.     if [catch {$clientCont downLevel $sys} msg]  {
  356.         #puts $msg
  357.         $clientCont setLevelPath $oldLevelPath
  358.         return
  359.     }
  360. }
  361.  
  362. # Return the "Imported From" attribute from $obj
  363. #
  364. proc fstorage::get_imp_from {fileSpec} {
  365.     set vsFile [fstorage::getVSFile [path_name file $fileSpec]]
  366.  
  367.     if { $vsFile == "" } {
  368.     return ""
  369.     }
  370.  
  371.     return [$vsFile getClass]
  372. }
  373.  
  374. # Set the "Imported From" attribute of $obj to $value
  375. #
  376. proc fstorage::set_imp_from {fileSpec value} {
  377.     set vsFile [fstorage::getVSFile [path_name file $fileSpec]]
  378.  
  379.     if { $vsFile == "" } {
  380.     error "Unable to set property for '$fileSpec': it is not a file within this system"
  381.     }
  382.  
  383.     return [$vsFile setClass $value]
  384. }
  385.  
  386. # return path of object in user environment
  387. #
  388. proc fstorage::getObjectUserPath {object} {
  389.     global VSSystem
  390.     return [$VSSystem::vsObjectUserPath $object]
  391. }
  392.  
  393. # return path of object in VCM environment
  394. #
  395. proc fstorage::getObjectVSPath {object} {
  396.     global VSSystem
  397.     return [$VSSystem::vsObjectVSPath $object]
  398. }
  399.  
  400. # Remove '$fullName' from VCM system
  401. #
  402. proc fstorage::remove {fullName} {
  403.     set vsFile [fstorage::getVSFile $fullName]
  404.  
  405.     if { $vsFile == "" } {
  406.     error "Unable remove '$fullName': it is not a file within this system"
  407.     }
  408.  
  409.     $vsFile removeFromVS
  410.     global fstorage::cacheValid
  411.     set fstorage::cacheValid 0
  412. }
  413.  
  414. # Construct the path from level (read from the client-context) and subdir.
  415. # This is the user environment path
  416. proc fstorage::getFsPath {level {subDir ""} {pathType "User"}} {
  417.     set path ""
  418.     set cc [ClientContext::global]
  419.  
  420.     set errorMessage "Unknown level $level"
  421.     switch -glob $level {
  422.     corp* {
  423.         set path [m4_var get M4_home]
  424.         set errorMessage ""
  425.     }
  426.     proj* {
  427.         set proj [$cc currentProject]
  428.         if [$proj isNil] {
  429.         set errorMessage "The current level should at least be Project"
  430.         } else {
  431.         set path [fstorage::getObject${pathType}Path $proj]
  432.         set errorMessage ""
  433.         }
  434.     }
  435.     conf* {
  436.         set confV [$cc currentConfig]
  437.         if [$confV isNil] {
  438.         set errorMessage "The current level should at least be Configuration"
  439.         } else {
  440.         set path [fstorage::getObject${pathType}Path $confV]
  441.         set errorMessage ""
  442.         }
  443.     }
  444.     phase {
  445.         set phaseV [$cc currentPhase]
  446.         if [$phaseV isNil] {
  447.         set errorMessage "The current level should at least be Phase"
  448.         } else {
  449.         set path [fstorage::getObject${pathType}Path $phaseV]
  450.         set errorMessage ""
  451.         }
  452.     }
  453.     system {
  454.         set systemV [$cc currentSystem]
  455.         if [$systemV isNil] {
  456.         set errorMessage "The current level should at least be System"
  457.         } else {
  458.         set path [fstorage::getObject${pathType}Path $systemV]
  459.         set errorMessage ""
  460.         }
  461.     }
  462.     }
  463.     if {$errorMessage != ""} {
  464.     puts stderr $errorMessage
  465.     return ""
  466.     }
  467.  
  468.     return [path_name concat $path $subDir]
  469. }
  470.  
  471.  
  472. # Copy a file to a certain directory, if this directory does not exist 
  473. # the directory is created. (Returns the complete filePathName).
  474. #
  475. proc fstorage::copyFile {fromFilePath toLevel toSubDir toFileName} {
  476.     global VSSystem
  477.     set toDirUserPath [fstorage::getFsPath $toLevel $toSubDir]
  478.     set toDirVSPath [fstorage::getFsPath $toLevel $toSubDir "VS"]
  479.  
  480.     # create paths if necessary
  481.     if { ![$VSSystem::createUserPath $toDirUserPath] } {
  482.     return ""
  483.     }
  484.     if { ![$VSSystem::createVSPath $toDirVSPath] } {
  485.     return ""
  486.     }
  487.  
  488.     # get an object for the file 
  489.     set toFilePath [path_name concat $toDirUserPath $toFileName]
  490.     set toFileVSPath [path_name concat $toDirVSPath $toFileName]
  491.     set vsFile [$VSSystem::getFileObject $toFilePath $toFileVSPath]
  492.     if { $vsFile == "" } {
  493.     return ""
  494.     }
  495.  
  496.     set mustCopy 1
  497.     # compare file if they existed already
  498.     if [$vsFile existsInVS] {
  499.     set vsRef [$vsFile getReference]
  500.     if [catch {set fromDesc [open $fromFilePath r]}] {
  501.         $vsFile deleteReference $vsRef
  502.         return ""
  503.     }
  504.     if [catch {set toDesc [open $vsRef r]}] {
  505.         $vsFile deleteReference $vsRef
  506.         if { $fromDesc != "" } {
  507.         close $fromDesc
  508.         return ""
  509.         }
  510.     }
  511.     if { ($fromDesc == "") || ($toDesc == "") } {
  512.         $vsFile deleteReference $vsRef
  513.         if { $fromDesc != "" } {
  514.         close $fromDesc
  515.         }
  516.         if { $toDesc != "" } {
  517.         close $toDesc
  518.         }
  519.     }
  520.     if { ![string compare [read $fromDesc] [read $toDesc]] } {
  521.         set mustCopy 0
  522.         puts "Skipping $toFilePath: already installed"
  523.     }
  524.     close $fromDesc
  525.     close $toDesc
  526.     $vsFile deleteReference $vsRef
  527.     } else {
  528.     if {![$vsFile createInVS {"Installed by ObjectTeam"}] } {
  529.         return ""
  530.     }
  531.     }
  532.  
  533.     if $mustCopy {
  534.     set canCopy 1
  535.     if { ![$vsFile isCheckedOut] } {
  536.         if {![file writable $toFilePath]} {
  537.         set comment "Checked out by ObjectTeam"
  538.         if {![$vsFile checkOut $comment]} {
  539.             puts "Cannot obtain writable copy of '$toFileName'"
  540.             set canCopy 0
  541.         }
  542.         } else {
  543.         puts "Cannot check out '$toFileName': a writable copy exists in the user environment"
  544.         set canCopy 0
  545.         }
  546.     }
  547.     if $canCopy {
  548.         BasicFS::copyFile $fromFilePath $toFilePath
  549.         return $toFilePath
  550.     }
  551.     }
  552.     return ""
  553. }
  554.  
  555. # Do not delete this line -- regeneration end marker
  556.