<%
' ----------------------------------------------------------------------------
' Settings (change if necessary)
' ----------------------------------------------------------------------------
' Highlight matched words in results
Highlighting = 1 ' 0 = off, 1 = on
HighlightColor = "#FFFF40" ' Highlight colour
HighlightLimit = 1000 ' Max number of words matched before
' highlighting is disabled
' Set this to your template HTML page
' (for the formatting and location of the search form)
TemplateFilename = "search_template.html"
' The options available in the dropdown menu for number of results
' per page
PerPageOptions = Array(10, 20, 50, 100)
FormFormat = 2 '0 = No search form (note that you must pass parameters to
' the script directly from elsewhere on your website).
'1 = Basic search form
'2 = Advanced search form (with options)
ZoomInfo = 1 '0 = Don't display Zoom info line at bottom of search
'1 = Display Zoom info line at bottom of search
OutputStyle = 1 '0 = Basic Style, Page Title, Score and URL
'1 = Descriptive Stlye, Match number, Page Title,
' Page description, Score and URL
Logging = 0 '0 = No logging of words that a user enter.
'1 = Words are logged to a file for later analysis. (See
' documentation for file permission issues)
LogFileName = ".\logs\searchwords.log" 'Path and File name of search word log file
MaxKeyWordLineLen = 2000 'Maximum line length of a single line in the KeyWords file.
'Increase, if required, so that
'MaxKeyWordLineLen >= Number of web pages in site * 6
WordSplit = 1 '0 = Only split input search phrase into words when a
' Space character is found
'1 = Split input search phrase at Space ' ',
' UnderScore '_' , Dash '-' and Plus '+' characters
Timing = 0 '0 = don't display timing results of search
'1 = display timing results
SearchAsSubstring = 1 ' 0 = do not force substring search, word must match entirely
' 1 = force substring search for all searchwords
ToLowerSearchWords = 1 ' 0 = Do not change search words to lowercase (for non-alphabetic languages)
' 1 = Change search words to lowercase (for alphanumeric languages)
' ----------------------------------------------------------------------------
' Parameter initilisation
' ----------------------------------------------------------------------------
' we use the method=GET and 'query' parameter now (for sub-result pages etc)
if Request.QueryString("zoom_query").Count <> 0 then
query = Request.QueryString("zoom_query")
end if
' number of results per page, defaults to 10 if not specified
if Request.QueryString("zoom_per_page").Count <> 0 then
per_page = Request.QueryString("zoom_per_page")
else
per_page = 10
end if
' current result page number, defaults to the first page if not specified
if Request.QueryString("zoom_page").Count <> 0 then
page = Request.QueryString("zoom_page")
else
page = 1
end if
' AND operator.
' 1 if we are searching for ALL terms
' 0 if we are searching for ANY terms (default)
if Request.QueryString("zoom_and").Count <> 0 then
andq = Request.QueryString("zoom_and")
else
andq = 0
end if
' categories
if Request.QueryString("zoom_cat").Count <> 0 then
cat = CInt(Request.QueryString("zoom_cat"))
else
cat = -1
end if
selfURL = Request.ServerVariables("URL")
if (Highlighting = 1) then
dim matchwords()
matchwords_num = 0
ReDim matchwords(0) ' ensures that it is an array for LBound to work
end if
Sub PrintEndOfTemplate
'Let others know about Zoom.
if (ZoomInfo = 1) then
Response.Write("Busqueda indexada sobre www.concereal.com
") & VbCrlf
end if
if (UBound(Template) > 0) then
'If rest of template exists
Response.Write(Template(1)) & VbCrLf
end if
End Sub
' Translate a wildcard pattern to a regexp pattern
' Supports '*' and '?' only at the moment.
Function pattern2regexp(pattern)
' ASP/VBScript's RegExp has some 7-bit ASCII char issues
' and treats accented characters as an end of word for boundaries ("\b")
' So we use ^ and $ instead, since we're matching single words anyway
if (SearchAsSubstring = 0) then
pattern2regexp = "^"
end if
pattern = Replace(pattern, ".", "\.")
pattern = Replace(pattern, "*", ".*")
pattern = Replace(pattern, "?", ".")
pattern2regexp = pattern2regexp & pattern
if (SearchAsSubstring = 0) then
pattern2regexp = pattern2regexp + "$"
end if
End Function
'Returns true if a value is found within the array
Function IsInArray(strValue, arrayName)
Dim iLoop, bolFound
IsInArray = False
if (IsArray(arrayName) = False) then
Exit Function
End if
For iLoop = LBound(arrayName) to UBound(arrayName)
if (CStr(arrayName(iLoop)) = CStr(strvalue)) then
IsInArray = True
Exit Function
end if
Next
End Function
Function PrintHighlightDescription(line)
For i = 0 to UBound(matchwords)
'replace with marker text, '[;:]' and '[:;]'
regExp.Pattern = "\b(" & matchwords(i) & ")\b"
line = regExp.Replace(line, "[;:]$1[:;]")
Next
line = replace(line, "[;:]", "")
line = replace(line, "[:;]", "")
Response.Write(line)
End Function
Function SplitMulti(string, delimiters)
For i = 1 to UBound(delimiters)
string = Replace(string, delimiters(i), delimiters(0))
Next
string = Trim(string) 'for replaced quotes
SplitMulti = Split(string, delimiters(0))
End Function
Sub ShellSort(array)
last = UBound(array, 2)
first = LBound(array, 2)
num = last - first + 1
' find the best value for distance
do
distance = distance * 3 + 1
loop until (distance > num)
do
distance = distance \ 3
for index = (distance + first) to last
value = array(1, index)
value0 = array(0, index)
value2 = array(2, index)
index2 = index
do while (index2 - distance => first)
'do while (array(1, index2 - distance) < value)
if (array(2, index2 - distance) > value2) then
exit do
end if
if (array(2, index2 - distance) = value2) then
if (array(1, index2 - distance) >= value) then
exit do
end if
end if
array(0, index2) = array(0, index2 - distance)
array(1, index2) = array(1, index2 - distance)
array(2, index2) = array(2, index2 - distance)
index2 = index2 - distance
'if index2 - distance < first then
' exit do
'end if
loop
array(1, index2) = value
array(0, index2) = value0
array(2, index2) = value2
next
loop until distance = 1
End Sub
' ----------------------------------------------------------------------------
' Main starts here
' ----------------------------------------------------------------------------
' For timing of the search
if (Timing = 1) then
Dim StartTime, ElapsedTime
StartTime = Timer
end if
'Open and print start of result page template
set fso = CreateObject("Scripting.FileSystemObject")
set template = fso.OpenTextFile(Server.MapPath(TemplateFilename), 1)
' find the "" string in the template html file
dim line, templateFile
do while template.AtEndOfStream <> True
line = template.ReadLine & VbCrLf
templateFile = templateFile & line
loop
Template = split(templateFile, "")
Response.Write(Template(0)) & VbCrLf
'' Check for category files
UseCats = False
if (fso.FileExists(Server.MapPath("zoom_cats.dat")) = True) AND (fso.FileExists(Server.MapPath("zoom_catpages.dat")) = True) then
UseCats = True
' Loads the entire categories page into an array
set catnames_file = fso.OpenTextFile(Server.MapPath("zoom_cats.dat"), 1)
catnames = split(catnames_file.ReadAll, chr(13) & chr(10))
set catpages_file = fso.OpenTextFile(Server.MapPath("zoom_catpages.dat"), 1)
catpages = split(catpages_file.ReadAll, chr(13) & chr(10))
end if
' Load the entire pages file into an array, all URL's on the site
set pages_file = fso.OpenTextFile(Server.MapPath("zoom_pages.dat"), 1)
urls = split(pages_file.ReadAll, chr(13) & chr(10))
' Replace the key text with the following
if (FormFormat > 0) then
' Insert the form
Response.Write("") & VbCrlf
end if
' Give up early if no search words provided
if Len(query) = 0 then
'Response.Write("No search query entered.
")
'stop here, but finish off the html
call PrintEndOfTemplate
Response.End
end if
'Split search phrase into words
query = Trim(query) 'for wildcards
if WordSplit = 1 then
SearchWords = SplitMulti(query, Array(" ", "_", "[", "]", "+", """", "'"))
else
SearchWords = Split(query)
end if
' Load the entire pages file into an array, all URL's on the site
set pages_file = fso.OpenTextFile(Server.MapPath("zoom_pages.dat"), 1)
urls = split(pages_file.ReadAll, chr(13) & chr(10))
pages_file.Close
' Load the entire page titles file into an array
set titles_file = fso.OpenTextFile(Server.MapPath("zoom_titles.dat"), 1)
titles = split(titles_file.ReadAll, chr(13) & chr(10))
titles_file.Close
if OutputStyle = 1 then
set desc_file = fso.OpenTextFile(Server.MapPath("zoom_descriptions.dat"), 1, False)
descriptions = split(desc_file.ReadAll, chr(13) & chr(10))
desc_file.Close
end if
'Print heading
Response.Write("Resultados de la consulta para: """ & query & """")
if (UseCats = True) then
if (cat = -1) then
Response.Write(" en todas las categorías")
else
Response.Write(" en la categoría """ & catnames(cat) & """")
end if
end if
Response.Write("
") & VbCrlf
'Open keywords file
set fpkeywords = fso.OpenTextFile(Server.MapPath("zoom_keywords.dat"), 1, False)
'Open keywords_idx file
if (fso.FileExists(Server.MapPath("zoom_keywords_idx.dat")) = False) then
Response.Write("Error: Can not find ""zoom_keywords_idx.dat"".
This file is now required for the new Zoom ASP script as it can improve search ")
Response.Write("performances significantly. Please re-index your site with the latest version of Zoom Indexer and upload the zoom_keywords_idx.dat file in addition to the other index files.")
Response.End
end if
set keywordsidx_file = fso.OpenTextFile(Server.MapPath("zoom_keywords_idx.dat"), 1)
keywordsidx = split(keywordsidx_file.ReadAll, chr(13) & chr(10))
keywordsidx_count = UBound(keywordsidx)
keywordsidx_file.Close
'Loop through all search words
numwords = UBound(SearchWords)+1
outputline = 0
'default to use wildcards
UseWildCards = 1
'Initialise regular expression object
set regExp = New RegExp
if (ToLowerSearchWords = 0) then
regExp.IgnoreCase = False
else
regExp.IgnoreCase = True
end if
regExp.Global = True
pagesCount = UBound(urls)
Dim res_table()
Redim preserve res_table(1, pagesCount)
matches = 0
relative_pos = 0
current_pos = 0
for sw = 0 to numwords-1
' check whether there are any wildcards used
if (InStr(SearchWords(sw), "*") = False AND InStr(SearchWords(sw), "?") = False) then
UseWildCards = 0
else
' new keyword pattern to match for
regExp.Pattern = pattern2regexp(SearchWords(sw))
UseWildCards = 1
end if
'Read in a line at a time from the keywords file
for i = 0 to keywordsidx_count-1
idxline = Split(keywordsidx(i), ",")
if (UseWildCards = 0) then
if (SearchAsSubstring = 0) then
if (ToLowerSearchWords = 0) then
bMatched = SearchWords(sw) = idxline(0)
else
bMatched = Lcase(SearchWords(sw)) = idxline(0)
end if
else
if (ToLowerSearchWords = 0) then
bMatched = InStr(idxline(0), SearchWords(sw))
else
bMatched = InStr(idxline(0), Lcase(SearchWords(sw)))
end if
end if
else
bMatched = regExp.Test(idxline(0))
end if
if (bMatched) then
fpkeywords.Skip(idxline(1))
if (fpkeywords.AtEndOfStream = True) then
exit for
end if
line = fpkeywords.ReadLine
data = Split(line, ",")
'Keyword found, so include it in the output list
if (Highlighting = 1) then
' Add to matched words list
if (IsInArray(data(0), matchwords) = False) then
Redim preserve matchwords(matchwords_num)
matchwords(matchwords_num) = data(0)
matchwords_num = matchwords_num + 1
if (matchwords_num >= HighlightLimit) then
Highlighting = 0
Response.Write("Too many words to highlight. Highlighting disabled.
")
end if
end if
end if
num = UBound(data)
for kw = 1 to num Step 2
'Check if page is already in output list
pageexists = 0
ipage = data(kw)
if (Int(res_table(0, ipage)) = 0) then
matches = matches + 1
res_table(0, ipage) = Int(res_table(0, ipage)) + Int(data(kw+1))
else
if (Int(res_table(0, ipage)) > 10000) then
' take it easy if its too big (to prevent huge scores)
res_table(0, ipage) = Int(res_table(0, ipage)) + 1
else
res_table(0, ipage) = Int(res_table(0, ipage)) + Int(data(kw+1))
res_table(0, ipage) = Int(res_table(0, ipage)) * 2
end if
end if
res_table(1, ipage) = Int(res_table(1, ipage)) + 1
next
if (UseWildCards = 0) then
exit for
else
' need to reset the fpkeywords file in order to skip properly for wildcards
fpkeywords.Close
set fpkeywords = fso.OpenTextFile(Server.MapPath("zoom_keywords.dat"), 1, False)
end if
end if
next
if (sw <> numwords-1) then
'Return to start of file - apparently only way to do this in ASP
'is close and re-open (according to msdn technet)
fpkeywords.Close
set fpkeywords = fso.OpenTextFile(Server.MapPath("zoom_keywords.dat"), 1, False)
end if
next
'Close the keywords file that was being used
fpkeywords.Close
oline = 0
fullmatches = 0
ResFiltered = False
dim output()
for i = 0 to pagesCount Step 1
IsFiltered = False
if (Int(res_table(0, i)) > 0) then
if (UseCats = True AND cat <> -1) then
if (CInt(catpages(i)) <> cat) then
IsFiltered = True
end if
end if
if (IsFiltered = False) then
if (Int(res_table(1, i)) >= numwords) then
fullmatches = fullmatches + 1
elseif (andq = 1) then
' AND search, filter out non-matching results
IsFiltered = True
end if
end if
if (IsFiltered = False) then
' copy if not filtered out
redim preserve output(2, oline)
output(0, oline) = i
output(1, oline) = res_table(0, i)
output(2, oline) = res_table(1, i)
oline = oline + 1
else
ResFiltered = True
end if
end if
Next
If (ResFiltered = True) then
matches = oline
End if
' Sort the results
if (matches > 1) then
lobound = LBound(output, 2)
hibound = UBound(output, 2)
call ShellSort(output)
end if
'Display search results
Response.Write("")
if matches = 1 Then
Response.Write("1 resultado encontrado.")
elseif matches = 0 Then
Response.Write("No se han encontrado resultados.")
elseif numwords > 1 AND andq = 0 then
SomeTermMatches = matches - fullmatches
Response.Write("" & fullmatches & " resultados encontrados conteniendo todos los términos. ")
if (SomeTermMatches > 0) then
Response.Write(SomeTermMatches & " resultados encontrados conteniendo algunos de los términos.")
end if
Response.Write("")
elseif numwords > 1 AND andq = 1 then
Response.Write("" & fullmatches & " resultados encontrados conteniendo todos los términos.")
else
Response.Write("" & matches & " resultados encontrados.")
end if
Response.Write("
") & VbCrlf
'Number of pages of results
' Amazingly, there is no Ceiling function in VB prior to .NET
' Also note the way CInt rounds to nearest _whole_ number (0.5 -> 0, 1.5 -> 2)
' Hence this workaround
if (matches MOD per_page = 0) then
'whole number
num_pages = CInt(matches / per_page)
else
'unwholey number
num_pages = CInt((matches / per_page) + 0.5)
end if
if (num_pages > 1) then
Response.Write("
" & num_pages & " pages of results.
") & VbCrlf
end if
' Determine current line of result from the $output array
if (page = 1) then
arrayline = 0
else
arrayline = (page - 1) * per_page
end if
' The last result to show on this page
result_limit = arrayline + per_page
' Display the results
do while (arrayline < matches AND arrayline < result_limit)
ipage = output(0, arrayline)
score = output(1, arrayline)
if (OutputStyle = 0) then
'Basic style
Response.Write("" & "Page: " & titles(ipage) & "
") & VbCrlf
Response.Write("Score: " & score & " URL:" & urls(ipage) & "
") & VbCrlf
else
'Descriptive style
Response.Write("" & (arrayline+1) & ". " & titles(ipage) & "") & VbCrlf
if (UseCats = True) then
catindex = catpages(ipage)
Response.Write(" [" & catnames(catindex) & "]")
end if
Response.Write("
") & VbCrlf
if (Highlighting = 1) then
PrintHighlightDescription(descriptions(ipage))
else
Response.Write(descriptions(ipage))
end if
Response.Write("...
") & VbCrlf
Response.Write("Terms matched: " & output(2, arrayline) & " Score: " & score & " URL: " & urls(ipage) & "
") & VbCrlf
end if
arrayline = arrayline + 1
loop
'Show links to other result pages
if (num_pages > 1) then
' 10 results to the left of the current page
start_range = page - 10
if (start_range < 1) then
start_range = 1
end if
' 10 to the right
end_range = page + 10
if (end_range > num_pages) then
end_range = num_pages
end if
Response.Write("Result Pages: ")
if (page > 1) then
Response.Write("<< Previous ")
end if
'for i = 1 to num_pages
for i = start_range to end_range
if (CInt(i) = CInt(page)) then
Response.Write(page & " ")
else
Response.Write("" & i & " ")
end if
next
if (cInt(page) <> cInt(num_pages)) then
Response.Write("Next >> ")
end if
end if
' Time the searching
if (Timing = 1) then
ElapsedTime = Timer - StartTime
Response.Write("
Search took " & ElapsedTime & " seconds")
end if
'Print out the end of the template
call PrintEndOfTemplate
'Log the search words, if required
if (Logging = 1) then
LogString = FormatDateTime(Now) & ", " & Request.ServerVariables("REMOTE_ADDR") & ", """ & query & """, Matches = " & matches
set logfile = fso.OpenTextFile(Server.MapPath(LogFileName), 8, true, 0)
logfile.WriteLine(LogString)
logfile.Close
end if
%>