<%@ Language=VBScript %>
<!--#include virtual="/inc/FreeHost-AG-Function.asp"-->
<%title="　上传域名证书中的盖章"%>
<%
If session("agentusername")="" Then
	ef=True
	ec="授权非法，有可能是超时造成的。"
ElseIf session("agentusername")<>""  and RegExpTest("[^A-Za-z0-9]",session("agentusername")) Then
	ef=True
	ec="请输入合法的代理名！"
end if


if not ef then

dim filevalue

if Request.ServerVariables("REQUEST_METHOD") = "POST" Then
Dim Fields
UploadSizeLimit=100000
Set Fields = GetUpload()
dim Field
For Each Field In Fields.Items
select case Field.name
'case "thetext" sss=BinaryToString(Field.value)
'case "type" fff=BinaryToString(Field.value)
'case "submit" submit=BinaryToString(Field.value)
case "freehostfile"
filename=field.FileName
fileContentType=field.ContentType
filevalue=field.value
fileLength=Field.Length
end select
next
'---------------

'Response.write int(fileLength)
'Response.end
'if filename<>"" and fileContentType<>"image/gif" and fileContentType<>"image/pjpeg" then
'response.contenttype="image/gif"
'response.AddHeader "Length: ",fileLength
'Response.BinaryWrite filevalue
'Response.end

end if

If fileLength>500000 Then
	ef=True
	ec="上传的文件超过了50K。"
end if
end if

if not ef then

'Response.write VarType(filevalue)
'session("upgif")= filevalue 
'dsreg.update 
'session("upgiflen")=int(fileLength)

'filevalue="fdsfsdfsdfsdfsdf00000000000000000000000000000000000000000000000000000000000000000000"

Dim up, ret
Set up = New XMLUploadImpl
up.Charset = "utf-8"


'下两行代码设置的是文件路径
up.AddFile "freehostfile", "x:\images\x.gif", "image/gif", BinaryToBytes(filevalue)
up.AddForm "submit", "OK"

APIret = up.Upload(APISite&"/agent/domainupgif2.asp")
Set up = Nothing


'APIret=POSTOPByte("/agent/domainupgif3.asp",filevalue)
If InStr(APIret,title) Then
APIret=mid(APIret,InStr(APIret,title)+Len(title))
End if

'response.contenttype="image/jpeg"
'Response.BinaryWrite filevalue
'Response.end



end If



if not ef then%>
<!--#include virtual="/agent/agent-moban.asp"-->
<%end if

if ef then
Response.Redirect "e.asp?e="&ec
end If











Public Const adTypeBinary = 1
Public Const adTypeText = 2
Public Const adLongVarBinary = 205

'字节数组转指定字符集的字符串
Public Function BytesToString(vtData, ByVal strCharset)
    Dim objFile
    Set objFile = Server.CreateObject("ADODB.Stream")
    objFile.Type = adTypeBinary
    objFile.Open
    If VarType(vtData) = vbString Then
        objFile.Write BinaryToBytes(vtData)
    Else
        objFile.Write vtData
    End If
    objFile.Position = 0
    objFile.Type = adTypeText
    objFile.Charset = strCharset
    BytesToString = objFile.ReadText(-1)
    objFile.Close
    Set objFile = Nothing
End Function

'字节字符串转字节数组，即经过MidB/LeftB/RightB/ChrB等处理过的字符串
Public Function BinaryToBytes(vtData)
    Dim rs
    Dim lSize
    lSize = LenB(vtData)
    Set rs = Server.CreateObject("ADODB.RecordSet")
    rs.Fields.Append "Content", adLongVarBinary, lSize
    rs.Open
    rs.AddNew
    rs("Content").AppendChunk vtData
    rs.Update
    BinaryToBytes = rs("Content").GetChunk(lSize)
    rs.Close
    Set rs = Nothing
End Function

'指定字符集的字符串转字节数组
Public Function StringToBytes(ByVal strData, ByVal strCharset)
    Dim objFile
    Set objFile = Server.CreateObject("ADODB.Stream")
    objFile.Type = adTypeText
    objFile.Charset = strCharset
    objFile.Open
    objFile.WriteText strData
    objFile.Position = 0
    objFile.Type = adTypeBinary
    If UCase(strCharset) = "UNICODE" Then
        objFile.Position = 2 'delete UNICODE BOM
    ElseIf UCase(strCharset) = "UTF-8" Then
        objFile.Position = 3 'delete UTF-8 BOM
    End If
    StringToBytes = objFile.Read(-1)
    objFile.Close
    Set objFile = Nothing
