<%
function convertTypeIdToDbTable(id)
dim tempString
select case id
case 1
tempString = "content_headings"
case 2
tempString = "content_images"
case 3
tempString = "content_text"
case 4
tempString = "content_links"
case 5
tempString = "content_files"
case 6
tempString = "content_dates"
case 7
tempString = "content_plugins"
case 8
tempString = "content_hr"
case 9
tempString = "content_anchorlist"
case 10
tempString = "content_dl"
end select
convertTypeIdToDbTable = tempString
end function
function convertTypeIdToDbColumn(id)
dim tempString
select case id
case 1
tempString = "heading_id"
case 2
tempString = "image_content_id"
case 3
tempString = "text_id"
case 4
tempString = "link_content_id"
case 5
tempString = "file_content_id"
case 6
tempString = "date_id"
case 7
tempString = "plugin_content_id"
case 8
tempString = "hr_id"
case 9
tempString = "anchorList_id"
case 10
tempString = "dl_id"
end select
convertTypeIdToDbColumn = tempString
end function
function returnStatusName(value)
dim tempString
select case value
case 1
tempString = "Draft"
case 2
tempString = "Pending approval"
case 3
tempString = "Live"
case 4
tempString = "Live with a newer version in draft"
case 5
tempString = "Live with a newer version pending approval"
case 6
tempString = "Archive"
end select
returnStatusName = tempString
end function
'---------------------------------------------------
' Takes an SQL Query
' Runs the Query and returns a recordset
'---------------------------------------------------
Function LoadRSFromDB(p_strSQL)
if not sqlIsSafe(p_strSQL) then
response.write("
Database error
" & VbCrLf)
response.write("
We're sorry but an database error has occured.
")
message = "USER IP: " & Request.ServerVariables("REMOTE_ADDR") & VbCrLf &_
"REMOTE HOST: " & Request.ServerVariables("REMOTE_HOST") & VbCrLf &_
"REMOTE_USER: " & Request.ServerVariables("REMOTE_USER") & VbCrLf &_
"REQUEST_METHOD: " & Request.ServerVariables("REQUEST_METHOD") & VbCrLf &_
"OFFENDING SQL: " & p_strSQL & VbCrLf
call sendEmail("admin@" & websiteDomainName, "malcolm@electricputty.co.uk", projectName & " SQL Error", message)
response.end
else
dim rs, cmd
Set rs = Server.CreateObject("adodb.Recordset")
Set cmd = Server.CreateObject("adodb.Command")
'Run the SQL
cmd.ActiveConnection = dbConnectionString
cmd.CommandText = p_strSQL
cmd.CommandType = 1
cmd.Prepared = true
rs.CursorLocation = 3
rs.Open cmd, , 0, 1
if Err <> 0 then
Err.Raise Err.Number, "ADOHelper: RunSQLReturnRS", Err.Description
end if
' Disconnect the recordsets and cleanup
set rs.ActiveConnection = Nothing
set cmd.ActiveConnection = Nothing
set cmd = Nothing
set LoadRSFromDB = rs
end if
End Function
Function RunSQL(ByVal p_strSQL)
' Create the ADO objects
Dim cmd
Set cmd = Server.CreateObject("adodb.Command")
cmd.ActiveConnection = dbConnectionString
cmd.ActiveConnection.BeginTrans
cmd.CommandText = p_strSQL
cmd.CommandType = 1
' Execute the query without returning a recordset
' Specifying adExecuteNoRecords reduces overhead and improves performance
cmd.Execute true, , adExecuteNoRecords
cmd.ActiveConnection.CommitTrans
if Err <> 0 then
cmd.ActiveConnection.RollBackTrans
Err.Raise Err.Number, "ADOHelper: RunSQL", Err.Description
end if
' Cleanup
Set cmd.ActiveConnection = Nothing
Set cmd = Nothing
End Function
'---------------------------------------------------
' Quick SQL string check for injection attacks
'---------------------------------------------------
function sqlIsSafe(strSQL)
'-- response.write strSQL & ""
'-- -------------------------------------------------
'-- Semi-colons should only appear in any querysting as encoded ampersands
'-- Encode 'good' semi-colons
t_strSQL = strSQL
t_strSQL = replace(t_strSQL, "&", "[a]")
t_strSQL = replace(t_strSQL, "'", "[sq]")
dim badQuery : badQuery = false
if session("securitylevel")>0 then
'-- Don't check the control words
else
'-- Check for dangerous words
if Instr(lcase(t_strSQL), "alter")>0 then badQuery = true
if Instr(lcase(t_strSQL), "begin")>0 then badQuery = true
if Instr(lcase(t_strSQL), "convert")>0 then badQuery = true
'if Instr(lcase(t_strSQL), "create")>0 then badQuery = true
if Instr(lcase(t_strSQL), "cursor")>0 then badQuery = true
if Instr(lcase(t_strSQL), "declare")>0 then badQuery = true
if Instr(lcase(t_strSQL), "delete")>0 then badQuery = true
if Instr(lcase(t_strSQL), "drop")>0 then badQuery = true
if Instr(lcase(t_strSQL), "exec")>0 then badQuery = true
if Instr(lcase(t_strSQL), "exists")>0 then badQuery = true
if Instr(lcase(t_strSQL), "sysobjects")>0 then badQuery = true
if Instr(lcase(t_strSQL), "information_schema")>0 then badQuery = true
if Instr(lcase(t_strSQL), "concat")>0 then badQuery = true
end if
'-- Check for suspicious characters
if Instr(lcase(t_strSQL), ";")>0 then badQuery = true
if Instr(lcase(t_strSQL), "--")>0 then badQuery = true
if Instr(lcase(t_strSQL), "/*")>0 then badQuery = true
if Instr(lcase(t_strSQL), "*/")>0 then badQuery = true
'-- Check for encoded characters
if Instr(lcase(t_strSQL), "%3b")>0 then badQuery = true '-- Hex semi-colon
if Instr(lcase(t_strSQL), "00111011")>0 then badQuery = true '-- Binary semi-colon
if Instr(lcase(t_strSQL), "%2d")>0 then badQuery = true '-- Hex hyphen
if Instr(lcase(t_strSQL), "00101101")>0 then badQuery = true '-- Binary hyphen
if Instr(lcase(t_strSQL), "%2a")>0 then badQuery = true '-- Hex asterisk
if Instr(lcase(t_strSQL), "00101010")>0 then badQuery = true '-- Binary asterisk
'-response.write badQuery & ""
'-response.end
if badQuery then
sqlIsSafe = false
else
sqlIsSafe = true
end if
end function
'---------------------------------------------------
' Sanatise input functions
'---------------------------------------------------
private function sanitiseToInteger(byVal string)
dim regExp
set regExp = New RegExp
regExp.Global = True
regExp.IgnoreCase = True
regExp.Pattern = "[^0-9]"
sanitiseToInteger = regExp.replace(string,"")
end function
function getPageName(page_id)
pSQL = "Select page_title from page_info where page_id = " & page_id
set rs = LoadRSFromDB(pSQL)
if not rs.EOF then
getPageName = rs("page_title")
else
getPageName = "Blank page"
end if
set rs = nothing
end function
function writePaginationRow(rs, url, colspan1, colspan2)
if rs.RecordCount > RecordsPerPage then
rs.PageSize = RecordsPerPage
else
rs.PageSize = rs.RecordCount
end if
rs.CacheSize = rs.PageSize
intPageCount = rs.PageCount
intRecordCount = rs.RecordCount
if cint(intPage) > cint(intPageCount) then intPage = intPageCount
if cint(intPage) <= 0 then intPage = 1
if intRecordCount > 0 Then
rs.AbsolutePage = intPage
intStart = rs.AbsolutePosition
if cint(intPage) = cint(intPageCount) then
intFinish = intRecordCount
else
intFinish = intStart + (rs.PageSize - 1)
end if
end If
'-- Concatenate the pagination string
dim paginationString
if cint(intPage) > 1 then
paginationString = "<< Previous"
else
paginationString = "<< Previous"
end if
paginationString = paginationString & " | "
if cint(intPage) < cint(intPageCount) then
paginationString = paginationString & "Next >>"
else
paginationString = paginationString & "Next >>"
end if
returnString = "
" & VbCrLf
writePaginationRow = returnString
end function
'---------------------------------------------------
' Avoid apostrophe errors in SQL
'---------------------------------------------------
function SQLSafe(byVal S)
dim L,i,R,C
L = Len(S)
R = ""
for i = 1 to L
C = mid(S,i,1)
if (C = "'") Then
R = R & "'"
else
R = R & C
end if
next
SQLSafe = R
end function
'---------------------------------------------------
' List content of directory using the fso
'---------------------------------------------------
function filelist(folderspec)
dim fso, f, f1, fc, s
set fso = CreateObject("Scripting.FileSystemObject")
set f = fso.GetFolder(folderspec)
set fc = f.Files
for each f1 in fc
s = s & f1.name & ";"
next
if len(s) > 0 then
s = left(s,len(s)-1)
filelist = split(s,";")
end if
end function
'---------------------------------------------------
' Write page title
'---------------------------------------------------
function writePageTitle(page_id)
strSQL = "SELECT page_title from page_info where page_id = " & page_id
set rs = LoadRSFromDB(strSQL)
if not rs.EOF then
writePageTitle = rs("page_title")
end if
set rs = nothing
end function
'---------------------------------------------------
' Write Breadcrumb trail
'---------------------------------------------------
function writeBreadcrumb(page_id)
Dim visualtemplate
Dim bStr
Dim bSQL
Dim bRS
bStr = ""
bSQL = "SELECT p.page_id, "&_
"pi.page_title, pi.visual_template, pi.page_id, " &_
"(SELECT pl.page_title from page_info pl where pl.page_id = p.page_id and pl.language_id = " & session("languageID") &") as language_title "&_
"FROM pages p "&_
"INNER JOIN page_info pi on p.page_id = pi.page_id "&_
"INNER JOIN ia ia on pi.page_id = ia.ia_childid "&_
"WHERE ia.ia_childid = (SELECT p.ia_parentid FROM ia p WHERE p.ia_childid = " & page_id & " AND ia_depth > 1) "&_
"AND pi.language_ID = 1"
set bRS = LoadRSFromDB(bSQL)
if not bRS.EOF then
Do While not bRS.EOF
if len(bRS("language_title")) then
bStr = replace(bRS("language_title")," & "," & ") & " > " & bStr
else
bStr = replace(bRS("page_title")," & "," & ") & " > " & bStr
end if
call writeBreadcrumb(bRS("page_id"))
bRS.MoveNext
Loop
end if
response.write bStr
bRS.Close
Set bRS = Nothing
end function
'---------------------------------------------------
' Function to check a string is Alpha Numeric
'---------------------------------------------------
Private Function IsAlphaNumeric(byVal string)
dim regExp, match, i, spec
For i = 1 to Len( string )
spec = Mid(string, i, 1)
Set regExp = New RegExp
regExp.Global = True
regExp.IgnoreCase = True
regExp.Pattern = "[A-Z]|[a-z]|\s|[_]|[0-9]|[.]"
set match = regExp.Execute(spec)
If match.count = 0 then
IsAlphaNumeric = False
Exit Function
End If
Set regExp = Nothing
Next
IsAlphaNumeric = True
End Function
'---------------------------------------------------
' Function to for valid email addresses
'---------------------------------------------------
Function isValidEmail(myEmail)
dim isValidE
dim regEx
isValidE = True
set regEx = New RegExp
regEx.IgnoreCase = False
regEx.Pattern = "^[a-zA-Z][\w\.-]*[a-zA-Z0-9]@[a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$"
isValidE = regEx.Test(myEmail)
isValidEmail = isValidE
End Function
'---------------------------------------------------
' Function to return a nodes ancestors for tree session variable
'---------------------------------------------------
function collectAncestors(page_id,tempString)
strSQL = "SELECT ia_parentid, ia_depth FROM ia WHERE ia_childid = " & page_id
set rs = LoadRSFromDB(strSQL)
if not rs.EOF then
if rs("ia_depth") >= 1 then
tempString = page_id & "||" & tempString
call collectAncestors(rs("IA_ParentID"),tempString)
else
tempString = "1||" & tempString
end if
end if
rs.Close
Set rs = Nothing
collectAncestors = tempString
end function
'---------------------------------------------------
' Function to return all a node's descendants
'---------------------------------------------------
function collectDescendants(page_id,tempString)
strSQL = "SELECT ia_childid FROM ia WHERE ia_parentid = " & page_id
set rs = LoadRSFromDB(strSQL)
if not rs.EOF then
do while not rs.EOF
tempString = rs("ia_childid") & "||" & tempString
call collectDescendants(rs("ia_childid"),tempString)
rs.movenext
loop
end if
rs.Close
Set rs = Nothing
collectDescendants = tempString
end function
'---------------------------------------------------
' Function to return the page id of any page's ultimate parent
'---------------------------------------------------
function getParentID(page_id, targetDepth)
Set rs = Server.CreateObject("ADODB.Recordset")
strSQL = "SELECT ia_childid, ia_parentid, ia_depth FROM ia WHERE ia_childid = " & page_id
set rs = LoadRSFromDB(strSQL)
if not rs.EOF then
if rs("ia_depth") = targetDepth then
activeNavID = rs("ia_childid")
else
call getParentID(rs("ia_parentid"), targetDepth)
end if
end if
rs.Close
set rs = nothing
getParentID = activeNavID
end function
'---------------------------------------------------
' Function to return a pluralised version of a string
'---------------------------------------------------
function makeplural(text)
dim temp
if right(text,1) = "y" then
temp = left(text,len(text)-1) & "ies"
elseif right(text,1) = "s" then
'do nothing
else
temp = text & "s"
end if
makeplural = temp
end function
function initialCap(text)
dim temp
temp = ucase(left(text,1)) & mid(text,2,len(text)-1)
initialCap = temp
end function
'---------------------------------------------------
' Function to reset navigation depth array
'---------------------------------------------------
Dim LastNodeDepth
LastNodeDepth = 0
Dim depth_counter(100)
Dim depth_sibling_counter(100)
function resetArray()
dim i
for i = 0 to 99
depth_counter(i) = 1
depth_sibling_counter(i) = 0
next
end function
'---------------------------------------------------
' Return current date and time
'---------------------------------------------------
function getCurrentDateTime()
dim dateString
dateString = Date() & " " & Time()
dateString = year(dateString) & "-" & month(dateString) & "-" & day(dateString) & " " & hour(dateString) + timeDifference & ":" & minute(dateString) & ":" & second(dateString)
getCurrentDateTime = dateString
end function
function getCurrentDate()
dim dateString
dateString = Date() & " " & Time()
dateString = year(dateString) & "-" & month(dateString) & "-" & day(dateString) & " 00:00:00"
getCurrentDate = dateString
end function
function formatDate(thisDate)
dim dateString
dateString = year(thisDate) & "-" & month(thisDate) & "-" & day(thisDate)
formatDate = dateString
end function
function isInFuture(endYear, endMonth, endDay, startYear, startMonth, startDay)
dim isInF
isInF = false
if cint(endYear) > cint(startYear) then
isInF = true
elseif cint(endYear) < cint(startYear) then
isInF = false
else
if cint(endMonth) > cint(startMonth) then
isInF = true
elseif cint(endMonth) < cint(startMonth) then
isInF = false
else
if cint(endDay) >= cint(startDay) then
isInF = true
else
isInF = false
end if
end if
end if
isInFuture = isInF
end function
Function sendEmail(e_from,e_to,e_subject,e_message)
Dim Mailer
Set Mailer = Server.CreateObject("CDO.Message")
Mailer.From = e_from
Mailer.To = e_to
Mailer.cc = "malcolm@electricputty.co.uk"
Mailer.Subject = e_subject
Mailer.TextBody = e_message
Mailer.send
Set Mailer = Nothing
end function
function getContentDBReady(byVal string)
string = trim(string)
string = SQLSafe(string)
if not session("languageName") = "Arabic" then
string = encodeSpecialCharacters(string)
end if
'--Strip out the URLs of all internal links
string = replace(string,"href=""" & websiteURL,"href=""||INTERNAL||")
getContentDBReady = string
end function
%>
<%
function encodeForURL(textString)
textString = replace(textString,"&","[AMP]")
textString = replace(textString,"#","[HASH]")
textString = replace(textString,"<","[")
textString = replace(textString,">","]")
encodeForURL = textString
end function
function unEncodeFromURL(textString)
textString = replace(textString,"[AMP]","&")
textString = replace(textString,"[HASH]","#")
textString = replace(textString,"[","<")
textString = replace(textString,"]",">")
unEncodeFromURL = textString
end function
function encodeForQueryString(byVal string)
string = trim(string)
string = replace(string," ","%20")
encodeForQueryString = string
end function
function makeJavascriptSafe(sourceString)
dim safeString
safeString = replace(sourceString," ","%20")
safeString = replace(safeString,"'","\'")
safeString = replace(safeString,"'","\'")
makeJavascriptSafe = safeString
end function
function getFileIcon(fileName)
'--strip the file extension and render correct icon
FileExtension = lcase(right(fileName,3))
if FileExtension = "pdf" then
FileIcon = "icon_pdf.gif"
elseif FileExtension = "doc" then
FileIcon = "icon_doc.gif"
elseif FileExtension = "zip" then
FileIcon = "icon_zip.gif"
'-- Check for audio file types
elseif FileExtension = "ram" then
FileIcon = "icon_real.gif"
elseif FileExtension = "mp3" then
FileIcon = "icon_mp3.gif"
'-- Otherwise
else
FileIcon = "icon_file.gif"
end if
getFileIcon = FileIcon
end function
'---------------------------------------------------
' Generate write dropdown function
'---------------------------------------------------
function writeDropDown(tableName, idName, nameName, condition, selectedID, namePadLoops)
ddSQL = "SELECT " & idName & " AS itemID, " & nameName & " AS itemName FROM " & tableName & " " & condition & " ORDER BY " & nameName
Set ddRS = LoadRSFromDB(ddSQL)
if not ddRS.eof then
Do While not ddRS.EOF
response.write("" & VbCrLf)
ddRS.movenext
loop
end if
set ddRS = nothing
end function
function getFileFolderID(page_id)
dim tempID
tempID = 8
select case page_id
case 27
tempID = pressReleasesParentID
case 31
tempID = ambMagParentID
case 32
tempID = annualReviewsParentID
case 57
tempID = publicationsParentID
end select
getFileFolderID = tempID
end function
%>