home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / repository.tcl < prev    next >
Text File  |  1997-06-04  |  48KB  |  1,706 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Cayenne Software Inc.    1997
  4. #
  5. #      File:           @(#)repository.tcl    /main/hindenburg/50
  6. #      Author:         <generated>
  7. #      Description:
  8. #---------------------------------------------------------------------------
  9. # SccsId = @(#)repository.tcl    /main/hindenburg/50   4 Jun 1997 Copyright 1997 Cayenne Software Inc.
  10.  
  11. # Start user added include file section
  12. require repdbms.tcl
  13. require options.tcl
  14. # End user added include file section
  15.  
  16.  
  17. Class Repository : {GCObject} {
  18.     constructor
  19.     method destructor
  20.     method msg
  21.     method message
  22.     method warning
  23.     method error
  24.     method execute
  25.     method quickTimeOut
  26.     method resetTimeOut
  27.     method getAvailableRepositories
  28.     method setCurrent
  29.     method currentCorporate
  30.     method checkCorporate
  31.     method currentOwner
  32.     method findDbServer
  33.     method currentDbServer
  34.     method shutdownDbServers
  35.     method getActiveClients
  36.     method getServerById
  37.     method getServerByObject
  38.     method getServerByName
  39.     method changeServerDefinition
  40.     method removeServerDefinition
  41.     method getInfoFromDatabase
  42.     method getInfoFromCmdLine
  43.     method getInfoFromCorporate
  44.     method makeOptions
  45.     method makeDbOptions
  46.     method makeCmdLine
  47.     method makeDbCmdLine
  48.     method makeDbToolCmd
  49.     method runDbScript
  50.     method startDbTool
  51.     method toolFinished
  52.     method checkRepositoryName
  53.     method createRepository
  54.     method changeRepository
  55.     method fixRepositoryDir
  56.     method deleteRepository
  57.     method deleteRepositoryDir
  58.     method deleteRepositoryDb
  59.     method deleteServerEntry
  60.     method optimizeRepository
  61.     method backupRepository
  62.     method restoreRepository
  63.     method expandArchiveCommand
  64.     method archiveRepository
  65.     method unarchiveRepository
  66.     method getExternalFileVersions
  67.     method getLockServer
  68.     method getLockServerFromId
  69.     method getLocks
  70.     method isHangingLock
  71.     method describeLock
  72.     method checkLock
  73.     method setLock
  74.     method removeLock
  75.     attribute currentName
  76.     attribute orbTimeOut
  77.     attribute extFiles
  78.     attribute extFilesLoaded
  79.     attribute extCorp
  80.     attribute extProj
  81.     attribute extConf
  82.     attribute useLockServerId
  83.     attribute toolFinishedScript
  84.     attribute context
  85.     attribute messageHandler
  86.     attribute lockServer
  87.     attribute badServers
  88. }
  89.  
  90. constructor Repository {class this} {
  91.     set this [GCObject::constructor $class $this]
  92.     # Start constructor user section
  93.  
  94.         # Make this usable by both otk and otsh.
  95.         #
  96.     catch { OtkRegister::repository }
  97.     catch { OtkRegister::lockServer }
  98.     catch { OtkRegister::reportWriter }
  99.  
  100.         catch { OTShRegister::clientContext }
  101.         catch { OTShRegister::repository }
  102.         catch { OTShRegister::lockServer }
  103.         catch { OTShRegister::reportWriter }
  104.         catch { OTShRegister::semanticModel }
  105.  
  106.     if [catch {$this context [ClientContext::global]} msg] {
  107.         # Do this again, since on error, it returns "",
  108.         # but only the first time.
  109.         #
  110.         $this context [ClientContext::global]
  111.     }
  112.  
  113.     # Determine default corporate from M4_levelpath
  114.     #
  115.     set path [m4_var get M4_levelpath]
  116.     if [regexp {^/([^/]*)} $path dummy corpName] {
  117.         $this currentName $corpName
  118.     }
  119.  
  120.         # Remember original ORB timeout.
  121.         #
  122.     $this orbTimeOut [m4_var get M4_orb_timeout]
  123.  
  124.     $this extFiles [List new]
  125.     $this extFilesLoaded 0
  126.     $this extCorp ""
  127.     $this extProj ""
  128.     $this extConf ""
  129.  
  130.         $this lockServer [ORB::nil]
  131.         $this useLockServerId 0
  132.  
  133.         $this badServers [Dictionary new]
  134.  
  135.     # End constructor user section
  136.     return $this
  137. }
  138.  
  139. method Repository::destructor {this} {
  140.     # Start destructor user section
  141.     # End destructor user section
  142. }
  143.  
  144.  
  145. # Formats a number of seconds as a string with the
  146. # format: HH:MM:SS where HH, MM, SS are hours, minutes
  147. # and seconds respectively.  If the number of seconds 
  148. # spans one day or more, the string "D day(s), " is
  149. # prepended to the time string, where D is the
  150. # number of days.
  151. #
  152. proc Repository::formatSeconds {seconds} {
  153.     set d [expr {$seconds / (24*3600)}]
  154.     set h [expr {($seconds % (24*3600)) / 3600}]
  155.     set m [expr {($seconds % 3600) / 60}]
  156.     set s [expr {$seconds % 60}]
  157.  
  158.     set time [format "%02d:%02.2d:%02d" $h $m $s]
  159.     if {$d == 0} {
  160.         return $time
  161.     }
  162.  
  163.     set s "s"
  164.     if {$d == 1} {
  165.         set s ""
  166.     }
  167.  
  168.     return "$d day$s, $time"
  169. }
  170.  
  171.  
  172. # Expands special symbols and variables
  173. # in the given file name, and returns
  174. # the new file name.  If 'escape' is true,
  175. # backslashes are escaped as well.
  176. #
  177. proc Repository::expandFileName {file {escape 0}} {
  178.     # Substitute ~ and ~user.  Cannot use glob directory on $file since
  179.     # that returns nothing if the directory/file does not exist.
  180.     #
  181.     if ![regsub {^~} $file [glob ~] file] {
  182.     if [regexp {^~([a-zA-Z0-9][a-zA-Z0-9]*)/} $file dummy user] {
  183.         regsub {^~[a-zA-Z0-9][a-zA-Z0-9]*} $file [glob ~${user}] file
  184.     }
  185.     }
  186.  
  187.     # Substitute environment variables.
  188.     #
  189.     global env
  190.     while {[regexp -indices {\$([a-zA-Z][a-zA-Z0-9]*)} $file dummy list]} {
  191.         set var [string range $file [lindex $list 0] [lindex $list 1]]
  192.         regsub "\\\$${var}" $file $env($var) file
  193.     }
  194.  
  195.     # Escape backslashes.
  196.     #
  197.     if $escape {
  198.     regsub -all {\\} $file {\\\\} file
  199.     }
  200.  
  201.     return $file
  202. }
  203.  
  204.  
  205. # Does the same as 'expandFileName', but additionally
  206. # stores the part of the directory that really exists in the
  207. # file system in the variable named by 'existing'.
  208. #
  209. proc Repository::expandDirName {dir {existing ""} {escape 0}} {
  210.     set dir [Repository::expandFileName $dir $escape]
  211.  
  212.     if {$existing != ""} {
  213.         upvar $existing existingPart
  214.     set existingPart $dir
  215.     while {![file exists $existingPart]} {
  216.         set existingPart [file dir $existingPart]
  217.     }
  218.     }
  219.  
  220.     return $dir
  221. }
  222.  
  223. method Repository::msg {this type msg {options ""}} {
  224.     set handler [$this messageHandler]
  225.     if {$handler != ""} {
  226.         eval $handler $type [list $msg] $options
  227.     }
  228. }
  229.  
  230. method Repository::message {this msg} {
  231.     $this msg MESSAGE $msg
  232. }
  233.  
  234. method Repository::warning {this warning} {
  235.     $this msg WARNING $warning
  236. }
  237.  
  238. method Repository::error {this error {options ""}} {
  239.     $this msg ERROR $error $options
  240. }
  241.  
  242.  
  243. # Executes the given command line and returns an empty string
  244. # if it was successful, else it returns an error string.
  245. #
  246. method Repository::execute {this cmd} {
  247.     if $win95 {
  248.         set outFile [BasicFS::tmpFile]
  249.         systemNoCon "cmd.exe /c \"$cmd\" > $outFile"
  250.     set result [BasicFS::readFile $outFile]
  251.     BasicFS::removeFile $outFile
  252.         if {$result == ""} {
  253.             # Should have gotten at least the dbserver banner.
  254.             return "Failed to execute '$cmd'"
  255.         }
  256.     } else {
  257.         set errFile [BasicFS::tmpFile]
  258.         catch {set result [eval "exec $cmd 2>$errFile"]}
  259.     set error [BasicFS::readFile $errFile]
  260.     BasicFS::removeFile $errFile
  261.         if {$error != ""} {
  262.             # If successful, no output should be found.
  263.             return $error
  264.         }
  265.     }
  266.  
  267.     # Success.
  268.     return ""
  269. }
  270.  
  271.  
  272. # Changes the ORB timeout to a short time, for calls
  273. # that should take little time. 
  274. #
  275. method Repository::quickTimeOut {this {smallTimeOut 1000}} {
  276.     # NOTE: does not consider host-context of variable.
  277.     # 
  278.     if {[m4_var get M4_orb_timeout] != $smallTimeOut} {
  279.     m4_var set M4_orb_timeout $smallTimeOut
  280.     m4_var saveStatus M4_orb_timeout 0
  281.     }
  282. }
  283.  
  284.  
  285. # Resets the ORB timeout to its original value.
  286. #
  287. method Repository::resetTimeOut {this} {
  288.     m4_var set M4_orb_timeout [$this orbTimeOut]
  289.     m4_var saveStatus M4_orb_timeout 0
  290. }
  291.  
  292.  
  293. # Returns a list with all available repository names.
  294. #
  295. method Repository::getAvailableRepositories {this} {
  296.     set names {}
  297.     foreach entry [[ORB::nameServer] serverDefinitions] {
  298.     set id [lindex $entry 2]
  299.     if {$id > 100 && $id < 1000} {
  300.         lappend names [lindex $entry 0]
  301.     }
  302.     }
  303.     return $names
  304. }
  305.  
  306.  
  307. # Changes the selected repository to the one with the new name.
  308. # Always succeeds.  Use currentCorporate or checkCorporate to find
  309. # out if the repository could be accessed.
  310. #
  311. method Repository::setCurrent {this newName} {
  312.  
  313.     if {[$this currentName] != ""} {
  314.         set dbserver [$this currentDbServer]
  315.         if ![$dbserver isNil] {
  316.             $dbserver disconnect
  317.         }
  318.     }
  319.     $this currentName $newName
  320.     [$this context] setLevelPath ""
  321.     if {$newName != ""} {
  322.     [$this context] setLevelPath /$newName
  323.     }
  324. }
  325.  
  326.  
  327. # Returns the currently selected corporate object.  If none
  328. # is selected or accessible, a nil object is returned.
  329. #
  330. method Repository::currentCorporate {this} {
  331.     set name [$this currentName]
  332.     set corp [[$this context] currentCorporate]
  333.     if {$name == "" || [$corp isNil]} {
  334.         return [ORB::nil]
  335.     }
  336.     return $corp
  337. }
  338.  
  339.  
  340. # Returns the currently selected corporate object.  If none
  341. # is selected or accessible, an error is returned.
  342. #
  343. method Repository::checkCorporate {this} {
  344.     set name [$this currentName]
  345.     if {$name == ""} {
  346.         return -code error "No current repository set."
  347.     }
  348.  
  349.     set corp [[$this context] currentCorporate]
  350.     if {$name == "" || [$corp isNil]} {
  351.         return -code error "Cannot access repository \"$name\"."
  352.     }
  353.  
  354.     return [$this currentCorporate]
  355. }
  356.  
  357.  
  358. # Returns the name of the user that owns
  359. # the currently selected repository.
  360. # This is determined by examining the
  361. # owner of the corporate directory.
  362. #
  363. method Repository::currentOwner {this} {
  364.     set corp [$this checkCorporate]
  365.     set dir [path_name concat [$corp location] [$corp name]]
  366.  
  367.     if [file exists $dir] {
  368.     if ![catch {set owner [BasicFS::owner $dir]} error] {
  369.             if {$owner == "everyone"} {
  370.         set owner ""
  371.             }
  372.             return $owner
  373.     } else {
  374.             $this error $error
  375.         }
  376.     }
  377.  
  378.     return ""
  379. }
  380.  
  381.  
  382. # Returns the BrokerImplemServer object
  383. # that represent the dbserver that is servicing
  384. # the currently selected corporate.  Returns
  385. # [ORB::nil] if no corporate is selected.
  386. #
  387. method Repository::currentDbServer {this} {
  388.     set name [$this currentName]
  389.     if {$name == ""} {
  390.         return [ORB::nil]
  391.     }
  392.  
  393.     set broker [ORB::broker]
  394.     if [$broker isNil] {
  395.         return [ORB::nil]
  396.     }
  397.  
  398.     if ![$this getServerByName $name entry] {
  399.         return [ORB::nil]
  400.     }
  401.  
  402.     set implem [$broker findImplementation $entry(fullId)]
  403.     if [$implem isNil] {
  404.         return [ORB::nil]
  405.     }
  406.  
  407.     foreach server [$implem servers] {
  408.         set me [$server findClient [ORB::currentHost] [ORB::currentProcessId]]
  409.         if ![$me isNil] {
  410.             return $server
  411.     }
  412.     }
  413.  
  414.     return [ORB::nil]
  415. }
  416.  
  417. method Repository::findDbServer {this serverId} {
  418.     set broker [ORB::broker]
  419.     if [$broker isNil] {
  420.         return [ORB::nil]
  421.     }
  422.  
  423.     set implem [$broker findImplementation $serverId]
  424.     if [$implem isNil] {
  425.         return [ORB::nil]
  426.     }
  427.  
  428.     foreach server [$implem servers] {
  429.         set me [$server findClient [ORB::currentHost] [ORB::currentProcessId]]
  430.         if ![$me isNil] {
  431.             return $server
  432.     }
  433.     }
  434.  
  435.     return [ORB::nil]
  436. }
  437.  
  438. method Repository::shutdownDbServers {this name {shutdownRef ""} {delayedRef ""}} {
  439.     if {$delayedRef != ""} {
  440.         upvar $delayedRef delayedCount
  441.     }
  442.     if {$shutdownRef != ""} {
  443.         upvar $shutdownRef shutdownCount
  444.     }
  445.  
  446.     set ns [ORB::nameServer]
  447.  
  448.     if ![$this getServerByName $name serverDef] {
  449.     $this error "Server definition of server '$name' not found."
  450.     return 0
  451.     }
  452.  
  453.     # Disconnect from current dbserver if shutting current.
  454.     #
  455.     if {[$this currentName] == $name} {
  456.         set dbserver [$this currentDbServer]
  457.         if ![$dbserver isNil] {
  458.             $dbserver disconnect
  459.         }
  460.     }
  461.  
  462.     # Find all current dbservers and shut them down.
  463.     # If any servers are still running, abort name/dir change.
  464.     #
  465.     set delayedCount 0
  466.     set shutdownCount 0
  467.     foreach broker [$ns brokers] {
  468.         set implem [$broker findImplementation $serverDef(fullId)]
  469.         if [$implem isNil] {
  470.             continue
  471.         }
  472.  
  473.         # TODO: tell implementation to shutdown, meaning that it won't
  474.         #       start any new servers, because busy clients will try to
  475.         #       restart a dbserver.
  476.         # $implem shutdown
  477.  
  478.         foreach server [$implem servers] {
  479.             if [catch {$server shutdown} error] {
  480.         # Server could not be disconnected.
  481.                 #
  482.                 incr delayedCount
  483.                 $this error $error
  484.             } else {
  485.                 incr shutdownCount
  486.             }
  487.         }
  488.     }
  489.     if {$delayedCount > 0} {
  490.         if {$delayedCount == 1} {
  491.             set s "is still 1 server"
  492.         } else {
  493.             set s "are still $delayedCount servers"
  494.         }
  495.  
  496.     $this error "There $s of implementation '$name' running.\nQuit all\
  497.              clients and wait for all servers to exit, then retry.\n" -add
  498.                     
  499.     return 0
  500.     }
  501.  
  502.     if {$shutdownCount == 0} {
  503.         $this message "No servers of implementation '$name' were found."
  504.     } else {
  505.         if {$shutdownCount == 1} {
  506.             set servers "The only server"
  507.             set have "has"
  508.         } else {
  509.             set servers "All $shutdownCount servers"
  510.             set have "have"
  511.         }
  512.     $this message "$servers of implementation '$name' $have been shutdown."
  513.     }
  514.  
  515.     return 1
  516. }
  517.  
  518.  
  519. # Returns the set of active clients.  This
  520. # set contains all clients that are currently
  521. # connected to an OT server, be it a
  522. # dbserver or lockserver.
  523. #
  524. method Repository::getActiveClients {this clientMapRef} {
  525.     upvar $clientMapRef clientMap
  526.  
  527.     # Build active client map to improve search perforance.
  528.     #
  529.     set ns [ORB::nameServer]
  530.     foreach broker [$ns brokers] {
  531.         if [catch {set implems [$broker implementations]} error] {
  532.             # Skip this broker, but let user know something is wrong
  533.             # with it.
  534.             #
  535.             lappend brokerErrors $error
  536.             continue
  537.         }
  538.     foreach client [query -s servers.clients $implems] {
  539.         set clientKey "[$client host],[$client pid]"
  540.         set clientMap($clientKey) $client
  541.     }
  542.     }
  543.  
  544.     if [info exists brokerErrors] {
  545.     $this warning "Could not consider clients of servers of not-responding\
  546.                broker(s) due to errors:\n\n[join $brokerErrors "\n\n"]"
  547.     }
  548.  
  549.     if ![info exists clientMap] {
  550.         return 0
  551.     }
  552.     return [array size clientMap]
  553. }
  554.  
  555. method Repository::getServerById {this implemId serverRef} {
  556.     upvar $serverRef serverDef
  557.  
  558.     set entry [[ORB::nameServer] findServerDefinition $implemId]
  559.     if [lempty $entry] {
  560.         return 0
  561.     }
  562.  
  563.     set serverDef(name)        [lindex $entry 0]
  564.     set serverDef(fullId)    [lindex $entry 1]
  565.     set serverDef(id)        [lindex $entry 2]
  566.     set serverDef(version)     [lindex $entry 3]
  567.     set serverDef(policy)    [lindex $entry 4]
  568.     set serverDef(protocol)    [lindex $entry 5]
  569.     set serverDef(executable)    [lindex $entry 6]
  570.     set serverDef(cmdline)    [lindex $entry 7]
  571.     set serverDef(host)        [lindex $entry 8]
  572.  
  573.     return 1
  574. }
  575.  
  576. method Repository::getServerByObject {this objectId serverRef} {
  577.     upvar $serverRef serverDef
  578.  
  579.     set decoded [ORB::decodeObjectId $objectId]
  580.     set implemId [ORB::makeImplemId [lindex $decoded 1] [lindex $decoded 2]]
  581.  
  582.     return [$this getServerById $implemId serverDef]
  583. }
  584.  
  585. method Repository::getServerByName {this implemName serverRef} {
  586.     upvar $serverRef serverDef
  587.  
  588.     foreach entry [[ORB::nameServer] serverDefinitions] {
  589.         set name [lindex $entry 0]
  590.     if {$name == $implemName} {
  591.         return [$this getServerById [lindex $entry 1] serverDef]
  592.     }
  593.     }
  594.  
  595.     return 0
  596. }
  597.  
  598. method Repository::changeServerDefinition {this id version name policy protocol executable cmdline host} {
  599.     set ns [ORB::nameServer]
  600.     $ns changeServerDefinition \
  601.         $id $version $name $policy $protocol $executable $cmdline $host
  602.  
  603.     # Tell all brokers that server definition has changed, in case they
  604.     # have retrieved it already from the name server.
  605.     #
  606.     set implemId [ORB::makeImplemId $id $version]
  607.     foreach broker [$ns brokers] {
  608.         if [catch {
  609.             $broker changeParameter "implementationChanged" $implemId
  610.         } error] {
  611.             $this error $error
  612.         }
  613.     }
  614.  
  615.     return 0
  616. }
  617.  
  618. method Repository::removeServerDefinition {this implemId} {
  619.     set ns [ORB::nameServer]
  620.     $ns removeServerDefinition $implemId
  621.  
  622.     # Tell all brokers that server definition has been removed.
  623.     #
  624.     foreach broker [$ns brokers] {
  625.         if [catch {
  626.             $broker changeParameter "removeImplementation" $implemId
  627.         } error] {
  628.             $this error $error
  629.         }
  630.     }
  631.  
  632.     return 0
  633. }
  634.  
  635.  
  636. # Retrieves Corporate object information from the named database.
  637. # Returns a list with four elements: corporate object id, corporate name,
  638. # product release string and corporate directory.  Uses the dbserver
  639. # to retrieve the info, therefore only available on Unix and NT.
  640. #
  641. method Repository::getInfoFromDatabase {this cmdInfoRef dbName dbInfoRef} {
  642.     upvar $cmdInfoRef cmdInfo
  643.     upvar $dbInfoRef dbInfo
  644.  
  645.     set result [$this runDbScript cmdInfo $dbName dbcorpinfo.tcl]
  646.     if {[lindex $result 0] != "OK"} {
  647.         $this error "Could not retrieve Repository info from database\
  648.              '$dbName':\n[lindex $result 1]" -add
  649.         return 0
  650.     }
  651.  
  652.     set info [lindex $result 1]
  653.  
  654.     set dbInfo(id)        [lindex $info 0]
  655.     set dbInfo(name)        [lindex $info 1]
  656.     set dbInfo(productRelease)    [lindex $info 2]
  657.     set dbInfo(location)    [lindex $info 3]
  658.  
  659.     return 1
  660. }
  661.  
  662.  
  663. # Retrieves database info from a given
  664. # dbserver command line as found in the object
  665. # servers file.  The given variable name is used
  666. # as an associative Tcl variable where its
  667. # members are the following (if the repository
  668. # RDBMS supports them): dbname, dbdir, dbuser,
  669. # dbpassword, dbcryptedpassword, dbhost
  670. # and dbserver.
  671. #
  672. method Repository::getInfoFromCmdLine {this implemId cmdLine cmdInfoRef} {
  673.     upvar $cmdInfoRef cmdInfo
  674.  
  675.     set dbServer 0
  676.     if {$implemId > 100 && $implemId < 1000} {
  677.         set dbServer 1
  678.     }
  679.  
  680.     set tool [lindex $cmdLine 0]
  681.     set argv [lrange $cmdLine 1 end]
  682.     set options(-M4) {m4options noarg {} "M4 options"}
  683.  
  684.     if $dbServer {
  685.     if [RepositoryDBMS::hasDirectory] {
  686.         set options(-d)    {dir arg "" "database directory"}
  687.     }
  688.     if [RepositoryDBMS::hasUser] {
  689.         set options(-u)    {user arg "" "database user"}
  690.     }
  691.     if [RepositoryDBMS::hasPassword] {
  692.         set options(-p)    {cryptedPassword arg "" "crypted password"}
  693.         set options(-P)    {plainPassword arg "" "plain password"}
  694.     }
  695.     if [RepositoryDBMS::hasHost] {
  696.         set options(-h)    {host arg "" "database host"}
  697.     }
  698.     if [RepositoryDBMS::hasServer] {
  699.         set options(-s)    {server arg "" "database server"}
  700.     }
  701.  
  702.     if [catch {Options::parse $tool options argv name} error] {
  703.         $this error "Error parsing command line of server entry:\n\n$error."
  704.         return 0
  705.     }
  706.  
  707.     set cmdInfo(m4options)    $m4options
  708.     set cmdInfo(dbname)    $name
  709.     set cmdInfo(dbdir) ""
  710.     set cmdInfo(dbuser) ""
  711.     set cmdInfo(dbpassword) ""
  712.     set cmdInfo(dbcryptedpassword) ""
  713.     set cmdInfo(dbhost) ""
  714.     set cmdInfo(dbserver) ""
  715.  
  716.     if [RepositoryDBMS::hasDirectory] {
  717.         set cmdInfo(dbdir)    $dir
  718.     }
  719.     if [RepositoryDBMS::hasUser] {
  720.         set cmdInfo(dbuser)    $user
  721.     }
  722.     if [RepositoryDBMS::hasPassword] {
  723.         if {$cryptedPassword != ""} {
  724.         set cmdInfo(dbcryptedpassword) $cryptedPassword
  725.         } elseif {$plainPassword != ""} {
  726.         set cmdInfo(dbpassword) $plainPassword
  727.         set cmdInfo(dbcryptedpassword) [ORB::cryptPassword \
  728.                                                                 $plainPassword]
  729.         }
  730.     }
  731.     if [RepositoryDBMS::hasHost] {
  732.         set cmdInfo(dbhost)    $host
  733.     }
  734.     if [RepositoryDBMS::hasServer] {
  735.         set cmdInfo(dbserver)    $server
  736.     }
  737.     } else {
  738.     if [catch {Options::parse $tool options argv} error] {
  739.         $this error "Error parsing command line of server entry:\n\n$error."
  740.         return 0
  741.     }
  742.  
  743.     set cmdInfo(m4options)    $m4options
  744.     }
  745.  
  746.     return 1
  747. }
  748.  
  749. method Repository::getInfoFromCorporate {this cmdInfoRef} {
  750.     upvar $cmdInfoRef cmdInfo
  751.  
  752.     set corp [$this checkCorporate]
  753.  
  754.     set cmdInfo(dbname)        [$corp databaseName]
  755.     set cmdInfo(m4options)    {}
  756.     set cmdInfo(dbdir) ""
  757.     set cmdInfo(dbuser) ""
  758.     set cmdInfo(dbpassword) ""
  759.     set cmdInfo(dbcryptedpassword) ""
  760.     set cmdInfo(dbhost) ""
  761.     set cmdInfo(dbserver) ""
  762.  
  763.     if [RepositoryDBMS::hasDirectory] {
  764.     set cmdInfo(dbdir)    [$corp databaseDirectory]
  765.     }
  766.     if [RepositoryDBMS::hasUser] {
  767.     set cmdInfo(dbuser)    [$corp databaseUser]
  768.     }
  769.     if [RepositoryDBMS::hasPassword] {
  770.     set cmdInfo(dbcryptedpassword) [$corp databasePassword]
  771.     }
  772.     if [RepositoryDBMS::hasHost] {
  773.     set cmdInfo(dbhost)    [$corp databaseHost]
  774.     }
  775.     if [RepositoryDBMS::hasServer] {
  776.     set cmdInfo(dbserver)    [$corp databaseServer]
  777.     }
  778.  
  779.     return 1
  780. }
  781.  
  782. method Repository::makeOptions {this cmdInfoRef} {
  783.     upvar $cmdInfoRef cmdInfo
  784.     set options ""
  785.  
  786.     if [info exists cmdInfo(m4options)] {
  787.     foreach m4option $cmdInfo(m4options) {
  788.             set list [split $m4option "="]
  789.             if {[llength $list] == 1} {
  790.                 set option +$m4option
  791.             } else {
  792.                 set name [lindex $list 0]
  793.         set value [join [lrange $list 1 end] =]
  794.                 if {$value == 0} {
  795.                     set option -${name}
  796.                 } elseif {$value == 1} {
  797.                     set option +${name}
  798.                 } else {
  799.                     set option -${name}=${value}
  800.                 }
  801.             }
  802.         append options " [quoteIf $option]"
  803.     }
  804.     }
  805.  
  806.     return $options
  807. }
  808.  
  809. method Repository::makeDbOptions {this cmdInfoRef {plainPassword ""}} {
  810.     upvar $cmdInfoRef cmdInfo
  811.     set options ""
  812.  
  813.     if [RepositoryDBMS::hasUser] {
  814.     if [string length $cmdInfo(dbuser)] {
  815.         append options " -u [quoteIf $cmdInfo(dbuser)]"
  816.         }
  817.     }
  818.     if [RepositoryDBMS::hasPassword] {
  819.         if [string length $plainPassword] {
  820.             append options " -P [quoteIf $plainPassword]"
  821.         } elseif [string length $cmdInfo(dbcryptedpassword)] {
  822.         append options " -p [quoteIf $cmdInfo(dbcryptedpassword)]"
  823.         } elseif [string length $cmdInfo(dbpassword)] {
  824.         append options " -P [quoteIf $cmdInfo(dbpassword)]"
  825.         }
  826.     }
  827.     if [RepositoryDBMS::hasDirectory] {
  828.     if [string length $cmdInfo(dbdir)] {
  829.         append options " -d [quoteIf $cmdInfo(dbdir)]"
  830.         }
  831.     }
  832.     if [RepositoryDBMS::hasServer] {
  833.     if [string length $cmdInfo(dbserver)] {
  834.         append options " -s [quoteIf $cmdInfo(dbserver)]"
  835.         }
  836.     }
  837.     if [RepositoryDBMS::hasHost] {
  838.     if [string length $cmdInfo(dbhost)] {
  839.         append options " -h [quoteIf $cmdInfo(dbhost)]"
  840.         }
  841.     }
  842.  
  843.     set m4options [$this makeOptions cmdInfo]
  844.     if ![lempty $m4options] {
  845.         append options " $m4options"
  846.     }
  847.  
  848.     return $options
  849. }
  850.  
  851. method Repository::makeCmdLine {this tool cmdInfoRef} {
  852.     upvar $cmdInfoRef cmdInfo
  853.  
  854.     if [info exists cmdInfo(dbname)] {
  855.     return "$tool[$this makeDbOptions cmdInfo] $cmdInfo(dbname)"
  856.     } else {
  857.         return "$tool[$this makeOptions cmdInfo]"
  858.     }
  859. }
  860.  
  861.  
  862. # Creates the command line for a database tool,
  863. # based on the contents of the assiociative Tcl
  864. # variable given.  The same members as returned
  865. # by getInfoFromCmdLine must be specified.
  866. #
  867. method Repository::makeDbCmdLine {this tool cmdInfoRef} {
  868.     upvar $cmdInfoRef cmdInfo
  869.     return "$tool[$this makeDbOptions cmdInfo] $cmdInfo(dbname)"
  870. }
  871.  
  872. method Repository::makeDbToolCmd {this tool cmdInfoRef usePlainPassword argv} {
  873.     upvar $cmdInfoRef cmdInfo
  874.  
  875.     if {[catch {set toolPath [m4_path_name bin $tool$EXE_EXT]}] ||
  876.        ![file exists $toolPath]} {
  877.         $this warning "No '$tool' available."
  878.         return {}
  879.     }
  880.  
  881.     # Always require an uncrypted password to be specified (or none).
  882.     #
  883.     if [RepositoryDBMS::hasPassword] {
  884.     if {$usePlainPassword} {
  885.         set cmdInfo(dbcryptedpassword) ""
  886.     } else {
  887.         if [string length $cmdInfo(dbpassword)] {
  888.         set crypted [ORB::cryptPassword $cmdInfo(dbpassword)]
  889.         set cmdInfo(dbcryptedpassword) $crypted
  890.         set cmdInfo(dbpassword) ""
  891.         }
  892.     }
  893.     }
  894.  
  895.     set dbOptions [$this makeDbOptions cmdInfo]
  896.     set cmd "[quoteIf $toolPath] $dbOptions $argv"
  897.  
  898.     # Only need an xtool if the plain password was not specified and the
  899.     # used DBMS needs one, since then the db tool will ask for it.
  900.     #
  901.     set type "mtool"
  902.  
  903.     if [RepositoryDBMS::hasPassword] {
  904.         if {$cmdInfo(dbpassword) == "" && $cmdInfo(dbcryptedpassword) == ""} {
  905.             set type "xtool"
  906.         }
  907.     }
  908.  
  909.     return [list $type $cmd]
  910. }
  911.  
  912. method Repository::runDbScript {this cmdInfoRef database script {argv {}}} {
  913.     upvar $cmdInfoRef cmdInfo
  914.  
  915.     # Need uncrypted password if executing a script via -f.
  916.     #
  917.     if {[RepositoryDBMS::hasPassword] && $cmdInfo(dbpassword) == ""} {
  918.         return [list ERROR "No password specified."]
  919.     }
  920.     set cmdInfo(dbcryptedpassword) ""
  921.  
  922.     set script [quoteIf [m4_path_name tcl $script]]
  923.     if {$database == "-"} {
  924.         # Prepend -- to signify end-of-options.
  925.         set database "-- -"
  926.     }
  927.  
  928.     set tmpFile [BasicFS::tmpFile]
  929.     set cmd [lindex [$this makeDbToolCmd dbserver cmdInfo 1 \
  930.                         [concat -f $script $database $tmpFile $argv]] 1]
  931.     if {$cmd == ""} {
  932.         BasicFS::removeFile $tmpFile
  933.     return [list ERROR "Error in command line."]
  934.     }
  935.  
  936.     set error [$this execute $cmd]
  937.     if {$error != ""} {
  938.         BasicFS::removeFile $tmpFile
  939.         return [list ERROR $error]
  940.     }
  941.  
  942.     # Parse tmpFile contents: first line is OK or ERROR, further lines
  943.     # contain result or error message(s).
  944.     #
  945.     set f [BasicFS::readFile $tmpFile]
  946.     BasicFS::removeFile $tmpFile
  947.  
  948.     set lines [split $f "\n"]
  949.     if {[lindex $lines 0] == "ERROR"} {
  950.         return [list "ERROR" [join [lrange $lines 1 end] "\n"]]
  951.     }
  952.  
  953.     return [list "OK" [lindex $lines 1]]
  954. }
  955.  
  956. method Repository::startDbTool {this tool endScript msg cmdInfoRef argv} {
  957.     upvar $cmdInfoRef cmdInfo
  958.  
  959.     set cmdList [$this makeDbToolCmd $tool cmdInfo 0 $argv]
  960.     set type [lindex $cmdList 0]
  961.     set cmd [lindex $cmdList 1]
  962.  
  963.     $this toolFinishedScript $endScript
  964.     $wmttoolObj startCommand $type $cmd "$this toolFinished" $msg {0 0} 1
  965. }
  966.  
  967. method Repository::toolFinished {this} {
  968.     set exitCode 0
  969.     foreach exitCode [$wmttoolObj exitStatusList] {
  970.         # Get last status.
  971.     }
  972.     if {$exitCode == ""} {
  973.         set exitCode 0
  974.     }
  975.  
  976.     set endScript [$this toolFinishedScript]
  977.     if {$endScript != ""} {
  978.         if [catch {eval "$endScript $exitCode"} error] {
  979.             $this error $error
  980.         }
  981.     }
  982. }
  983.  
  984. method Repository::checkRepositoryName {this name} {
  985.     # Detect some invalid characters.
  986.     #
  987.     if [regexp {[~#$*()\{\}/\\|'`"?;]} $name invalid dummy] {
  988.         $this error "Repository name '$name' contains invalid\
  989.                      character '$invalid'." -add
  990.         return 0
  991.     }
  992.  
  993.     if {[string length $name] >= 80} {
  994.         $this error "Repository name '$name' is too long.\nAt most 80\
  995.              characters are allowed." -add
  996.     return 0
  997.     }
  998.  
  999.     return 1
  1000. }
  1001.  
  1002. method Repository::createRepository {this endScript cmdInfoRef name dir} {
  1003.     upvar $cmdInfoRef cmdInfo
  1004.     $this startDbTool "dbserver" $endScript \
  1005.         "Creating new repository '$name'..." cmdInfo \
  1006.         [concat [list -c $name $cmdInfo(dbname)] [quoteIf $dir]]
  1007. }
  1008.  
  1009. method Repository::changeRepository {this cmdInfoRef name dir newName newDir moveDir} {
  1010.     upvar $cmdInfoRef cmdInfo
  1011.  
  1012.     set ns [ORB::nameServer]
  1013.  
  1014.     if ![$this getServerByName $name serverDef] {
  1015.     $this error "Server definition of server '$name' not found."
  1016.     return 0
  1017.     }
  1018.  
  1019.     # Strip all spaces: leading, trailing, interior.
  1020.     #
  1021.     set newName [rmWhiteSpace $newName]
  1022.  
  1023.     if ![$this checkRepositoryName $newName] {
  1024.         return 0
  1025.     }
  1026.  
  1027.     # Script executed on error to undo previously succeeded actions.
  1028.     #
  1029.     set undoScript ""
  1030.  
  1031.     if ![$this shutdownDbServers $name] {
  1032.         return 0
  1033.     }
  1034.  
  1035.     if {$newName == "" && $newDir == ""} {
  1036.         $this warning "Nothing to change."
  1037.         return 0
  1038.     }
  1039.  
  1040.     if {$newName != "" || $newDir != ""} {
  1041.     set argv {}
  1042.  
  1043.     if {$newName != ""} {
  1044.         lappend argv c_name=${newName} 
  1045.  
  1046.         # Change server entry.
  1047.         #
  1048.         if [catch {$this changeServerDefinition \
  1049.                 $serverDef(id) \
  1050.                 $serverDef(version) \
  1051.                 $newName \
  1052.                 $serverDef(policy) \
  1053.                 $serverDef(protocol) \
  1054.                 $serverDef(executable) \
  1055.                 $serverDef(cmdline) \
  1056.                 $serverDef(host)} error] {
  1057.         $this error "Failed to change server definition of server\
  1058.                  '$name':\n\n$error"
  1059.         return 0
  1060.         }
  1061.  
  1062.             set undoScript "
  1063.         if \[catch {$this changeServerDefinition \
  1064.                 $serverDef(id) \
  1065.                 $serverDef(version) \
  1066.                 [list $serverDef(name)] \
  1067.                 [list $serverDef(policy)] \
  1068.                 [list $serverDef(protocol)] \
  1069.                 [list $serverDef(executable)] \
  1070.                 [list $serverDef(cmdline)] \
  1071.                 [list $serverDef(host)]} error] {
  1072.                     $this error $error
  1073.                 }
  1074.                 $undoScript
  1075.             "
  1076.     }
  1077.  
  1078.     if {$newDir != ""} {
  1079.         lappend argv c_directory=${newDir}
  1080.     }
  1081.  
  1082.         set r [$this runDbScript cmdInfo $cmdInfo(dbname) dbcorpch.tcl $argv]
  1083.         if {[lindex $r 0] != "OK"} {
  1084.             $this error [lindex $r 1]
  1085.             eval $undoScript
  1086.             return 0
  1087.         }
  1088.  
  1089.         set undoScript "
  1090.         set argv \[list c_name=${name} c_directory=${dir}]
  1091.         set r \[$this runDbScript cmdInfo \
  1092.                                 $cmdInfo(dbname) dbcorpch.tcl \$argv]
  1093.         if {\[lindex \$r 0] != \"OK\"} {
  1094.         $this error \[lindex \$r 1]
  1095.         }
  1096.             $undoScript
  1097.         "
  1098.     }
  1099.  
  1100.     if $moveDir {
  1101.         if {$newName != ""} {
  1102.             # Move repository directory within old parent directory,
  1103.             # or move it into the new parent directory.
  1104.             # '$dstDir' is assumed to exist.
  1105.             #
  1106.             if {$newDir == ""} {
  1107.         set dstDir $dir
  1108.             } else {
  1109.                 set dstDir $newDir
  1110.             }
  1111.  
  1112.         set orgRepDir [path_name concat $dir $name]
  1113.         set newRepDir [path_name concat $dstDir $newName]
  1114.  
  1115.         if [catch {BasicFS::renameDir $orgRepDir $newRepDir} error] {
  1116.         $this error "Could not move repository directory:\n\n$error"
  1117.         eval $undoScript
  1118.         return 0
  1119.         }
  1120.         } elseif {$newDir != ""} {
  1121.             # Move repository directory from old into new parent directory.
  1122.             #
  1123.         set orgRepDir [path_name concat $dir $name]
  1124.         set newRepDir [path_name concat $newDir $name]
  1125.  
  1126.         if [catch {BasicFS::renameDir $orgRepDir $newRepDir} error] {
  1127.         $this error "Could not move repository directory:\n\n$error"
  1128.         eval $undoScript
  1129.         return 0
  1130.         }
  1131.         }
  1132.     }
  1133.  
  1134.     return 1
  1135. }
  1136.  
  1137. method Repository::fixRepositoryDir {this cmdInfoRef dir name nameInDb} {
  1138.     upvar $cmdInfoRef cmdInfo
  1139.  
  1140.     # Try to make directory in database correspond with
  1141.     # directory in file system.
  1142.     #
  1143.     set repDir     [path_name concat $dir $name]
  1144.     set repDirInDb [path_name concat $dir $nameInDb]
  1145.     if {$repDir == $repDirInDb} {
  1146.     $this warning "Repository directory '$repDir'\
  1147.                corresponds with repository database."
  1148.     return 1
  1149.     }
  1150.  
  1151.     # Update database to have the correct name and directory.
  1152.     #
  1153.     if {$name != $nameInDb} {
  1154.     set argv c_name=${name}
  1155.         set r [$this runDbScript cmdInfo $cmdInfo(dbname) dbcorpch.tcl $argv]
  1156.         if {[lindex $r 0] != "OK"} {
  1157.             $this error [lindex $r 1]
  1158.             return 0
  1159.         }
  1160.     }
  1161.  
  1162.     set repDirExists [file exists $repDir]
  1163.     set repDirInDbExists [file exists $repDirInDb]
  1164.  
  1165.     if {!$repDirExists && $repDirInDbExists} {
  1166.     # Move directory to correspond with database.
  1167.     #
  1168.     if [catch {BasicFS::renameDir $repDirInDb $repDir} error] {
  1169.         $this error $error
  1170.         return 0
  1171.     }
  1172.     } elseif {!$repDirExists && !$repDirInDbExists} {
  1173.     $this error "Neither one of repository directory \
  1174.              '$repDir' not '$repDirInDb' exists."
  1175.     return 0
  1176.     } elseif {$repDirExists && $repDirInDbExists} {
  1177.     $this error "Both of repository directory \
  1178.                  '$repDir' and '$repDirInDb' exists.  Cannot choose."
  1179.     return 0
  1180.     }
  1181.  
  1182.     return 1
  1183. }
  1184.  
  1185.  
  1186. # Deletes the current repository.
  1187. # Database, directory and server entry are all deleted.
  1188. #
  1189. method Repository::deleteRepository {this} {
  1190.     $this getInfoFromCorporate cmdInfo
  1191.     $this deleteRepositoryDb cmdInfo
  1192.     $this deleteRepositoryDir
  1193.     $this deleteServerEntry
  1194.  
  1195.     return 1
  1196. }
  1197.  
  1198. method Repository::deleteRepositoryDir {this} {
  1199.     set corp [$this checkCorporate]
  1200.     set location [path_name concat [$corp location] [$corp name]]
  1201.  
  1202.     if [catch {BasicFS::removeDirAll $location} error] {
  1203.     $this error $error
  1204.         return 0
  1205.     }
  1206.     return 1
  1207. }
  1208.  
  1209. method Repository::deleteRepositoryDb {this cmdInfoRef} {
  1210.     upvar $cmdInfoRef cmdInfo
  1211.  
  1212.     set database $cmdInfo(dbname)
  1213.  
  1214.     set result [$this runDbScript cmdInfo - dbcorpdrop.tcl $database]
  1215.     if {[lindex $result 0] != "OK"} {
  1216.         $this error [lindex $result 1]
  1217.         return 0
  1218.     }
  1219.  
  1220.     return 1
  1221. }
  1222.  
  1223. method Repository::deleteServerEntry {this} {
  1224.     set name [$this currentName]
  1225.  
  1226.     if [$this getServerByName $name serverDef] {
  1227.     set ns [ORB::nameServer]
  1228.     if [catch {$this removeServerDefinition $serverDef(fullId)} error] {
  1229.         $this error $error
  1230.             return 0
  1231.         }
  1232.     } else {
  1233.     $this error "Server entry of repository '$name' not found."
  1234.         return 0
  1235.     }
  1236.     return 1
  1237. }
  1238.  
  1239. method Repository::optimizeRepository {this endScript cmdInfoRef options name projects} {
  1240.  
  1241.     if ![$this shutdownDbServers $name] {
  1242.         return
  1243.     }
  1244.  
  1245.     upvar $cmdInfoRef cmdInfo
  1246.     $this startDbTool "dboptimize" $endScript \
  1247.             "Optimizing repository '$name' ..." cmdInfo \
  1248.             [concat $options $cmdInfo(dbname) $projects]
  1249. }
  1250.  
  1251. method Repository::backupRepository {this endScript cmdInfoRef options name projects archive toFile} {
  1252.     upvar $cmdInfoRef cmdInfo
  1253.  
  1254.     set corp [$this currentCorporate]
  1255.     set repDir [$corp location]
  1256.     set msg "Backing up repository '$name'"
  1257.  
  1258.     set cmdList [$this makeDbToolCmd dbdump cmdInfo 0 \
  1259.                 [concat $options $cmdInfo(dbname) $projects]]
  1260.     if [lempty $cmdList] {
  1261.         return 
  1262.     }
  1263.  
  1264.     set cmd [lindex $cmdList 1]
  1265.     if $archive {
  1266.         # Cd to repository directory so we can make a relative archive.
  1267.         #
  1268.         if [catch {cd $repDir} error] {
  1269.             $this error "Could not change directory to repository\
  1270.              directory '$repDir'"
  1271.             return
  1272.         }
  1273.  
  1274.         set archiveCmd [$this expandArchiveCommand \
  1275.                 [m4_var get M4_archive_cmd] $repDir $name $toFile "archive"]
  1276.  
  1277.         append cmd "; $archiveCmd"
  1278.         if {$toFile != ""} {
  1279.         append msg " in '$toFile'"
  1280.         }
  1281.     }
  1282.  
  1283.     $this toolFinishedScript $endScript
  1284.     $wmttoolObj startCommand [lindex $cmdList 0] $cmd \
  1285.     "$this toolFinished" "$msg ..." {0 0} 1 [list [quoteIf $repDir]]
  1286. }
  1287.  
  1288. method Repository::restoreRepository {this endScript cmdInfoRef options name repDir projects unarchive fromFile} {
  1289.     upvar $cmdInfoRef cmdInfo
  1290.  
  1291.     set fromDir [path_name concat $repDir $name]
  1292.     set msg "Restoring repository '$name'"
  1293.     set cmd ""
  1294.  
  1295.     if $unarchive {
  1296.         # First unarchive $fromFile into $repDir.
  1297.         # Archive must contain $name as top level directory (just like
  1298.         # the archive created by backupRepository).
  1299.         #
  1300.         if [catch {cd $repDir} error] {
  1301.             $this error "Could not change directory to repository\
  1302.              directory '$repDir'"
  1303.             return
  1304.         }
  1305.  
  1306.         set unarchiveCmd [$this expandArchiveCommand \
  1307.         [m4_var get M4_unarchive_cmd] $repDir $name $fromFile "unarchive"]
  1308.  
  1309.         set cmd "$unarchiveCmd; "
  1310.         if {$fromFile != ""} {
  1311.         append msg "from '$fromFile'"
  1312.         }
  1313.     }
  1314.  
  1315.     set cmdList [$this makeDbToolCmd dbdump cmdInfo 0 \
  1316.                     [concat -r $fromDir $options $cmdInfo(dbname) $projects]]
  1317.     append cmd [lindex $cmdList 1]
  1318.  
  1319.     $this toolFinishedScript $endScript
  1320.     $wmttoolObj startCommand [lindex $cmdList 0] $cmd \
  1321.     "$this toolFinished" "$msg ..." {0 0} 1 [list [quoteIf $repDir]]
  1322. }
  1323.  
  1324. method Repository::expandArchiveCommand {this cmd repDir repName file type} {
  1325.     # Name of repository.  Not quoted since user may want to use this
  1326.     # string to build another string.
  1327.     regsub -all %N $cmd $repName cmd
  1328.  
  1329.     # Parent of repository directory.  Not quoted since user may want to add
  1330.     # something to this string.
  1331.     regsub -all %P $cmd $repDir cmd
  1332.  
  1333.     # Repository directory.
  1334.     regsub -all %R $cmd [quoteIf [path_name concat $repDir $repName]] cmd
  1335.  
  1336.     # Full path to dump file.
  1337.     regsub -all %F $cmd [quoteIf $file] cmd
  1338.  
  1339.     # Directory part of dump file path.
  1340.     regsub -all %D $cmd [file dirname $file] cmd
  1341.  
  1342.     # File name part of dump file path.
  1343.     regsub -all %T $cmd [file tail $file] cmd
  1344.  
  1345.     # Type of command: "archive" or "unarchive"
  1346.     regsub -all %W $cmd $type cmd
  1347.     
  1348.     return $cmd
  1349. }
  1350.  
  1351. method Repository::archiveRepository {this endScript dstFile} {
  1352.     set corp [$this currentCorporate]
  1353.     set repDir [$corp location]
  1354.  
  1355.     set cmd [$this expandArchiveCommand [m4_var get M4_archive_cmd] \
  1356.                         $repDir [$corp name] $dstFile "archive"]
  1357.  
  1358.     $this toolFinishedScript $endScript
  1359.     $wmttoolObj startCommand "mtool" $cmd "$this toolFinished" \
  1360.         "Archiving repository in '$dstFile' ..." {0 0} 1 \
  1361.         [list [quoteIf $repDir]]
  1362. }
  1363.  
  1364. method Repository::unarchiveRepository {this endScript repDir repName srcFile} {
  1365.     set cmd [$this expandArchiveCommand [m4_var get M4_unarchive_cmd] \
  1366.                         $repDir $repName $srcFile "unarchive"]
  1367.  
  1368.     $this toolFinishedScript $endScript
  1369.     $wmttoolObj startCommand "mtool" $cmd "$this toolFinished" \
  1370.         "Unarchiving repository from '$srcFile' ..." {0 0} 1 \
  1371.         [list [quoteIf $repDir]]
  1372. }
  1373.  
  1374.  
  1375. # Retrieves a list of pairs each containing an ExternalFileVersion and
  1376. # a ConfigVersion in which that file exists.  Only those external files are
  1377. # returned for which a file in the client's file system exists.
  1378. # The list of returned files can be restricted by specifying a Project
  1379. # or ConfigVersion. By default, the entire current corporate
  1380. # is searched for external file versions.
  1381. # 
  1382. # This action may take a while.
  1383. # 
  1384. # Options:
  1385. #    -clear: clears the cached list of external file versions; always returns
  1386. #           empty list
  1387. #    -dirs: only returns objects that represent a directory in the client's
  1388. #           files system (i.e. Corporate, Project, ConfigVersion,
  1389. #           PhaseVersion or SystemVersion); the returned list now contains
  1390. #           pairs with an object (Corporate, Project, ConfigVersion,
  1391. #          PhaseVersion or SystemVersion) and a ConfigVersion (if object
  1392. #          is not a Project, ConfigVersion or PhaseVersion)
  1393. #    -proj: restricts search to the given Project object
  1394. #    -conf: restricts search to the given ConfigVersion object
  1395. #
  1396. method Repository::getExternalFileVersions {this args} {
  1397.     set corp [$this checkCorporate]
  1398.  
  1399.     set opts(-dirs)  { dirs }
  1400.     set opts(-clear) { clear }
  1401.     set opts(-proj)  " proj arg [ORB::nil] "
  1402.     set opts(-conf)  " conf arg [ORB::nil] "
  1403.     Options::parse getExternalFileVersions opts args
  1404.  
  1405.     if ![$conf isNil] {
  1406.         set proj [$conf project]
  1407.     }
  1408.  
  1409.     if {$clear || ($corp != [$this extCorp] ||
  1410.                    $proj != [$this extProj] ||
  1411.                    $conf != [$this extConf])} {
  1412.         $this extFilesLoaded 0
  1413.         if $clear {
  1414.             return {}
  1415.     }
  1416.     }
  1417.  
  1418.     $this extCorp $corp
  1419.     $this extProj $proj
  1420.     $this extConf $conf
  1421.  
  1422.     if ![$this extFilesLoaded] {
  1423.         [$this extFiles] contents {}
  1424.  
  1425.     if [$conf isNil] {
  1426.         if [$proj isNil] {
  1427.         set configVersions [query $corp.projects.configVersions]
  1428.             } else {
  1429.                 set configVersions [query $proj.configVersions]
  1430.             }
  1431.         } else {
  1432.             set configVersions [list $conf]
  1433.         }
  1434.  
  1435.         foreach configV $configVersions {
  1436.         foreach f [query "file.isExternal == 1" \
  1437.                     $configV.phaseVersions.systemVersions.localFileVersions] {
  1438.  
  1439.         [$this extFiles] append [list $f $configV]
  1440.         }
  1441.         }
  1442.  
  1443.         $this extFilesLoaded 1
  1444.     }
  1445.  
  1446.     if $dirs {
  1447.         [$this extFiles] foreach pair {
  1448.         set f [lindex $pair 0]
  1449.             set c [lindex $pair 1]
  1450.  
  1451.             # insert parent objects from corporate to configV
  1452.             set dirMap([$f corporate]) [ORB::nil]
  1453.             set dirMap([$f project]) [ORB::nil]
  1454.             set dirMap($c) [ORB::nil]
  1455.  
  1456.             # insert phaseV and systemV objects
  1457.             set p [$c findPhaseVersion -byPhase [$f phase]]
  1458.             set s [$p findSystemVersion -bySystem [$f system]]
  1459.             set dirMap($p) $c
  1460.             set dirMap($s) $c
  1461.         }
  1462.         set extDirs {}
  1463.         if [info exists dirMap] {
  1464.         foreach dir [lsort [flatten [array names dirMap]]] {
  1465.         lappend extDirs [list $dir $dirMap($dir)]
  1466.         }
  1467.         }
  1468.         return $extDirs
  1469.     }
  1470.     return [[$this extFiles] contents]
  1471. }
  1472.  
  1473.  
  1474. # Retrieves the lockserver object (LockAdmin).
  1475. # If the lockserver is not running, [ORB::nil] is
  1476. # returned unless startIfNotRunning is true, in which
  1477. # case the lockserver is started.
  1478. #
  1479. method Repository::getLockServer {this {startIfNotRunning 1}} {
  1480.     if [$this useLockServerId] {
  1481.         set ls [$this getLockServerFromId]
  1482.     } elseif {[catch {set ls [ORB::lockServer]; $ls isNil} error]} {
  1483.         $this useLockServerId 1
  1484.         set ls [$this getLockServerFromId]
  1485.     }
  1486.  
  1487.     if {[$ls isNil] && $startIfNotRunning} {
  1488.         # Lockserver is not running, cause it to startup.
  1489.         #
  1490.         $this message "Starting lockserver..."
  1491.  
  1492.         set ls [$this getLockServerFromId]
  1493.         if [catch {$ls pid} startupError] {
  1494.             $this warning "Could not start lockserver:\n\n$startupError."
  1495.         } else {
  1496.         $this message "Lockserver started."
  1497.         }
  1498.     }
  1499.  
  1500.     return $ls
  1501. }
  1502.  
  1503.  
  1504. # Retrieves the lockserver object by using its
  1505. # object id directly.
  1506. #
  1507. method Repository::getLockServerFromId {this} {
  1508.     if [[$this lockServer] isNil] {
  1509.     set lockServerId "LockAdmin:UVyGGcC7HYAUAAAAAAGQAAQAAAAAA"
  1510.     $this lockServer [LockAdmin new $lockServerId]
  1511.     }
  1512.     return [$this lockServer]
  1513. }
  1514.  
  1515.  
  1516. # Returns all locks described by the description.  If onlyHanging is 1, only
  1517. # the hanging locks in the set are returned.
  1518. #
  1519. method Repository::getLocks {this desc {onlyHangingLocks 0}} {
  1520.     set ls [$this getLockServer]
  1521.     if [$ls isNil] {
  1522.         $this warning "Lockserver is not running."
  1523.         return NO_LOCKSERVER
  1524.     }
  1525.  
  1526.     # For now, do pattern matching on reason here, instead of in lockserver.
  1527.     #
  1528.     set matchReason 0
  1529.     if {[lsearch [$desc what] "Reason"] != -1} {
  1530.     set reason [$desc reason]
  1531.     if {[string first "*" $reason] != -1 ||
  1532.         [string first "?" $reason] != -1} {
  1533.         set matchReason 1
  1534.         $desc setReason "*"
  1535.     }
  1536.     }
  1537.  
  1538.     if [catch {set locks [$ls findLocks $desc]} error] {
  1539.         $this error $error
  1540.         return NO_LOCKSERVER
  1541.     }
  1542.  
  1543.     if $matchReason {
  1544.         set matched {}
  1545.         foreach lock $locks {
  1546.             if [string match $reason [$lock reason]] {
  1547.                 lappend matched $lock
  1548.             }
  1549.         }
  1550.         set locks $matched
  1551.     }
  1552.  
  1553.     if $onlyHangingLocks {
  1554.         set hanging {}
  1555.  
  1556.         $this getActiveClients clients
  1557.         foreach lock $locks {
  1558.         set clientKey "[$lock host],[$lock pid]"
  1559.         if ![info exists clients($clientKey)] {
  1560.                 lappend hanging $lock
  1561.             }
  1562.         }
  1563.         return $hanging
  1564.     }
  1565.     return $locks
  1566. }
  1567.  
  1568.  
  1569. # Returns 1 if the given lock is hanging, else 0.
  1570. #
  1571. method Repository::isHangingLock {this lock} {
  1572.     if {[$this getActiveClients clients] == 0} {
  1573.         return 1
  1574.     }
  1575.  
  1576.     set clientKey "[$lock host],[$lock pid]"
  1577.     if [info exists clients($clientKey)] {
  1578.         # A client exists with host and pid of the lock,
  1579.         # so the lock is not hanging.
  1580.         #
  1581.         return 0
  1582.     }
  1583.     return 1
  1584. }
  1585.  
  1586. method Repository::describeLock {this lock} {
  1587.     set objectId [$lock objectId]
  1588.     set lockType [$lock type]
  1589.     set text $objectId
  1590.  
  1591.     set list [ORB::decodeObjectId $objectId]
  1592.     set serverId [lindex $list 1].[lindex $list 2]
  1593.     set isBadServer 0
  1594.     if {[[$this badServers] set $serverId] == "1"} {
  1595.         set isBadServer 1
  1596.     }
  1597.  
  1598.     if {!$isBadServer && [catch {
  1599.     if {$lockType == "readLock" || $lockType == "writeLock"} {
  1600.         # NOTE: This takes a long time if lots of locks are present...
  1601.         #
  1602.         regexp {^([^:]*):} $objectId dummy className
  1603.         set obj [$className new $objectId]
  1604.  
  1605.         set isVersion [$obj isA Version]
  1606.         set isVersionable [$obj isA Versionable]
  1607.  
  1608.         if {$isVersion || $isVersionable} {
  1609.         if $isVersion {
  1610.             set versable [$obj object]
  1611.             set suffix "([$obj versionName])"
  1612.         } else {
  1613.             set versable $obj
  1614.             set suffix ""
  1615.         }
  1616.  
  1617.         if {[$versable isA Phase] ||
  1618.             [$versable isA System] ||
  1619.             [$versable isA File]} {
  1620.             set text "[$versable name].[$versable type]"
  1621.         } else {
  1622.             set text "[$versable name]"
  1623.         }
  1624.         if {$suffix != ""} {
  1625.             append text " $suffix"
  1626.         }
  1627.         }
  1628.     }
  1629.     }]} {
  1630.         # Remember that an error occurred while starting server,
  1631.         # so the next time we do not try to start a server again.
  1632.         #
  1633.         [$this badServers] set $serverId 1
  1634.  
  1635.         set text $objectId
  1636.     }
  1637.  
  1638.     set dbserver [$this findDbServer \
  1639.                     [ORB::makeImplemId [lindex $list 1] [lindex $list 2]]]
  1640.     if ![$dbserver isNil] {
  1641.     $dbserver disconnect
  1642.     }
  1643.  
  1644.     return $text
  1645. }
  1646.  
  1647. method Repository::checkLock {this lock} {
  1648.     if [catch {
  1649.         set lockType [$lock type]
  1650.     set lockObject [$lock objectId]
  1651.     }] {
  1652.         $this error "Lock has been removed already."
  1653.         return 0
  1654.     }
  1655.  
  1656.     if {$lockType == "noLock"} {
  1657.     $this error \
  1658.             "Lock on '[$this describeLock $lock]' has been removed already."
  1659.     return 0
  1660.     }
  1661.  
  1662.     return 1
  1663. }
  1664.  
  1665. method Repository::setLock {this desc} {
  1666.     set ls [$this getLockServer]
  1667.     if [$ls isNil] {
  1668.         $this error "Lockserver is not running."
  1669.         return 0
  1670.     }
  1671.  
  1672.     $ls setLock $desc
  1673.     return 1
  1674. }
  1675.  
  1676. method Repository::removeLock {this lock} {
  1677.     set ls [$this getLockServer 0]
  1678.     if [$ls isNil] {
  1679.         $this warning "Lockserver is not running."
  1680.         return 0
  1681.     }
  1682.  
  1683.     if ![$this checkLock $lock] {
  1684.         return 0
  1685.     }
  1686.  
  1687.     if ![$this isHangingLock $lock] {
  1688.         $this error "Lock on '[$this describeLock $lock]' is not hanging.\
  1689.                  Owning process [$lock pid] of '[$lock user]'\
  1690.                      is still running on host '[$lock host]'."
  1691.         return 0
  1692.     }
  1693.  
  1694.     set rm [LockDescription new]
  1695.     $rm setObject [$lock objectId]
  1696.     $rm addType [LockFilter::lock2descType [$lock type]]
  1697.     $rm setPid [$lock pid]
  1698.     $rm setHost [$lock host]
  1699.     $rm setUser [$lock user]
  1700.  
  1701.     return [$ls removeLocks $rm]
  1702. }
  1703.  
  1704. # Do not delete this line -- regeneration end marker
  1705.  
  1706.