<% ' ------------------------------------------------------------------- ' File: SSECommon.asp ' ' Copyright (c) 2003 DPA Software. All rights reserved. ' ------------------------------------------------------------------- ' ------------------------------------------------------------------- ' Constants / Globals ' ------------------------------------------------------------------- nl = Chr(13) & Chr(10) ' cr lf lf = Chr(10) 'lf cr = Chr(13) 'cr sp = Chr(32) 'space qt = Chr(34) 'quote ns = Chr(35) 'number sign ap = Chr(39) 'apostrophe cm = Chr(44) 'comma tb = Chr(09) 'tab vt = Chr(11) 'vertical tab ff = Chr(12) 'form feed ' ------------------------------------------------------------------- ' RemoveSharedBorders ' ' Removes FP Shared Borders from text using tags ' Warning: will unbalance table tags ' ------------------------------------------------------------------- Function RemoveSharedBorders ( byval strText ) 'first read the shared border meta tag loc = InStr(strText, "") RemoveSharedBorders = MyArray(segment) End Function ' ------------------------------------------------------------------- ' RemoveCode ' ' Removes specifed script tag from the text ' ------------------------------------------------------------------- Function RemoveCode ( byval strText, byval sStart, byval sEnd ) sText = strText do while 1 s = InStr ( 1, sText, sStart, 1 ) if s = 0 then exit do e = InStr ( s+1, sText, sEnd, 1 ) if e = 0 then sText = left ( sText, s-1 ) exit do else sText = left ( sText, s-1 ) & Mid ( sText, e+len(sEnd) ) end if loop RemoveCode = sText end function ' ------------------------------------------------------------------- ' RemoveHTML ' ' Removes HTML tags and illegal chars from text ' ------------------------------------------------------------------- Function RemoveHTML ( byval strText, byval ext ) Dim RegEx strText = Replace(strText, "
", sp) strText = Replace(strText, nl, sp) select case lcase(ext) case "asp", "aspx", "jsp" strText = RemoveCode ( strText, "<" & "%", "%" & ">" ) case "php", "php3" strText = RemoveCode ( strText, "" ) end select strText = RemoveCode ( strText, "" ) Set RegEx = New RegExp RegEx.Global = True RegEx.Pattern = "<[^>]*>" strText = RegEx.Replace(strText, " ") RegEx.Pattern = " " strText = RegEx.Replace(strText, " ") RegEx.Pattern = """ strText = RegEx.Replace(strText, """") RegEx.Pattern = ">" strText = RegEx.Replace(strText, ">") RegEx.Pattern = "<" strText = RegEx.Replace(strText, "<") RegEx.Pattern = "[ \r\n\t\v][ \r\n\t\v]*" strText = RegEx.Replace(strText, " ") Set RegEx = Nothing RemoveHTML = strText End Function ' ------------------------------------------------------------------- ' CountOccurrences ' ' Counts the CountOccurrences ' ------------------------------------------------------------------- Function CountOccurrences ( byval strText, byval strMatch, nFirstOccurrence ) count = 0 loc = InStr(1, strText, strMatch, 1) nFirstOccurrence = loc msize = Len(strMatch) n = loc + msize Do While loc <> 0 loc = InStr(n, strText, strMatch, 1) n = loc + msize count = count + 1 Loop CountOccurrences = count End Function ' ------------------------------------------------------------------- ' SearchPage ' ' searches page for query ' returns a relevance value for the page. 0 means no match ' ------------------------------------------------------------------- Function SearchPage ( byval strPageText, byval pageurl, byval pagetitle, byval keywords, byval arrQuery, sSummary ) dim i, totrelv, relv, lastopr, dummy, count, kwmatch, titlematch totrelv = 0 relv = 0 lastopr = 0 titlematch = "" kwmatch = "" for i = lbound(arrQuery,1) to ubound(arrQuery,1) ' calculate relevance of current word relv = ( 10 * CountOccurrences(strPageText,arrQuery(i,0),arrQuery(i,2)) ) count = CountOccurrences ( pagetitle, arrQuery(i,0), dummy ) if count > 0 then titlematch = 1 relv = relv + ( 100 * count ) end if count = CountOccurrences ( keywords, arrQuery(i,0), dummy ) if count > 0 then if len(kwmatch) > 0 then kwmatch = kwmatch & ", " kwmatch = kwmatch & arrQuery(i,0) relv = relv + ( 50 * count ) end if ' if current relevance is 0 and last opr was 'and', this page does not match the criteria if relv = 0 and lastopr = 1 then totrelv = 0 exit for end if ' calculate total relevance totrelv = totrelv + relv ' if total relevance is 0 and current opr is 'and', this page does not match the criteria if totrelv = 0 and arrQuery(i,1) = 1 then exit for ' if current opr is 0, we have processed the last word, break out of the loop if arrQuery(i,1) = 0 then exit for ' save current opr for later use lastopr = arrQuery(i,1) next if totrelv > 0 then matchlocation = 0 for i = lbound(arrQuery,1) to ubound(arrQuery,1) matchlocation = arrQuery(i,2) if matchlocation <> 0 then exit for next if matchlocation > 0 then 'get the preview out of the page If matchlocation < 51 Then summary = Mid(strPageText,1,200) Else summary = Mid(strPageText,matchlocation-50,200) End If 'hightlight query word (CASE PROBLEM) for i = lbound(arrQuery,1) to ubound(arrQuery,1) highlight = "" & UCase(arrQuery(i,0)) & "" summary = Replace(summary, arrQuery(i,0), highlight, 1, -1, 1) if arrQuery(i,1) = 0 then exit for next summary = "... " & summary & " ..." else summary = "" if len(titlematch) > 0 then summary = "Title match: " & pagetitle if len(summary) > 0 then summary = summary & "
" if len(kwmatch) > 0 then summary = summary & "Keyword match: " & kwmatch end if 'format the output string if len(pagetitle) = 0 then pagetitle = pageurl htmlsummary = " "" then htmlsummary = htmlsummary & " target='" & sTarget & "'" htmlsummary = htmlsummary & ">" & pagetitle & ": relevance: (%R)%
" htmlsummary = htmlsummary & summary sSummary = htmlsummary & "
" & pageurl & "

" end if SearchPage = totrelv End Function ' ------------------------------------------------------------------- ' GetRelevance ' ' Gets the occurrence count from the page search string ' in the form: occurrences|HTML display string ' ------------------------------------------------------------------- Function GetRelevance ( byval matchstring ) GetRelevance = 0 loc = InStr(matchstring, "|") If loc <> 0 Then t = Left(matchstring, loc-1) If IsNumeric(t) Then GetRelevance = CInt(t) End If End If End Function ' ------------------------------------------------------------------- ' SortMatchesArray ' ' sort the Matches array in ascending order ' ------------------------------------------------------------------- Sub SortMatchesArray ( byval sSortBy, byval count, queryMatches() ) dim bSwap, i, j, k, temp for i = 0 to count-2 for j = (i+1) to count-1 bSwap = False select case sSortBy case "relv_desc" if CInt(queryMatches(i,0)) < CInt(queryMatches(j,0)) Then bSwap = true case "title" if StrComp(queryMatches(i,1),queryMatches(j,1),1) > 0 Then bSwap = true end select if bSwap then for k = lbound(queryMatches,2) to ubound(queryMatches,2) temp = queryMatches(i,k) queryMatches(i,k) = queryMatches(j,k) queryMatches(j,k) = temp next end if next next End Sub ' ------------------------------------------------------------------- ' IsValidWord ' ' check if the word is one of the common words ' ------------------------------------------------------------------- function IsValidWord ( byval sWord ) dim i ' array of words to be excluded from the search arrExclude = Array ("", "a", "also", "am", "an", "be", "for", "had", "has", "have", "is", "not", "that", "the", "this", "to", "was", "were") IsValidWord = ( InStr ( 1, ("|" & Join(arrExclude,"|") & "|"), ("|" & lcase(sWord) & "|") ) = 0 ) end function ' ------------------------------------------------------------------- ' ProcessQueryString ' ' break query string into words and the joining criteria ( and/or ) ' ------------------------------------------------------------------- function ProcessQueryString ( byval sQuery, arrQuery ) Dim arrSplit, i, j, nOpr nOpr = 1 j = 0 arrSplit = Split(LCase(sQuery), " ") ReDim arrQuery(UBound(arrSplit) - LBound(arrSplit) + 1, 2) For i = LBound(arrSplit) To UBound(arrSplit) arrSplit(i) = Trim(arrSplit(i)) If arrSplit(i) = "and" Then nOpr = 1 ElseIf arrSplit(i) = "or" Then nOpr = 2 Else If IsValidWord(arrSplit(i)) Then arrQuery(j, 0) = arrSplit(i) arrQuery(j, 1) = 0 If j > 0 Then arrQuery(j - 1, 1) = nOpr j = j + 1 End If nOpr = 1 End If Next ProcessQueryString = j end function ' ------------------------------------------------------------------- ' GetTitle ' ' Get the title from the given HTML ' ------------------------------------------------------------------- function GetTitle ( byval sPageHTML ) dim i1, i2, c GetTitle = "" ' look for the title tag i1 = InStr ( 1, sPageHTML, " ">" then exit function i1 = InStr ( i1, sPageHTML, ">", 1 ) if i1 = 0 then exit function ' get the text after the title tag sPageHTML = Mid ( sPageHTML, i1+1 ) ' look for the /title tag i1 = InStr ( 1, sPageHTML, " ">" then exit function if InStr(i1,sPageHTML,">",1) = 0 then exit function GetTitle = Left ( sPageHTML, i1-1 ) end function ' ------------------------------------------------------------------- ' GetKeywords ' ' Get the Keywords meta tag contents from the given HTML ' ------------------------------------------------------------------- function GetKeywords ( byval sPageHTML ) dim sLookFor, index, index2 GetKeywords = "" sLookFor = " 0 ) end function ' ------------------------------------------------------------------- ' AdjustRelevance ' ' Adjust relevance value for search results ' ------------------------------------------------------------------- function AdjustRelevance ( byval nCount, queryMatches ) dim i, hr ', temp hr = 0 for i = 0 to nCount-1 if ( queryMatches(i,0) > hr ) then hr = queryMatches(i,0) next hr = hr * 1.25 for i = 0 to nCount-1 'temp = queryMatches(i,0) queryMatches(i,0) = cInt(( queryMatches(i,0) * 100 ) / hr) 'queryMatches(i,2) = Replace ( queryMatches(i,2), "(%R)", (temp & " -> " & CStr(queryMatches(i,0))) ) queryMatches(i,2) = Replace ( queryMatches(i,2), "(%R)", CStr(queryMatches(i,0)) ) next end function ' ------------------------------------------------------------------- ' GenerateSearchResults ' ' search the pages in the selected area and generate search results ' ------------------------------------------------------------------- function GenerateSearchResults ( byval query ) dim arrQuery(), i, sSummary, relv Session("queryMatches") = empty Session("matchindex") = 0 query = Trim(query) If query <> "" Then if QueryType = "bool" then i = ProcessQueryString ( query, arrQuery ) else redim arrQuery(1,2) arrQuery(0,0) = query arrQuery(0,1) = 0 i = 1 end if if i > 0 then 'determine the search area file filename = AreaFile If filename = "" Then filename = "default.inc" 'get the urls to search, needs error handling set filesys = server.createobject("scripting.FileSystemObject") urls = filesys.openTextfile(web_sse & filename).readall urlsArray = Split(urls, nl) 'create array for page data Dim queryMatches() Redim queryMatches(Ubound(urlsArray), 3) 'read in the files and strip the shared borders and HTML tags 'search the page for the query string and build queryMatches array matchindex = 0 For i = 0 To Ubound(urlsArray) if urlsArray(i) <> "" Then urldetail = Split(urlsArray(i), "|") if filesys.FileExists(web_root_disk & urldetail(0)) then ext = "" index = InStrRev ( urldetail(0), ".", -1, 1 ) if index > 0 then ext = Mid ( urldetail(0), index+1 ) text = filesys.openTextfile(web_root_disk & urldetail(0)).readall title = Trim(GetTitle(text)) keywords = GetKeywords ( text ) pagestring = RemoveHTML ( RemoveSharedBorders(text), ext ) relv = SearchPage ( pagestring, urldetail(0), title, keywords, arrQuery, sSummary ) If relv > 0 Then queryMatches(matchindex, 0) = relv if len(title) > 0 then queryMatches(matchindex, 1) = title else queryMatches(matchindex, 1) = urldetail(0) end if queryMatches(matchindex, 2) = sSummary matchindex = matchindex + 1 End If End if End If Next ' adjust relevance value to % AdjustRelevance matchindex, queryMatches 'sort matches array SortMatchesArray SortOrder, matchindex, queryMatches 'then page the results to the screen. Session("queryMatches") = queryMatches Session("matchindex") = matchindex set filesys = nothing end if end if end function ' ------------------------------------------------------------------- ' ShowSearchResults ' ' show the search results based on page index and no. of items per page ' ------------------------------------------------------------------- function ShowSearchResults ( byval PageItems, byval PageIndex, byval bQuery ) dim queryMatches, matchindex, nPages If IsEmpty(Session("queryMatches")) Then if bQuery then response.write ("No search string specified or contains common words which are ignored.") else response.write ("Type in a search string") end if Else queryMatches = Session("queryMatches") matchindex = Session("matchindex") If matchindex = 0 Then response.write ("No Matches Found") Else If matchindex > 1 Then q = "s" if PageItems = 0 then PageItems = matchindex nPages = 0 nPages = matchindex \ PageItems if matchindex mod PageItems then nPages = nPages + 1 nStart = ( PageIndex - 1 ) * PageItems nEnd = PageIndex * PageItems if nEnd >= matchindex then nEnd = matchindex response.write ( "

" ) response.write ("Found " & matchindex & " Page" & q & " matching the search criteria") response.write ( "	" ) if nPages > 1 then if PageIndex > 1 then response.write ( "Previous " ) else response.write ( "Previous " ) end if response.write ( "" ) for i = 1 to nPages if i = PageIndex then s = "selected" else s = "" end if response.write ( " " & i ) next response.write ( "" ) if PageIndex < nPages then response.write ( " Next" ) else response.write ( " Next" ) end if end if response.write ( "
" ) For i = nStart To nEnd-1 Response.Write(queryMatches(i,2)) Next response.write ( "

" ) End If End If end function %>