End Function

'获取文件内容的字节数组
Public Function GetFileBinary(ByVal strPath)
    Dim objFile
    Set objFile = Server.CreateObject("ADODB.Stream")
    objFile.Type = adTypeBinary
    objFile.Open
    objFile.LoadFromFile strPath
    GetFileBinary = objFile.Read(-1)
    objFile.Close
    Set objFile = Nothing
End Function

'XML Upload Class
Class XMLUploadImpl
Private xmlHttp
Private objTemp
Private strCharset, strBoundary

Private Sub Class_Initialize()
    Set xmlHttp = Server.CreateObject("MSXML2.ServerXMLHTTP")
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    strCharset = "GBK"
    strBoundary = GetBoundary()
End Sub

Private Sub Class_Terminate()
    objTemp.Close
    Set objTemp = Nothing
    Set xmlHttp = Nothing
End Sub

'获取自定义的表单数据分界线
Private Function GetBoundary()
    Dim ret(24)
    Dim table
    Dim i
    table = "ABCDEFGHIJKLMNOPQRSTUVWXZYabcdefghijklmnopqrstuvwxzy0123456789"
    Randomize
    For i = 0 To UBound(ret)
        ret(i) = Mid(table, Int(Rnd() * Len(table) + 1), 1)
    Next
    GetBoundary = "__NextPart__ " & Join(ret, Empty)
End Function 

'设置上传使用的字符集
Public Property Let Charset(ByVal strValue)
    strCharset = strValue
End Property

'添加文本域的名称和值
Public Sub AddForm(ByVal strName, ByVal strValue)
    Dim tmp
    tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""\r\n\r\n$3"
    tmp = Replace(tmp, "\r\n", vbCrLf)
    tmp = Replace(tmp, "$1", strBoundary)
    tmp = Replace(tmp, "$2", strName)
    tmp = Replace(tmp, "$3", strValue)
    objTemp.Write StringToBytes(tmp, strCharset)
End Sub

'设置文件域的名称/文件名称/文件MIME类型/文件路径或文件字节数组
Public Sub AddFile(ByVal strName, ByVal strFileName, ByVal strFileType, vtValue)
    Dim tmp
    tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""; filename=""$3""\r\nContent-Type: $4\r\n\r\n"
    tmp = Replace(tmp, "\r\n", vbCrLf)
    tmp = Replace(tmp, "$1", strBoundary)
    tmp = Replace(tmp, "$2", strName)
    tmp = Replace(tmp, "$3", strFileName)
    tmp = Replace(tmp, "$4", strFileType)
    objTemp.Write StringToBytes(tmp, strCharset)
    If VarType(vtValue) = (vbByte Or vbArray) Then
        objTemp.Write vtValue
    Else
        objTemp.Write GetFileBinary(vtValue)
    End If
End Sub

'设置multipart/form-data结束标记
Private Sub AddEnd()
    Dim tmp
	tmp = "\r\n--$1--\r\n" 
	tmp = Replace(tmp, "\r\n", vbCrLf) 
	tmp = Replace(tmp, "$1", strBoundary) 
    objTemp.Write StringToBytes(tmp, strCharset)
    objTemp.Position = 0
End Sub


'上传到指定的URL，并返回服务器应答
Public Function Upload(ByVal strURL)
    Call AddEnd
    xmlHttp.Open "POST", strURL, False
    xmlHttp.setRequestHeader "Content-Type", "multipart/form-data; boundary="&strBoundary

    xmlHttp.setRequestHeader "Content-Length", objTemp.size
xmlHttp.setRequestHeader "FreeHostAPI","7i24.com"
xmlHttp.setRequestHeader "FreeHostAPIIP",Request.ServerVariables("REMOTE_ADDR")
If session("APIOPcookie")<>"" Then xmlHttp.setRequestHeader "COOKIE", session("APIOPcookie")
    
'	response.write objTemp.size
'	response.end

	xmlHttp.Send objTemp

    Upload = bytes2BSTR(xmlHttp.responseBody)
End Function
End Class









Dim UploadSizeLimit

'********************************** 得到上传数据 **********************************
Function GetUpload()
  Dim Result
  Set Result = Nothing
  If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST"
    Dim CT, PosB, Boundary, Length, PosE
    CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-Type header
    If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type header must be "multipart/form-data"
      'This is upload request.
      'Get the boundary and length from Content-Type header
      PosB = InStr(LCase(CT), "boundary=") 'Finds boundary
      If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary
      Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get Content-Length header
      if "" & UploadSizeLimit<>"" then
        UploadSizeLimit = clng(UploadSizeLimit)
        if Length > UploadSizeLimit then 
