System.Data.SQLite
Artifact Content
Not logged in

Artifact 00abe06a8b1e8ceb369e5bbc0a1eb17a6e211204:


###############################################################################
#
# file3.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle File 3 Package File
#
# Copyright (c) 2007-2012 by Joe Mistachkin.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
#
###############################################################################

#
# NOTE: Use our own namespace here because even though we do not directly
#       support namespaces ourselves, we do not want to pollute the global
#       namespace if this script actually ends up being evaluated in Tcl.
#
namespace eval ::Eagle {
  #
  # NOTE: This procedure uses the type of the specified path to figure out
  #       the (possibly normalized) path to add to the finder results.
  #
  proc getDirResultPath { pattern path } {
    #
    # NOTE: This should work properly in both Tcl and Eagle.
    #       Is the result path itself already absolute?
    #
    if {[file pathtype $path] eq "absolute"} then {
      #
      # NOTE: Ok, the result path is already absolute.
      #       Normalize and return it.
      #
      return [file normalize $path]
    } elseif {[file pathtype $pattern] eq "absolute"} then {
      #
      # NOTE: The pattern refers to an absolute path.  Strip
      #       the final part of the pattern and join it with
      #       the result path (which we already know is not
      #       absolute).
      #
      return [file normalize [file join [file dirname $pattern] $path]]
    } else {
      #
      # NOTE: Neither the result path nor the input pattern
      #       contain an absolute path; therefore, use the
      #       current directory to hang the result path on.
      #
      return [file normalize [file join [pwd] $path]]
    }
  }

