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