<%option explicit%> <%response.buffer=true%> <%ShopOpenDatabase dbc%> <% '********************************************************************************* ' 7.00 ' 1 Dec 2009 ' Search Page '********************************************************************************* InitializeSystem dim howManyItems, chosencategory, lowprice, highprice dim mysearchfields dim allwordsString, exactString, atleastString, withoutString dim fieldCount, delimiter dim allwordsCount, atleastCount, withoutCount dim allwordsWords(10), atleastWords(10), withoutWords(10) dim strSearchFields dim cprice '700 - Paging Navigation dim qpage qpage = CleanChars(Request.Querystring("page")) if qpage = "" then qpage = 1 dim Saction SetSess "CurrentURL", "shopsearch.asp" '6.50 - precautionary security fix Saction = CleanChars(Request.Querystring("Search")) SError = CleanChars(Request("msg")) if Saction = "" then '800 - 2015.08.17 - Better handling on the site title '2019.04.29 - Enhancement: To include options to generate meta title to the site dim temp_meta_site_title temp_meta_site_title = GetLang("langcommonsearch") include_xtitle_process temp_meta_site_title SetSess "Dynamictitle", temp_meta_site_title ShopPageHeader '6.09 - added breadcrumb / VP-ASP 6.50 - added config option to turn breadcrumb on/off if GetConfig("xbreadcrumbs") = "Yes" then htmlwrite "

" & GetLang("langcommonhome") & " " & SubCatSeparator & " " & GetLang("langcommonsearch") & "

