tracking_kits/MVC/lib.Upload.asp

<!--METADATA
  TYPE="TypeLib"
  NAME="Microsoft ActiveX Data Objects 2.5 Library"
  UUID="{00000205-0000-0010-8000-00AA006D2EA4}"
  VERSION="2.5"
-->


<%
' For examples, documentation, and your own free copy, go to:
' http://www.freeaspupload.net
' Note: You can copy and use this script for free and you can make changes
' to the code, but you cannot remove the above comment.

'Changes:
'Aug 2, 2005: Add support for checkboxes and other input elements with multiple values
'Jan 6, 2009: Lars added ASP_CHUNK_SIZE

const DEFAULT_ASP_CHUNK_SIZE = 200000

Class FreeASPUpload
  Public UploadedFiles
  Public FormElements

  Private VarArrayBinRequest
  Private StreamRequest
  Private uploadedYet
  Private internalChunkSize

  Private Sub Class_Initialize()
    Set UploadedFiles = Server.CreateObject("Scripting.Dictionary")
    Set FormElements = Server.CreateObject("Scripting.Dictionary")
    Set StreamRequest = Server.CreateObject("ADODB.Stream")
    StreamRequest.Type = 2  ' adTypeText
    StreamRequest.Open
    uploadedYet = false
    internalChunkSize = DEFAULT_ASP_CHUNK_SIZE
  End Sub
  
  Private Sub Class_Terminate()
    If IsObject(UploadedFiles) Then
      UploadedFiles.RemoveAll()
      Set UploadedFiles = Nothing
    End If
    If IsObject(FormElements) Then
      FormElements.RemoveAll()
      Set FormElements = Nothing
    End If
    StreamRequest.Close
    Set StreamRequest = Nothing
  End Sub

  Public Property Get Form(sIndex)
    Form = ""
    If FormElements.Exists(LCase(sIndex)) Then Form = FormElements.Item(LCase(sIndex))
  End Property

  Public Property Get Files()
    Files = UploadedFiles.Items
  End Property
  
Public Property Get Exists(sIndex)
Exists = false
If FormElements.Exists(LCase(sIndex)) Then Exists = true
End Property

Public Property Get FileExists(sIndex)
FileExists = false
if UploadedFiles.Exists(LCase(sIndex)) then FileExists = true
End Property

Public Property Get chunkSize()
    chunkSize = internalChunkSize
  End Property

  Public Property Let chunkSize(sz)
    internalChunkSize = sz
  End Property

  'Calls Upload to extract the data from the binary request and then saves the uploaded files
  Public Sub Save(path)
    Dim streamFile, fileItem

    if Right(path, 1) <> "\" then path = path & "\"

    if not uploadedYet then Upload

    For Each fileItem In UploadedFiles.Items
      Set streamFile = Server.CreateObject("ADODB.Stream")
      streamFile.Type = 1
      streamFile.Open
      StreamRequest.Position=fileItem.Start
      StreamRequest.CopyTo streamFile, fileItem.Length
      streamFile.SaveToFile path & fileItem.FileName, 2
      streamFile.close
      Set streamFile = Nothing
      fileItem.Path = path & fileItem.FileName
     Next
  End Sub
  
  public sub SaveOne(path, num, byref outFileName, byref outLocalFileName)
    Dim streamFile, fileItems, fileItem, fs

