<%@ LANGUAGE="VBSCRIPT" %> <% PageStrings = "18, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 68, 69, 70, 71, 121, 164, 222, 301, 821, 822, 823, 824, 825, 1078, 1086, 1450, 1617, 1618, 1619, 1620, 1621, 1623, 1672, 1709, 1724, 1767, 1768, 1786, 1788, 1882, 1907, 1908, 1909, 1910, 1911, 1930" blnDateStrings = true %> <% '=============================================== ' CactuShop ASP Shopping Cart ' 1999-2007 Cactusoft International FZ-LLC ' www.cactusoft.com '=============================================== ' All rights reserved. ' Use of this code is covered by the terms and ' conditions in the license agreement. No ' unauthorized duplication or distribution is ' permitted. Cactusoft's copyright notices must ' remain in the ASP sections of the code. '=============================================== '************************************************************************** 'CACTUSHOP v6 CONFIG FILE - READ THIS FIRST! ' This defines a few configuration settings. You need to set up the following ' ' 1 - Set license number ' 2 - Database Connection ' ' The following can also be set here if required. ' ' 1 - Set your own developer license code ' 2 - Set an IP lock for the backend ' 3 - Enable execution statistics (for non-live only!) ' 4 - Set your encryption key (if using CactuShop Encrypted Mail) ' 5 - A table prefix if you're running multiple stores on one database ' ' All other settings can be done through the backend. '************************************************************************** 'Leave these! session.LCID = 1033 'local identifier - CactuShop is designed to run on US defaults, leave this setting intact numScriptExecutionStartTime = Timer 'Starts the script execution timer '----------------------------------------------- 'CACTUSHOP LICENSE NUMBER 'The license number given to you when you 'received your copy of CactuShop must be entered 'below, within the double quotes: 'CONST LICENSENUMBER = "XXXXXXXX-P0000-001" CONST LICENSENUMBER = "AXISSTUD-2807-01" 'This is a license requirement - to run 'CactuShop without the valid license number, or 'to run more than one copy of CactuShop with the 'same license number is a copyright violation 'and a breach of the software license. '----------------------------------------------- '----------------------------------------------- 'DATABASE CONNECTION SETTINGS 'Uncomment (remove the ' at the start of the 'line) the database type you are using, and 'comment up the other two. 'Depending on which database you are using, 'uncomment the connection string and enter in 'the connection details. See the Quick Setup 'Guide and the manual for more information '----------------------------------------------- 'Database type - access, sql or mysql 'CONST strDatabaseType = "mysql" 'CONST strDatabaseType = "mssql" CONST strDatabaseType = "access" ' ----------------------- MySQL ODBC Connection String ------------------------- 'CONST strDataSourceName = "DRIVER={MySQL ODBC 3.51 Driver};SERVER=yourserver;DATABASE=cactushop6;USER=username;PASSWORD=password;OPTION=3;" 'CONST strDataSourceName = "DRIVER={MySQL};SERVER=yourserver;DATABASE=cactushop6;USER=username;PASSWORD=password;OPTION=3;" ' ----------------------- MS SQLServer Connection String ----------------------- ' (for connecting on port 1433 - the standard port for SQL Server) 'CONST strDataSourceName="Provider=sqloledb;Data Source=yourserver,1433;Network Library=DBMSSOCN;Initial Catalog=cactushop6;User ID=username;Password=password;" 'CONST strDataSourceName="Provider=sqloledb;Data Source=yourserver,1433;Network Library=DBMSSOCN;Initial Catalog=cactushop6;Trusted_Connection=yes;" '------------------------MS SQLServer 2005 Connection String-------------------- 'CONST strDataSourceName="Provider=SQLNCLI;Server=yourserver;Database=cactushop6;UID=username;PWD=@password;" ' ----------------------- MSDE Connection String ------------------------------- 'CONST strDataSourceName = "Provider=SQLOLEDB.1;Initial Catalog=cactushop6;Data Source=sql.yourhost.com;User ID=username;Password=password;" ' ----------------------- MS Access OLEDB Connection String -------------------- strPathToDatabase = "../access_db/cactushop6.mdb" 'WE ADVISE TO CHANGE THIS OR TURN OFF READ ACCESS TO THIS FOLDER strDatabasePassword = "db4ta2" strDataSourceName = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(strPathToDatabase) & ";Jet OLEDB:Database Password=" & strDatabasePassword '----------------------------------------------- 'DEVELOPER LICENSE 'If you are a developer you can include your own 'license or copyright notice at the top of all 'the pages (it will appear underneath the 'cactushop license) by editing this setting '----------------------------------------------- CONST DEVELOPERLICENSE = "MYDEVLICNUM" '----------------------------------------------- 'BACKEND IP LOCK 'With this you can lock access to the backend 'through only one IP or IP range. If you have 'a static IP, then set this to exactly your IP. 'Access to the backend will only be granted to 'that IP. If you have a dynamic IP, you can 'enter your ISPs IP range to lock access to these. 'To do this, enter the IP block (e.g. "212.132") 'ONLY SET THIS IF YOU KNOW WHAT YOU ARE DOING! 'See the manual for more information on this 'before you go playing around with it. '----------------------------------------------- CONST BACKEND_IP_LOCK = "" '----------------------------------------------- 'EXECUTION STATISTICS 'Set whether to show execution stats. Only turn 'this on while testing! '----------------------------------------------- blnShowDebugStats = false blnShowDebugStatsQueries = false '----------------------------------------------- 'TABLE PREFIX 'If you need to run multiple cactushop on one 'database, you can add in a table prefix and rename 'your tables. This comes after the 'tblCactuShop" & TABLE_PREFIX & "'. 'e.g., a table prefix of '1' would have tables: 'tblCactuShop" & TABLE_PREFIX & "1AdminLog 'tblCactuShop" & TABLE_PREFIX & "1AffiliateLog '----------------------------------------------- CONST TABLE_PREFIX = "1" %> <% '=============================================== ' CactuShop ASP Shopping Cart ' 1999-2007 Cactusoft International FZ-LLC ' www.cactusoft.com '=============================================== ' All rights reserved. ' Use of this code is covered by the terms and ' conditions in the license agreement. No ' unauthorized duplication or distribution is ' permitted. Cactusoft's copyright notices must ' remain in the ASP sections of the code. '=============================================== '************************************************************************** ' CONFIG SETTINGS THAT YOU DON'T NEED TO CHANGE ' Have been moved to here to make config.asp cleaner '************************************************************************** '----------------------------------------------- 'VERSION INFORMATION 'This is currently primarily used for support and 'language string version information. 'Changing this won't necessarily kill your shop, 'but it will for ever more make (language table) 'upgrades difficult and links to the 'knowledgebase may not work correctly. '----------------------------------------------- CONST CACTUSHOPVERSION = 6.1 '----------------------------------------------- 'MYSQL, SQL SERVER OR ACCESS 'This sets a few variables based on which 'database is set to be used. This was in 'functions.asp until v5.117 when it moved here 'and also incorporated the cursor type setting. '----------------------------------------------- Select case strDatabaseType Case "access" strDeleteStatementSyntax = "DELETE * FROM" strDistinctRowStatement = "DISTINCTROW" strDateDelimiter = "#" numCursorType = 3 Case "mssql" strDeleteStatementSyntax = "DELETE FROM" strDistinctRowStatement = "DISTINCT" strDateDelimiter = "'" numCursorType = 1 Case "mysql" strDeleteStatementSyntax = "DELETE FROM" strDistinctRowStatement = "DISTINCT" strDateDelimiter = "'" numCursorType = 3 Case Else If not blnInstall then response.write("Your strDatabaseType setting in the config.asp is not valid.") response.end End If End Select '----------------------------------------------- 'SET EXECUTION STATS 'Counters for execution. This is useful for debug stats '----------------------------------------------- Dim numTotalExecuteRS, numTotalExecuteScalar, numTotalExecuteNonQuery, numQueryExecutionTime, strQueryBuildup numTotalExecuteRS = 0: numTotalExecuteScalar = 0: numTotalExecuteNonQuery = 0 numQueryExecutionTime = 0 '----------------------------------------------- 'CREATE DATABASE CONNECTION '----------------------------------------------- If not blnInstall then Set objDataConn = Server.CreateObject("ADODB.Connection") objDataConn.Open strDataSourceName Set cmdTemp = Server.CreateObject("ADODB.Command") Set objRecordSet = Server.CreateObject("ADODB.Recordset") Set objRecordSet2 = Server.CreateObject("ADODB.Recordset") End If 'This sub closes all the connections. Should be called at 'the bottom of everypage, and before and page redirect Dim strSessionQS Dim objCactuSession Sub EndPage() 'Kill out session - save a static value for the querystring 'as we may still need it for response.redirects strSessionQS = Replace(objCactuSession.QS, "&", "&") set objCactuSession = nothing 'Close all database stuff objDataConn.Close set objRecordSet = nothing set objRecordSet2 = nothing set cmdTemp = nothing set objDataConn = nothing 'Show debug stats at bottom of page If blnShowDebugStats then 'End script execution timer numScriptExecutionTime = Timer - numScriptExecutionStartTime response.Write "
" response.write "Total Querys Executed : " & numTotalExecuteRS + numTotalExecuteScalar + numTotalExecuteNonQuery & "
" response.write "Recordsets : " & numTotalExecuteRS & "
" response.write "Scalars : " & numTotalExecuteScalar & "
" response.write "Nonquerys : " & numTotalExecuteNonQuery & "
" response.Write "
" response.Write "Total Page Execution Time : " & round(numScriptExecutionTime, 2) * 100 & "ms
" response.Write "queries : " & round(numQueryExecutionTime, 2) * 100 & "ms
" response.Write "scripts : " & round(numScriptExecutionTime - numQueryExecutionTime, 2) * 100 & "ms
" response.Write "
" 'Show all the queries that have executed If blnShowDebugStatsQueries then response.Write "Queries Executed:
" response.Write "" End If response.Write "
" end if End Sub '----------------------------------------------- 'SET UP MISCELLANEOUS ARRAYS, VARIABLES, ETC. '----------------------------------------------- If not blnInstall then Dim objCurrency Set objCurrency = New CurrencyData Dim strCategoryListHTML '----------------------------------------------- 'PERFORM MAINTENANCE TASKS 'This resetting can be forced by passing 'reset' 'as a querystring called 'appvar'. The config 'list file in the back end does this to allow 'you to force changes to the config settings to 'take effect. 'IE seems to have a bug that it sometimes 'returns the value with the hash anchor. So we 'check for one and split around it. '----------------------------------------------- strAppVar = request.QueryString("appvar") if instr(strAppVar,"#") > 0 Then aryAppVar = split(strAppVar,"#") strAppVar = aryAppVar(0) End If 'Run the maintenance if: '- the appvar querystring tells us to '- The languageid isn't found (a common problem when using the upgrader) '- The lastupdated config setting is blank '- The lastupdated is different to the one in the DB (only for multiserver) '- Every set period of minutes datDatabaseLastUpdated = GetAppVar("lastupdated") blnMaintenance = (GetAppVar("lastupdated") = "") or (GetAppVar("defaultlanguage") & "" = "") or (strAppVar="reset") or (datDatabaseLastUpdated <> GetAppVar("lastupdated")) If blnMaintenance = false then strQuery = "SELECT CFG_Value FROM tblCactuShop" & TABLE_PREFIX & "Config WHERE CFG_Name = 'lastupdated'" blnMaintenance = Not datDatabaseLastUpdated = ExecuteScalar(strQuery) End If 'Perform maintenance tasks every set period of minutes If blnMaintenance = false then If IsDate(datDatabaseLastUpdated) And NumSafe(GetAppVar("maintenance")) > 0 then blnMaintenance = (DateAdd("n", NumSafe(GetAppVar("maintenance")), datDatabaseLastUpdated) < NowOffset) Else blnMaintenance = True End If End If 'Lets rebuild if we need to If blnMaintenance then 'Update the lastupdated date with the datetime strQuery = "UPDATE tblCactuShop" & TABLE_PREFIX & "Config SET CFG_Value = '" & ReverseDate(NowOffset) & "' WHERE CFG_Name = 'lastupdated'" Call ExecuteNonQuery(strQuery) 'Rebuild all the config settings strQuery = "SELECT CFG_Name, CFG_Value, CFG_DataType FROM tblCactuShop" & TABLE_PREFIX & "Config" Call ExecuteRS(strQuery, objRecordSet) Do while NOT objRecordSet.EOF If objRecordSet("CFG_DataType") = "n" then CFG_Value = objRecordSet("CFG_Value") * 1 Else CFG_Value = objRecordSet("CFG_Value") End if Call SetAppVar(objRecordSet("CFG_Name"), CFG_Value) objRecordSet.MoveNext loop objRecordSet.Close 'Delete all session values that have expired Select case strDatabaseType Case "access" strQuery = "DELETE DISTINCTROW sv.* FROM " & SESSIONVALUES_TABLENAME & " sv INNER JOIN " & SESSION_TABLENAME & " s ON sv.SESSV_SessionID = s.SESS_ID WHERE DATEADD('n', SESSV_Expiry, SESS_DateLastUpdated) < " & strDateDelimiter & ReverseDate(NowOffset) & strDateDelimiter Call ExecuteNonQuery(strQuery) strDateAdd = " WHERE DATEADD('n', SESS_Expiry, SESS_DateLastUpdated) < " & strDateDelimiter & ReverseDate(NowOffset) & strDateDelimiter Case "mysql" strQuery = "DELETE sv.* FROM " & SESSIONVALUES_TABLENAME & " sv INNER JOIN " & SESSION_TABLENAME & " s ON sv.SESSV_SessionID = s.SESS_ID WHERE DATE_ADD(SESS_DateLastUpdated, interval SESSV_Expiry minute) < now()" Call ExecuteNonQuery(strQuery) strDateAdd = " WHERE DATE_ADD(SESS_DateLastUpdated, interval SESS_EXPIRY minute) < now()" Case "mssql" strQuery = "DELETE FROM " & SESSIONVALUES_TABLENAME & " WHERE SESSV_SessionID IN (SELECT SESS_ID FROM " & SESSION_TABLENAME & " WHERE DATEADD(n, SESSV_Expiry, SESS_DateLastUpdated) < " & strDateDelimiter & ReverseDate(NowOffset) & strDateDelimiter & ")" Call ExecuteNonQuery(strQuery) strDateAdd = " WHERE DATEADD(n, SESS_Expiry, SESS_DateLastUpdated) < " & strDateDelimiter & ReverseDate(NowOffset) & strDateDelimiter End Select 'Delete sesssions that have expired strQuery = strDeleteStatementSyntax & " " & SESSION_TABLENAME & strDateAdd Call ExecuteNonQuery(strQuery) End if '----------------------------------------------- 'CHECK WHETHER WE SHOULD BE RUNNING THE INSTALL 'If we're on the front end, redirect to install '----------------------------------------------- If GetAppVar("install") = "install" then If InStr(request.ServerVariables("PATH_INFO"), "/_") = 0 then response.Redirect("install.asp") End If End If '----------------------------------------------- 'START THE CACTUSESSION OBJECT 'Create an instance of our own session state 'class '----------------------------------------------- Set objCactuSession = New CactuSession '----------------------------------------------- 'SSL CHECK 'After doing a secure order on the site itself, 'we want to check if a page that shouldn't be 'secure is still running with https. If so, we 'recall the page with http. '----------------------------------------------- If request.servervariables("HTTPS") = "on" and not (blnMenuDisabled OR InStr(Request.ServerVariables("URL"), "/_") > 0) then strFullQueryStringVars = replace(Request.Querystring, "%3D", "=") aryURLbreakup = split(Request.ServerVariables("URL"), "/", -1) numURLbreakupUbound = Ubound(aryURLbreakup) response.redirect GetAppVar("webshopURL") & aryURLbreakup(Ubound(aryURLbreakup)) & "?" & strFullQueryStringVars ElseIf GetAppVar("usesecurearea") = "y" and (blnMenuDisabled OR InStr(Request.ServerVariables("URL"), "/_") > 0) then If request.servervariables("HTTPS") <> "on" then strFullQueryStringVars = replace(Request.Querystring, "%3D", "=") aryURLbreakup = split(Request.ServerVariables("URL"), "/", -1) numURLbreakupUbound = Ubound(aryURLbreakup) response.redirect Replace(GetAppVar("webshopURL"), "http://", "https://") & aryURLbreakup(Ubound(aryURLbreakup)) & "?" & strFullQueryStringVars End If End If '----------------------------------------------- 'GET THE CURRENCY CHOICE 'If a currency is in the querystring, then store 'that. Otherwise check the session. Failing that, 'use the first value. If it's the back end, use 'the default currency. '----------------------------------------------- If InStr(request.ServerVariables("PATH_INFO"), "/_") then numCurrencyID = 1 else numCurrencyID = NumSafe(DualRequest("numCurrencyID")) If numCurrencyID = 0 then 'Might come from end of URL on fake-urls strQS = request.QueryString numStart = instr(strQS, "numCurrencyID=") If numStart > 0 then numCurrencyID = NumSafe(mid(strQS, numStart + 14)) End If If numCurrencyID > 0 then objCactuSession.Edit "numCurrencyID", numCurrencyID Else numCurrencyID = NumSafe(objCactuSession.Value("numCurrencyID")) End if If numCurrencyID = 0 then numCurrencyID = 1 End if end if '----------------------------------------------- 'GET THE LANGUAGE CHOICE 'If a language is in the querystring, then store 'that. Otherwise check the session. Failing that, 'use the default. If it's the backend, use the 'login language, or failing that the config setting '----------------------------------------------- blnBackEnd = False If InStr(request.ServerVariables("PATH_INFO"), "/_") Then 'In backend, grab it from session numLanguageID = objCactuSession.Value("LOGIN_LanguageID") If numLanguageID = "" then numLanguageID = GetAppVar("defaultlanguage") blnBackEnd = True Else 'Set the language ID numLanguageID = NumSafe(DualRequest("numLanguageID")) If numLanguageID = 0 then 'Might come from end of URL on fake-urls strQS = request.QueryString numStart = instr(strQS, "numLanguageID=") If numStart > 0 then numLanguageID = NumSafe(mid(strQS, numStart + 14)) End If If numLanguageID > 0 then objCactuSession.Edit "numLanguageID", numLanguageID blnChangeLanguage = True 'used later in customer_security to update customer record with lang pref Else numLanguageID = NumSafe(objCactuSession.Value("numLanguageID")) blnChangeLanguage = False End If If numLanguageID = 0 then numLanguageID = NumSafe(GetAppVar("defaultlanguage")) End If End If strQuery = "SELECT LANG_SkinLocation, LANG_EmailTo, LANG_EmailToContact, LANG_EmailFrom, LANG_DateFormat, LANG_DateAndTimeFormat FROM tblCactuShop" & TABLE_PREFIX & "Languages WHERE LANG_ID = " & numLanguageID Call ExecuteRS(strQuery, objRecordSet) If Not (objRecordSet.BOF And objRecordSet.EOF) Then strLanguageSkinLocation = objRecordSet("LANG_SkinLocation") 'Get the language-specific email settings strEmailTo = objRecordSet("LANG_EmailTo") strEmailToContact = objRecordSet("LANG_EmailToContact") strEmailFrom = objRecordSet("LANG_EmailFrom") strDateFormat = objRecordSet("LANG_DateFormat") strDateAndTimeFormat = objRecordSet("LANG_DateAndTimeFormat") Else numLanguageID = 1 End If objRecordSet.Close strLanguageTableName = "tblCactuShop" & TABLE_PREFIX & "LanguageStrings" & CInt(numLanguageID) 'If either date formats are blank, set them to default If strDateFormat = "" then strDateFormat = "[d] [mna] [yy]" If strDateAndTimeFormat = "" then strDateAndTimeFormat = "[d] [mna] [yy], [24h0]:[n0]" '----------------------------------------------- 'LOAD UP THE PAGE STRINGS '----------------------------------------------- Dim StringDict Set StringDict = Server.CreateObject("Scripting.Dictionary") 'Base page strings for all front- and back-end pages. strBaseStrings = "18, 242, 243, 244, 255, 256, 257, 258, 259, 260, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 284, 300, 308, 603, 683, 704, 833, 834, 863, 883, 886, 887, 888, 902, 1130, 1201, 1712, 1771, 1772" 'Backend-only strings If blnBackEnd Then 'Add in strings specific to the back-end strBaseStrings = strBaseStrings & ", 309, 310, 311, 312, 313, 319, 320, 371, 415, 419, 548, 592, 593, 594, 595, 596, 597, 598, 599, 600, 601, 602, 603, 604, 605, 606, 607, 608, 609, 610, 611, 612, 613, 614, 615, 616, 617, 619, 663, 690, 691, 692, 693, 715, 800, 835, 872, 873, 874, 896, 897, 898, 899, 900, 903, 904, 907, 932, 939, 940, 960, 974, 988, 990, 991, 1006, 1038, 1066, 1073, 1074, 1081, 1082, 1140, 1178, 1238, 1255, 1279, 1280, 1345, 1362, 1371, 1394, 1395, 1425, 1447, 1474, 1475, 1492, 1493, 1494, 1495, 1496, 1497, 1498, 1499, 1500, 1501, 1502, 1503, 1503, 1504, 1505, 1506, 1507, 1508, 1509, 1596, 1645, 1646, 1647, 1648, 1658, 1667, 1681, 1682, 1683, 1684, 1685, 1686, 1700, 1723, 1725, 1729, 1817, 1818, 1819, 1847, 1857, 1885, 1889, 1912, 1940" Else 'Frontend-only strings strBaseStrings = strBaseStrings & ", 825, 1411, 1788" End If 'Adminbar strings now used front and back on v6 strAdminBarStrings = "314, 315, 316, 317, 618, 1004, 1008, 1009, 1070, 1071, 1072, 1076, 1114, 1115, 1735, 1736, 1737, 1738, 1739, 1740, 1883" strTotalStrings = strBaseStrings & "," & strAdminBarStrings 'Add in page specific strings If Not PageStrings = "" Then strTotalStrings = strTotalStrings & "," & PageStrings 'Date strings - If a site is flagged as using FormatDate, it needs the following date strings If blnDateStrings then strTotalStrings = strTotalStrings & ", 1215, 1216, 1217, 1218, 1219, 1220, 1221, 1516, 1517, 1518, 1519, 1520, 1521, 1522, 1523, 1524, 1525, 1526, 1527, 1528, 1529, 1530, 1531, 1532, 1533, 1534, 1535, 1536, 1537, 1538, 1539, 1540, 1541, 1542, 1543, 1544, 1545, 1546" End If Call LoadStrings(strTotalStrings, strLanguageTableName) '----------------------------------------------- 'SET DEFAULT PAGETITLE (SOME PAGES OVERRULE IT!) '----------------------------------------------- strPageTitleHTML = GetString("Config_Webshopname") End If 'Check if enableunicode config is set If GetAppVar("enableunicode") = "y" then Response.ContentType = "text/html; charset=utf-8" if session.codepage <> 65001 then session.codepage = 65001 if strDatabaseType = "mssql" then strUnicode = "N" else strUnicode = "" End If strTemplateShopFolder = "/" & Trim(GetAppVar("webshopfolder")) %> <% If request.QueryString = Rot("<:;LBM> BL KNGGBG@ j: <% ' Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm, ' as set out in the memo RFC1321. ' ' ' ASP VBScript code for generating an MD5 'digest' or 'signature' of a string. The ' MD5 algorithm is one of the industry standard methods for generating digital ' signatures. It is generically known as a digest, digital signature, one-way ' encryption, hash or checksum algorithm. A common use for MD5 is for password ' encryption as it is one-way in nature, that does not mean that your passwords ' are not free from a dictionary attack. ' ' This is 'free' software with the following restrictions: ' ' You may not redistribute this code as a 'sample' or 'demo'. However, you are free ' to use the source code in your own code, but you may not claim that you created ' the sample code. It is expressly forbidden to sell or profit from this source code ' other than by the knowledge gained or the enhanced value added by your own code. ' ' Use of this software is also done so at your own risk. The code is supplied as ' is without warranty or guarantee of any kind. ' ' Should you wish to commission some derivative work based on this code provided ' here, or any consultancy work, please do not hesitate to contact us. ' ' Web Site: http://www.frez.co.uk ' E-mail: sales@frez.co.uk ' ' Modification by Nick at Cactusoft.com (nick@cactusoft.com ' Functions F, G, H and I renamed to avoid variable clashes Private Const BITS_TO_A_BYTE = 8 Private Const BYTES_TO_A_WORD = 4 Private Const BITS_TO_A_WORD = 32 Private m_lOnBits(30) Private m_l2Power(30) m_lOnBits(0) = CLng(1) m_lOnBits(1) = CLng(3) m_lOnBits(2) = CLng(7) m_lOnBits(3) = CLng(15) m_lOnBits(4) = CLng(31) m_lOnBits(5) = CLng(63) m_lOnBits(6) = CLng(127) m_lOnBits(7) = CLng(255) m_lOnBits(8) = CLng(511) m_lOnBits(9) = CLng(1023) m_lOnBits(10) = CLng(2047) m_lOnBits(11) = CLng(4095) m_lOnBits(12) = CLng(8191) m_lOnBits(13) = CLng(16383) m_lOnBits(14) = CLng(32767) m_lOnBits(15) = CLng(65535) m_lOnBits(16) = CLng(131071) m_lOnBits(17) = CLng(262143) m_lOnBits(18) = CLng(524287) m_lOnBits(19) = CLng(1048575) m_lOnBits(20) = CLng(2097151) m_lOnBits(21) = CLng(4194303) m_lOnBits(22) = CLng(8388607) m_lOnBits(23) = CLng(16777215) m_lOnBits(24) = CLng(33554431) m_lOnBits(25) = CLng(67108863) m_lOnBits(26) = CLng(134217727) m_lOnBits(27) = CLng(268435455) m_lOnBits(28) = CLng(536870911) m_lOnBits(29) = CLng(1073741823) m_lOnBits(30) = CLng(2147483647) m_l2Power(0) = CLng(1) m_l2Power(1) = CLng(2) m_l2Power(2) = CLng(4) m_l2Power(3) = CLng(8) m_l2Power(4) = CLng(16) m_l2Power(5) = CLng(32) m_l2Power(6) = CLng(64) m_l2Power(7) = CLng(128) m_l2Power(8) = CLng(256) m_l2Power(9) = CLng(512) m_l2Power(10) = CLng(1024) m_l2Power(11) = CLng(2048) m_l2Power(12) = CLng(4096) m_l2Power(13) = CLng(8192) m_l2Power(14) = CLng(16384) m_l2Power(15) = CLng(32768) m_l2Power(16) = CLng(65536) m_l2Power(17) = CLng(131072) m_l2Power(18) = CLng(262144) m_l2Power(19) = CLng(524288) m_l2Power(20) = CLng(1048576) m_l2Power(21) = CLng(2097152) m_l2Power(22) = CLng(4194304) m_l2Power(23) = CLng(8388608) m_l2Power(24) = CLng(16777216) m_l2Power(25) = CLng(33554432) m_l2Power(26) = CLng(67108864) m_l2Power(27) = CLng(134217728) m_l2Power(28) = CLng(268435456) m_l2Power(29) = CLng(536870912) m_l2Power(30) = CLng(1073741824) Private Function LShift(lValue, iShiftBits) If iShiftBits = 0 Then LShift = lValue Exit Function ElseIf iShiftBits = 31 Then If lValue And 1 Then LShift = &H80000000 Else LShift = 0 End If Exit Function ElseIf iShiftBits < 0 Or iShiftBits > 31 Then Err.Raise 6 End If If (lValue And m_l2Power(31 - iShiftBits)) Then LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000 Else LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits)) End If End Function Private Function RShift(lValue, iShiftBits) If iShiftBits = 0 Then RShift = lValue Exit Function ElseIf iShiftBits = 31 Then If lValue And &H80000000 Then RShift = 1 Else RShift = 0 End If Exit Function ElseIf iShiftBits < 0 Or iShiftBits > 31 Then Err.Raise 6 End If RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits) If (lValue And &H80000000) Then RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1))) End If End Function Private Function RotateLeft(lValue, iShiftBits) RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits)) End Function Private Function AddUnsigned(lX, lY) Dim lX4 Dim lY4 Dim lX8 Dim lY8 Dim lResult lX8 = lX And &H80000000 lY8 = lY And &H80000000 lX4 = lX And &H40000000 lY4 = lY And &H40000000 lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF) If lX4 And lY4 Then lResult = lResult Xor &H80000000 Xor lX8 Xor lY8 ElseIf lX4 Or lY4 Then If lResult And &H40000000 Then lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8 Else lResult = lResult Xor &H40000000 Xor lX8 Xor lY8 End If Else lResult = lResult Xor lX8 Xor lY8 End If AddUnsigned = lResult End Function Private Function singleF(x, y, z) singleF = (x And y) Or ((Not x) And z) End Function Private Function singleG(x, y, z) singleG = (x And z) Or (y And (Not z)) End Function Private Function singleH(x, y, z) singleH = (x Xor y Xor z) End Function Private Function singleI(x, y, z) singleI = (y Xor (x Or (Not z))) End Function Private Sub FF(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(singleF(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Sub GG(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(singleG(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Sub HH(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(singleH(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Sub II(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(singleI(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Function ConvertToWordArray(sMessage) Dim lMessageLength Dim lNumberOfWords Dim lWordArray() Dim lBytePosition Dim lByteCount Dim lWordCount Const MODULUS_BITS = 512 Const CONGRUENT_BITS = 448 lMessageLength = Len(sMessage) lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD) ReDim lWordArray(lNumberOfWords - 1) lBytePosition = 0 lByteCount = 0 Do Until lByteCount >= lMessageLength lWordCount = lByteCount \ BYTES_TO_A_WORD lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition) lByteCount = lByteCount + 1 Loop lWordCount = lByteCount \ BYTES_TO_A_WORD lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition) lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3) lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29) ConvertToWordArray = lWordArray End Function Private Function WordToHex(lValue) Dim lByte Dim lCount For lCount = 0 To 3 lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1) WordToHex = WordToHex & Right("0" & Hex(lByte), 2) Next End Function Public Function MD5(sMessage) Dim x Dim k Dim AA Dim BB Dim CC Dim DD Dim a Dim b Dim c Dim d Const S11 = 7 Const S12 = 12 Const S13 = 17 Const S14 = 22 Const S21 = 5 Const S22 = 9 Const S23 = 14 Const S24 = 20 Const S31 = 4 Const S32 = 11 Const S33 = 16 Const S34 = 23 Const S41 = 6 Const S42 = 10 Const S43 = 15 Const S44 = 21 x = ConvertToWordArray(sMessage) a = &H67452301 b = &HEFCDAB89 c = &H98BADCFE d = &H10325476 For k = 0 To UBound(x) Step 16 AA = a BB = b CC = c DD = d FF a, b, c, d, x(k + 0), S11, &HD76AA478 FF d, a, b, c, x(k + 1), S12, &HE8C7B756 FF c, d, a, b, x(k + 2), S13, &H242070DB FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE FF a, b, c, d, x(k + 4), S11, &HF57C0FAF FF d, a, b, c, x(k + 5), S12, &H4787C62A FF c, d, a, b, x(k + 6), S13, &HA8304613 FF b, c, d, a, x(k + 7), S14, &HFD469501 FF a, b, c, d, x(k + 8), S11, &H698098D8 FF d, a, b, c, x(k + 9), S12, &H8B44F7AF FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1 FF b, c, d, a, x(k + 11), S14, &H895CD7BE FF a, b, c, d, x(k + 12), S11, &H6B901122 FF d, a, b, c, x(k + 13), S12, &HFD987193 FF c, d, a, b, x(k + 14), S13, &HA679438E FF b, c, d, a, x(k + 15), S14, &H49B40821 GG a, b, c, d, x(k + 1), S21, &HF61E2562 GG d, a, b, c, x(k + 6), S22, &HC040B340 GG c, d, a, b, x(k + 11), S23, &H265E5A51 GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA GG a, b, c, d, x(k + 5), S21, &HD62F105D GG d, a, b, c, x(k + 10), S22, &H2441453 GG c, d, a, b, x(k + 15), S23, &HD8A1E681 GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8 GG a, b, c, d, x(k + 9), S21, &H21E1CDE6 GG d, a, b, c, x(k + 14), S22, &HC33707D6 GG c, d, a, b, x(k + 3), S23, &HF4D50D87 GG b, c, d, a, x(k + 8), S24, &H455A14ED GG a, b, c, d, x(k + 13), S21, &HA9E3E905 GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8 GG c, d, a, b, x(k + 7), S23, &H676F02D9 GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A HH a, b, c, d, x(k + 5), S31, &HFFFA3942 HH d, a, b, c, x(k + 8), S32, &H8771F681 HH c, d, a, b, x(k + 11), S33, &H6D9D6122 HH b, c, d, a, x(k + 14), S34, &HFDE5380C HH a, b, c, d, x(k + 1), S31, &HA4BEEA44 HH d, a, b, c, x(k + 4), S32, &H4BDECFA9 HH c, d, a, b, x(k + 7), S33, &HF6BB4B60 HH b, c, d, a, x(k + 10), S34, &HBEBFBC70 HH a, b, c, d, x(k + 13), S31, &H289B7EC6 HH d, a, b, c, x(k + 0), S32, &HEAA127FA HH c, d, a, b, x(k + 3), S33, &HD4EF3085 HH b, c, d, a, x(k + 6), S34, &H4881D05 HH a, b, c, d, x(k + 9), S31, &HD9D4D039 HH d, a, b, c, x(k + 12), S32, &HE6DB99E5 HH c, d, a, b, x(k + 15), S33, &H1FA27CF8 HH b, c, d, a, x(k + 2), S34, &HC4AC5665 II a, b, c, d, x(k + 0), S41, &HF4292244 II d, a, b, c, x(k + 7), S42, &H432AFF97 II c, d, a, b, x(k + 14), S43, &HAB9423A7 II b, c, d, a, x(k + 5), S44, &HFC93A039 II a, b, c, d, x(k + 12), S41, &H655B59C3 II d, a, b, c, x(k + 3), S42, &H8F0CCC92 II c, d, a, b, x(k + 10), S43, &HFFEFF47D II b, c, d, a, x(k + 1), S44, &H85845DD1 II a, b, c, d, x(k + 8), S41, &H6FA87E4F II d, a, b, c, x(k + 15), S42, &HFE2CE6E0 II c, d, a, b, x(k + 6), S43, &HA3014314 II b, c, d, a, x(k + 13), S44, &H4E0811A1 II a, b, c, d, x(k + 4), S41, &HF7537E82 II d, a, b, c, x(k + 11), S42, &HBD3AF235 II c, d, a, b, x(k + 2), S43, &H2AD7D2BB II b, c, d, a, x(k + 9), S44, &HEB86D391 a = AddUnsigned(a, AA) b = AddUnsigned(b, BB) c = AddUnsigned(c, CC) d = AddUnsigned(d, DD) Next MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d)) End Function %> <% '=============================================== ' CactuShop ASP Shopping Cart ' 1999-2007 Cactusoft International FZ-LLC ' www.cactusoft.com '=============================================== ' All rights reserved. ' Use of this code is covered by the terms and ' conditions in the license agreement. No ' unauthorized duplication or distribution is ' permitted. Cactusoft's copyright notices must ' remain in the ASP sections of the code. '=============================================== '----------------------------------------------- 'CHECK IF SITE HAS BEEN LOCKED FROM BACK-END 'Owner can close the shop while he/she updates 'stock details or for any other reason. '----------------------------------------------- 'Get whether we're logged in to the backend Dim blnLoggedInToBackend strLogin = objCactuSession.Value("strLogin") blnLoggedInToBackend = false If strLogin <> "" then blnLoggedInToBackend = true strQuery = "SELECT * FROM tblCactuShop" & TABLE_PREFIX & "Logins WHERE LOGIN_Username = " & strUnicode & "'" & SQLSafe(strLogin) & "' AND LOGIN_Live = 'y'" Call ExecuteRS(strQuery, objRecordSet2) If objRecordSet2.BOF and objRecordSet2.EOF then blnLoggedInToBackend = false Else 'Check case sensitivity if strLogin <> objRecordSet2("LOGIN_UserName") then blnLoggedInToBackend = false Else 'Check IP lock If BACKEND_IP_LOCK <> "" then strYourIP = request.ServerVariables("REMOTE_ADDR") If len(strYourIP) = len(BACKEND_IP_LOCK) then blnLoggedInToBackend = true end if end if If blnLoggedInToBackend then strDatabasePassword = objRecordSet2("LOGIN_Password") strThisUserLOGIN_Username = objRecordSet2("LOGIN_Username") strThisUserLOGIN_Orders = objRecordSet2("LOGIN_Orders") strThisUserLOGIN_Products = objRecordSet2("LOGIN_Products") strThisUserLOGIN_Config = objRecordSet2("LOGIN_Config") strIP = request.ServerVariables("LOCAL_ADDR") strDatabasePasswordHash = MD5(strDatabasePassword & strIP) If objCactuSession.Value("strPasswordHash") <> strDatabasePasswordHash then blnLoggedInToBackend = false End If end if End If End If objRecordSet2.Close end if 'Redirect If not blnLoggedInToBackend then If GetAppVar("shopstatus") = "locked" Then 'Redirect to the closed page Call EndPage() Response.Redirect(strTemplateShopFolder & "closed.asp?" & strSessionQS) ElseIf GetAppVar("shopstatus") = "hardlocked" Then 'Redirect to the static hardlock page Call EndPage() Response.Redirect(strTemplateShopFolder & "closed.html") End If End If %> <% '=============================================== ' CactuShop ASP Shopping Cart ' 1999-2007 Cactusoft International FZ-LLC ' www.cactusoft.com '=============================================== ' All rights reserved. ' Use of this code is covered by the terms and ' conditions in the license agreement. No ' unauthorized duplication or distribution is ' permitted. Cactusoft's copyright notices must ' remain in the ASP sections of the code. '=============================================== 'Create out basket object Set objBasket = New Basket If request.querystring("strWipeBasket") = "yes" then '----------------------------------------------- 'WIPE BASKET 'If we get the action in the querystring, then 'remove all the basket session variables '----------------------------------------------- objCactuSession.Delete "strItems" objCactuSession.Delete "strQuantities" objCactuSession.Delete "strOptionGroups" objCactuSession.Delete "strOptions" objCactuSession.Delete "CP_CouponCode" End If '----------------------------------------------- 'LOAD IN THE BASKET '----------------------------------------------- Set objBasket = New Basket strItems = objCactuSession.Value("strItems") strQuantities = objCactuSession.Value("strQuantities") strOptionGroups = objCactuSession.Value("strOptionGroups") strOptions = objCactuSession.Value("strOptions") 'Load in to basket objBasket.Load strItems, strQuantities, strOptionGroups, strOptions %> <% '=============================================== ' CactuShop ASP Shopping Cart ' 1999-2007 Cactusoft International FZ-LLC ' www.cactusoft.com '=============================================== ' All rights reserved. ' Use of this code is covered by the terms and ' conditions in the license agreement. No ' unauthorized duplication or distribution is ' permitted. Cactusoft's copyright notices must ' remain in the ASP sections of the code. '=============================================== '----------------------------------------------- 'FUNCTIONS THAT ARE REQUIRED ON MANY PAGES 'OK, maybe some SUBS too... '----------------------------------------------- '*********************************************** '-SAFE PROCEDURES 'These functions check the validity of data. 'This is to ensure incoming variables are what 'we expect. '*********************************************** '----------------------------------------------- 'SQLSafe '----------------------------------------------- Function SQLSafe(strText) SQLSafe = Replace(strText, "'", "''") If strDatabaseType = "mysql" Then SQLSafe = Replace(SQLSafe, "\", "\\") End If End Function '----------------------------------------------- 'NUMSAFE - makes sure a number is a valid double '----------------------------------------------- Public Function NumSafe(objNumber) If isnull(objNumber) then NumSafe = 0 ElseIf not isnumeric(objNumber) or objNumber = "" then NumSafe = 0 else If objNumber > -9223372036854775808 and objNumber < 9223372036854775807 then NumSafe = Cdbl(objNumber) Else NumSafe = 0 End If End If End Function '----------------------------------------------- 'SQLDECIMALS - ensures that commas used for 'decimal separators on non-English Windows are 'replaced with points prior to submission to DB '(otherwise they look like field separators). '----------------------------------------------- Public Function SQLDecimals(numNumber) If isnull(numNumber) then SQLDecimals = "0" ElseIf InStr(Cstr(numNumber), ",") > 1 then SQLDecimals = replace(Cstr(numNumber), ",", ".") Else SQLDecimals = Cstr(numNumber) End If End Function '----------------------------------------------- 'FILENAMESAFE - strips out any characters which 'aren't allowed in windows-based file names '----------------------------------------------- Function FileNameSafe(strFileName) aryRemove = Array(" ", "'", ",", """", "/", "\", ":", "*", "?", "<", ">", "|", "(", ")", "%") aryReplace = Array("-", "", "-", "", "", "", "", "", "", "", "", "", "", "", "pc") FileNameSafe = strFileName Dim numCount For numCount = 0 to ubound(aryRemove) FileNameSafe = Replace(FileNameSafe, aryRemove(numCount), aryReplace(numCount)) Next End Function '----------------------------------------------- 'WRITESAFE - ensures against XSS attacks - all 'outgoing variables ar writesafed first. '----------------------------------------------- Public Function WriteSafe(strValue) If strValue <> "" and not IsNull(strValue) then WriteSafe = Server.HTMLEncode(strValue) WriteSafe = replace(WriteSafe, "'", "'") End if End Function '----------------------------------------------- 'URLSAFE - ensures against XSS attacks in urls '----------------------------------------------- Public Function URLSafe(strValue) If strValue <> "" and not IsNull(strValue) then URLSafe = server.URLEncode(strValue) End if End Function '----------------------------------------------- 'LISTSAFE - checks a value is part of a comma- 'seperated list of allowed values '----------------------------------------------- Function ListSafe(strValue, strAllowedValues, strDefaultValue) If IsNull(strValue) then strValue = "" If IsNull(strAllowedValues) then strAllowedValues = "" If IsNull(strDefaultValue) then strDefaultValue = "" If Contains(strAllowedValues, strValue) then ListSafe = strValue Else ListSafe = strDefaultValue End If End Function '----------------------------------------------- 'STRIPHTML - removes HTML tags from text '----------------------------------------------- Function StripHTML(strValue) if strValue <> "" then Dim objRegExp : set objRegExp = new RegExp with objRegExp .Pattern = "<(.|\n)*?>" .IgnoreCase = true .Global = true end with StripHTML = objRegExp.replace(strValue, "") set objRegExp = nothing End if End Function '*********************************************** '*********************************************** 'GENERAL-USE PROCEDURES '*********************************************** '----------------------------------------------- 'CastSQL - cast the string if its Ntext in MSSQL '----------------------------------------------- Function CastSQL(strText) if strDatabaseType = "mssql" then CastSQL = "cast(" & strText & " as nvarchar(4000))" else CastSQL = strText End Function '----------------------------------------------- 'SAFE ROUND 'For some reason, the round function doesn't 'round 0.5 correctly. '----------------------------------------------- Public Function SafeRound(numValue, numDecimalPlaces) SafeRound = Round(NumSafe(numValue) + 0.00001, numDecimalPlaces) End Function 'Same as above, but for negative numbers Public Function NegSafeRound(numValue, numDecimalPlaces) NegSafeRound = Round(NumSafe(numValue) - 0.00001, numDecimalPlaces) End Function '----------------------------------------------- 'IIF FUNCTION 'This is a really useful function to keep code 'nice and clean. If the clause is true, 'it returns the first value, otherwise it returns 'the second. '----------------------------------------------- Public Function IIf(blnWhichOne, objTruePart, objFalsePart) If blnWhichOne then IIf = objTruePart Else IIf = objFalsePart End If End Function '----------------------------------------------- 'OCCURRENCES 'Returns the number of times a string appears in 'another string '----------------------------------------------- Function Occurrences(str1, str2) Occurrences = Len(Replace(str1, str2, str2 & " ")) - Len(str1) End Function '----------------------------------------------- 'MAX/MIN 'Returns the bigger/smaller of two numbers '----------------------------------------------- Function Max(num1, num2) Max = IIf(num2 > num1, num2, num1) End Function Function Min(num1, num2) Min = IIf(num2 < num1, num2, num1) End Function '----------------------------------------------- 'GET RANDOM STRING 'This function returns a random alpha-numeric 'string, of length 'numLength' (passed). '----------------------------------------------- Function GetRandomString(numLength) 'Generate a new seed based on the server timer Randomize strRandomString = "" 'Loop for as many letters as we need Do while len(strRandomString) < numLength 'Generate random number numRandomNumber = int(rnd(1) * 36) + 1 if numRandomNumber < 11 then 'If it's less than 11 then we'll do a number strRandomString = strRandomString & chr(numRandomNumber + 47) else 'Otherwise we'll do a letter; + 86 because 96 (min being 97, 'a') - 10 (the first 10 was for the number) strRandomString = strRandomString & chr(numRandomNumber + 86) end if loop 'Zero and 'o' and '1' and 'I' are easily confused... 'So we replace any of these with alternatives 'To ensure best randomness, replace the numbers 'with alternative letters and letters 'with alternative numbers strRandomString = replace(strRandomString, "0", "X") strRandomString = replace(strRandomString, "1", "Y") strRandomString = replace(strRandomString, "O", "4") strRandomString = replace(strRandomString, "I", "9") GetRandomString = strRandomString End Function '----------------------------------------------- 'FORMAT DATE IN REVERSE FORMAT 'e.g. 2000/12/1 for 1st December 2000. This way 'works (or should work) in all language formats 'and in the US or UK where standard numerical 'dates are written MM/DD/YYYY or DD/MM/YYYY. 'You wouldn't believe how many problems dates 'cause... '----------------------------------------------- Function ReverseDate(datDateTime) If IsNull(datDateTime) then ReverseDate = "" elseif CStr(datDatetime) = "" then ReverseDate = "" else strDatabaseFormat = GetAppVar("databasedateformat") ReverseDate = FormatDate(datDateTime, strDatabaseFormat) end if End Function '----------------------------------------------- 'PARSE AND HANDLE DYNAMIC TAGS, i.e. SESSION 'The cookieless sessions feature in CactuShop 'allows the session state ID to be passed around 'the store in form fields and querystrings as 'well as backed-up on a cookie (depending on the 'usecookies config setting). To ensure this 'querystring can be included in URLs that are 'added manually to news items, language strings 'product descriptions and other places, we have 'this function. It will parse a text script and 'find/replace occurences of the following tags 'with the appropriate content: 'xxxWEBSHOPURLxxx 'xxxWEBSHOPFOLDERxxx 'xxxTEMPLATEIMAGESxxx 'xxxSESSIONQSxxx '----------------------------------------------- Function HandleDynamicTagsInContent(strValue) strValue = Replace(strValue & "", "xxxWEBSHOPURLxxx", GetAppVar("webshopurl")) strValue = Replace(strValue & "", "xxxWEBSHOPFOLDERxxx", strTemplateShopFolder) strValue = Replace(strValue & "", "xxxTEMPLATEIMAGESxxx", strTemplateImagesFolder) strValue = Replace(strValue & "", "xxxSESSIONQSxxx", objCactuSession.QS) HandleDynamicTagsInContent = strValue End Function '----------------------------------------------- 'ROT - obfuscates data. '----------------------------------------------- Function Rot(strValue) For numCount = 1 To len(strValue) numChar = Asc(mid(strValue, numCount, 1)) If numChar >= 48 And numChar <= 125 Then numChar = numChar + 39 If numChar > 125 Then numChar = numChar - 78 End If End If Rot = (Rot & ChrW(numChar)) Next End Function '----------------------------------------------- 'FORMAT DATE 'Formats a date to a specific format. Supports 'the following codes. A '0' means it has leading zeros 'and a 'a' means it's abbreviated ' '[m] [m0] month number '[mn] [mna] month name '[d] [da] day of the month with leading number '[w], [wa] Weekday name '[24h], [24h0] hour in 24 hour clock '[h], [h0] hour in 12 hour clock '[n], [n0] minutes '[s], [s0] seconds '[yy] year (two digits) '[yyyy] year (four digits) '[a] AM or PM ' 'This is a replacement for the old 'friendlydate' '----------------------------------------------- Function FormatDate(datValue, strDateFormat) 'Take a copy of the format strFormat = strDateFormat 'Check date is valid If not isDate(datValue) then FormatDate = "" Exit Function End If 'Set all variables numMonth = Month(datValue) strMonthZero = AddLeadingZero(numMonth) numDay = Day(datValue) strDayZero = AddLeadingZero(numDay) num24Hour = Hour(datValue) str24HourZero = AddLeadingZero(num24Hour) numHour = IIf(num24Hour <= 12, num24Hour, num24Hour - 12) strHourZero = AddLeadingZero(numHour) numMinutes = Minute(datValue) strMinutesZero = AddLeadingZero(numMinutes) numSeconds = Second(datValue) strSecondsZero = AddLeadingZero(numSeconds) strYear4 = Year(datValue) strYear2 = right(strYear4, 2) strAMPM = IIf(num24Hour >= 12, "PM", "AM") 'We check we need these before calling them. That's because 'they require language strings, and in some cases language 'strings don't exist yet (like in the session.asp) If instr(strDateFormat, "[mn") > 0 then strMonthName = GetMonthName(datValue, false) strMonthNameAbbr = GetMonthName(datValue, true) end if If instr(strDateFormat, "[w") > 0 then strWeekday = GetWeekDay(datValue, false) strWeekDayAbbr = GetWeekday(datValue, true) end if 'Now do the replacements strFormat = Replace(strFormat, "[m]", numMonth) strFormat = Replace(strFormat, "[m0]", strMonthZero) strFormat = Replace(strFormat, "[mn]", strMonthName) strFormat = Replace(strFormat, "[mna]", strMonthNameAbbr) strFormat = Replace(strFormat, "[d]", numDay) strFormat = Replace(strFormat, "[da]", strDayZero) strFormat = Replace(strFormat, "[w]", strWeekday) strFormat = Replace(strFormat, "[wa]", strWeekDayAbbr) strFormat = Replace(strFormat, "[24h]", num24Hour) strFormat = Replace(strFormat, "[24h0]", str24HourZero) strFormat = Replace(strFormat, "[h]", numHour) strFormat = Replace(strFormat, "[h0]", strHourZero) strFormat = Replace(strFormat, "[n]", numMinutes) strFormat = Replace(strFormat, "[n0]", strMinutesZero) strFormat = Replace(strFormat, "[s]", numSeconds) strFormat = Replace(strFormat, "[s0]", strSecondsZero) strFormat = Replace(strFormat, "[yy]", strYear2) strFormat = Replace(strFormat, "[yyyy]", strYear4) strFormat = Replace(strFormat, "[a]", strAMPM) FormatDate = strFormat End Function 'Used above to suffix a 0 at the start of 2 digit numbers. Function AddLeadingZero(strValue) If len(CStr(strValue)) = 1 then AddLeadingZero = "0" & strValue Else AddLeadingZero = strValue End If End Function 'Function to return the translation of the weekday. Optional 'abbreviation. LS 1215-1221, 1516-1523 Function GetWeekDay(datValue, blnAbbreviate) GetWeekDay = GetString("WeekDay_" & WeekdayName(Weekday(datValue)) & IIf(blnAbbreviate, "_Abbr", "")) End Function 'Same as the abbove, but for months LS 1523-1546 Function GetMonthName(datValue, blnAbbreviate) GetMonthName = GetString("Month_" & MonthName(Month(datValue)) & IIf(blnAbbreviate, "_Abbr", "")) End Function '----------------------------------------------- 'NOW OFFSET '----------------------------------------------- 'A 'now' replacement, to return the current time + an 'hourly offset. Should be used everywhere in the 'code instead of Now(), Date() and Time() Function NowOffset() NowOffset = DateAdd("h", GetAppVar("timeoffset"), now) End Function '----------------------------------------------- 'SEND MAIL FUNCTION 'General use send email function. Supports aspmail, 'persits ASPEmail, CDO, CDOSys, and jmail, and 'has two debug modes (write and off). '----------------------------------------------- Sub SendEMail(strEmailMethod, strMailServer, strToAddress, strCCAddress, strBCCAddress, strFromAddress, strFromName, strReplyAddress, strReplyName, strSubjectLine, strBodyText, strAttachmentPath, blnHTML) 'If we're attaching a file, check it here If strAttachmentPath <> "" then set objFileSystem = CreateObject("Scripting.FileSystemObject") If objFileSystem.FileExists(strAttachmentPath) then aryTempPathSplit = split(strAttachmentPath, "\") numLastChunk = Ubound(aryTempPathSplit) strAttachmentFileName = aryTempPathSplit(numLastChunk) Else strAttachmentPath = "" End if set objFileSystem = Nothing End if 'Send the email! Select Case lcase(strEmailMethod) Case "aspmail" Set objMail = Server.CreateObject("SMTPsvg.Mailer") objMail.RemoteHost = strMailServer objMail.FromName = strFromName objMail.FromAddress = strFromAddress objMail.AddRecipient strToAddress, strToAddress If strCCAddress <> "" then objMail.AddCC strCCAddress, strCCAddress If strBCCAddress <> "" then objMail.AddBCC strBCCAddress, strBCCAddress if blnHTML then objMail.ContentType = "text/html" else objMail.ContentType = "text/plain" end if objMail.Subject = strSubjectLine 'NO SMTP AUTHENTICATION SUPPORT!!! objMail.BodyText = strBodyText If strAttachmentPath <> "" then objMail.AddAttachment(strAttachmentPath) End if If not objMail.SendMail then 'If the mail send fails, code can go here 'to handle it end if Set objMail = Nothing Case "persits", "aspemail" Set objMail = Server.CreateObject("Persits.MailSender") objMail.Host = strMailServer objMail.AddAddress strToAddress If strBCCAddress <> "" then objMail.AddBCC strBCCAddress If strCCAddress <> "" then objMail.AddCC strCCAddress objMail.IsHTML = blnHTML objMail.From = strFromAddress objMail.FromName = strFromName objMail.Subject = strSubjectLine 'Handle SMTP authentication If GetAppVar("smtpauthusername") <> "" then 'need authentication objMail.Username = GetAppVar("smtpauthusername") objMail.Password = GetAppVar("smtpauthpassword") End if objMail.Body = strBodyText If strAttachmentPath <> "" then objMail.AddAttachment(strAttachmentPath) End if objMail.Send Set objMail = Nothing Case "cdo", "cdonts" Set objMail = Server.CreateObject("CDONTS.NewMail") objMail.To = strToAddress If strCCAddress <> "" then objMail.CC = strCCAddress If strBCCAddress <> "" then objMail.BCC = strBCCAddress objMail.From = strFromAddress objMail.Value("Reply-To") = strReplyAddress If blnHTML then objMail.BodyFormat = 0 objMail.MailFormat = 0 end if objMail.Subject = strSubjectLine 'NO SMTP AUTHENTICATION SUPPORT!!! objMail.Body = strBodyText If strAttachmentPath <> "" then objMail.AttachFile strAttachmentPath, strAttachmentFileName End if objMail.Send Set objMail = Nothing case "cdosys" 'CDOSYS is the successor to CDONTS, used on Windows Server 2003 and later 'Create the CDOSYS objects Set objCDOSYSMail = Server.CreateObject("CDO.Message") Set objCDOSYSCon = Server.CreateObject("CDO.Configuration") 'Set configuration settings objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = GetAppVar("smtpportnumber") If strMailServer <> "" then 'if a mail server is set, use that objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strMailServer else 'otherwise use the local SMTP service pickup directory objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 1 end if 'Handle SMTP authentication If GetAppVar("smtpauthusername") <> "" then 'need authentication objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'set auth ON objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = GetAppVar("smtpauthusername") objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = GetAppVar("smtpauthpassword") End if 'Set the configuration of the message objCDOSYSCon.Fields.Update Set objCDOSYSMail.Configuration = objCDOSYSCon Set objCDOSYSCon = nothing 'Set settings and send the email With objCDOSYSMail .From = strFromAddress .To = strToAddress .Subject = strSubjectLine .ReplyTo = strReplyAddress If strCCAddress <> "" then .CC = strCCAddress If strBCCAddress <> "" then .BCC = strBCCAddress If blnHTML then .HTMLBody = strBodyText else .TextBody = strBodyText If strAttachmentPath <> "" then objCDOSYSmail.AddAttachment strAttachmentPath .Send End With 'Destroy mailing object Set objCDOSYSMail = nothing Case "jmail" set objMail = Server.CreateObject("JMail.Message") objMail.From = strFromAddress objMail.FromName = strFromName objMail.Subject = strSubjectLine 'Handle SMTP authentication If GetAppVar("smtpauthusername") <> "" then 'need authentication objMail.MailServerUserName = GetAppVar("smtpauthusername") objMail.MailServerPassWord = GetAppVar("smtpauthpassword") End if objMail.AddRecipient strToAddress If strAttachmentPath <> "" then objMail.AddAttachment strAttachmentPath else if blnHTML then objMail.ContentType = "text/html" else objMail.ContentType = "text/plain" end if End if objMail.Body = strBodyText objMail.Send(strMailServer) set objMail = Nothing Case "write" 'useful for development/testing response.write("INFO: Why am I seeing emails written to the screen?

") response.write("mailto: " & strToAddress & "
") response.write("from: " & strFromAddress & "
") response.write("subject: " & strSubjectLine & "
") response.write("smtp port#: " & GetAppVar("smtpportnumber") & "
") response.write("smtp auth username: " & GetAppVar("smtpauthusername") & "
") response.write("smtp auth password: " & GetAppVar("smtpauthpassword") & "
") response.write("format: " & IIf(blnHTML, "HTML", "Plain Text") & "
") if strAttachmentPath <> "" then response.write("attachment: " & strAttachmentPath & "
") end if response.write("
") Case Else 'JUST DO NOTHING 'This is way of disabling mail sends totally, again, useful for debugging 'If you suspect the mail send is throwing an error, disable mail and 'try again - if it clears your problem, pretty fair bet the mail send is 'responsible. End Select End Sub '----------------------------------------------- 'ADD VALUE TO URL 'Adds a name/value pair to the querystring or a 'url '----------------------------------------------- Function AddValueToURL(strURL, strNameAndValue) If instr(strURL, "?") = 0 then AddValueToURL = strURL & "?" & strNameAndValue Else AddValueToURL = strURL & "&" & strNameAndValue End If End Function '----------------------------------------------- 'BUILD SINGLE DROPDOWN MENUS 'Just a bit of code that generates a dropdown 'menu based on the open recordset and other 'details passed to it. Will also check what 'option is selected. '----------------------------------------------- Sub SingleDropDown(strDropdownName, strFirstLineValue, strFirstLineDisplay, objRS, strValueName, strDisplayName, strSelectedVariable) 'Start the select strMenuText = "" strMenuText = "" response.write(strMenuText) End Sub '----------------------------------------------- 'QUOTE MARK HANDLER 'Ok, when we create the Javascript popup links, 'there is a problem in IE. Even if you try to 'HTMLencode or URLencode the item names, this 'isn't enough to stop IE throwing an annoying 'Javascript error when you click on the link to 'launch a large view. Therefore, we have to 'manually create this special function to 'replace ' and " with something IE won't object 'to and then switch them back later. BTW, 'strCallMode is '1' to encode and '2' to decode. '----------------------------------------------- Function JavascriptPopupEncode(strLink, strCallMode) If strCallMode = 1 then JavascriptPopupEncode = replace(strLink, "'", "apostrophemark") JavascriptPopupEncode = replace(JavascriptPopupEncode, """", "doublequotemark") Else JavascriptPopupEncode = replace(strLink, "apostrophemark", "'") JavascriptPopupEncode = replace(JavascriptPopupEncode, "doublequotemark", """") End if End Function '----------------------------------------------- 'LIMIT SQL 'Adds in the 'limit' part of a query - either the 'TOP X in mssql/access, or LIMIT 0, X for mysql '----------------------------------------------- Function LimitSQL(strQuery, numLimit, blnDistinct) strDistinct = IIf(blnDistinct, "DISTINCT ", "") If numLimit = -1 then LimitSQL = "SELECT " & strDistinct & strQuery ElseIf strDatabaseType = "mysql" then LimitSQL = "SELECT " & strDistinct & strQuery & " LIMIT 0, " & CStr(numLimit) Else LimitSQL = "SELECT " & strDistinct & "TOP " & CStr(numLimit) & " " & strQuery End If End Function '----------------------------------------------- 'GET A FILE LOCATION 'Accepts Location Folder, FileName, Array of 'File Types and a FSO. If a file is found, 'returns the file name, else returns an emtpy 'string '----------------------------------------------- Function GetFileLocation(strPath, strName, aryFileTypes, objFileSystem) GetFileLocation = "" If IsArray(aryFileTypes) Then For numCount = 0 To UBound(aryFileTypes) If objFileSystem.FileExists(strPath & "\" & strName & "." & aryFileTypes(numCount)) Then GetFileLocation = strName & "." & aryFileTypes(numCount) Exit For End If Next End If End Function '----------------------------------------------- 'CONTAINS 'Checks to see if a value is contained in a 'comma-seperated list of values '----------------------------------------------- Function Contains(strCommaValues, strValue) Contains = InStr("," & strCommaValues & ",", "," & strValue & ",") > 0 End Function '----------------------------------------------- 'DUAL REQUEST 'Checks the form value first - if that is blank 'it gets it from the querystring '----------------------------------------------- Function DualRequest(strValue) DualRequest = request.Form(strValue) If DualRequest = "" then DualRequest = request.QueryString(strValue) End If End Function '----------------------------------------------- 'GET APP VAR 'Returns an application variable '----------------------------------------------- Function GetAppVar(strName) GetAppVar = Application(LICENSENUMBER & strName) End Function '----------------------------------------------- 'SET APP VAR 'Sets an application variable '----------------------------------------------- Sub SetAppVar(strName, strValue) Application(LICENSENUMBER & strName) = strValue End Sub '*********************************************** '*********************************************** 'SEARCH-RELATED FUNCTIONS '*********************************************** '----------------------------------------------- 'HIGHLIGHT KEYWORDS 'This is used in the search forms to highlight 'the keywords that are being searched. The string, 'a comma-delimited list of keywords and the css 'tag to replace the words are passed, and the 'highlighted text is returned. '----------------------------------------------- Function Highlight(strBaseText, aryKeywords) Highlight = strBaseText If IsArray(aryKeywords) then for each strKeyword in aryKeywords If not strKeyword = "" then 'Instead of using replace, this code keeps the original text (that way we keep the case of the word) 'We mark the front and back of the search term with chr(1) and (2), then replace with span tags later numLastSearchPosition = 1 do while InStr(numLastSearchPosition, lcase(Highlight), lcase(strKeyword)) > 0 numFoundPlace = instr(numLastSearchPosition, lcase(Highlight), lcase(strKeyword)) Highlight = (left(Highlight, numFoundPlace - 1) & chr(1) & mid(Highlight, numFoundPlace, len(strKeyword)) & chr(2) & mid(Highlight, numFoundPlace + len(strKeyword))) numLastSearchPosition = numFoundPlace + len(strKeyword) + 1 loop end if next 'now replace the dummy characters with the span Highlight = Highlight & " " Highlight = Replace(Highlight, chr(1), "") Highlight = Replace(Highlight, chr(2), "") End If End Function '----------------------------------------------- 'CLEAN KEYWORDS 'Cleans up a phrase entered by the user so it's 'ready for parsing. '----------------------------------------------- Function CleanSearchKeywords(strKeywords, strSearchCriteria) 'Make a local copy strNewKeywords = strKeywords 'Replace characters from removal array with a space aryRemove = Array(",", ";", "%", "_", "[", "]") For numCount = 0 to ubound(aryRemove) strNewKeywords = Replace(strNewKeywords, aryRemove(numCount), " ") Next 'Remove all occurrences of space duplication Do While instr(strNewKeywords, " ") > 0 strNewKeywords = Replace(strNewKeywords, " ", " ") Loop strNewKeywords = Trim(strNewKeywords) 'Only add keywords up to the max allowed, and trim all to size 'We need size checks to ensure the query doesn't get too long numAppMaxSearchKeywords = GetAppVar("maxsearchkeywords") numAppMaxSearchKeywordLength = GetAppVar("maxsearchkeywordlength") If strSearchCriteria = "exact" then 'Treat the whole thing like one keyword CleanSearchKeywords = Left(strNewKeywords, numAppMaxSearchKeywordLength) Else 'Validate each keyword aryAllKeywords = Split(strNewKeywords, " ") Redim aryNewKeywords(Min(ubound(aryAllKeywords), numAppMaxSearchKeywords - 1)) For numCount = 0 to ubound(aryNewKeywords) aryNewKeywords(numCount) = Left(aryAllKeywords(numCount), numAppMaxSearchKeywordLength) Next CleanSearchKeywords = Join(aryNewKeywords, " ") End If End Function '----------------------------------------------- 'CREATE KEYWORD ARRAY 'Set the keywords array. If we're doing an exact, 'then it's a one bound array. If we have no 'keywords, then it's a one-bound blank array. 'Otherwise it has bound for each word. '----------------------------------------------- Function CreateKeywordArray(strKeywords, strSearchCriteria) If strKeywords = "" then 'Splitting a blank string doesn't return an array ReDim aryNewKeywords(0) aryNewKeywords(0) = "" ElseIf strSearchCriteria = "exact" then 'put it all in one bound ReDim aryNewKeywords(0) aryNewKeywords(0) = strKeywords Else 'Split by a space aryNewKeywords = Split(strKeywords, " ") End If CreateKeywordArray = aryNewKeywords End Function '*********************************************** '*********************************************** 'CACTUSHOP-SPECIFIC FUNCTIONS 'Specific functions useful in one or more places 'in the cactushop software '*********************************************** '----------------------------------------------- 'ADD TO MAILING LIST 'This function adds the passed email address to 'the mailing list database. It then sends a 'confirmation email to the user that they need 'to click on to authorize themselves. It 'returns and error message if it fails '----------------------------------------------- Function AddToMailingList(strEmailAddress, blnHTML, objRS) Dim strBodyText 'Check whether they already exist strQuery = "SELECT COUNT(*) FROM tblCactuShop" & TABLE_PREFIX & "Customers WHERE C_EmailAddress=" & strUnicode & "'" & SQLSafe(strEmailAddress) & "' AND C_ML_ConfirmationDateTime>" & strDateDelimiter & ReverseDate("1/1/1900") & strDateDelimiter If clng(ExecuteScalar(strQuery)) > 0 then AddToMailingList = CreateError(GetString("ContentText_EmailAlreadySignedUp")) Else 'There are two possibilities '1. They have an account but it is currently set to NOT be on mailing list '- In this case, we adjust existing record and add signup info, try to get confirmation '2. They don't have an account yet '- In this case, we create the account and try to get confirmation numPasswordLength = GetAppVar("minimumcustomercodesize") If numPasswordLength = 0 then numPasswordLength = 8 C_ML_RandomKey = GetRandomString(numPasswordLength) 'this key is used later to validate confirmation - only the address owner will receive this strQuery = "SELECT COUNT(*) FROM tblCactuShop" & TABLE_PREFIX & "Customers WHERE C_EmailAddress='" & SQLSafe(strEmailAddress) & "'" If clng(ExecuteScalar(strQuery)) > 0 then '1. They have account so we need to do UPDATE query strQuery = "UPDATE tblCactuShop" & TABLE_PREFIX & "Customers SET " &_ "C_EmailAddress=" & strUnicode & "'" & SQLSafe(strEmailAddress) & "', " &_ "C_ML_SignupDateTime=" & strDateDelimiter & ReverseDate(NowOffset) & strDateDelimiter & ", " &_ "C_ML_SignupIP='" & objCactuSession.IP & "', " &_ "C_ML_RandomKey=" & strUnicode & "'" & C_ML_RandomKey & "', " &_ "C_ML_Format='" & IIf(blnHTML, "h", "t") & "', " &_ "C_LanguageID=" & NumSafe(numLanguageID) & " WHERE C_EmailAddress=" & strUnicode & "'" & SQLSafe(strEmailAddress) & "'" Else '2. No account - create one with an INSERT strQuery = "INSERT INTO tblCactuShop" & TABLE_PREFIX & "Customers (C_EmailAddress, C_Password, C_ML_SignupDateTime, C_ML_SignupIP, C_ML_RandomKey, C_ML_Format, C_LanguageID) VALUES (" & strUnicode & "'" & SQLSafe(strEmailAddress) & "', " & strUnicode & "'" & SQLSafe(C_ML_RandomKey) & "', " & strDateDelimiter & ReverseDate(NowOffset) & strDateDelimiter & ", '" & objCactuSession.IP & "', " & strUnicode & "'" & SQLSafe(C_ML_RandomKey) & "', '" & IIf(blnHTML, "h", "t") & "'," & CInt(numLanguageID) & ")" End if Call ExecuteNonQuery(strQuery) 'Get the ID C_ID = 0 strQuery = LimitSQL("C_ID FROM tblCactuShop" & TABLE_PREFIX & "Customers WHERE C_EmailAddress=" & strUnicode & "'" & SQLSafe(strEmailAddress) & "' AND C_ML_RandomKey=" & strUnicode & "'" & SQLSafe(C_ML_RandomKey) & "'" , 1, false) Do While C_ID = 0 Call ExecuteRS(strQuery, objRecordSet) if not (objRecordSet.bof and objRecordSet.eof) then C_ID = objRecordSet("C_ID") end if objRecordSet.close loop 'Send email to signup strBodyText = GetString("EmailText_NewsletterSignup") & vbcrlf & vbcrlf &_ "xxxWEBSHOPURLxxxa.asp?id=" & C_ID & "&r=" & C_ML_RandomKey & vbcrlf & vbcrlf &_ GetString("EmailText_NewsletterAuthorizeFooter") strBodyText = replace(strBodyText, "xxxIPADDRESSxxx", objCactuSession.IP) strBodyText = replace(strBodyText, "xxxWEBSHOPNAMExxx", GetString("Config_Webshopname")) strBodyText = replace(strBodyText, "xxxWEBSHOPURLxxx", GetAppVar("webshopurl")) Call SendEMail(GetAppVar("emailmethod"), GetAppVar("mailserver"), strEmailAddress, "", "", strEmailFrom, GetString("Config_OwnerName"), strEmailFrom, GetString("Config_OwnerName"), GetString("Config_Subjectline3"), strBodyText, "", false) End If End Function '----------------------------------------------- 'CLEAN CARD NUMBER 'Removes any oft-used characters from a 'credit card number '----------------------------------------------- Function CleanCardNumber(strCreditCard) If strCreditCard <> "" then strCreditCard = replace(strCreditCard, " ", "") strCreditCard = replace(strCreditCard, "/", "") strCreditCard = replace(strCreditCard, "-", "") strCreditCard = replace(strCreditCard, ".", "") End if CleanCardNumber = strCreditCard End Function '----------------------------------------------- 'LUHNCHECK TO PRE-CHECK CREDIT CARD NUMBER 'A Luhncheck will only determine is a credit 'card number is of the correct format. It will 'not detect fraudulent use of cards or any other 'such errors or misuse. There is a switch in the 'config settings. This way you can bang in random 'numbers during testing and not keep getting 'errors. '----------------------------------------------- Function LuhnCheck(strCreditCard) strCard = CleanCardNumber(strCreditCard) if NumSafe(strCard) = 0 then LuhnCheck = false else numLength = len(strCard) For numPlace = 0 to numLength - 1 strRealPlace = numLength - numPlace if numPlace mod 2 <> 0 then numTempValue = Mid(strCard, strRealPlace, 1) * 2 else numTempValue = Mid(strCard, strRealPlace, 1) end if strNewString = strNewString & numTempValue Next numTempValue = 0 numLength = len(strNewString) For numPlace = 1 to numLength numTempValue = numTempValue + Mid(strNewString, numPlace, 1) Next if (numTempValue mod 10) = 0 then LuhnCheck = true else LuhnCheck = false end if End Function '----------------------------------------------- 'GET COUNTRY STRING 'Accepts the ID of the destination record and 'the language (plus db connection info), 'and returns the destination name '----------------------------------------------- Function GetCountryString(numID, numLanguage) 'Pull out the country name Set objRecordSetCountry = Server.CreateObject("ADODB.Recordset") strQuery = "SELECT D_Destination" & CStr(numLanguage) & " FROM tblCactuShop" & TABLE_PREFIX & "Destination WHERE D_ID = " & numID Call ExecuteRS(strQuery, objRecordSetCountry) strCountry = objRecordSetCountry("D_Destination" & CStr(numLanguage)) objRecordSetCountry.Close Set objRecordSetCountry = nothing 'And return it GetCountryString = strCountry End Function '----------------------------------------------- 'ADD TO RECENT PRODUCTS / GET RECENT PRODUCTS 'Note that we don't limit the array to the '"recentproducts" '----------------------------------------------- Sub SaveToRecentProducts(strID) numID = NumSafe(strID) If numID > 0 then 'Get the recent products list - note that we set a large max - we 'dont want to use the config setting because some may be removed 'later on in the SQL query, and we still want up to a possible 5. numAppRecentProducts = GetAppVar("recentproducts") strRecentProducts = "," & GetRecentProducts(50, 0) & "," If strRecentProducts = ",," then strRecentProducts = "," 'If it's already in it - remove it so it goes to the start If instr(strRecentProducts, "," & numID & ",") > 0 then strRecentProducts = Replace(strRecentProducts, "," & numID & ",", ",") End If 'Add it on to the front of the list and save to cactusession, triming the trailing , strRecentProducts = left(strRecentProducts, len(strRecentProducts) - 1) strRecentProducts = numID & strRecentProducts objCactuSession.Edit "recentproducts", strRecentProducts end if End Sub 'Get the products, check validity, and return a comma-delimited string. 'Optionally pass an ID to exclude. Function GetRecentProducts(numMax, numExclude) aryRecentProducts = Split(objCactuSession.Value("recentproducts"), ",") For Each strRecentProduct in aryRecentProducts numRecentProduct = NumSafe(strRecentProduct) If numRecentProduct > 0 and Occurrences(strRecentProducts, ",") + 1 < numMax and numRecentProduct <> numExclude then strRecentProducts = IIf(strRecentProducts = "", numRecentProduct, strRecentProducts & "," & numRecentProduct) End If Next GetRecentProducts = strRecentProducts End Function '----------------------------------------------- 'ADMIN LOG 'Lots an event - such as a config or language- 'string change - to the database '----------------------------------------------- Function AdminLog(AL_Type, AL_Description, AL_Query, AL_RelatedID) AL_DateStamp = NowOffset() AL_LoginID = numThisUserLOGIN_ID strQuery = "INSERT INTO tblCactuShop" & TABLE_PREFIX & "AdminLog (AL_DateStamp, AL_LoginID, AL_Type, AL_Description, AL_Query, AL_RelatedID, AL_IP) VALUES (" & strDateDelimiter & ReverseDate(AL_DateStamp) & strDateDelimiter & "," & NumSafe(AL_LoginID) & ",'" & SQLSafe(AL_Type) & "'," & strUnicode & "'" & SQLSafe(AL_Description) & "'," & strUnicode & "'" & SQLSafe(AL_Query) & "','" & SQLSafe(AL_RelatedID) & "', '" & request.ServerVariables("REMOTE_ADDR") & "')" Call ExecuteNonQuery(strQuery) End Function '----------------------------------------------- 'LOG SALE 'Lots a version sale. Only do this if tracking 'is turned on '----------------------------------------------- Function LogSale(numVersionID, numQuantity) if GetAppVar("trackingsales") = "y" then strQuery = "INSERT INTO tblCactuShop" & TABLE_PREFIX & "VersionSalesStats (VSS_VersionID, VSS_Quantity, VSS_Date, VSS_IP) VALUES (" & _ NumSafe(numVersionID) & "," & _ NumSafe(numQuantity) & "," &_ strDateDelimiter & ReverseDate(NowOffset()) & strDateDelimiter & "," &_ "'" & SQLSafe(objCactuSession.IP) & "')" Call ExecuteNonQuery(strQuery) End if End Function '----------------------------------------------- 'UPDATE PRODUCT AVERAGE 'This updates the static product customer rating 'average. '----------------------------------------------- Sub UpdateProductAverage(numProductID) strQuery = "UPDATE tblCactuShop" & TABLE_PREFIX & "Products SET P_AverageRating = " & GetProductAverage(numProductID) & " WHERE P_ID = " & NumSafe(numProductID) Call ExecuteNonQuery(strQuery) End Sub Function GetProductAverage(numProductID) strQuery = "SELECT Round(SUM(REV_Rating) / COUNT(*), 1) As AverageRating FROM tblCactuShop" & TABLE_PREFIX & "Reviews WHERE REV_ProductID = " & numProductID & " AND REV_Rating > 0 AND REV_Live = 'y'" GetProductAverage = NearestHalfInteger(NumSafe(ExecuteScalar(strQuery))) End Function 'Founds a value to the nearest half - e.g. 0, 0.5, 1, etc Function NearestHalfInteger(numValue) numMainPart = Int(numValue) numFractionalPart = numValue - numMainPart If numFractionalPart < 0.25 then numNewFractionalPart = 0 ElseIf numFractionalPart < 0.75 then numNewFractionalPart = 0.5 Else numNewFractionalPart = 1 End If NearestHalfInteger = numMainPart + numNewFractionalPart End Function '----------------------------------------------- 'GET COUNTRY CODE '----------------------------------------------- Function GetCountryCode(numShippingCountry) strQuery = "SELECT D_ISOCode FROM tblCactuShop" & TABLE_PREFIX & "Destination WHERE D_ID=" & NumSafe(numShippingCountry) Call ExecuteRS(strQuery, objRecordSet) If not (objRecordSet.BOF and objRecordSet.EOF) Then GetCountryCode = objRecordSet("D_ISOCode") end if objRecordSet.Close End Function 'GET KB REDIRECT 'Returns the URL to redirect to the knowledgebase Function GetRedirect(strID) GetRedirect = "http://www.cactushop.com/requests/redirect/?t=" & strID End Function '*********************************************** '*********************************************** 'NEW ERROR CHECKING FUNCTIONS 'Validates data '*********************************************** 'Create a formatted error Function CreateError(strError) CreateError = "
  • " & strError & "
  • " & vbcrlf End Function 'Create a label Function CreateLabel(strName, strLabel) CreateLabel = "" End Function 'Create error with token in language string Function CreateErrorWithLabel(strError, strName, strLabel) CreateErrorWithLabel = CreateError(Replace(strError, "