Copying Partial Hierarchies

# $Id: copySubtree.tcl,v 1.2 2002/03/27 15:51:06
#
# Last changed: 2009-09-25
# Purpose:
#   copySubtreeAndLinks: Copy a file tree and re-generate the links
#   copySubtree: Simple tree-copying without linkage
# Parameters:
#   File ID or name of the folder to copy,
#   File ID or name of the destination folder
#   [keepStatus]
# keepStatus (optional) tries to assign the same status to the copied files
# as they had before and prints a warning if a file has a released and a
# draft/committed version. In this case only the released version will be copied.

proc copySubtreeAndLinks {{objId ""} {destination ""} {option ""} } {
  if {$destination==""} {
    global copySubtree_usage
    puts $copySubtree_usage
    return
  }
  if {($option!="") && ($option!="keepStatus")} {
    puts "$option is a not allowed option!"
    return
  }
  set to_release 0
  set objId [findObjectId $objId]
  set destination [findObjectId $destination]
  set oldPath [obj withId $objId get path]
  set newPath [obj withId $destination get path]
  set newPath $newPath/[obj withId $objId get name]
  if {[catch {findObjectId $newPath}] == 0} {
    set newPath [obj withId [obj withId $destination create objClass \
      [obj withId $objId get objClass] name [obj withId $objId get name]] get path]
    obj withPath $newPath delete
  }
  puts "Copying files ..."
  copySubtree $objId $destination $option
  puts "\nSubtree successfully copied, now links will be adapted ..."
  set newId [obj withPath $newPath get id]
  foreach i [listSubtree $newId] {
     if !{[obj withId $i get isMirror]} {
        if {[obj withId $i get isReleased] == 1} {
          obj withId $i unrelease
          set to_release 1
        }
        foreach j [obj withId $i get subLinks] {
          set dest [link withId $j get destinationUrl]
          if {[regexp "^$oldPath" $dest]} {
            regsub $oldPath $dest $newPath dest
            link withId $j set destinationUrl $dest
          }
        }
        if {$to_release == 1} {
          obj withId $i release
          set to_release 0
        }
     }
  }
  puts "done"
}


proc copySubtree {{objId ""} {destination ""} {option ""} } {
  if {$destination==""} {
    global copySubtree_usage
    puts $copySubtree_usage
    return
  }
  set objId [findObjectId $objId]
  set destination [findObjectId $destination]
  if {$objId == $destination} {
    puts "You can't copy a file to itself"
    return
  }
  set newId [obj withId $objId copy parent $destination]
  puts -nonewline "\r$objId"
  flush stdout
  if {$option=="keepStatus"} {
    if {[obj withId $objId get isCommitted]=="1"} {
      obj withId $newId commit
    }
    if {[obj withId $objId get isReleased]=="1"} {
      obj withId $newId release
      if {([obj withId $objId get isCommitted]=="1") ||
          ([obj withId $objId get isEdited]=="1")} {
        puts "\nFile $objId has a released and a draft version.\ 
          Only the released version was copied"
      }
    }
  }
  if {[obj withId $objId get objType] == "publication" &&
      ![obj withId $objId get isMirror]} {
    foreach i [obj withId $objId get children] {
      copySubtree $i $newId $option
    }
  }
}

copySubtreeAndLinks /en/news /internet/en