#download.mo

WAPmo手机网站管理平台是一款创建与管理维护WAP网站的的软件产品

Option Explicit

TBBS.AddLang "common|head|foot|error"
TBBS.SetNodes "env|user"

TBBS.Page("name") = TBBS.Env("bbs_name")
TBBS.Vars("skin") = "default"

Call main

Private Sub doGet()
    If TBBS.Permit("download") = 0 Then
        TBBS.AddError "ps_download", Array()
    ElseIf Not CheckFile(Request.QueryString("id")) Then
        TBBS.AddError "missing_file", Array()
    ElseIf Not ValidCent() Then
        TBBS.AddError "cent_no_enough", Array()
    ElseIf Not ValidCoin() Then
        TBBS.AddError "coin_no_enough", Array()
    Else
        Call doGetFile
    End If
End Sub

Private Sub doPost()
    TBBS.AddError "invalid_handle", Array()
End Sub

Private Function CheckFile(ByVal strID)
    Dim lngID
    lngID = atol(strID)
    If lngID < 1 Then
        CheckFile = False
        Exit Function
    End If
    Dim xmlDoc, strSQL
    strSQL = MyKernel.DB.GetLimitSQL(1, "*", T_UPLOAD, "SEQID=$(SeqID)", "", "")
    strSQL = Replace(strSQL, "$(SeqID)", lngID)
    Set xmlDoc = MyKernel.DB.SQLToXML(strSQL, "downs", "down")
    CheckFile = xmlDoc.documentElement.hasChildNodes
    If CheckFile Then
        TBBS.AppendNode xmlDoc.documentElement.firstChild
    End If
    Set xmlDoc = Nothing
End Function

Private Function ValidCent()
    If MyKernel.Memory("seqid") = TBBS.Attr("down", "userid") Then
        ValidCent = True
    ElseIf atol(TBBS.Attr("down", "cent")) > 0 Then
        ValidCent = CBool(atol(TBBS.Attr("down", "cent")) <= atol(MyKernel.Memory("cent")))
    Else
        ValidCent = True
    End If
End Function

Private Function ValidCoin()
    Dim strSQL
    If MyKernel.Memory("seqid") = TBBS.Attr("down", "userid") Then
        ValidCoin = True
    ElseIf atol(TBBS.Attr("down", "coin")) > 0 Then
        strSQL = MyKernel.DB.GetLimitSQL(1, "SEQID", T_DOWNLOAD, "FILEID=$(FileID) AND USERID=$(UserID)", "", "")
        strSQL = Replace(strSQL, "$(FileID)", TBBS.Attr("down", "seqid"))
        strSQL = Replace(strSQL, "$(UserID)", MyKernel.Memory("seqid"))
        ValidCoin = MyKernel.DB.HasRow(strSQL)
    Else
        ValidCoin = True
    End If
End Function

Private Sub doGetFile()
    Dim strPath, strSQL
    strPath = "upload/" & TBBS.Attr("down", "uppath")
    If fso.FileExists(TBBS.MapPath(strPath)) Then
        'Response.ContentType = GetMIMEType(TBBS.Attr("down", "upext"))
        'Response.AddHeader "Content-Length", TBBS.Attr("down", "upsize")
        'Response.AddHeader "Content-Disposition", "attachment; filename=" & TBBS.Attr("down", "upname")
        'Response.BinaryWrite GetFileBinary(TBBS.MapPath(strPath))
        'MyIO.Redirect strPath
        If DownloadFile(TBBS.MapPath(strPath), TBBS.Attr("down", "upname"), TBBS.Attr("down", "upext")) Then
            strSQL = "UPDATE $0 SET DOWNLOADS=DOWNLOADS+1 WHERE SEQID=$1"
            strSQL = str_format(strSQL, Array(T_UPLOAD, TBBS.Attr("down", "seqid")))
            MyKernel.DB.Exec strSQL
        End IF
    Else
        TBBS.AddError "missing_file", Array()
    End If
End Sub

Private Function GetContentType(ByVal strExt)
    Dim xmlDoc, xmlNode
    Set xmlDoc = WM_GetCache("mime")
    Set xmlNode = XMLQuery(xmlDoc.documentElement, "mime[@name='" & XPathString(LCase(strExt)) & "']")
    If Not xmlNode Is Nothing Then
        GetContentType = XMLAttr(xmlNode, "type")
    Else
        GetContentType = "application/octet-stream"
    End If
    Set xmlNode = Nothing
    Set xmlDoc = Nothing
End Function

Private Function DownloadFile(ByVal strPath, ByVal strFileName, ByVal strExt)
    Dim objTemp, vtData
    Dim lngSize, lngBytes, lngChunk, lngRange, lngBreak
    Dim strRange, arr
    DownloadFile = False
    lngSize = GetFileSize(strPath)
    strRange = MyIO.Env("HTTP_RANGE")
    If strRange = "" Then
        lngRange = 0
        lngBreak = lngSize
    Else
        strRange = Mid(strRange, 7)
        arr = Split(strRange, "-")
        lngRange = CLng(arr(0))
        If IsNumeric(arr(1)) Then
            lngBreak = CLng(arr(1))
        Else
            lngBreak = lngSize
        End If
        If lngBreak > lngSize Then
            lngBreak = lngSize
        End If
    End If
    lngBytes = lngBreak - lngRange
    If lngBytes < 1 Then
        TBBS.AddError "invalid_range", Array(lngSize, lngBreak, lngRange)
        Exit Function
    End If
    If strRange <> "" Then Response.Status = "206 Partial Content"
    Response.ContentType = GetContentType(strExt)
    Response.AddHeader "Content-Length", lngBytes
    Response.AddHeader "Content-Disposition", "attachment; filename=" & strFileName
    If strRange <> "" Then
        If lngBreak = lngSize Then
            Response.AddHeader "Content-Range", "bytes " & lngRange & "-" & (lngBreak - 1) & "/" & lngSize
        Else
            Response.AddHeader "Content-Range", "bytes " & lngRange & "-" & lngBreak & "/" & lngSize
        End If
    End If
    Response.AddHeader "Last-Modified", FormatGDate(GetFileModify(strPath), 0)
    Response.AddHeader "Accept-Ranges", "bytes"
    lngChunk = KBYTE * 200
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    objTemp.LoadFromFile strPath
    objTemp.Position = lngRange
    Do While lngBytes > lngChunk And Response.IsClientConnected
        Response.BinaryWrite objTemp.Read(lngChunk)
        Response.Flush
        lngBytes = lngBytes - lngChunk
    Loop
    If lngBytes > 0 And Response.IsClientConnected Then
        Response.BinaryWrite objTemp.Read(lngBytes)
        Response.Flush
    End If
    objTemp.Close
    Set objTemp = Nothing
    DownloadFile = True
End Function