class_sys.asp

本息统基于中国网站技术人员最熟悉WindowsNT环境和Asp语言

<%
Class class_sys
    Public cache_name, cache_name_custom, cache_data, Reloadtime, setup, userip, errstr, userdir, user_copyright, ver, is_password_cookies, is_gb2312
    Public logined_uname, logined_upass, logined_ulevel, logined_ushowlogword, logined_uid, logined_uupfilemax, logined_uupfilesize, logined_udir, logined_isubb, logined_udomain, logined_ufolder
    Public comeurl, autoupdate
    Private Sub class_initialize()
        Reloadtime = 14400
        cache_name = blogdir& cache_name_user
        userip = request.ServerVariables("HTTP_X_FORWARDED_FOR")
        If userip = "" Then userip = request.ServerVariables("REMOTE_ADDR")
        comeurl = Trim(request.ServerVariables("HTTP_REFERER"))
        ver = "3.1"
        autoupdate = True '更新整站首页开关
        is_password_cookies = 1 '是否编码cookies,1为开启,0为关闭
        is_gb2312 = 1   '系统平台，1为简体中文平台，0为其他平台
    End Sub
    Public Property Let name(ByVal vNewValue)
        cache_name_custom = LCase(vNewValue)
    End Property
    Public Property Let Value(ByVal vNewValue)
        If cache_name_custom <> "" Then
            ReDim cache_data(2)
            cache_data(0) = vNewValue
            cache_data(1) = ServerDate(Now())
            Application.Lock
            Application(cache_name & "_" & cache_name_custom) = cache_data
            Application.unLock
        Else
            Err.Raise vbObjectError + 1, "CacheServer", " please change the CacheName."
        End If
    End Property
    Public Property Get Value()
        If cache_name_custom <> "" Then
            cache_data = Application(cache_name & "_" & cache_name_custom)
            If IsArray(cache_data) Then
                Value = cache_data(0)
            Else
                Err.Raise vbObjectError + 1, "CacheServer", " The Cache_Data(" & cache_name_custom & ") Is Empty."
            End If
        Else
            Err.Raise vbObjectError + 1, "CacheServer", " please change the CacheName."
        End If
    End Property
    Public Function ObjIsEmpty()
        ObjIsEmpty = True
        cache_data = Application(cache_name & "_" & cache_name_custom)
        If Not IsArray(cache_data) Then Exit Function
        If Not IsDate(cache_data(1)) Then Exit Function
        If DateDiff("s", CDate(cache_data(1)), ServerDate(Now())) < (60 * Reloadtime) Then ObjIsEmpty = False
    End Function
    Public Sub DelCahe(MyCaheName)
        Application.Lock
        Application.Contents.Remove (cache_name & "_" & MyCaheName)
        Application.unLock
    End Sub
    Public Sub ReloadSetup()
        Dim sql, rs, i
        sql = "select * from [oblog_setup] "
        Set rs = execute(sql)
        name = "setup"
        Value = rs.GetRows(1)
        Set rs = Nothing
        Application.Lock
        Application(cache_name & "index_update") = True
        Application(cache_name & "list_update") = True
        Application.unLock
    End Sub
    '读取用户目录及绑定的路径到缓存
    Public Sub ReloadUserdir()
        Dim sql, rs, s
        sql = "select userdir,dirdomain from [oblog_userdir] "
        Set rs = execute(sql)
        While Not rs.EOF
            s = s & rs(0) & "!!??((" & rs(1) & "##))=="
            rs.movenext
        Wend
        Application.Lock
        Application(cache_name & "dirdomain") = s
        Application.unLock
        Set rs = Nothing
    End Sub
    Public Sub start()
        name = "setup"
        If ObjIsEmpty() Then ReloadSetup()
        setup = Value
        user_copyright = setup(7, 0) & "</div><div id=""powered""><a href=""http://www.oblog.cn"" target=""_blank""><img src=""images\oblog_powered.gif"" border=""0"" alt=""Powered by Oblog."" /></a>"
        If DateDiff("s", Application(oblog.cache_name & "index_updatetime"), ServerDate(Now())) > setup(17, 0) And Application(cache_name & "class_update") = False And autoupdate Then
            ReloadSetup()
            'ReloadUserdir()
            Application.Lock
            Application(cache_name & "index_update") = True
            Application(cache_name & "list_update") = True
            Application(cache_name & "class_update") = True
            Application.unLock
            response.Write ("<script src="""&blogdir&"index.asp?re=0""></script>")
        End If
    End Sub
    Public Sub sys_err(errmsg)
        Dim strErr
        strErr = strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf
        strErr = strErr & "<link href='images/admin/admin_style.css' rel='stylesheet' type='text/css'></head><body>" & vbCrLf
        strErr = strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf
        strErr = strErr & "  <br><tr align='center'><td height='22' class='title'><strong>错误信息</strong></td></tr>" & vbCrLf
        strErr = strErr & "  <tr><td height='100' class='tdbg' valign='top'><b>产生错误的可能原因：</b><br>" & errmsg & "</td></tr>" & vbCrLf
        strErr = strErr & "  <tr align='center'><td class='tdbg'><a href='javascript:history.go(-1)'>&lt;&lt; 返回上一页</a></td></tr>" & vbCrLf
        strErr = strErr & "</table>" & vbCrLf
        strErr = strErr & "</body></html>" & vbCrLf
        response.Write strErr
    End Sub
    Public Sub chk_comeurl()
        If is_chk_comeurl = 1 Then
            Dim comeurl, curl
            comeurl = LCase(Trim(request.ServerVariables("HTTP_REFERER")))
            If comeurl = "" Then
                response.Write "<br><p align=center><font color='red'>对不起，为了系统安全，不允许直接输入地址访问本系统的后台管理页面。</font></p>"
                response.End
            Else
                curl = Trim("http://" & request.ServerVariables("SERVER_NAME"))
                If Mid(comeurl, Len(curl) + 1, 1) = ":" Then
                    curl = curl & ":" & request.ServerVariables("SERVER_PORT")
                End If
                curl = LCase(curl & request.ServerVariables("SCRIPT_NAME"))
                If LCase(Left(comeurl, InStrRev(comeurl, "/"))) <> LCase(Left(curl, InStrRev(curl, "/"))) Then
                    response.Write "<br><p align=center><font color='red'>对不起，为了系统安全，不允许从外部链接地址访问本系统的后台管理页面。</font></p>"
                    response.End
                End If
            End If
        End If
    End Sub
    Public Function site_bottom()
        site_bottom = setup(7, 0) & vbCrLf
        site_bottom = site_bottom & "<div style=""display:none;clear: both;text-align: center;width: 100%;padding: 1;""><a href=""http://www.oblog.cn"" target=""_blank"">Powered by oBlog.cn</a></div>" & vbCrLf
        site_bottom = site_bottom & "</body>" & vbCrLf
        site_bottom = site_bottom & "</html>" & vbCrLf
    End Function
    Public Function execute(sql)
        If Not IsObject(conn) Then link_database
        If is_debug = 0 Then
            On Error Resume Next
            Set execute = conn.execute(sql)
            If Err Then
                Err.Clear
                Set conn = Nothing
                response.Write "查询数据的时候发现错误，请检查您的查询代码是否正确。"
                response.End
            End If
        Else
            'Response.Write sql & "<br>"
            Set execute = conn.execute(sql)
        End If
    End Function
    Public Function chk_regname(regname)
        Dim regbadstr, i
        regbadstr = Split(setup(51, 0), vbCrLf)
        chk_regname = False
        For i = 0 To UBound(regbadstr)
            If Trim(regbadstr(i)) <> "" Then
                If Trim(regname) = Trim(regbadstr(i)) Then
                    chk_regname = True
                End If
            End If
            If chk_regname = True Then Exit For
        Next
    End Function
    Public Function chk_badword(Str)
        Dim badstr, i, n
        badstr = Split(setup(50, 0), vbCrLf)
        n = 0
        For i = 0 To UBound(badstr)
            If Trim(badstr(i)) <> "" Then
                If InStr(Str, Trim(badstr(i))) > 0 Then
                    n = n + 1
                End If
            End If
        Next
        chk_badword = n
    End Function
    Public Function filt_badword(Str)
        Dim badstr, i
        badstr = Split(setup(50, 0), vbCrLf)
        For i = 0 To UBound(badstr)
            If Trim(badstr(i)) <> "" Then
                Str = Replace(Str, badstr(i), "***")
            End If
        Next
        filt_badword = Str
    End Function
    Public Function getcode()
        getcode = "<img src=""" & blogdir & "inc/code.asp"" />"
    End Function
    '检查验证码是否正确
    Public Function codepass()
        Dim CodeStr
        CodeStr = Trim(request("CodeStr"))
        If CStr(Session("GetCode")) = CStr(CodeStr) And CodeStr <> "" Then
            codepass = True
            'Session("GetCode")=empty
        Else
            codepass = False
            'Session("GetCode")=empty
        End If
    End Function
    Public Function type_domainroot(Str)
        Dim domainroot, i
        domainroot = Trim(oblog.setup(4, 0))
        If InStr(domainroot, "|") > 0 Then
            domainroot = Split(domainroot, "|")
            For i = 0 To UBound(domainroot)
                If Trim(domainroot(i)) <> "" Then
                    If domainroot(i) = Str Then
                    type_domainroot = type_domainroot & "<option value='" & Trim(domainroot(i)) & "' selected>" & "." & domainroot(i) & "</option>"
                    Else
                    type_domainroot = type_domainroot & "<option value='" & Trim(domainroot(i)) & "'>" & "." & domainroot(i) & "</option>"
                    End If
                End If
            Next
        Else
            type_domainroot = "<option value='" & domainroot & "'>" & "." & domainroot & "</option>"
        End If
    End Function
    Public Function show_class(kind, CurrentID, kindType)
        Dim rsClass, sqlClass, strTemp, tmpDepth, i
        Dim arrShowLine(20)
        For i = 0 To UBound(arrShowLine)
            arrShowLine(i) = False
        Next
        If kind = "user" Then
            sqlClass = "select * From oblog_userclass order by RootID,OrderID"
        ElseIf kind = "log" Then
            sqlClass = "select * From oblog_logclass  Where idType=" & kindType & " order by RootID,OrderID"
        End If
        Set rsClass = execute(sqlClass)
        If rsClass.bof And rsClass.EOF Then
            show_class = "<option value='0'>请选择类别</option>"
        Else
            show_class = "<option value='0'>请选择类别</option>"
            Do While Not rsClass.EOF
                tmpDepth = rsClass("Depth")
                If rsClass("NextID") > 0 Then
                    arrShowLine(tmpDepth) = True
                Else
                    arrShowLine(tmpDepth) = False
                End If
                    strTemp = "<option value='" & rsClass("id") & "'"
                If CurrentID > 0 And rsClass("id") = CurrentID Then
                     strTemp = strTemp & " selected"
                End If
                strTemp = strTemp & ">"
                
                If tmpDepth > 0 Then
                    For i = 1 To tmpDepth
                        strTemp = strTemp & "&nbsp;&nbsp;"
                        If i = tmpDepth Then
                            If rsClass("NextID") > 0 Then
                                strTemp = strTemp & "├&nbsp;"
                            Else
                                strTemp = strTemp & "└&nbsp;"
                            End If
                        Else
                            If arrShowLine(i) = True Then
                                strTemp = strTemp & "│"
                            Else
                                strTemp = strTemp & "&nbsp;"
                            End If