<%
' +----------------------------------------------------------------------
' | KCMS [ 启点在线网站管理系统 ]
' | Copyright (c) 2018 http://www.kelvinvt.com All rights reserved.
' | Licensed ( http://www.kelvinvt.com )
' | Author: kelvinvt <kelvinvt@qq.com>
' +----------------------------------------------------------------------

Class Uploader
    Private cfgMaxSize
    Private cfgAllowType
    Private cfgSavePath
    Private cfgFileField
    Private stateString
    Private rsOriginalFileName
    Private rsFileName
    Private rsFilePath
    Private rsFileSize
    Private rsFileType
    Private rsState
    Private rsFormValues
	Private PY_ARRAY

    Private Sub Class_Initialize
        cfgMaxSize = 1 * 1024 * 1024
        cfgAllowType = ".png,.jpg,.jpeg,.gif,.bmp"
        cfgSavePath = "upload/"

        Set stateString = Server.CreateObject("Scripting.Dictionary")
        stateString.Add "size", "文件太大了"
        stateString.Add "name", "文件类型不匹配"
    End Sub

    Public Property Let MaxSize(ByVal size)
        cfgMaxSize = size
    End Property

    Public Property Let AllowType(ByVal types)
        cfgAllowType = types
    End Property

    Public Property Let SavePath(ByVal path)
        cfgSavePath = path
    End Property

    Public Property Let FileField(ByVal field)
        cfgFileField = field
    End Property

    Public Property Get OriginalFileName
        OriginalFileName = rsOriginalFileName
    End Property

    Public Property Get FileName
        FileName = rsFileName
    End Property 

    Public Property Get FilePath
        FilePath = rsFilePath
    End Property

    Public Property Get FileSize
        FileSize = rsFileSize
    End Property

    Public Property Get FileType
        FileType = rsFileType
    End Property

    Public Property Get State
        State = rsState
    End Property

    Public Property Get FormValues
        Set FormValues = rsFormValues
    End Property

    Public Function UploadForm()
       ProcessForm()
       SaveFile()
    End Function

    Public Function ProcessForm()   
		dim processor    
        Set processor = new MultiformProcessor
        Set rsFormValues = processor.Process()
    End Function

    Public Function SaveFile()
        Dim stream, filename    
        Set stream = rsFormValues.Item( "file" )
        filename = rsFormValues.Item( "filename" )
        DoUpload stream, filename
    End Function

    Public Function UploadBase64( content ) 
        Dim stream
        Set stream = Base64Decode( content )
        DoUpload stream, "Base64Upload.png"
    End Function

    Public Function UploadRemote( url )
        Dim stream, filename
        filename = Right( url, Len(url) - InStrRev(url, "/") )
        Set stream = CrawlImage( url )
        If Not IsNull(stream) Then
            DoUpload stream, filename
        Else
            rsState = "Failed"
        End If
        Set stream = Nothing
    End Function

    Private Function DoUpload( stream, filename )
        Dim savepath,fs,ai,testPath
        rsFileSize = stream.Size
        If rsFileSize > ParseSizeLimit(cfgMaxSize) Then
            rsState = stateString.Item( "size" )
            Exit Function
        End If
        rsOriginalFileName = filename
        rsFileType = GetExt( filename )
        If CheckExt(rsFileType) = False Then
            rsState = stateString.Item( "name" )
            Exit Function
        End If
		if datefolder=1 then
        	savepath = GetSavePath()
		else
			savepath = cfgSavePath
		end if
        NewFolder savepath
        rsFileName = GetSaveName( filename )
        rsFilePath = savepath + rsFileName

        Set fs = Server.CreateObject("Scripting.FileSystemObject")
        ai = 1
        testPath = rsFilePath		
        Do While fs.FileExists( Server.MapPath( testPath ) )
			if coverMark=0 then
              testPath = GetNameWithoutExt( rsFilePath ) & "_" & ai & GetExt( rsFilePath )
              ai = ai + 1
			elseif coverMark=1 then
			  delfile testPath
			 elseif coverMark=2 then
			  die "{""url"":"""&rsFilePath&""",""ext"":"""&getfileext( rsFilePath)&""",""state"":""SUCCESS"",""title"":"""&GetFileName( filename )&"""}"
			end if
        Loop
        rsFilePath = testPath		
        stream.SaveToFile Server.MapPath( rsFilePath )
        stream.Close
        rsState = "SUCCESS"
    End Function

    Private Function Base64Decode( content )
        dim xml, stream, node
        Set xml = Server.CreateObject("MSXML2.DOMDocument")
        Set stream = Server.CreateObject("ADODB.Stream")
        Set node = xml.CreateElement("tmpNode")
        node.dataType = "bin.base64"
        node.Text = content
        stream.Charset ="gb2312"
        stream.Type = 1
        stream.Open()
        stream.Write( node.nodeTypedValue )
        Set Base64Decode = stream
        Set node = Nothing
        Set stream = Nothing
        Set xml = Nothing
    End Function

    Private Function CrawlImage( url )
        Dim http, stream
        Set http = Server.CreateObject("Microsoft.XMLHTTP")
        http.Open "GET", url, false
        http.Send
        If http.Status = 200 Then
            Set stream = Server.CreateObject("ADODB.Stream")
            stream.Type = 1
            stream.Open()
            stream.Write http.ResponseBody
            Set CrawlImage = stream
        Else
            Set CrawlImage = null
        End If
        Set http = Nothing
    End Function

    Private Function CheckExt( fileType )
		dim ext,tempExe,i
		CheckExt = false
		cfgAllowType=replace(cfgAllowType,".","")
		cfgAllowType=replace(cfgAllowType,",",";")
		cfgAllowType=replace(cfgAllowType,"，",";")
		cfgAllowType=replace(cfgAllowType,"|",";")
		If cfgAllowType="*" then
			CheckExt=true 
			Exit Function		
		elseIf ifstrin(cfgAllowType, ";") Then
			tempExe = Split(UCase(cfgAllowType), ";")
			I = 0
			For I = 0 To UBound(tempExe)
				If UCase(replace(fileType,".","")) = tempExe(I) Then
					 CheckExt = true
					Exit Function
				End If
			Next
		elseif UCase(cfgAllowType)=UCase(replace(fileType,".","")) then
			CheckExt = true
		else
			echo cfgAllowType&"="&fileType
		end if			
    End Function

    Private Function GetExt( file )
        GetExt = Right( file, Len(file) - InStrRev(file, ".") + 1)
    End Function

    Private Function GetNameWithoutExt( file )
        GetNameWithoutExt = Left( file, InStrRev(file, ".") - 1 )
    End Function

    Private Function GetSavePath()		
          GetSavePath = cfgSavePath & GetFormatedDate() & "/"
    End Function
	
	function pinYin(byval s)
		dim i,ss
		PY_ARRAY = split(PY_DATA,"|")
		for i=1 to len(s)
			ss = ss & pinYinOne(mid(s,i,1))
		next
		pinYin = ss
	end function
	
	function pinYinOne(ByVal s)
		dim i
		if instr("~!@#$%^&*()\-+;:'""<>,.\\，。；：“‘、 　]+$",s)>0 then 	pinYinOne = ""	: exit 	function
		i = instr(PY_LIST,s)
		if i>0 then
			pinYinOne = PY_ARRAY(i)
		elseif instr(PY_LIST,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_- ")>0 Then 
			pinYinOne = lcase(s)
		else
			pinYinOne = s
		end if
	end function

    Private Function GetSaveName( ByVal filename )		
        Dim format, ext, name,randPattern,invalidPattern,digit,min,max
		'echop rsFormValues.Item( "format" )
		format = rsFormValues.Item( "format" )
        If isnul( format ) Then  format = "{yy}{mm}{dd}{hh}{ii}{ss}{rand:6}"		
        ext = GetExt( filename )
        name = GetNameWithoutExt( filename )	
        filename = Replace( format, "{filename}", name )	
		if format="{pinyin}" then filename=Replace(filename, "{pinyin}",pinYin(name))		
        filename = Replace( filename, "{time}", TimeStamp() )
        filename = Replace( filename, "{yyyy}", Year(Now) )
        filename = Replace( filename, "{yy}", Year(Now) Mod 100 )
        filename = Replace( filename, "{mm}", LeadZero( Month(Now) ) )
        filename = Replace( filename, "{dd}", LeadZero( Day(Now) ) )
        filename = Replace( filename, "{hh}", LeadZero( Hour(Now) ) )
        filename = Replace( filename, "{ii}", LeadZero( Minute(Now) ) )
        filename = Replace( filename, "{ss}", LeadZero( Second(Now) ) )
        Set randPattern = new RegExp
        randPattern.Pattern = "{rand(\:?)(\d+)}"
        Set matches = randPattern.Execute(filename)
        If matches.Count Then
            Set match = matches(0)
            digit = 6
            If match.SubMatches.Count > 1 Then
                digit = 0 + match.SubMatches(1)
            End If
            min = 1
            Do While digit > 0
                min = min * 10
                digit = digit - 1
            Loop
            max = min * 10
            filename = randPattern.Replace( filename, Rand( min, max ) )
        End If
        Set invalidPattern = new RegExp
        invalidPattern.Pattern = "[\\\/\:\*\?\<\>\|""]"
        invalidPattern.Global = true
        filename = invalidPattern.Replace( filename, "" )
        GetSaveName = filename + ext
    End Function

    Private Function TimeStamp()
        TimeStamp = DateDiff("s", "1970-1-1 8:00:00", Now())
    End Function

    Private Function Rand( min, max )
        Randomize 
        Rand = Int( (max - min + 1) * Rnd + min )
    End Function

    Private Function GetFormatedDate()
        Dim yyyy, mm, dd
        yyyy = Year(Date) mod 100
        mm = LeadZero(Month(Date))
        dd = LeadZero(Day(Date))
        GetFormatedDate = yyyy & mm & dd
    End Function

    Private Function LeadZero( number )
        If number < 10 Then
            LeadZero = "0" & number
        Else
            LeadZero = number
        End If
    End Function
End Class

Class MultiformProcessor
    Private adTypeBinary
    Private adTypeText
    Private adModeReadWrite
    Private binCtLf
    Private binCtLf2

    private Sub Class_Initialize()
        adTypeBinary = 1
        adTypeText = 2
        adModeReadWrite = 3
        binCtLf = ChrB(13) & ChrB(10)
        binCtLf2 = binCtLf & binCtLf
    End Sub

    Private Function OpenStream( optype )
		dim stream
        Set stream = Server.CreateObject("ADODB.Stream")
        stream.Type = optype
        stream.Mode = adModeReadWrite
        stream.Open
        Set OpenStream = stream
    End Function

    Private Function CopyStreamPart( stream, pBgn, pEnd )
        Dim iStream, oStream
        Set iStream = stream
        Set oStream = OpenStream( adTypeBinary )
        iStream.Position = pBgn
        iStream.CopyTo oStream, pEnd - pBgn
        Set CopyStreamPart = oStream
    End Function

    Private Function GetString( stream, pBgn, pEnd )
        Dim iStream, oStream
        Set iStream = stream
        Set oStream = OpenStream( adTypeBinary )
        iStream.Position = pBgn
        iStream.CopyTo oStream, pEnd - pBgn
        oStream.Position = 0
        oStream.Type = adTypeText
        oStream.Charset = GetCharset
        GetString = oStream.ReadText
        oStream.Close
    End Function

    Private Function GetCharset()
		dim Charset
        If Charset = "" Then
            GetCharset = "utf-8"
        Else
            GetCharset = Charset
        End If
    End Function

    'See RFC 2388
    'http://www.ietf.org/rfc/rfc2388.txt
    public Function Process()
        Dim formBytes, bLen, pBgn, pEnd, header, stream
        Dim varPtn, filePtn, formValues, key, field,boundary,isFileBlock
		'echop Request.TotalBytes
        formBytes = Request.BinaryRead( Request.TotalBytes )
        Set stream = OpenStream( adTypeBinary )
            stream.Write formBytes
        Set varPtn = new RegExp
            varPtn.Pattern = "(\w+?)=""(.+?)"""
            varPtn.Global = True
        Set filePtn = new RegExp
            filePtn.Pattern = "filename="
        Set formValues = Server.CreateObject("Scripting.Dictionary")
        bLen = InStrB( 1, formBytes, binCtLf ) - 1
        boundary = LeftB( formBytes, bLen )
        pBgn = 1
        Do
            'Find begin pointer and end pointer for block header
            pBgn = pBgn + bLen + LenB( binCtLf ) - 1
            pEnd = InStrB( pBgn, formBytes, binCtLf2 )

            'If next block not found, means all blocks processed
            If pEnd = 0 Then
                Exit Do 'Load Finished
            End If

            'Decode the headerf
            header = GetString( stream, pBgn, pEnd )

            'Test if the block is a file block
            isFileBlock = filePtn.Test( header ) 

            'Find begin pointer and end pointer for block content
            pBgn = pEnd + LenB(binCtLf2) - 1
            pEnd = InStrB(pBgn, formBytes, boundary) - LenB( binCtLf ) - 1

            'Extract field values from header, which like key = "filed"
            Set matches = varPtn.Execute( header )
            For Each match In matches
                key = match.SubMatches(0)
                field = match.SubMatches(1)
                'filename as a field
                If key = "filename" Then
                    formValues.Add key, field 
                'name specified fields
                ElseIf key = "name" Then
                    If isFileBlock Then
                        'Resolve content as stream for fileblock
                        formValues.Add field, CopyStreamPart(stream, pBgn, pEnd)
                    Else
                        'Resolve content as string for non-fileblock
                        formValues.Add field, GetString(stream, pBgn, pEnd)
                    End If
                End If
            Next

            'Move over the begin pointer to next block
            pBgn = pEnd + LenB( binCtLf ) + 1
        Loop
        stream.Close
        Set Process = formValues
    End Function
End Class

%>