set fs = Server.CreateObject("Scripting.FileSystemObject")
    if Right(path, 1) <> "\" then path = path & "\"

    if not uploadedYet then Upload
    if UploadedFiles.Count > 0 then
      fileItems = UploadedFiles.Items
      set fileItem = fileItems(num)
    
      outFileName = fileItem.FileName
      outLocalFileName = GetFileName(path, outFileName)
    
      Set streamFile = Server.CreateObject("ADODB.Stream")
      streamFile.Type = 1
      streamFile.Open
      StreamRequest.Position = fileItem.Start
      StreamRequest.CopyTo streamFile, fileItem.Length
      streamFile.SaveToFile path & outLocalFileName, 2
      streamFile.close
      Set streamFile = Nothing
      fileItem.Path = path & filename
    end if
  end sub

  Public Function SaveBinRequest(path) ' For debugging purposes
    StreamRequest.SaveToFile path & "\debugStream.bin", 2
  End Function

  Public Sub DumpData() 'only works if files are plain text
    Dim i, aKeys, f
    response.write "Form Items:<br>"
    aKeys = FormElements.Keys
    For i = 0 To FormElements.Count -1 ' Iterate the array
      response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "<BR>"
    Next
    response.write "Uploaded Files:<br>"
    For Each f In UploadedFiles.Items
      response.write "Name: " & f.FileName & "<br>"
      response.write "Type: " & f.ContentType & "<br>"
      response.write "Start: " & f.Start & "<br>"
      response.write "Size: " & f.Length & "<br>"
     Next
  End Sub

  Public Sub Upload()
    Dim nCurPos, nDataBoundPos, nLastSepPos
    Dim nPosFile, nPosBound
    Dim sFieldName, osPathSep, auxStr
    Dim readBytes, readLoop, tmpBinRequest
    
    'RFC1867 Tokens
    Dim vDataSep
    Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType
    tNewLine = String2Byte(Chr(13))
    tDoubleQuotes = String2Byte(Chr(34))
    tTerm = String2Byte("--")
    tFilename = String2Byte("filename=""")
    tName = String2Byte("name=""")
    tContentDisp = String2Byte("Content-Disposition")
    tContentType = String2Byte("Content-Type:")

    uploadedYet = true

    on error resume next
      readBytes = internalChunkSize
      VarArrayBinRequest = Request.BinaryRead(readBytes)
      VarArrayBinRequest = midb(VarArrayBinRequest, 1, lenb(VarArrayBinRequest))
      for readLoop = 0 to 300000
        tmpBinRequest = Request.BinaryRead(readBytes)
        if readBytes < 1 then exit for
        VarArrayBinRequest = VarArrayBinRequest & midb(tmpBinRequest, 1, lenb(tmpBinRequest))
      next
      if Err.Number <> 0 then
        response.write "<br><br><B>System reported this error:</B><p>"
        response.write Err.Description & "<p>"
        response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the <A HREF='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</A>.<p>"
        Exit Sub
      end if
    on error goto 0 'reset error handling

    nCurPos = FindToken(tNewLine,1) 'Note: nCurPos is 1-based (and so is InstrB, MidB, etc)

    If nCurPos <= 1 Then Exit Sub
    
    'vDataSep is a separator like -----------------------------21763138716045
    vDataSep = MidB(VarArrayBinRequest, 1, nCurPos-1)

    'Start of current separator
    nDataBoundPos = 1

    'Beginning of last line
    nLastSepPos = FindToken(vDataSep & tTerm, 1)

    Do Until nDataBoundPos = nLastSepPos
      
      nCurPos = SkipToken(tContentDisp, nDataBoundPos)
      nCurPos = SkipToken(tName, nCurPos)
      sFieldName = ExtractField(tDoubleQuotes, nCurPos)

      nPosFile = FindToken(tFilename, nCurPos)
      nPosBound = FindToken(vDataSep, nCurPos)
      
      If nPosFile <> 0 And nPosFile < nPosBound Then
        Dim oUploadFile
        Set oUploadFile = New UploadedFile
        
        nCurPos = SkipToken(tFilename, nCurPos)
        auxStr = ExtractField(tDoubleQuotes, nCurPos)
' We are interested only in the name of the file, not the whole path
' Path separator is \ in windows, / in UNIX
' While IE seems to put the whole pathname in the stream, Mozilla seem to
' only put the actual file name, so UNIX paths may be rare. But not impossible.
osPathSep = "\"
if InStr(auxStr, osPathSep) = 0 then osPathSep = "/"
        oUploadFile.FileName = Right(auxStr, Len(auxStr)-InStrRev(auxStr, osPathSep))

        if (Len(oUploadFile.FileName) > 0) then 'File field not left empty
          nCurPos = SkipToken(tContentType, nCurPos)
          
