|
在解碼速度方面，化境 2.0 已經非常高了，但是，它還存在以下兩個問題：
1、用Data_5xsoft.Write Request.BinaryRead(Request.TotalBytes)一次讀取全部數據，以及用RequestData =Data_5xsoft.Read 一次取出全部數據，在上傳數據過大時，會由于內存不足，導致上傳失敗，這里應該采用分段讀取方式。
2、保存數據時，需要先從Data_5xsoft中復制到一個臨時流中，在保存大文件時，需要兩倍的存儲資源，在單機狀態下測試，可以發現保存時間隨文件尺寸急劇增長，甚至超過上傳和解碼時間。 本人所寫的這個類，采用在解碼的過程中，逐塊讀取（注意：塊的大小與速度不成正比，單機測試表明，64K的塊比1M的塊快得多）的方法，解決問題1，同時采用對普通數據，寫入工作流；對文件內容，直接寫入文件自身的流的方式，解決問題2。 代碼如下，用法類似于化境: Server.ScriptTimeOut = 600 Class QuickUpload
Private FForm, FFile, Upload_Stream, ConvertStream
property get Form
set Form = FForm
end property
property get File
set File = FFile
end property
Private Sub Class_Initialize
dim iStart, iEnd, boundary, FieldName, FileName, ContentType, ItemValue, theFile, LineEnd
set FForm=CreateObject("Scripting.Dictionary")
set FFile=CreateObject("Scripting.Dictionary")
set Upload_Stream=CreateObject("Adodb.Stream")
Upload_Stream.mode=3
Upload_Stream.type=1
Upload_Stream.open
set ConvertStream = Server.CreateObject("adodb.stream")
ConvertStream.Mode =3
ConvertStream.Charset="GB2312"
if Request.TotalBytes<1 then Exit Sub
'dStart = CDbl(Time)
'查找第一個邊界
iStart = Search(Upload_Stream, ChrB(13)&ChrB(10), 1)
'取邊界串
boundary = subString(1, iStart-1, false)
'不是結束邊界,則循環
do while StrComp(subString(iStart, 2, false),ChrB(13)&ChrB(10))=0
iStart = iStart+2
'取表單項信息頭
do while true
iEnd = Search(Upload_Stream, ChrB(13)&ChrB(10), iStart)
'分解信息頭
line = subString(iStart, iEnd-iStart, true)
'移動位置
iStart = iEnd+2
if Line="" then Exit do
pos = instr(line,":")
if pos>0 then
if StrComp(left(Line,pos-1),"Content-Disposition",1)=0 then
'取表單項名稱
FieldName = ExtractValue(Line,pos+1,"name")
'取文件名稱
FileName = ExtractValue(Line,pos+1,"filename")
'刪除文件路徑
FileName = Mid(FileName,InStrRev(FileName, "\")+1)
elseif StrComp(left(Line,pos-1),"Content-Type",1)=0 then
'取文件類型
ContentType = trim(mid(Line,pos+1))
end if
end if
loop
'取表單項內容
if FileName<>"" then
'新建文件內容
set theFile = new FileInfo
theFile.Init FileName, ContentType
'文件流內容移到文件流中
MoveData Upload_Stream, theFile.Stream, iStart
'上傳數據直接傳入文件流，可以減少文件存儲時間
iEnd = Search(theFile.Stream, boundary, 1)
'后繼數據移入工作流
MoveData theFile.Stream, Upload_Stream, iEnd-2
'
FFile.add FieldName, theFile
'移動位置
iStart = iStart+2+LenB(boundary)
else
'查找邊界
iEnd = Search(Upload_Stream, boundary, iStart)
'取表單項內容
ItemValue = subString(iStart, iEnd-2-iStart, true)
'
if FForm.Exists(FieldName) then
FForm.Item(FieldName) = FForm.Item(FieldName) & "," & ItemValue
else
FForm.Add FieldName, ItemValue
end if
'移動位置
iStart = iEnd+LenB(boundary)
end if
loop
'Response.Write "parse time:" & FormatNumber((CDbl(Time)-dStart)*24*60*60,-1,-1) & "<br>"
End Sub Private Function Search(src, str, theStart)
iStart = theStart
pos=0
do while pos=0
'長度不夠，讀一塊
if src.Size<(iStart+lenb(str)-1) then ReadChunk src
'取一段數據，約64K，可以減少內存需求
src.Position = iStart-1
buf = src.Read
'檢測邊界
pos=InStrB(buf,str)
'如果未找到,向后移動
if pos=0 then iStart = iStart+LenB(buf)-LenB(str)+1
loop
Search = iStart+pos-1
End function
private sub MoveData(Src, Dest, theStart)
Src.Position = theStart-1
Dest.Position = Dest.Size
Src.CopyTo dest
Src.Position = theStart-1
Src.SetEOS
end sub
private function ExtractValue(line,pos,name)
dim t, p
ExtractValue = ""
t = name + "="""
p = instr(pos,line,t)
if p>0 then
n1 = p+len(t)
n2 = instr(n1,line,"""")
if n2>n1 then ExtractValue = mid(line,n1,n2-n1)
end if
end function Private Function subString(theStart,theLen, ConvertToUnicode)
if theLen>0 then
'當長度不夠時，讀一塊數據
if Upload_Stream.Size<theStart+theLen-1 then ReadChunk Upload_Stream
Upload_Stream.Position=theStart-1
Binary =Upload_Stream.Read(theLen)
if ConvertToUnicode then
ConvertStream.Type = 1
ConvertStream.Open
ConvertStream.Write Binary
ConvertStream.Position = 0
ConvertStream.Type = 2
subString = ConvertStream.ReadText
ConvertStream.Close
else
subString = midB(Binary,1)
end if
else
subString = ""
end if
End function
Private Sub ReadChunk(src)
'讀一塊，通過一次讀64K，可以防止數據量過大時內存溢出
if Response.IsClientConnected = false then Raise "網絡連接中斷"
BytesRead = 65536
src.Position = src.Size
src.Write Request.BinaryRead(BytesRead)
End Sub
'異常信息
Private Sub Raise(Message)
Err.Raise vbObjectError, "QuickUpload", Message
End Sub Private Sub Class_Terminate
form.RemoveAll
file.RemoveAll
set form=nothing
set file=nothing
Upload_Stream.close
set Upload_Stream=nothing
ConvertStream.Close
set ConvertStream=nothing
End Sub End Class Class FileInfo
Private FFileName, FFileType, FFileStart, FFileSize, FStream
property get FileName
FileName = FFileName
end property
property get FileType
FileType = FFileType
end property
property get FileSize
FileSize = FStream.Size
end property
property get Stream
set Stream = FStream
end property
Public Sub Init(AFileName, AFileType)
FFileName = AFileName
FFileType = AFileType
End Sub
Public function SaveAs(FullPath)
dim dr,ErrorChar,i
'dStart = CDbl(Time)
SaveAs=1
if trim(fullpath)="" or right(fullpath,1)="/" then exit function
On Error Resume Next
FStream.SaveToFile FullPath,2
if Err.Number>0 then Response.Write "保存數據出錯：" & Err.Description & "<br>"
SaveAs=0
'Response.Write "save time:" & FormatNumber((CDbl(Time)-dStart)*24*60*60,-1,-1) & "<br>"
end function
Private Sub Class_Initialize
set FStream=CreateObject("Adodb.Stream")
FStream.mode=3
FStream.type=1
FStream.open
end sub
Private Sub Class_Terminate
FStream.Close
set FStream=nothing
end sub
End Class
|
