<%
Class FileUpload
Private UploadRequest, oProps, iFrmCt
Private iKnownFileCount, iKnownFormCount
Private oOutFiles
Private Sub Class_Initialize
iFrmCt = 0
Set oProps = New FO_Properties
Set UploadRequest = Server.CreateObject("Scripting.Dictionary")
iKnownFileCount = 0
iKnownFormCount = 0
set oOutFiles = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate
set oOutFiles = Nothing
Set UploadRequest = Nothing
Set oProps = Nothing
End Sub
Public Property Get Version()
Version = "1.0"
End Property
Public Function GetUploadSettings()
Set GetUploadSettings = oProps
End Function
Public Property Get FormCount
FormCount = iKnownFormCount
End Property
Public Property Get FileCount
FileCount = iKnownFileCount
End Property
Public Property Get TotalFormCount
TotalFormCount = iFrmCt
End Property
Private Function GetFormEncType()
Dim sContType, hCutOff
sContType = request.servervariables("CONTENT_TYPE")
hCutOff = instr(sContType, ";")
if hCutOff > 0 then
sContType = UCase(Trim(Left(sContType, hCutOff - 1)))
else
sContType = UCase(Trim(sContType))
end if
GetFormEncType = sContType
End Function
Public Default Sub ProcessUpload
Dim RequestBin, oProcess, iTotBytes, key, arr, iKnownProps, oFile
Dim fofilecheck, sEncType, sReqMeth
iTotBytes = Request.TotalBytes
if iTotBytes = 0 then
iFrmCt = 0
exit sub
end if
RequestBin = Request.BinaryRead(iTotBytes)
sReqMeth = request.servervariables("REQUEST_METHOD")
select case UCase(sReqMeth)
case "POST"
sEncType = GetFormEncType
select case sEncType
case "MULTIPART/FORM-DATA"
Set oProcess = New FO_Processor
oProcess.BuildUploadRequest RequestBin, UploadRequest
Set oProcess = Nothing
case "APPLICATION/X-WWW-FORM-URLENCODED"
Set oProcess = New FO_Processor
oProcess.BuildUploadRequest_ASCII oProcess.getString(RequestBin), UploadRequest
Set oProcess = Nothing
case else
end select
case "GET"
case else
end select
arr = uploadrequest.keys
if not isarray(arr) then
iFrmCt = 0
exit sub
end if
iFrmCt = ubound(arr)
for each key in arr
if isobject(uploadrequest.item(key)) then
iKnownProps = ubound(uploadrequest.item(key).keys) + 1
if iKnownProps = 4 then
iKnownFileCount = iKnownFileCount + 1
set fofilecheck = new FO_FileChecker
fofilecheck.SetCurrentProperties oProps
fofilecheck.FileInput_NamePath = uploadrequest.item(key).item("FileName")
fofilecheck.FileInput_ContentType = uploadrequest.item(key).item("ContentType")
fofilecheck.FileInput_BinaryText = uploadrequest.item(key).item("Value")
fofilecheck.FileInput_FormInputName = uploadrequest.item(key).item("InputName")
set oFile = fofilecheck.ValidateVerifyReturnFile()
set fofilecheck = nothing
oOutFiles.add iKnownFileCount, oFile
set oFile = nothing
uploadrequest.remove key
elseif iKnownProps = 2 then
iKnownFormCount = iKnownFormCount + 1
else
end if
end if
next
End Sub
Public Function File(ByVal blobName)
Dim blobs, blob, subdict, tmpName
blobs = oOutFiles.Keys
For Each blob In blobs
Set subdict = oOutFiles.Item(blob)
tmpName = subdict.frmInputName
If UCase(Trim(tmpName)) = UCase(Trim(blobName)) Then
blobName = blob
Exit For
End If
Next
if isobject(oOutFiles.Item(blobName)) then
Set File = oOutFiles.Item(blobName)
else
Set File = Nothing
end if
End Function
Public Function Form(ByVal inputName)
if isobject(UploadRequest.Item(inputName)) then
Form = UploadRequest.Item(inputName).Item("Value")
else
Form = ""
end if
End Function
Public Function FormLen(ByVal inputName)
if isobject(UploadRequest.Item(inputName)) then
FormLen = Len(UploadRequest.Item(inputName).Item("Value"))
else
FormLen = 0
end if
End Function
Public Function FormEx(ByVal inputName, ByVal vDefaultValue)
dim vTmp
if isobject(UploadRequest.Item(inputName)) then
vTmp = UploadRequest.Item(inputName).Item("Value")
if len(trim(CStr(vTmp))) = 0 then
FormEx = vDefaultValue
Exit Function
end if
FormEx = vTmp
Exit Function
end if
FormEx = vDefaultValue
End Function
Public Function Inputs()
if isobject(UploadRequest) then
Inputs = UploadRequest.keys
else
Inputs = ""
end if
End Function
Public Sub ShowUploadForm(ByVal sSubmitPage)
Dim tmp, item
With Response
.Write("Kabul Edilen Dosya Türleri:
")
tmp = ""
If IsArray(oProps.Extensions) Then
For Each Item In oProps.Extensions
tmp = tmp & "*." & Item & ", "
Next
tmp = left( tmp, Len(tmp) - 2 )
End If
.Write(tmp & "
")
.Write("Max. Dosya boyutu: ~ ")
.Write(Round( oProps.MaximumFileSize / 1024, 1 ) & " k ")
.Write("
Min. Dosya boyutu: ~ ")
.Write(FormatNumber(Round( oProps.MininumFileSize _
/ 1024, 1 ), 1) & " k.
")
.Write("")
.Write("" & vbCrLf)
End With
End Sub
End Class
Class FO_FileChecker
Private oProps, sFileName, hFileBinLen, sFileBin, sFileContentType, sFileFormInputName
Private Sub Class_Initialize()
sFileName = ""
hFileBinLen = 0
sFileBin = ""
sFileContentType = ""
End Sub
Public Sub SetCurrentProperties(byref oPropertybag)
Set oProps = oPropertybag
End Sub
Public Property Let FileInput_FormInputName(ByVal fname)
sFileFormInputName = fname
End Property
Public Property Let FileInput_NamePath(ByVal fname)
Dim realfilename
realfilename = Right(fname, Len(fname) - InstrRev(fname,"\"))
sFileName = trim(realfilename)
End Property
Public Property Let FileInput_ContentType(ByVal conttype)
sFileContentType = conttype
End Property
Public Property Let FileInput_BinaryText(ByVal binstring)
Dim binlen
binlen = lenb(binstring)
hFileBinLen = binlen
sFileBin = binstring
End Property
Public Function ValidateVerifyReturnFile()
if IllegalCharsFound then
Set ValidateVerifyReturnFile = FillFOFileObj(false, "", "", "dosya adında geçersiz karakter bulunamaz", "", "", "", sFileFormInputName)
Exit Function
end if
if FileNameBadOrExists then
Set ValidateVerifyReturnFile = FillFOFileObj(false, "", "", "bir dosya seçmediniz ya da seçtiğiniz dosya yolu yanlış; bir diğer olasılık seçtiğiniz dosya zaten yüklü", "", "", "", sFileFormInputName)
Exit Function
end if
If FileExtensionIsBad then
Set ValidateVerifyReturnFile = FillFOFileObj(false, "", "", "bu dosya türü desteklenmemektedir", "", "", "", sFileFormInputName)
Exit Function
End If
If FileSizeIsBad then
Set ValidateVerifyReturnFile = FillFOFileObj(false, "", "", "dosya boyutu uygun boyutta değil. lütfen max. ve min. boyutlar arasında bir dosya yükleyiniz.", "", "", "", sFileFormInputName)
Exit Function
end if
Set ValidateVerifyReturnFile = FillFOFileObj(false, "", "", "", sFileContentType, sFileName, sFileBin, sFileFormInputName)
End Function
Private Function FillFOFileObj(byval success, byval abspath, byval virpath, byval stderr, byval contenttype, byval fname, byval binarytext, byval forminputname)
Dim oFile
set oFile = New FO_File
oFile.SetCurrentProperties oProps
oFile.bSuccess = success
oFile.sAbsPath = abspath
oFile.sVirPath = virpath
oFile.sStdErr = stderr
oFile.sCType = contenttype
oFile.sFileName = fname
oFile.binValue = binarytext
oFile.frmInputName = forminputname
set FillFOFileObj = oFile
End Function
Public Function IllegalCharsFound()
Dim re
set re = new regexp
re.pattern = "\\\/\:\*\?\""\<\>\|" ' burada hackerlara engel koyuyoruz
re.global = true
re.ignorecase = true
if re.test(sFileName) then
IllegalCharsFound = true
else
IllegalCharsFound = false
end if
set re = nothing
End Function
Public Function FileNameBadOrExists()
Dim absuploaddirectory, oFSO
if len(trim(sFileName)) = 0 then
FileNameBadOrExists = true
Exit Function
end if
if oProps.AllowOverWrite then
FileNameBadOrExists = false
Exit Function
end if
absuploaddirectory = oProps.uploaddirectory & "\" & trim(sFileName)
set oFSO = server.createobject("Scripting.FileSystemObject")
if oFSO.FileExists(absuploaddirectory) then
FileNameBadOrExists = true
else
FileNameBadOrExists = false
end if
Set oFSO = Nothing
End Function
Public Function FileExtensionIsBad()
Dim sFileExtension, bFileExtensionIsValid, sFileExt
if len(trim(sFileName)) = 0 then
FileExtensionIsBad = true
Exit Function
end if
sFileExtension = right(sFileName, len(sFileName) - instrrev(sFileName, "."))
bFileExtensionIsValid = false
for each sFileExt in oProps.extensions
if ucase(sFileExt) = ucase(sFileExtension) then
bFileExtensionIsValid = True
exit for
end if
next
FileExtensionIsBad = not bFileExtensionIsValid
End Function
Public Function FileSizeIsBad()
if hFileBinLen > oProps.MaximumFileSize then
FileSizeIsBad = True
Exit Function
end if
if hFileBinLen < oProps.MininumFileSize then
FileSizeIsBad = True
Exit Function
end if
FileSizeIsBad = False
End Function
End Class
Class FO_Processor
Private Function getByteString(byval StringStr)
dim char, i
For i = 1 to Len(StringStr)
char = Mid(StringStr, i, 1)
getByteString = getByteString & chrB(AscB(char))
Next
End Function
Public Function getString(byval StringBin)
dim intCount
getString =""
For intCount = 1 to LenB(StringBin)
getString = getString & chr(AscB(MidB(StringBin, intCount, 1)))
Next
End Function
Public Sub BuildUploadRequest_ASCII(ByVal sPostStr, ByRef UploadRequest)
dim i, j, blast, sName, vValue
dim tmphash
blast = false
i = -1
do while i <> 0
if i = -1 then
i = 1
else
i = i + 1
end if
j = instr(i, sPostStr, "=") + 1
sName = mid(sPostStr, i, j-i-1)
i = instr(j, sPostStr, "&")
if i = 0 then
vValue = mid(sPostStr, j)
else
vValue = mid(sPostStr, j, i - j)
end if
Dim uploadcontrol
set uploadcontrol = createobject("Scripting.Dictionary")
uploadcontrol.add "Value", vValue
if not uploadrequest.exists(sName) then
uploadrequest.add sName, uploadcontrol
else
set tmphash = uploadrequest(sName)
tmphash("Value") = tmphash("Value") & ", " & vValue
set uploadrequest(sName) = tmphash
end if
loop
End Sub
Public Sub BuildUploadRequest(byref RequestBin, byref UploadRequest)
dim PosBeg, PosEnd, boundary, boundaryPos, Pos, Name, PosFile
dim PosBound, FileName, ContentType, Value, sEncType, sReqMeth
dim tmphash, isfile
if lenb(RequestBin) = 0 then
exit sub
end if
PosBeg = 1
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
if posend = 0 then
BuildUploadRequest_ASCII getString(requestbin), UploadRequest
Exit Sub
end if
boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
boundaryPos = InstrB(1,RequestBin,boundary)
Do until (boundaryPos=InstrB(RequestBin,boundary & getByteString("--")))
Dim UploadControl
Set UploadControl = Server.CreateObject("Scripting.Dictionary")
Pos = InstrB(BoundaryPos,RequestBin,getByteString("Content-Disposition"))
Pos = InstrB(Pos,RequestBin,getByteString("name="))
PosBeg = Pos+6
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
Name = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
PosFile = InstrB(BoundaryPos,RequestBin,getByteString("filename="))
PosBound = InstrB(PosEnd,RequestBin,boundary)
isfile = false
If PosFile<>0 AND (PosFile "" Then
exit sub
end if
WriteUploadFile oProps.uploaddirectory & "\" & sFileName, binValue
End Sub
Public Function SaveAsBinaryString()
If LenB(binValue) = 0 Then
bBtCt = 0
bSuccess = false
Exit Function
End If
if oProps.UploadDisabled then
bBtCt = 0
bSuccess = false
sStdErr = "Yükleme Sayfa Yönetimi Tarafından Engellendi"
Exit Function
end if
SaveAsBinaryString = binValue
hBtCt = lenb(binValue)
bSuccess = true
End Function
Public Function SaveAsString()
Dim outstr, i
If LenB(binValue) = 0 Then
bBtCt = 0
bSuccess = false
Exit Function
End If
if oProps.UploadDisabled then
bBtCt = 0
bSuccess = false
sStdErr = "Yükleme Sayfa Yönetimi Tarafından Engellendi"
Exit Function
end if
outstr = ""
For i = 1 to LenB( binValue )
outstr = outstr & chr( AscB( MidB( binValue, i, 1) ) )
Next
SaveAsString = outstr
hBtCt = lenb(binValue)
bSuccess = true
End Function
Public Function SaveAsBase64EncodedStr()
Dim outstr, oEnc
If LenB(binValue) = 0 Then
bBtCt = 0
bSuccess = false
Exit Function
End If
if oProps.UploadDisabled then
bBtCt = 0
bSuccess = false
sStdErr = "Yükleme Sayfa Yönetimi Tarafından Engellendi"
Exit Function
end if
Set oEnc = New Base64Encoder
outstr = oEnc.EncodeStr(binValue)
Set oEnc = Nothing
SaveAsBase64EncodedStr = outstr
hBtCt = lenb(binValue)
bSuccess = true
End Function
Private Sub WriteUploadFile(byVal NAME, byVal CONTENTS)
dim ScriptObject, i, NewFile
on error resume next
if oProps.UploadDisabled then
err.raise "31234", "FO Obj", "Yükleme Sayfa Yönetimi Tarafından Engellendi"
else
Set ScriptObject = Server.CreateObject("Scripting.FileSystemObject")
Set NewFile = ScriptObject.CreateTextFile( NAME )
For i = 1 to LenB( CONTENTS )
NewFile.Write chr( AscB( MidB( CONTENTS, i, 1) ) )
Next
NewFile.Close
Set NewFile = Nothing
Set ScriptObject = Nothing
end if
if err.number <> 0 then
sStdErr = Err.Description
bSuccess = false
else
sAbsPath = NAME
sVirPath = UnMappath(NAME)
hBtCt = lenb(CONTENTS)
sURiPath = "http://" & request.servervariables("HTTP_HOST") & sVirPath
bSuccess = true
end if
on error goto 0
End Sub
Private Function UnMappath(byVal pathname)
dim tmp, strRoot
strRoot = Server.Mappath("/")
tmp = replace( lcase( pathname ), lcase( strRoot ), "" )
tmp = replace( tmp, "\", "/" )
UnMappath = tmp
End Function
Public Property Get ContentType()
ContentType = sCType
End Property
Public Property Let FileName(byval newfilename)
Dim oFileChk
set oFileChk = New FO_FileChecker
oFileChk.SetCurrentProperties oProps
oFileChk.FileInput_NamePath = newfilename
if oFileChk.IllegalCharsFound Then
sStdErr = "Dosya içerisinde geçersiz karakterler bulundu"
bSuccess = false
set oFileChk = Nothing
Exit Property
end if
if oFileChk.FileNameBadOrExists Then
sStdErr = "Dosya ismi geçersiz ya da bu dosyadan zaten mevcut ve üstüne yazma engellenmiş"
bSuccess = false
set oFileChk = Nothing
Exit Property
End If
if oFileChk.FileExtensionIsBad Then
sStdErr = "bu dosya türü desteklenmemektedir"
bSuccess = false
set oFileChk = Nothing
Exit Property
End If
Set oFileChk = Nothing
sStdErr = ""
sFileName = newfilename
End Property
Public Property Get FileExtension()
FileExtension = sFiExt
End Property
Public Property Get FileNameWithoutExtension()
FileNameWithoutExtension = StripFileExtensionFromFileName(sFileName)
End Property
Public Function StripFileExtensionFromFileName(ByVal filenametostrip)
Dim hExtensionStart, tmpfilenametoalter
tmpfilenametoalter = filenametostrip
hExtensionStart = -1
do while not hExtensionStart = 0
hExtensionStart = instrrev(tmpfilenametoalter, ".")
if hExtensionStart > 0 then
tmpfilenametoalter = left(tmpfilenametoalter, hExtensionStart - 1)
end if
loop
StripFileExtensionFromFileName = tmpfilenametoalter
End Function
Public Function JoinFileExtensionToFileName(ByVal filenametojoin, byval fileextensiontojoin)
Dim strippedfilename
strippedfilename = StripFileExtensionFromFileName(filenametojoin)
JoinFileExtensionToFileName = strippedfilename & "." & fileextensiontojoin
End Function
Public Function GetFileNameFromFilePath(ByVal filewithpath)
dim fileend
fileend = instrrev(filewithpath, "\")
GetFileNameFromFilePath = right(filewithpath, len(filewithpath) - fileend)
End Function
Public Property Get FileName()
FileName = sFileName
End Property
Public Property Get UploadSuccessful()
UploadSuccessful = bSuccess
End Property
Public Property Get AbsolutePath()
AbsolutePath = sAbsPath
End Property
Public Property Get URLPath()
URLPath = sURiPath
End Property
Public Property Get VirtualPath()
VirtualPath = sVirPath
End Property
Public Property Get ErrorMessage()
ErrorMessage = sStdErr
End Property
Public Property Get ByteCount()
ByteCount = hBtCt
End Property
End Class
Class FO_Properties
Private sErrHead
Private sErrMsg
Private arrExt
Private strUploadDir
Private boolAllowOverwrite
Private lngUploadSize
Private bMin
Private bByPass
Private Sub Class_Initialize()
sErrHead = "Yanlış Kurulum Hatası"
sErrMsg = ""
arrExt = Array("tar", "gz", "zip", "tgz") ' dosya uzantıları DİKKAT
strUploadDir = Server.Mappath("/")
boolAllowOverwrite = false
lngUploadSize = 100000
bMin = 1024
bByPass = false
End Sub
Public Sub ResetAll()
Class_Initialize
End Sub
Public Property LET Extensions(byVal arrayInput)
dim item, bErr
bErr = false
if isarray(arrayInput) then
for each item in arrayInput
if instr(item, ".") <> 0 then
bErr = true
exit for
end if
next
if not bErr then
arrExt = arrayInput
Exit Property
else
arrayInput = ""
end if
end if
sErrMsg = "ASP dosyasında bulunan uzantılara nokta koymamalısınız(.)."
if arrayInput = "*" then
Err.Raise 21340, sErrHead, sErrMsg & _
" Desteklenmiyor."
else
Err.Raise 21341, sErrHead, sErrMsg
end if
End Property
Public Property LET UploadDirectory(byVal strInput)
Dim oFSO, bDoesntExist
bDoesntExist = false
if instr(strInput, "/") <> 0 then
strInput = ""
Err.Raise 21342, sErrHead, _
"Veri yolu tam olarak girilmeli."
exit property
end if
Set oFSO = CreateObject("Scripting.FileSystemObject")
if not oFSO.FolderExists(strInput) then bDoesntExist = true
set oFSO = Nothing
if bDoesntExist then
Err.Raise 21343, sErrHead, "HATA - """ & _
strInput & """ Bu dosya serverda bulunmamaktadır."
Exit Property
end if
strUploadDir = strInput
End Property
Public Property LET AllowOverWrite(byVal boolInput)
on error resume next
boolInput = cbool(boolInput)
on error goto 0
boolAllowOverwrite = boolInput
End Property
Public Property LET MaximumFileSize(byVal lngInput)
if isnumeric(lngInput) then
on error resume next
lngInput = CLng( lngInput )
on error goto 0
lngUploadSize = lngInput
exit property
end if
Err.Raise 21344, sErrHead, "Maksimum dosya boyutu rakamlardan oluşmalıdır."
End Property
Public Property LET MininumFileSize(byVal lngInput)
if isnumeric(lngInput) then
on error resume next
lngInput = CLng( lngInput )
on error goto 0
bMin = lngInput
exit property
end if
Err.Raise 21345, sErrHead, "Minimum dosya boyutu rakamlardan oluşmalıdır."
End Property
Public Property LET UploadDisabled(byval boolInput)
on error resume next
boolInput = cbool(boolInput)
on error goto 0
bByPass = boolInput
End Property
Public Property GET UploadDisabled()
UploadDisabled = bByPass
End Property
Public Property GET MininumFileSize()
MininumFileSize = bMin
End Property
Public Property GET Extensions()
Extensions = arrExt
End Property
Public Property GET UploadDirectory()
UploadDirectory = strUploadDir
End Property
Public Property GET AllowOverWrite()
AllowOverWrite = boolAllowOverwrite
End Property
Public Property GET MaximumFileSize()
MaximumFileSize = lngUploadSize
End Property
End Class
Class Base64Encoder
Private Base64Chars
Private Sub Class_Initialize()
Base64Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"abcdefghijklmnopqrstuvwxyz" & _
"0123456789" & _
"+/"
End Sub
Public Function EncodeStr(byVal strIn)
Dim c1, c2, c3, w1, w2, w3, w4, n, strOut
For n = 1 To Len(strIn) Step 3
c1 = Asc(Mid(strIn, n, 1))
c2 = Asc(Mid(strIn, n + 1, 1) + Chr(0))
c3 = Asc(Mid(strIn, n + 2, 1) + Chr(0))
w1 = Int(c1 / 4) : w2 = (c1 And 3) * 16 + Int(c2 / 16)
If Len(strIn) >= n + 1 Then
w3 = (c2 And 15) * 4 + Int(c3 / 64)
Else
w3 = -1
End If
If Len(strIn) >= n + 2 Then
w4 = c3 And 63
Else
w4 = -1
End If
strOut = strOut + mimeencode(w1) + mimeencode(w2) + _
mimeencode(w3) + mimeencode(w4)
Next
EncodeStr = strOut
End Function
Private Function mimedecode(byVal strIn)
If Len(strIn) = 0 Then
mimedecode = -1 : Exit Function
Else
mimedecode = InStr(Base64Chars, strIn) - 1
End If
End Function
Public Function DecodeStr(byVal strIn)
Dim w1, w2, w3, w4, n, strOut
For n = 1 To Len(strIn) Step 4
w1 = mimedecode(Mid(strIn, n, 1))
w2 = mimedecode(Mid(strIn, n + 1, 1))
w3 = mimedecode(Mid(strIn, n + 2, 1))
w4 = mimedecode(Mid(strIn, n + 3, 1))
If w2 >= 0 Then _
strOut = strOut + _
Chr(((w1 * 4 + Int(w2 / 16)) And 255))
If w3 >= 0 Then _
strOut = strOut + _
Chr(((w2 * 16 + Int(w3 / 4)) And 255))
If w4 >= 0 Then _
strOut = strOut + _
Chr(((w3 * 64 + w4) And 255))
Next
DecodeStr = strOut
End Function
Private Function mimeencode(byVal intIn)
If intIn >= 0 Then
mimeencode = Mid(Base64Chars, intIn + 1, 1)
Else
mimeencode = ""
End If
End Function
End Class
%>