" end if showAdvancedSearch ShopPageTrailer else SearchGetFormData SearchGenerateSQLv2 dbc DOSearchCapture '700 - Paging Navigation '700 - 2010.09.01 - Bug Fix: Advanced Searching is not working with Search Fields '800 - Enhanced SEO dim searchredirecturl searchredirecturl = "shopdisplayproducts.asp?Search="& Saction &"&sppp=" & howManyItems & "&page="& qpage &"&Keyword="& allwordsString &"&category=" & chosencategory & "&highprice=" & highprice & "&lowprice=" & lowprice & "&allwords=" & allwordsString & "&exact=" & exactString & "&atleast=" & atleastString & "&without=" & withoutString & "&cprice=" & cprice & "&searchfields="& strSearchFields &"" DoSEOSearchString searchredirecturl, Saction, howManyItems, qpage, allwordsString, chosencategory, highprice, lowprice, allwordsString, exactString, atleastString, withoutString, cprice, strSearchFields ResponseRedirect searchredirecturl end if ShopCloseDatabase dbc sub SearchGetFormData() dim tempcount dim i '6.50 - precautionary security fix strSearchFields = CleanChars(Request("searchfields"))' xsearchsortfield = "" xsearchsortupdown = "" XSearchSortField = CleanChars(Request("strsearchsort")) XSearchSortupdown = CleanChars(Request("strsearchsortupdown")) if xsearchsortfield = GetLang("langcommonselect") then xsearchsortfield = "" end if if xsearchsortupdown = GetLang("langcommonselect") then xsearchsortupdown = "ASC" end if if instr(strSearchFields, ";") then strSearchFields = "" if strSearchFields = "" then Fieldcount = 0 else mysearchfields = split(strSearchFields, ",") Fieldcount = ubound(mysearchfields) Fieldcount = Fieldcount + 1 end if '6.50 - precautionary security fix chosencategory = CleanChars(Request("category")) highprice = replace(CleanChars(Request("highprice")), "$", "") lowprice = replace(CleanChars(Request("lowprice")), "$", "") howManyItems = CleanChars(Request("howmanyitems")) cprice = replace(CleanChars(Request("cprice")), "$", "") if chosencategory = "" then chosencategory = "ALL" if howManyItems = "" then howManyItems = GetConfig("xproductsperpage") '6.50 - precautionary security fix allwordsString = CleanChars(Request("allwords")) if allwordsString = "" then allwordsString = CleanChars(Request("Keyword")) end if '6.50 - precautionary security fix exactString = CleanChars(Request("exact")) atleastString = CleanChars(Request("atleast")) withoutString = CleanChars(Request("without")) '800 - 2016.12.27 - Product search: Not able to search with comma exactString = replace(exactString,","," ") atleastString = replace(atleastString,","," ") withoutString = replace(withoutString,","," ") '700 - 2010.08.24 - Bug Fix: XSS issue ' All Words ' if instr(allwordsString, ";") then ' allwordsString = "" ' end if '702 - 2014.11.05 - Bug Fix: Default search keyword trigger infinity search loop if trim(allwordsString) = getlang("LangSearchboxDefault") then allwordsString = "" if allwordsString<>"" then '800 - Search: Better handling on spaces and comma allwordsString = elimiate_double_space(allwordsString) '701 - 2010.10.19 - Should return "No product match" directly if no keyword specified if trim(allwordsString) <> getlang("LangSearchboxDefault") then '6.08 - If there's a comma in the string, use it as the delimiter '800 - Search: Better handling on spaces and comma 'if instr(allwordsstring, ",") > 0 then ' delimiter = "," 'else ' Delimiter = " " 'end if Delimiter = " " ParseRecord allwordsString, allwordswords, allwordscount, delimiter 'CorrectSearchWords allwordswords, allwordscount '701 - 2010.10.19 - Should return "No product match" directly if no keyword specified else allwordscount = 0 end if else allwordscount = 0 end if '700 - 2010.08.24 - Bug Fix: XSS issue ' At least some words ' if instr(atleastString, ";") then ' atleastString = "" ' end if if atleastString<>"" then '800 - Search: Better handling on spaces and comma atleastString = elimiate_double_space(atleastString) Delimiter = " " ParseRecord atleastString, atleastwords, atleastcount, delimiter 'CorrectSearchWords atleastwords, atleastcount else atleastcount = 0 end if '700 - 2010.08.24 - Bug Fix: XSS issue ' Without words ' if instr(withoutString, ";") then ' withoutString = "" ' end if if withoutString<>"" then '800 - Search: Better handling on spaces and comma withoutString = elimiate_double_space(withoutString) Delimiter = " " ParseRecord withoutString, withoutwords, withoutcount, delimiter 'CorrectSearchWords withoutwords, withoutcount else withoutcount = 0 end if '701 - 2010.10.19 - Should return "No product match" directly if no keyword specified '701 - 2011.11.11 - Bug Fix: Exact search is not working '702 - 2013.06.11 - Bug Fix: Advanced search is not working properly for lowprice and highprice if allwordscount = 0 and atleastcount = 0 and withoutcount = 0 and len(exactString) <= 0 and len(highprice) <= 0 and len(lowprice) <= 0 then shoperror getlang("LangProductSearch") end if end sub sub CorrectSearchWords (words, wordcount) dim i for i = 0 to wordcount -1 '6.50.4 Bugs Fix - 08 October 2008 words(i) = replace(words(i), "''", "'") words(i) = replace(words(i), "'", "''") next end sub sub DoSearchCapture if GetConfig("XSearchCapture")<>"Yes" then exit sub '6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if instr(ucase(xdatabasetype), "MYSQL") > 0 then MYSQLDOSearchCapture exit sub end if ' Store search results in seach table dim Subcategories dim servername on error resume next '702 - 2013.12.04 - Bug Fix: Insert wrong value to searchresults.ipaddress '800 - 2017.02.20 - CloudFlare: to include cf real visitor ip servername = get_REMOTE_ADDR_cf '800 - 2017.03.10 - Search: Speed enhancement 'set objRS = Server.createobject ("ADODB.Recordset") 'objrs.open "searchresults", dbc, adopenkeyset, adlockoptimistic, adcmdtable 'objRS.AddNew 'objRS("categories") = chosencategory dim updatesearchstring if allwordsString > "" then updatesearchstring = "ALL: " & allwordsString end if if exactString > "" then if updatesearchstring > "" then updatesearchstring = updatesearchstring & " / " end if updatesearchstring = updatesearchstring & "EXACT: " & exactString end if if atleastString > "" then if updatesearchstring > "" then updatesearchstring = updatesearchstring & " / " end if updatesearchstring = updatesearchstring & "AT LEAST: " & atleastString end if if withoutString > "" then if updatesearchstring > "" then updatesearchstring = updatesearchstring & " / " end if updatesearchstring = updatesearchstring & "WITHOUT: " & withoutString end if '800 - 2017.03.10 - Search: Speed enhancement 'objRS("words") = updatesearchstring 'objRS("lastname") = GetSess("lastname") 'objRS("customerid") = GetSess("customerid") 'objRS("ipaddress") = servername 'objRS("rdate") = date() 'objRS("rtime") = formatdatetime(time(), vbshorttime) 'objRS.Update 'objRS.close dim usql, customerid customerid = GetSess("customerid") if isnull(customerid) then customerid = 0 if len(customerid) = 0 then customerid = 0 usql = "Insert into searchresults (categories,words,lastname,customerid,ipaddress,rdate,rtime) Values ('" & tosql(chosencategory,"Text") & "','" & tosql(updatesearchstring,"Text") & "','" & tosql(GetSess("lastname"),"Text") & "'," & customerid & ",'" & servername & "','" & date() & "','" & formatdatetime(time(), vbshorttime) & "')" dbc.execute(usql) on error goto 0 end sub '800 - Search: Better handling on spaces and comma function elimiate_double_space (strWords) do while instr(strWords," ") > 0 strWords = replace(strWords, " ", " ") loop elimiate_double_space = strWords end function %>