  #
  # NOTE: This procedure returns a list of directories matching the pattern
  #       specified.  It does not recurse into sub-directories.
  #
  proc findDirectories { pattern } {
    if {[isEagle]} then {
      #
      # NOTE: Block non-Windows platforms since this is Windows specific.
      #
      if {![isWindows]} then {
        error "not supported on this operating system"
      }

      #
      # NOTE: This should work properly in Eagle only.
      #
      set dir ""; set result [list]

      #
      # HACK: Optimize the variable access in this procedure to be
      #       as fast as possible.
      #
      makeVariableFast dir true; makeVariableFast result true

      #
      # NOTE: We will need to grab the ComSpec environment variable.
      #
      global env

      foreach dir [split [exec -unicode $env(ComSpec) /u /c dir \
          /ad /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set dir [string trim $dir]

        if {[string length $dir] > 0} then {
          set dir [getDirResultPath $pattern $dir]

          if {[lsearch -variable -exact -nocase result $dir] == -1} then {
            lappend result $dir
          }
        }
      }

      foreach dir [split [exec -unicode $env(ComSpec) /u /c dir \
          /ahd /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set dir [string trim $dir]

        if {[string length $dir] > 0} then {
          set dir [getDirResultPath $pattern $dir]

          if {[lsearch -variable -exact -nocase result $dir] == -1} then {
            lappend result $dir
          }
        }
      }

      return $result
    } else {
      #
      # NOTE: This should work properly in Tcl only.
      #
      eval lappend result [glob -nocomplain -types {d} \
          [file normalize $pattern]]

      eval lappend result [glob -nocomplain -types {d hidden} \
          [file normalize $pattern]]

      return $result
    }
  }

  #
  # NOTE: This procedure returns a list of directories matching the pattern
  #       specified.  It recurses into sub-directories.
  #
  proc findDirectoriesRecursive { pattern } {
    if {[isEagle]} then {
      #
      # NOTE: Block non-Windows platforms since this is Windows specific.
      #
      if {![isWindows]} then {
        error "not supported on this operating system"
      }

      #
      # NOTE: This should work properly in Eagle only.
      #
      set dir ""; set result [list]

      #
      # HACK: Optimize the variable access in this procedure to be
      #       as fast as possible.
      #
      makeVariableFast dir true; makeVariableFast result true

      #
      # NOTE: We will need to grab the ComSpec environment variable.
      #
      global env

      foreach dir [split [exec -unicode $env(ComSpec) /u /c dir \
          /ad /s /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set dir [string trim $dir]

        if {[string length $dir] > 0} then {
          set dir [getDirResultPath $pattern $dir]

          if {[lsearch -variable -exact -nocase result $dir] == -1} then {
            lappend result $dir
          }
        }
      }

      foreach dir [split [exec -unicode $env(ComSpec) /u /c dir \
          /ahd /s /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set dir [string trim $dir]

        if {[string length $dir] > 0} then {
          set dir [getDirResultPath $pattern $dir]

          if {[lsearch -variable -exact -nocase result $dir] == -1} then {
            lappend result $dir
          }
        }
      }

      return $result
    } else {
      #
      # NOTE: Block non-Windows platforms since this is Windows specific.
      #
      if {![isWindows]} then {
        error "not supported on this operating system"
      }

      #
      # NOTE: This should work properly in Tcl only.
      #
      set result [list]

      #
      # NOTE: We will need to grab the ComSpec environment variable.
      #
      global env

      #
      # NOTE: We will also need to check the Tcl version.
      #
      global tcl_version

      catch {
        foreach dir [split [exec $env(ComSpec) /c dir /ad /s /b \
            [file nativename $pattern]] \n] {
          set dir [string trim $dir]

          if {[string length $dir] > 0} then {
            set dir [getDirResultPath $pattern $dir]

            #
            # HACK: The -nocase option to [lsearch] is only available
            #       starting with Tcl 8.5.
            #
            if {$tcl_version >= 8.5} then {
              if {[lsearch -exact -nocase $result $dir] == -1} then {
                lappend result $dir
              }
            } else {
              if {[lsearch -exact [string tolower $result] \
                  [string tolower $dir]] == -1} then {
                lappend result $dir
              }
            }
          }
        }
      }

      catch {
        foreach dir [split [exec $env(ComSpec) /c dir /ahd /s /b \
            [file nativename $pattern]] \n] {
          set dir [string trim $dir]

          if {[string length $dir] > 0} then {
            set dir [getDirResultPath $pattern $dir]

            #
            # HACK: The -nocase option to [lsearch] is only available
            #       starting with Tcl 8.5.
            #
            if {$tcl_version >= 8.5} then {
              if {[lsearch -exact -nocase $result $dir] == -1} then {
                lappend result $dir
              }
            } else {
              if {[lsearch -exact [string tolower $result] \
                  [string tolower $dir]] == -1} then {
                lappend result $dir
              }
            }
          }
        }
      }

      return $result
    }
  }

  #
  # NOTE: This procedure returns a list of files matching the pattern
  #       specified.  It does not recurse into sub-directories.
  #
  proc findFiles { pattern } {
    if {[isEagle]} then {
      #
      # NOTE: Block non-Windows platforms since this is Windows specific.
      #
      if {![isWindows]} then {
        error "not supported on this operating system"
      }

      #
      # NOTE: This should work properly in Eagle only.
      #
      set fileName ""; set result [list]

      #
      # HACK: Optimize the variable access in this procedure to be
      #       as fast as possible.
      #
      makeVariableFast fileName true; makeVariableFast result true

      #
      # NOTE: We will need to grab the ComSpec environment variable.
      #
      global env

      foreach fileName [split [exec -unicode $env(ComSpec) /u /c dir \
          /a-d /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set fileName [string trim $fileName]

        if {[string length $fileName] > 0} then {
          set fileName [getDirResultPath $pattern $fileName]

          if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
            lappend result $fileName
          }
        }
      }

      foreach fileName [split [exec -unicode $env(ComSpec) /u /c dir \
          /ah-d /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set fileName [string trim $fileName]

        if {[string length $fileName] > 0} then {
          set fileName [getDirResultPath $pattern $fileName]

          if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
            lappend result $fileName
          }
        }
      }

      return $result
    } else {
      #
      # NOTE: This should work properly in Tcl only.
      #
      eval lappend result [glob -nocomplain -types {f} \
          [file normalize $pattern]]

      eval lappend result [glob -nocomplain -types {f hidden} \
          [file normalize $pattern]]

      return $result
    }
  }

  #
  # NOTE: This procedure returns a list of files matching the pattern
  #       specified.  It recurses into sub-directories.
  #
  proc findFilesRecursive { pattern } {
    if {[isEagle]} then {
      #
      # NOTE: Block non-Windows platforms since this is Windows specific.
      #
      if {![isWindows]} then {
        error "not supported on this operating system"
      }

      #
      # NOTE: This should work properly in Eagle only.
      #
      set fileName ""; set result [list]

      #
      # HACK: Optimize the variable access in this procedure to be
      #       as fast as possible.
      #
      makeVariableFast fileName true; makeVariableFast result true

      #
      # NOTE: We will need to grab the ComSpec environment variable.
      #
      global env

      foreach fileName [split [exec -unicode $env(ComSpec) /u /c dir \
          /a-d /s /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set fileName [string trim $fileName]

        if {[string length $fileName] > 0} then {
          set fileName [getDirResultPath $pattern $fileName]

          if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
            lappend result $fileName
          }
        }
      }

      foreach fileName [split [exec -unicode $env(ComSpec) /u /c dir \
          /ah-d /s /b [appendArgs \" [file nativename $pattern] \"]] \n] {
        set fileName [string trim $fileName]

        if {[string length $fileName] > 0} then {
          set fileName [getDirResultPath $pattern $fileName]

          if {[lsearch -variable -exact -nocase result $fileName] == -1} then {
            lappend result $fileName
          }
        }
      }

      return $result
    } else {
      #
      # NOTE: Block non-Windows platforms since this is Windows specific.
      #
      if {![isWindows]} then {
        error "not supported on this operating system"
      }

      #
      # NOTE: This should work properly in Tcl only.
      #
      set result [list]

      #
      # NOTE: We will need to grab the ComSpec environment variable.
      #
      global env

      #
      # NOTE: We will also need to check the Tcl version.
      #
      global tcl_version

      catch {
        foreach fileName [split [exec $env(ComSpec) /c dir /a-d /s /b \
            [file nativename $pattern]] \n] {
          set fileName [string trim $fileName]

          if {[string length $fileName] > 0} then {
            set fileName [getDirResultPath $pattern $fileName]

            #
            # HACK: The -nocase option to [lsearch] is only available
            #       starting with Tcl 8.5.
            #
            if {$tcl_version >= 8.5} then {
              if {[lsearch -exact -nocase $result $fileName] == -1} then {
                lappend result $fileName
              }
            } else {
              if {[lsearch -exact [string tolower $result] \
                  [string tolower $fileName]] == -1} then {
                lappend result $fileName
              }
            }
          }
        }
      }

      catch {
        foreach fileName [split [exec $env(ComSpec) /c dir /ah-d /s /b \
            [file nativename $pattern]] \n] {
          set fileName [string trim $fileName]

          if {[string length $fileName] > 0} then {
            set fileName [getDirResultPath $pattern $fileName]

            #
            # HACK: The -nocase option to [lsearch] is only available
            #       starting with Tcl 8.5.
            #
            if {$tcl_version >= 8.5} then {
              if {[lsearch -exact -nocase $result $fileName] == -1} then {
                lappend result $fileName
              }
            } else {
              if {[lsearch -exact [string tolower $result] \
                  [string tolower $fileName]] == -1} then {
                lappend result $fileName
              }
            }
          }
        }
      }

      return $result
    }
  }

  #
  # NOTE: This procedure attempts to copy all files matching the specified
  #       source directory and patterns to the destination directory.  This
  #       procedure may raise script errors.
  #
  proc copyFilesRecursive {
          sourceDirectory targetDirectory {patterns ""} {options ""} } {
    #
    # NOTE: Block non-Windows platforms since this is Windows specific.
    #
    if {![isWindows]} then {
      error "not supported on this operating system"
    }

    #
    # NOTE: Start out with the [exec] command and the necessary options
    #       to the command.
    #
    if {[isEagle]} then {
      set command [list exec -exitcode exitCode -- robocopy]
    } else {
      set command [list exec -- robocopy]
    }

    #
    # NOTE: Add the source and target directory names.  These are always
    #       required.
    #
    if {[isEagle]} then {
      lappend command [appendArgs \" [file nativename $sourceDirectory] \"]
      lappend command [appendArgs \" [file nativename $targetDirectory] \"]
    } else {
      lappend command [file nativename $sourceDirectory]
      lappend command [file nativename $targetDirectory]
    }

    #
    # NOTE: If there are patterns specified, add them now.  By default,
    #       all files are copied (i.e. "*.*").
    #
    if {[llength $patterns] > 0} then {
      eval lappend command $patterns
    }

    #
    # NOTE: Should the default Robocopy options be excluded?  Generally,
    #       these options should not be excluded.  All matching files
    #       are copied, using restartable mode, and using extra options
    #       when running as administrator to enable copying more files
    #       and metadata, e.g. using backup mode and copying the extra
    #       file security information.
    #
    if {[lsearch -exact $options -nocopyopts] == -1} then {
      lappend command /E

      if {[isEagle] && [isAdministrator]} then {
        lappend command /ZB /COPYALL
      } else {
        lappend command /Z
      }

      lappend command /DCOPY:T
    }

    #
    # NOTE: Should we override the default number of retries per file?
    #       If no retry related option is found, the Robocopy default
    #       behavior will be used (i.e. 1 million retries per file).
    #
    if {[set index [lsearch -glob $options -retries:*]] != -1} then {
      #
      # NOTE: Grab the retry option name/value from the list of options
      #       and attempt to extract the integer number of retries from
      #       it.
      #
      set value [lindex $options $index]

      if {[regexp -- {^-retries:(\d+)$} $value dummy retries] && \
          [string is integer -strict $retries] && $retries >= 0} then {
        #
        # NOTE: Use the specified number of retries.  This value will
        #       be greater than or equal to zero and within the range
        #       of a 32-bit integer.
        #
        lappend command [appendArgs /R: $retries]
      } else {
        #
        # NOTE: The specified number of retries is somehow invalid.
        #
        error "number of retries must be a positive integer"
      }
    } elseif {[lsearch -exact $options -retry] == -1} then {
      #
      # NOTE: Fallback to setting retry count to zero, which is used
      #       to disable per-file retries.
      #
      lappend command /R:0
    }

    #
    # NOTE: By default, do not process file system junctions.  This
    #       is used to avoid the possibility of infinite loops when
    #       traversing the file system (i.e. because it is trivial
    #       to utilize file system junctions in order to construct
    #       directory trees that loop back upon themselves).
    #
    if {[lsearch -exact $options -junctions] == -1} then {
      lappend command /XJ
    }

    #
    # NOTE: By default, do not purge any files that happen to be in
    #       the target directory.
    #
    if {[lsearch -exact $options -purge] != -1} then {
      lappend command /PURGE
    }

    #
    # NOTE: By default, do not produce a verbose log files in the
    #       temporary directory.
    #
    if {[lsearch -exact $options -logging] != -1} then {
      lappend command /X /V /FP /NP

      package require Eagle.Test
      set logFileName [getTemporaryFileName]

      if {[isEagle]} then {
        lappend command [appendArgs \
            \"/LOG: [file nativename $logFileName] \"]
      } else {
        lappend command [appendArgs \
            /LOG: [file nativename $logFileName]]
      }
    }

    #
    # NOTE: Upon success, the exit code from Robocopy will be between
    #       zero and seven.  If the exit code is eight or greater, it
    #       has somehow failed and that error must be reported to the
    #       caller via raising a script error.
    #
    if {[isEagle]} then {
      #
      # NOTE: Execute the resulting [exec] command in our context and
      #       capture the results.
      #
      set result [eval $command]

      if {[info exists exitCode] && $exitCode in \
          [list Success Failure Exception 0 1 2 3 4 5 6 7]} then {
        #
        # NOTE: Return the captured output from the Robocopy command,
        #       whatever it was.  Generally, this will either be the
        #       summary and details of the files copied -OR- the log
        #       file name.
        #
        return $result
      } else {
        #
        # NOTE: Raise a script error, using the captured errors from
        #       the Robocopy command, whatever it was.
        #
        error [appendArgs \
            "command \"" $command "\" error: " $result]
      }
    } else {
      #
      # NOTE: Execute the resulting [exec] command in our context and
      #       capture the results.
      #
      if {[catch $command result] == 0 || ([info exists ::errorCode] && \
          [maybeGetExitCode $::errorCode 8] < 8)} then {
        #
        # NOTE: Return the captured output from the Robocopy command,
        #       whatever it was.  Generally, this will either be the
        #       summary and details of the files copied -OR- the log
        #       file name.
        #
        return $result
      } else {
        #
        # NOTE: Raise a script error, using the captured errors from
        #       the Robocopy command, whatever it was.
        #
        error [appendArgs \
            "command \"" $command "\" error: " $result]
      }
    }
  }

  #
  # NOTE: Provide the Eagle "file finder" package to the interpreter.
  #
  package provide Eagle.File.Finder \
    [expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}