auxStr = ExtractField(tNewLine, nCurPos)
' NN on UNIX puts things like this in the stream:
' ?? python py type=?? python application/x-python
          oUploadFile.ContentType = Right(auxStr, Len(auxStr)-InStrRev(auxStr, " "))
          nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
          
          oUploadFile.Start = nCurPos+1
          oUploadFile.Length = FindToken(vDataSep, nCurPos) - 2 - nCurPos
          
          If oUploadFile.Length > 0 Then UploadedFiles.Add LCase(sFieldName), oUploadFile
        End If
      Else
        Dim nEndOfData
        nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
        nEndOfData = FindToken(vDataSep, nCurPos) - 2
        If Not FormElements.Exists(LCase(sFieldName)) Then
          FormElements.Add LCase(sFieldName), Byte2String(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
        else
FormElements.Item(LCase(sFieldName))= FormElements.Item(LCase(sFieldName)) & ", " & Byte2String(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
end if

      End If

      'Advance to next separator
      nDataBoundPos = FindToken(vDataSep, nCurPos)
    Loop
    StreamRequest.WriteText(VarArrayBinRequest)
  End Sub

  Private Function SkipToken(sToken, nStart)
    SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
    If SkipToken = 0 then
      Response.write "Error in parsing uploaded binary request. The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the <A HREF='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</A>.<p>"
      Response.End
    end if
    SkipToken = SkipToken + LenB(sToken)
  End Function

  Private Function FindToken(sToken, nStart)
    FindToken = InstrB(nStart, VarArrayBinRequest, sToken)
  End Function

  Private Function ExtractField(sToken, nStart)
    Dim nEnd
    nEnd = InstrB(nStart, VarArrayBinRequest, sToken)
    If nEnd = 0 then
      Response.write "Error in parsing uploaded binary request."
      Response.End
    end if
    ExtractField = Byte2String(MidB(VarArrayBinRequest, nStart, nEnd-nStart))
  End Function

  'String to byte string conversion
  Private Function String2Byte(sString)
    Dim i
    For i = 1 to Len(sString)
     String2Byte = String2Byte & ChrB(AscB(Mid(sString,i,1)))
    Next
  End Function

  'Byte string to string conversion
  Private Function Byte2String(bsString)
    Dim i
    dim b1, b2, b3, b4
    Byte2String =""
    For i = 1 to LenB(bsString)
     if AscB(MidB(bsString,i,1)) < 128 then
     ' One byte
     Byte2String = Byte2String & ChrW(AscB(MidB(bsString,i,1)))
    elseif AscB(MidB(bsString,i,1)) < 224 then
     ' Two bytes
     b1 = AscB(MidB(bsString,i,1))
     b2 = AscB(MidB(bsString,i+1,1))
     Byte2String = Byte2String & ChrW((((b1 AND 28) / 4) * 256 + (b1 AND 3) * 64 + (b2 AND 63)))
     i = i + 1
    elseif AscB(MidB(bsString,i,1)) < 240 then
     ' Three bytes
     b1 = AscB(MidB(bsString,i,1))
     b2 = AscB(MidB(bsString,i+1,1))
     b3 = AscB(MidB(bsString,i+2,1))
     Byte2String = Byte2String & ChrW(((b1 AND 15) * 16 + (b2 AND 60)) * 256 + (b2 AND 3) * 64 + (b3 AND 63))
     i = i + 2
    else
     ' Four bytes
     b1 = AscB(MidB(bsString,i,1))
     b2 = AscB(MidB(bsString,i+1,1))
     b3 = AscB(MidB(bsString,i+2,1))
     b4 = AscB(MidB(bsString,i+3,1))
     ' Don't know how to handle this, I believe Microsoft doesn't support these characters so I replace them with a "^"
     'Byte2String = Byte2String & ChrW(((b1 AND 3) * 64 + (b2 AND 63)) & "," & (((b1 AND 28) / 4) * 256 + (b1 AND 3) * 64 + (b2 AND 63)))
     Byte2String = Byte2String & "^"
     i = i + 3
     end if
    Next
  End Function
End Class

Class UploadedFile
  Public ContentType
  Public Start
  Public Length
  Public Path
  Private nameOfFile

' Need to remove characters that are valid in UNIX, but not in Windows
Public Property Let FileName(fN)
nameOfFile = fN
nameOfFile = SubstNoReg(nameOfFile, "\", "_")
nameOfFile = SubstNoReg(nameOfFile, "/", "_")
nameOfFile = SubstNoReg(nameOfFile, ":", "_")
nameOfFile = SubstNoReg(nameOfFile, "*", "_")
nameOfFile = SubstNoReg(nameOfFile, "?", "_")
nameOfFile = SubstNoReg(nameOfFile, """", "_")
nameOfFile = SubstNoReg(nameOfFile, "<", "_")
nameOfFile = SubstNoReg(nameOfFile, ">", "_")
nameOfFile = SubstNoReg(nameOfFile, "|", "_")
End Property

Public Property Get FileName()
FileName = nameOfFile
End Property

'Public Property Get FileN()ame
End Class


' Does not depend on RegEx, which is not available on older VBScript
' Is not recursive, which means it will not run out of stack space
Function SubstNoReg(initialStr, oldStr, newStr)
Dim currentPos, oldStrPos, skip
If IsNull(initialStr) Or Len(initialStr) = 0 Then
SubstNoReg = ""
ElseIf IsNull(oldStr) Or Len(oldStr) = 0 Then
SubstNoReg = initialStr
Else
If IsNull(newStr) Then newStr = ""
currentPos = 1
oldStrPos = 0
SubstNoReg = ""
skip = Len(oldStr)
Do While currentPos <= Len(initialStr)
oldStrPos = InStr(currentPos, initialStr, oldStr)
If oldStrPos = 0 Then
SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, Len(initialStr) - currentPos + 1)
currentPos = Len(initialStr) + 1
Else
SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr
currentPos = oldStrPos + skip
End If
Loop
End If
End Function

Function GetFileName(strSaveToPath, FileName)
'This function is used when saving a file to check there is not already a file with the same name so that you don't overwrite it.
'It adds numbers to the filename e.g. file.gif becomes file1.gif becomes file2.gif and so on.
'It keeps going until it returns a filename that does not exist.
'You could just create a filename from the ID field but that means writing the record - and it still might exist!
'N.B. Requires strSaveToPath variable to be available - and containing the path to save to
Dim Counter
Dim Flag
Dim strTempFileName
Dim FileExt
Dim NewFullPath
dim objFSO, p
Set objFSO = CreateObject("Scripting.FileSystemObject")
Counter = 0
p = instrrev(FileName, ".")
FileExt = mid(FileName, p+1)
strTempFileName = left(FileName, p-1)
NewFullPath = strSaveToPath & "\" & FileName
Flag = False

Do Until Flag = True
If objFSO.FileExists(NewFullPath) = False Then
Flag = True
GetFileName = Mid(NewFullPath, InstrRev(NewFullPath, "\") + 1)
Else
Counter = Counter + 1
NewFullPath = strSaveToPath & "\" & strTempFileName & Counter & "." & FileExt
End If
Loop
End Function
%>