<%
'  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

Class FreeASPUpload
	Public UploadedFiles
	Public FormElements

	Private VarArrayBinRequest
	Private StreamRequest
	Private uploadedYet

	Private Sub Class_Initialize()
		Set UploadedFiles = Server.CreateObject("Scripting.Dictionary")
		Set FormElements = Server.CreateObject("Scripting.Dictionary")
		Set StreamRequest = Server.CreateObject("ADODB.Stream")
		StreamRequest.Type = 1 'adTypeBinary
		StreamRequest.Open
		uploadedYet = false
	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

	'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 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

	Private Sub Upload()
	
		on error resume next
	
		Dim nCurPos, nDataBoundPos, nLastSepPos
		Dim nPosFile, nPosBound
		Dim sFieldName, osPathSep, auxStr

		'RFC1867 Tokens
		Dim vDataSep
		Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType
		tNewLine = Byte2String(Chr(13))
		tDoubleQuotes = Byte2String(Chr(34))
		tTerm = Byte2String("--")
		tFilename = Byte2String("filename=""")
		tName = Byte2String("name=""")
		tContentDisp = Byte2String("Content-Disposition")
		tContentType = Byte2String("Content-Type:")

		uploadedYet = true

on error goto 0 'reset error handling

		on error resume next
		VarArrayBinRequest = Request.BinaryRead(Request.TotalBytes)
		
		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 streaa:
                    '    ?? 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), String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
				else
                    FormElements.Item(LCase(sFieldName))= FormElements.Item(LCase(sFieldName)) & ", " & String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos)) 
                end if 

			End If

			'Advance to next separator
			nDataBoundPos = FindToken(vDataSep, nCurPos)
		Loop
		StreamRequest.Write(VarArrayBinRequest)
		
		on error goto 0
		
		'QS change
		application("doresize")=true
		
	End Sub

	Private Function SkipToken(sToken, nStart)
		SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
		If SkipToken = 0 then
			Response.write "Error in parsing uploaded binary request."
			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 = String2Byte(MidB(VarArrayBinRequest, nStart, nEnd-nStart))
	End Function

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

	'Byte string to string conversion
	'Private Function String2Byte(bsString)
	'	Dim i
	'	String2Byte =""
	'	For i = 1 to LenB(bsString)
	'	   String2Byte = String2Byte & Chr(AscB(MidB(bsString,i,1))) 
	'	Next
	'End Function
	
	Private Function String2Byte(bsString)
		Dim i
		String2Byte =""
		'For i = 1 to LenB(bsString)
			' String2Byte = String2Byte & Chr(AscB(MidB(bsString,i,1)))
		 'Next		
	
		i=1
		while (i <= LenB(bsString))
				if (AscB(MidB(bsString,i,1)) =< 127)  then
					String2Byte = String2Byte & Chr(AscB(MidB(bsString,i,1))) 
					i= i +1
				elseif (AscB(MidB(bsString,i,1)) >= 192 AND AscB(MidB(bsString,i,1)) =<223)  then
					String2Byte = String2Byte & ChrW( ((AscB(MidB(bsString,i,1))-192)*64) + (AscB(MidB(bsString,i+1,1))-128) )
					i= i +2
				elseif (AscB(MidB(bsString,i,1)) >=224 AND AscB(MidB(bsString,i,1)) <=239) then
					String2Byte = String2Byte & ChrW( ((AscB(MidB(bsString,i,1))-224)*4096) + ((AscB(MidB(bsString,i+1,1))-128)*64) + (AscB(MidB(bsString,i+2,1))-128) )
					i= i +3					
				elseif (AscB(MidB(bsString,i,1)) >=240 AND AscB(MidB(bsString,i,1)) <=247) then
					String2Byte = String2Byte & ChrW( ((AscB(MidB(bsString,i,1))-240)*262144) +  ((AscB(MidB(bsString,i+1,1))-128)*4096) + ((AscB(MidB(bsString,i+2,1))-128)*64) + (AscB(MidB(bsString,i+3,1))-128) )
					i= i +4					
				elseif (AscB(MidB(bsString,i,1)) >=248 AND AscB(MidB(bsString,i,1)) <=251) then
					String2Byte = String2Byte & ChrW( ((AscB(MidB(bsString,i,1))-248)*16777216) +  ((AscB(MidB(bsString,i+1,1))-128)*262144) +  ((AscB(MidB(bsString,i+2,1))-128)*4096) + ((AscB(MidB(bsString,i+3,1))-128)*64) + (AscB(MidB(bsString,i+4,1))-128) )
					i= i +5					
				elseif (AscB(MidB(bsString,i,1)) >=252 AND AscB(MidB(bsString,i,1)) <=253) then
					String2Byte = String2Byte & ChrW	( ((AscB(MidB(bsString,i,1))-252)*1073741824) +  ((AscB(MidB(bsString,i+1,1))-128)*16777216) +  ((AscB(MidB(bsString,i+2,1))-128)*262144) +  ((AscB(MidB(bsString,i+3,1))-128)*4096) + ((AscB(MidB(bsString,i+4,1))-128)*64) + (AscB(MidB(bsString,i+5,1))-128) )
					i= i +6					
				else
					Response.Write "***"
					i= i +1
				end if
		wend
	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 function delete()
				
		dim fsoUPLOAD
		set fsoUPLOAD=server.CreateObject ("scripting.filesystemobject")
	
		if fsoUPLOAD.FileExists (path) then
			fsoUPLOAD.DeleteFile (path)
		end if
		
		set fsoUPLOAD=nothing				
    
    end function

	Public function rename(newName,uploadsDirVar)
				
		dim fsoUPLOAD, file
		set fsoUPLOAD=server.CreateObject ("scripting.filesystemobject")
	
		if fsoUPLOAD.FileExists (path) then
			set file = fsoUPLOAD.GetFile(Path) 
			if file.name<>newName then
				if fsoUPLOAD.FileExists(uploadsDirVar&"\"&newName) then
					fsoUPLOAD.DeleteFile uploadsDirVar&"\"&newName
				end if
				file.name = newName
			end if
			set file = nothing 
    	end if
		
		set fsoUPLOAD=nothing				
    
    end function
    
    Public function move(name,oldPath,newPath)
			
		dim fsoUPLOADMove, file
		set fsoUPLOADMove=server.CreateObject ("scripting.filesystemobject")
	
		if fsoUPLOADMove.FileExists (oldPath & name) then
			set file = fsoUPLOADMove.GetFile(oldPath & name) 
				
				if oldPath<>newPath then
					if fsoUPLOADMove.fileExists(newPath & name) then
						fsoUPLOADMove.DeleteFile(newPath & name)
					end if
					fsoUPLOADMove.MoveFile oldPath & name,newPath & name
				end if
			
			set file = nothing 
    	end if
		
		set fsoUPLOADMove=nothing		
		
		'Response.Write 		newPath & name
    
    end function

    
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
%>