<%@LANGUAGE="VBSCRIPT" CODEPAGE="1252"%> - Coolbubble - <% ' URL Utility functions. ' Test Function sub testUrlFunctions RESPONSE.WRITE("
testUrlFunctions:") RESPONSE.WRITE("
curPageURL = " & curPageURL()) RESPONSE.WRITE("
curPageURLWithVariables = " & curPageURLWithVariables()) RESPONSE.WRITE("
curPageName = " & curPageName()) RESPONSE.WRITE("
curPageNameWithVariables = " & curPageNameWithVariables()) end sub ' Example: "http://www.coolbubble.com/test.asp" function curPageURL() dim s, protocol, port if Request.ServerVariables("HTTPS") = "on" then s = "s" else s = "" end if protocol = strleft(LCase(Request.ServerVariables("SERVER_PROTOCOL")), "/") & s if Request.ServerVariables("SERVER_PORT") = "80" then port = "" else port = ":" & Request.ServerVariables("SERVER_PORT") end if curPageURL = protocol & "://" & Request.ServerVariables("SERVER_NAME") &_ port & Request.ServerVariables("SCRIPT_NAME") end function ' Example: "http://www.coolbubble.com/test.asp?nick=10" function curPageURLWithVariables() dim url url = curPageURL() if Request.ServerVariables("QUERY_STRING") <> "" then url = url & "?" & Request.ServerVariables("QUERY_STRING") end if curPageURLWithVariables = url end function ' Example: "test.asp" function curPageName() dim pagename pagename = Request.ServerVariables("SCRIPT_NAME") if inStr(pagename, "/") > 0 then pagename = Right(pagename, Len(pagename) - instrRev(pagename, "/")) end if curPageName = pagename end function ' Example: "test.asp?nick=10" function curPageNameWithVariables() dim url url = curPageName() if Request.ServerVariables("QUERY_STRING") <> "" then url = url & "?" & Request.ServerVariables("QUERY_STRING") end if curPageNameWithVariables = url end function function strLeft(str1,str2) strLeft = Left(str1,InStr(str1,str2)-1) end function %> <% ' *** FUNCTIONS *** dim databasePassword databasePassword = "dbconnectpw1384" dim conn ' Some Site wide config variables. ' dim g_showComments const g_enableComments = true const g_sendMailNotificationOnNewComment = true const g_enableUrlInComments = true ' All connections to the database should be made through this function. function databaseConnect(s) set conn=s.CREATEOBJECT("ADODB.Connection") conn.Provider="Microsoft.Jet.OLEDB.4.0" conn.Open(s.Mappath("..\private\maindb_001.mdb")) 'conn.Open(s.Mappath("iis642\domains\c\coolbubble.com\user\private\maindb_001.mdb")) end function function databaseConnectFrom2Deep(s) set conn=s.CREATEOBJECT("ADODB.Connection") conn.Provider="Microsoft.Jet.OLEDB.4.0" conn.Open(s.Mappath("..\..\..\private\maindb_001.mdb")) 'conn.Open(s.Mappath("iis642\domains\c\coolbubble.com\user\private\maindb_001.mdb")) end function ' Returns a date string in the following format "Sun Nov 1, 21:17" function createDateString( in_date ) month_part = MONTHNAME(MONTH(in_date), True) day_part = WEEKDAYNAME(WEEKDAY(in_date), True) day_number_part = DAY(in_date) time_part = FORMATDATETIME(in_date,vbshorttime) createDateString = day_part & " " & month_part & " " & day_number_part & ", " & time_part end function ' Returns user name when passed the user id. function getNameFromID(user_id) rsname.Open "Select * FROM USERS where user_id = " & user_id , conn getNameFromID = rsname.Fields("user_name").value rsname.close end function ' Query if the currently logged in user can edit a post by the supplied user. function canEditPost(user_id) IF Session("logged_in")<>1 then ' Not logged in so can't edit post. canEditPost = 0 ELSE 'if Session("user_level=2") ' Logged in, is this the users post? IF Session("user_level") = 2 OR Session("user_id") = user_id then canEditPost = 1 end IF end IF end function ' Query if the currently logged in user can create a new post of any type (must be a moderator) function canCreateModPost() IF Session("logged_in")<>1 then ' Not logged in so can't edit post. canCreateModPost = 0 ELSE ' Logged in, is this the users post? IF Session("user_level") = 2 then canCreateModPost = 1 end IF end IF end function ' Sanatise text - make special characters safe for display. function convertSpecialCharacters(input_text) IF input_text <> empty then input_text = REPLACE(input_text, "<", "<") input_text = REPLACE(input_text, ">", ">") 'input_text = REPLACE(input_text, """, """") input_text = REPLACE(input_text, "&", "&") input_text = REPLACE(input_text, vbCrLf, "
") 'input_text = Replace(input_text, "java", "") 'input_text = Replace(input_text, "table", "") 'input_text = Replace(input_text, "form", "") 'input_text = Replace(input_text, "alert", "") 'input_text = Replace(input_text, "onclick", "") 'input_text = Replace(input_text, "style", "") 'input_text = Replace(input_text, "html", "") 'input_text = Replace(input_text, "body", "") end IF convertSpecialCharacters = input_text end function ' Convert dangerous characters to codes. function validateInput(input_text) input_text = REPLACE(input_text, "'", "'") ' Apostrophe input_text = REPLACE(input_text, vbCrLf, "
") validateInput = input_text end function ' Strip out angled brackets - used in post headers. ' also limits input to 255 chars function stripAngledBrackets(input_text) input_text = REPLACE(input_text, "<", "") input_text = REPLACE(input_text, ">", "") IF LEN(input_text) > 255 then input_text = LEFT(input_text,255) end IF stripAngledBrackets = input_text end function sub drawHeader %> <% call insertGoogleAnalyticsCode end sub ' Called only from drawHeader sub insertGoogleAnalyticsCode %> <% end sub ' Checks for hit count on an entity. ' If update_log is 1, the hit count is increased by calling this function. function getEntityHitCount(entity_name, update_log) 'set rs = Server.CreateObject("ADODB.recordset") rs.Open "Select * FROM ENTITY_LOG WHERE entity_name = '" & entity_name & "'", conn hits = 0 IF not rs.EOF then hits = rs.Fields("hit_count").value rs.close ELSE hits = 0 rs.close ' Get new row id dim next_entity_id rs.Open "Select max(entity_id) FROM ENTITY_LOG", conn 'RESPONSE.WRITE("next_entity_id: " & rs.Fields(0).value & "
") next_entity_id = rs.Fields(0).value + 1 rs.close ' Need to create an entity row. sql = "INSERT INTO ENTITY_LOG " sql = sql & "VALUES (" & next_entity_id & ", '" & entity_name & "', 0, '" & DATE() & "', '0')" 'RESPONSE.WRITE("SQL: " & sql & "
") on error resume next conn.Execute sql IF err<>0 then 'RESPONSE.WRITE("
ERROR" & err.description) 'RESPONSE.WRITE("Error - couldn't create entity log.") ELSE 'RESPONSE.WRITE("Created new entity log.") end IF end IF ' Increase counter. IF update_log = 1 then sql = "UPDATE ENTITY_LOG SET hit_count = " & hits+1 & " where entity_name = '" & entity_name & "'" on error resume next conn.Execute sql IF err<>0 then 'Response.Write("
ERROR" & err.description) 'response.write("Error - couldn't create entity log.") ELSE 'response.write("Created new entity log.") end IF end IF ' Log referring URLS sPreviousURL = Request.ServerVariables("HTTP_REFERER") if sPreviousURL <> "" then call logReferringURL(sPreviousURL) end if getEntityHitCount = hits end function ' log a referring url. ' REFERRING_URL sub logReferringURL(referring_url) ' First detect any existing rows with the same URL. sql = "select * from REFERRING_URL" sql = sql & " where ru_url = '" & referring_url &"'" rsp.Open sql, conn if rsp.EOF then ' No row was found, insert a new row. rsp.close sql = "INSERT INTO REFERRING_URL (ru_url, ru_date, ru_count) " sql = sql & " values('" & referring_url & "', '" & now() & "', 1)" conn.Execute sql else dim ru_count ru_count = rsp.Fields("ru_count").value rsp.close sql = "UPDATE REFERRING_URL" sql = sql & " set ru_date = '" & now() & "', ru_count = " & ru_count+1 sql = sql & " where ru_url = '" & referring_url & "'" conn.Execute sql end if end sub ' Used for drawing posts on the main page etc. sub drawPost(post_id) dim editUrl dim permLinkUrl dim bodyFixed dim userName dim commentCount dim commentPlural dim sql ' Get count of comments linked to this post. sql = "Select count(*) as _count FROM COMMENTS where post_id = " & post_id sql = sql + " AND deleted = '0'" rsp.Open sql, conn commentCount = 0 commentCount = rsp.Fields("_count").value rsp.close ' Do mail sql select. rsp.Open "Select * FROM POSTS where post_id = " & post_id , conn 'rsname.Open "Select * FROM USERS where user_id = " & rsp.Fields("user_id").value , conn userName = getNameFromID(rsp.Fields("user_id").value) editUrl = "editpost.asp?post_id=" & post_id permLinkUrl = "index.asp?post_id=" & post_id bodyFixed = convertSpecialCharacters(rsp.Fields("body").value) ' Draw permlink icon and create the link. %> <% 'RESPONSE.WRITE(" ") RESPONSE.WRITE(rsp.Fields("heading").value & "" ) RESPONSE.WRITE("

" & bodyFixed & "

") %>
<% RESPONSE.WRITE(" posted by " & userName ) RESPONSE.WRITE(" on " & rsp.Fields("date_created").value) ' Display comment count and create the link. commentPlural = "" if commentCount <> 1 then commentPlural = "s" end if %>  <%RESPONSE.WRITE(commentCount & " comment" & commentPlural & " ") if canEditPost(rsp.Fields("user_id").value) = 1 then %> [edit] <% end if %>
<% rsp.close 'rsname.close end sub ' Draw an individual bookmark from a supplied post id. ' if shorten is 1 then don't draw description. sub drawBookmark(post_id, shorten) rsp.Open "Select * FROM POSTS where post_id = " & post_id , conn dim editUrl dim shortLinkUrl dim linkText editUrl = "editpost.asp?post_id=" & rs.Fields("post_id").value rsname.Open "Select * FROM USERS where user_id = " & rs.Fields("user_id").value , conn ' Shorten the display url if required. linkUrl = rs.Fields("heading").value shortLinkUrl = linkUrl if LEN(shortLinkUrl) > 20 then shortLinkUrl = LEFT(linkUrl,18) + "..." end if %>

<% RESPONSE.WRITE(shortLinkUrl) %><% if shorten <> 1 then RESPONSE.WRITE(" ?" & rs.Fields("body").value) %> ?<% RESPONSE.WRITE(" posted by " & rsname.Fields("user_name").value) RESPONSE.WRITE(" on " & rs.Fields("date_created").value) %> ? <% end if if canEditPost(rs.Fields("user_id").value) = 1 then %> ?[edit]<% end if %>

<% rsname.close rsp.close end sub ' Draw All comments for a given object id and object type sub drawComments(object_id, object_type) RESPONSE.WRITE("

Comments:") ' Create the recordset dim sql dim show_deleted ' Detect any null values that might cause the SQL to fail if object_id = "" then exit sub end if if canCreateModPost() = 1 then 'show_deleted = 1 show_deleted = 0 ' let's hide deleted ones for now end if ' construct the sql for non-deleted and all posts. if show_deleted = 0 then sql = "Select * FROM COMMENTS where post_id = " & object_id sql = sql & " AND parent_type='" & object_type & "'" sql = sql & " AND deleted='0'" sql = sql & " ORDER BY comment_id" else sql = "Select * FROM COMMENTS where post_id = " & object_id sql = sql & " AND parent_type='" & object_type & "'" sql = sql & " ORDER BY comment_id" end if rs.Open sql, conn ' Display message and exit if post does not exist. if rs.eof then RESPONSE.WRITE(" - No comments yet, why not post one!
") rs.close RESPONSE.WRITE("View all site comments
") exit sub end if dim count do until rs.EOF if count mod 2 = 0 then RESPONSE.WRITE("
") else RESPONSE.WRITE("
") end if call drawComment(rs.Fields("comment_id").value) RESPONSE.WRITE("
") count = count + 1 rs.MoveNext loop RESPONSE.WRITE("View all site comments
") rs.close end sub ' 2007.01.07 draw a comment given a comment id. sub drawComment(comment_id) rsp.Open "Select * FROM COMMENTS where comment_id = " & comment_id , conn RESPONSE.WRITE("

On " & createDateString(rsp.Fields("date_created").value)) RESPONSE.WRITE(" " & rsp.Fields("user_name").value & " wrote:") RESPONSE.WRITE("

" & rsp.Fields("body").value) if rsp.Fields("deleted").value = "1" then RESPONSE.WRITE("

COMMENT DELETED BY ADMIN") end if ' Draw button to allow admin user to delete this post. if canCreateModPost() = 1 then dim back_url back_url = curPageURLWithVariables() %>

<% end if if canCreateModPost() = 1 then dim delPostUrl delPostUrl = "action.asp?action=delete_comment&object_id=" & comment_id RESPONSE.WRITE("

DELETE POST") end if 'RESPONSE.WRITE("
?" & rsp.Fields("comment_id").value) 'RESPONSE.WRITE("
?" & rsp.Fields("post_id").value) 'RESPONSE.WRITE("
?" & rsp.Fields("user_id").value) 'RESPONSE.WRITE("
?" & rsp.Fields("user_name").value) 'RESPONSE.WRITE("
?" & rsp.Fields("body").value) 'RESPONSE.WRITE("
?" & createDateString(rsp.Fields("date_created").value)) 'RESPONSE.WRITE("
?" & rsp.Fields("deleted").value) rsp.close end sub ' 2007.01.07 Draw form used for submitting comments. ' if the global variable g_enableComments is false then it displays ' a message instead. sub drawCommentPostingForm(post_id, parent_type) dim back_url back_url = curPageURLWithVariables() if g_enableComments <> true then RESPONSE.WRITE("

Comment posting is currently disabled.") else RESPONSE.WRITE("

Post a comment:") %>

Name
Comment
<% end if end sub sub updateTagCountForAllTags dim sql sql = "Select distinct tag_string FROM TAGS" sql = sql & " where deleted <> '1' and object_type='IMAGE'" rs.Open sql, conn if rs.EOF then RESPONSE.WRITE("
updateTagCountForAllTags: No tags found.") rs.close exit sub end if do until rs.EOF call updateTagCount(rs.Fields("tag_string").value, "IMAGE") rs.MoveNext loop rs.close end sub sub updateTagCount(tag_string, object_type) dim sql sql = "SELECT count(tag_string) as tag_count FROM TAGS where tag_string='" & tag_string & "'" sql = sql & " and object_type='" & object_type & "'" 'RESPONSE.WRITE("
sql: " & sql) rsp.Open sql, conn if rsp.eof then 'RESPONSE.WRITE("
no Tags found for string:" & tag_string) rsp.close exit sub end if dim num_rows num_rows = rsp.Fields("tag_count").value 'RESPONSE.WRITE("
tag_count = " & rsp.Fields("tag_count").value & " for: " & tag_string) rsp.close ' Now determine if a row exists in TAG_COUNT for the tag. sql = "select 1 from TAG_COUNT where tag_string='" & tag_string & "'" sql = sql & " and object_type='" & object_type & "'" rsp.Open sql, conn dim row_exists if rsp.eof then RESPONSE.WRITE("
No TAG_COUNT row found for string:" & tag_string) row_exists = 0 else RESPONSE.WRITE("
TAG_COUNT row found for string:" & tag_string) row_exists = 1 end if rsp.close ' Update or insert tag count row. if row_exists = 0 then sql = "insert into TAG_COUNT (tag_string, object_type, tag_count)" sql = sql & " values ('" & tag_string & "','" & object_type & "'," & num_rows & ")" RESPONSE.WRITE("
SQL: " & sql) conn.Execute sql end if if row_exists = 1 then sql = "update TAG_COUNT set tag_count=" & num_rows sql = sql & " where tag_string='" & tag_string & "' and object_type='" & object_type & "'" RESPONSE.WRITE("
SQL: " & sql) conn.Execute sql end if 'insert into TAG_COUNT (tag_string, object_type, count) values ( 'imogen','IMAGE', 22) end sub %> <% ' Page constants const numLinks = 15 ' number of new links to display const numNews = 5 ' number of news items to display const numNewImages = 18 ' number of new images to display dim passedInID passedInID = 0 call detectPassedInID %> <% ' Connect to database. call databaseConnect(SERVER) 'set conn=Server.CreateObject("ADODB.Connection") 'conn.Provider="Microsoft.Jet.OLEDB.4.0" 'conn.Open(Server.Mappath("..\private\maindb.mdb")) set rs = SERVER.CREATEOBJECT("ADODB.recordset") set rsp = SERVER.CREATEOBJECT("ADODB.recordset") ' used for individual posts set rsname = SERVER.CREATEOBJECT("ADODB.recordset") ' Used to get username from user id %> <% call drawHeader %>
<% if passedInID = 0 then %>

Latest Posts


<% call drawNews else %>


<% call drawPost(passedInID) call drawComments(passedInID, "POST") ' Handle comment posting call drawCommentPostingForm(passedInID, "POST") end if %>
<% ' *** FUNCTIONS *** function getNameFromID_removed(user_id) rsname.Open "Select * FROM USERS where user_id = " & user_id , conn getNameFromID = rsname.Fields("user_name").value rsname.close end function function detectPassedInID passedInID = request.querystring("post_id") end function sub drawPost_removed(post_id) rsp.Open "Select * FROM POSTS where post_id = " & post_id , conn 'rsname.Open "Select * FROM USERS where user_id = " & rsp.Fields("user_id").value , conn dim editUrl dim bodyFixed dim userName userName = getNameFromID(rsp.Fields("user_id").value) editUrl = "editpost.asp?post_id=" & post_id bodyFixed = convertSpecialCharacters(rsp.Fields("body").value) RESPONSE.WRITE("" & rsp.Fields("heading").value & "" ) RESPONSE.WRITE("

" & bodyFixed & "

") %>
<% RESPONSE.WRITE(" posted by " & userName ) RESPONSE.WRITE(" on " & rsp.Fields("date_created").value) if canEditPost(rsp.Fields("user_id").value) = 1 then %> [edit] <% end if %>
<% rsp.close 'rsname.close end sub sub drawEditorial ' Create the Editorial recordset rs.Open "Select * FROM POSTS where type_id = 2 ORDER BY date_created DESC", conn if rs.EOF then RESPONSE.WRITE("ERROR: No editorial posts to display.") else ' Draw one editorial item. call drawPost(rs.Fields("post_id").value) end if rs.close end sub sub drawNews ' Create the NEWS recordset dim sql sql = "Select * FROM POSTS where type_id = 1" sql = sql & " AND deleted = '0'" sql = sql & " ORDER BY date_created DESC" rs.Open sql, conn dim count do until rs.EOF if count '1'" sql = sql & "ORDER BY date_created DESC" rsp.Open sql, conn if rsp.EOF then RESPONSE.WRITE("
Image not found") rsp.close exit sub end if dim filename dim linkText ' Used to construct the image link. dim columnCount dim filenameStack ' String with all filenames added dim count filenameStack = "." RESPONSE.WRITE("
") do until rsp.EOF if count") end if ' Extract image details from record. filename = rsp.Fields("filename").value 'filenameStack ' Check if similar named filename has been displayed already if instr(filenameStack,Left(filename,6)) = 0 then filenameStack = filenameStack + filename ' Add filename to the combined name string. linkText = "gallery.asp?image_name=" & filename RESPONSE.WRITE("") columnCount = columnCount + 1 if columnCount = 3 then ' 3 columns columnCount = 0 RESPONSE.WRITE("") end if count = count + 1 end if end if rsp.MoveNext loop RESPONSE.WRITE("

") RESPONSE.WRITE("") RESPONSE.WRITE("") RESPONSE.WRITE("") RESPONSE.WRITE("
") rsp.close end sub %>