home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / tools / buildutil.tcl < prev    next >
Encoding:
Text File  |  1993-11-19  |  3.5 KB  |  113 lines
  1. #
  2. # buildutil.tcl -- 
  3. #
  4. # Utility procedures used by the build and install tools.
  5. #------------------------------------------------------------------------------
  6. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  7. #
  8. # Permission to use, copy, modify, and distribute this software and its
  9. # documentation for any purpose and without fee is hereby granted, provided
  10. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  11. # Mark Diekhans make no representations about the suitability of this
  12. # software for any purpose.  It is provided "as is" without express or
  13. # implied warranty.
  14. #------------------------------------------------------------------------------
  15. # $Id: buildutil.tcl,v 3.0 1993/11/19 07:00:08 markd Rel $
  16. #------------------------------------------------------------------------------
  17. #
  18.  
  19. #------------------------------------------------------------------------------
  20. # CopyFile -- 
  21. #
  22. # Copy the specified file and change the ownership.  If target is a directory,
  23. # then the file is copied to it, otherwise target is a new file name.
  24. # If the source file was owner-executable, the all-executable is set on the
  25. # created file.
  26. #------------------------------------------------------------------------------
  27.  
  28. proc CopyFile {sourceFile target} {
  29.     if {[file isdirectory $target]} {
  30.         set targetFile "$target/[file tail $sourceFile]"
  31.     } else {
  32.         set targetFile $target
  33.     }
  34.  
  35.     unlink -nocomplain $targetFile
  36.     set sourceFH [open $sourceFile r]
  37.     set targetFH [open $targetFile w]
  38.     copyfile $sourceFH $targetFH
  39.     close $sourceFH
  40.     close $targetFH
  41.  
  42.     # Fixup the mode.
  43.  
  44.     file stat $sourceFile sourceStat
  45.     if {$sourceStat(mode) & 0100} {
  46.         chmod a+rx $targetFile
  47.     } else {
  48.         chmod a+r  $targetFile
  49.     }
  50. }
  51.  
  52. #------------------------------------------------------------------------------
  53. # CopySubDir --
  54. #
  55. # Recursively copy part of a directory tree, changing ownership and 
  56. # permissions.  This is a utility routine that actually does the copying.
  57. #------------------------------------------------------------------------------
  58.  
  59. proc CopySubDir {sourceDir destDir} {
  60.     foreach sourceFile [glob -nocomplain $sourceDir/*] {
  61.         if [file isdirectory $sourceFile] {
  62.             set destFile $destDir/[file tail $sourceFile]
  63.             if {![file exists $destFile]} {
  64.                 mkdir $destFile}
  65.             CopySubDir $sourceFile $destFile
  66.         } else {
  67.             CopyFile $sourceFile $destDir
  68.         }
  69.     }
  70. }
  71.  
  72. #------------------------------------------------------------------------------
  73. # CopyDir --
  74. #
  75. # Recurisvely copy a directory tree.
  76. #------------------------------------------------------------------------------
  77.  
  78. proc CopyDir {sourceDir destDir} {
  79.     set cwd [pwd]
  80.     if ![file exists $sourceDir] {
  81.         error "\"$sourceDir\" does not exist"
  82.     }
  83.     if ![file isdirectory $sourceDir] {
  84.         error "\"$sourceDir\" isn't a directory"
  85.     }
  86.     
  87.     # Dirs must be absolutes paths, as we are going to change directories.
  88.  
  89.     set sourceDir [glob $sourceDir]
  90.     if {[cindex $sourceDir 0] != "/"} {
  91.         set sourceDir "$cwd/$sourceDir"
  92.     }
  93.     set destDir [glob $destDir]
  94.     if {[cindex $destDir 0] != "/"} {
  95.         set destDir "$cwd/$destDir"
  96.     }
  97.  
  98.     if {![file exists $destDir]} {
  99.         mkdir $destDir
  100.     }
  101.     if ![file isdirectory $destDir] {
  102.         error "\"$destDir\" isn't a directory"
  103.     }
  104.     cd $sourceDir
  105.     set status [catch {CopySubDir . $destDir} msg]
  106.     cd $cwd
  107.     if {$status != 0} {
  108.         global errorInfo errorCode
  109.         error $msg $errorInfo $errorCode
  110.     }
  111. }
  112.  
  113.