'          on error resume next 'Clears the input buffer
'            response.AddHeader "Connection", "Close"
'          on error goto 0
          Request.BinaryRead(Length)
          Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length,0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit,0) & "B"
          exit function
        end if
      end if
      
      If Length > 0 And Boundary <> "" Then 'Are there required informations about upload ?
        Boundary = "--" & Boundary
        Dim Head, Binary
        Binary = Request.BinaryRead(Length) 'Reads binary data from client
        
        'Retrieves the upload fields from binary data
        Set Result = SeparateFields(Binary, Boundary)
        Binary = Empty 'Clear variables
      Else
        Err.Raise 10, "GetUpload", "Zero length request ."
      End If
    Else
      Err.Raise 11, "GetUpload", "No file sent."
    End If
  Else
    Err.Raise 1, "GetUpload", "Bad request method."
  End If
  Set GetUpload = Result
End Function


Function SeparateFields(Binary, Boundary)
  Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
  Dim Fields
  Boundary = StringToBinary(Boundary)

    PosOpenBoundary = InstrB(Binary, Boundary)
    PosCloseBoundary = InstrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)

  Set Fields = CreateObject("Scripting.Dictionary")

  Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
    'Header and file/source field data
    Dim HeaderContent, FieldContent
    'Header fields
    Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
    'Helping variables
    Dim Field, TwoCharsAfterEndBoundary
    'Get end of header
        PosEndOfHeader = InstrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))

    'Separates field header
        HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)
        
    'Separates field content
        FieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)

    'Separates header fields from header
    GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type

    'Create one field and assign parameters
    Set Field = CreateUploadField()
    Field.Name = FormFieldName
    Field.ContentDisposition = Content_Disposition
    Field.FilePath = SourceFileName
    Field.FileName = GetFileName(SourceFileName)
    Field.ContentType = Content_Type
    Field.Value = FieldContent
    Field.Length = LenB(FieldContent)


    Fields.Add FormFieldName, Field

    'Is this ending boundary ?
    TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))
        'Binary.Mid(PosCloseBoundary + Len(Boundary), 2).String
    isLastBoundary = TwoCharsAfterEndBoundary = "--"
    If Not isLastBoundary Then 'This is not ending boundary - go to next form field.
      PosOpenBoundary = PosCloseBoundary
            PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary )
    End If
  Loop
  Set SeparateFields = Fields
End Function

'********************************** Utilities **********************************
Function BinaryToString(str)
strto = ""
for i=1 to lenb(str)
if AscB(MidB(str, i, 1)) > 127 then
        strto = strto & chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
        i = i + 1
     else
        strto = strto & Chr(AscB(MidB(str, i, 1)))
     end if
next
BinaryToString=strto
End Function

Function StringToBinary(String)
    Dim I, B
    For I=1 to len(String)
        B = B & ChrB(Asc(Mid(String,I,1)))
    Next 
    StringToBinary = B
End Function

'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type)
  Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))
  Name = (SeparateField(Head, "name=", ";")) 'ltrim
  If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)
  FileName = (SeparateField(Head, "filename=", ";")) 'ltrim
  If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)
  Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function

'Separets one filed between sStart and sEnd
Function SeparateField(From, ByVal sStart, ByVal sEnd)
  Dim PosB, PosE, sFrom
  sFrom = LCase(From)
  PosB = InStr(sFrom, sStart)
  If PosB > 0 Then
    PosB = PosB + Len(sStart)
    PosE = InStr(PosB, sFrom, sEnd)
    If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
    If PosE = 0 Then PosE = Len(sFrom) + 1
    SeparateField = Mid(From, PosB, PosE - PosB)
  Else
    SeparateField = Empty
  End If
End Function

'Separetes file name from the full path of file
Function GetFileName(FullPath)
  Dim Pos, PosF
  PosF = 0
  For Pos = Len(FullPath) To 1 Step -1
    Select Case Mid(FullPath, Pos, 1)
      Case "/", "": PosF = Pos + 1: Pos = 0
    End Select
  Next
  If PosF = 0 Then PosF = 1
  GetFileName = Mid(FullPath, PosF)
End Function

%>
<SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT>
//The function creates Field object.
function CreateUploadField(){ return new uf_Init() }
function uf_Init(){
  this.Name = null
  this.ContentDisposition = null
  this.FileName = null
  this.FilePath = null
  this.ContentType = null
  this.Value = null
  this.Length = null
}
</SCRIPT>