<% const upshashkey = "oiYhaTdaDa" dim pos,workrecord,words(2000),wordloc,wordcount,morewords Dim statuscode, statusmessage dim myconn 'VP-ASP 6.50 - Handle UPS 2007 Web Services Changes Dim ignoreerror ignoreerror = True Sub AnalyzeXML If getupsconfig("xtracexml",false, myconn)="Yes" then debugwrite "Data returned" debugwrite server.htmlencode(result) end if pos=0 Workrecord= Replace(result,"<","~") Workrecord= Replace(workrecord,">","~") Parserecord workrecord, words, Wordcount,"~" 'debugwrite "wordcount=" & wordcount wordloc=0 morewords=TRUE do while morewords=TRUE ' debugwrite "wordloc=" & wordloc ' debugwrite "words=" & words(wordloc) ProcessWord Words(wordloc) wordloc=wordloc+1 If wordloc>wordcount then morewords=false end if Loop If Statuscode<>"1" then xmlerror = "ERROR: DATA RETRIEVAL FAILED" end if end sub Sub AnalyzeLicenseRequestXML If getupsconfig("xtracexml",false, myconn)="Yes" then debugwrite "Data returned" debugwrite server.htmlencode(result) end if pos=0 Workrecord= Replace(result,"<","~") Workrecord= Replace(workrecord,">","~") Parserecord workrecord, words, Wordcount,"~" 'debugwrite "wordcount=" & wordcount wordloc=0 morewords=TRUE do while morewords=TRUE ' debugwrite "wordloc=" & wordloc ' debugwrite "words=" & words(wordloc) ProcessWord Words(wordloc) wordloc=wordloc+1 If wordloc>wordcount then morewords=false end if Loop If statusmessage = "Invalid license for the tool" then xmlerror = "ERROR: You need to re-register with UPS." end if If Statuscode<>"1" then xmlerror = "ERROR: DATA RETRIEVAL FAILED" end if end sub Sub Processword (fieldname) Dim tempoption, tempprice, ufieldname dim code,shippingmethod ufieldname=ucase(fieldname) Select Case uFieldname Case "USERID" Morewords=FALSE Statusmessage=words(wordloc+1) exit sub Case "RESPONSESTATUSCODE" Statuscode=words(wordloc+1) wordloc=wordloc+1 exit sub Case "ERRORCODE" Statuscode=words(wordloc+1) wordloc=wordloc+1 exit sub Case "RESPONSESTATUSDESCRIPTION" StatusMessage=words(wordloc+1) wordloc=wordloc+1 exit sub Case "/RATEDSHIPMENT" shippingcount=shippingcount+1 wordloc=wordloc+1 exit sub Case "DELIVERYDATE" ShippingDates(shippingcount)=words(wordloc+1) wordloc=wordloc+1 exit sub Case "RATEDSHIPMENT" wordloc=wordloc+5 code=words(wordloc) ServiceType=Convertshippingcode(code) wordloc=wordloc+1 ChargesFound=false exit sub Case "/RATEDPACKAGE" AddServicePrice servicetype, serviceprice, servicedate wordloc=wordloc+1 exit sub Case "TOTALCHARGES" ' tempoption=ShippingMethods(shippingcount) wordloc=wordloc+6 If chargesfound=false then ServicePrice=words(wordloc+1) wordloc=wordloc+1 chargesfound=true end if exit sub Case "/RATINGSERVICESELECTIONRESPONSE" MoreWords=False wordloc=wordloc+1 exit sub 'VP-ASP 6.50 - handle UPS 2007 changes Case "ERRORDESCRIPTION" If Not ignoreerror Then MoreWords=FALSE Statusmessage=words(wordloc+1) & "
" End If exit sub Case "ERRORSEVERITY" If UCase(words(wordloc+1)) = "WARNING" Then ignoreerror = True Else ignoreerror = False End If Exit sub Case "ACCESSLICENSETEXT" MoreWords=FALSE Statusmessage=words(wordloc+1) exit sub Case "ACCESSLICENSENUMBER" MoreWords=FALSE Statusmessage=words(wordloc+1) exit sub End select end sub Sub AddUPSAccessKeyToConfig dim sql, rs 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then sql = "select * from ups_config limit 0,1" else sql = "select TOP 1 * from ups_config" end if Set rs = Server.CreateObject("ADODB.RecordSet") rs.open SQL, myconn, adOpenKeyset, adLockOptimistic, adcmdText if not rs.eof then 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then 'VP-ASP 6.50 - precautionary security fix sql = "update ups_config set xupsacctno = '" & cleanchars(request("upsaccountno")) & "', AccessLicenceNum = '" & replace(EnDeCrypt(statusmessage,upshashkey), "'", "''") & "'" myconn.execute sql else 'VP-ASP 6.50 - precautionary security fix rs("xupsacctno") = cleanchars(request("upsaccountno")) rs("AccessLicenceNum") = EnDeCrypt(statusmessage,upshashkey) rs.update end if end if closerecordset rs ' ReloadConfig ' sql = "update ups_config set xupsacctno = '" & request("upsaccountno") & "', AccessLicenceNum = '" & EnDeCrypt(statusmessage,upshashkey) & "'" ' myconn.execute(sql) End Sub Sub AddUPSUserDataToConfig dim sql, rs 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then sql = "select * from ups_config limit 0,1" else sql = "select TOP 1 * from ups_config" end if Set rs = Server.CreateObject("ADODB.RecordSet") rs.open SQL, myconn, adOpenKeyset, adLockOptimistic, adcmdText if not rs.eof then 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then sql = "update ups_config set username = '" if ucase(statusmessage) <> "SUCCESS" then sql = sql & EnDeCrypt(statusmessage, upshashkey) & "', " else sql = sql & EnDeCrypt(getsess("username"), upshashkey) & "', " end if sql = sql & "Password = '" & EnDeCrypt(getsess("password"), upshashkey) & "'" myconn.execute sql else if ucase(statusmessage) <> "SUCCESS" then rs("Username") = EnDeCrypt(statusmessage, upshashkey) else rs("Username") = EnDeCrypt(getsess("username"), upshashkey) end if rs("Password") = EnDeCrypt(getsess("password"), upshashkey) rs.update end if end if closerecordset rs ' ReloadConfig ' sql = "update ups_config set username = '" & statusmessage & "', Password = '" & getsess("password") & "'" ' myconn.execute(sql) End Sub Sub AddUPSToShipMethods dim sql, rs 'CHECK IF UPS ALREADY EXISTS IN SHIPEMTHODS TABLE sql="select * from shipmethods where shiproutine = 'upsxmlrealtime.asp'" set rs=myconn.execute(sql) 'IF NOT, ADD IT if rs.eof then sql = "insert into shipmethods (shipmethod,shiproutine, shipcountry) VALUES ('UPS Real-Time','upsxmlrealtime.asp', 'other')" end if set rs=myconn.execute(sql) 'UPDATE SHIPPINGCALC IN CONFIG TO BE OTHER - NOT REQUIRED FOR 600 'sql = "update configuration set fieldvalue = 'other' WHERE fieldname = 'xshippingcalc'" 'set rs=myconn.execute(sql) 'ReloadConfig set rs = nothing End Sub Sub RemoveUPSFromConfig dim sql, rs 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then sql = "select * from ups_config limit 0,1" else sql = "select TOP 1 * from ups_config" end if Set rs = Server.CreateObject("ADODB.RecordSet") rs.open SQL, myconn, adOpenKeyset, adLockOptimistic, adcmdText if not rs.eof then 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then sql = "update ups_config set xupsacctno = '', AccessLicenceNum = '', username = '', password = ''" myconn.execute sql else rs("xupsacctno") = "" rs("AccessLicenceNum") = "" rs("Username") = "" rs("Password") = "" rs.update end if end if closerecordset rs sql = "delete from shipmethods WHERE shiproutine = 'upsxmlrealtime.asp'" set rs=myconn.execute(sql) set rs = nothing 'reloadconfig 'ReloadConfig End Sub Sub RequestLicense Dim xmlstring 'Create request doc xmlstring=xmlstring&"" ' xmlstring=xmlstring&"" xmlstring=xmlstring&"" xmlstring=xmlstring&"" xmlstring=xmlstring&"EULA Text" xmlstring=xmlstring&"1.0001" xmlstring=xmlstring&"" xmlstring=xmlstring&"AccessLicense" xmlstring=xmlstring&"AllTools" xmlstring=xmlstring&"" xmlstring=xmlstring&"" & GetUPSConfig("developerkey", true, myconn) & "" xmlstring=xmlstring&"" xmlstring=xmlstring&"US" xmlstring=xmlstring&"FR" xmlstring=xmlstring&"" xmlstring=xmlstring&"" xmlstring=xmlstring&"TrackXML" xmlstring=xmlstring&"1.0" xmlstring=xmlstring&"" xmlstring=xmlstring&"" xmlstring=xmlstring&"RateXML" xmlstring=xmlstring&"1.0" xmlstring=xmlstring&"" xmlstring=xmlstring&"" Shopxmlhttp getupsconfig("xml",false, myconn), getupsconfig("gatewaylocation_license",false, myconn), xmlstring, result, "POST", xmlerror ' dim xmlString ' xmlString = "" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "License Test" ' xmlString = xmlstring & "1.0001" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "AccessLicense" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "FBD953535386AF70" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "US" ' xmlString = xmlstring & "FR" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "" ' xmlString = xmlstring & "RateXML" ' xmlString = xmlstring & "1.0" ' xmlString = xmlstring & "" 'xmlString = xmlstring & "" ' Shopxmlhttp getupsconfig("xml",false, myconn), getupsconfig("gatewaylocation_license",false, myconn), xmlstring, result, "POST", xmlerror End Sub Function GetUPSConfig (fieldname, encrypted, myconn) dim sql, upsrs, tempconfig, upsconn sql="select " & fieldname & " from ups_config" set upsrs=myconn.execute(sql) 'VP-ASP 6.09 - changed this IF from one line to two for greater accuracy 'if (NOT upsrs.eof) AND (upsrs(fieldname) > "") then if NOT upsrs.eof Then If upsrs(fieldname) > "" then if encrypted = true then tempconfig = EnDeCrypt(upsrs(fieldname),upshashkey) else tempconfig = upsrs(fieldname) end if End If end if closerecordset upsrs GetUPSConfig = tempconfig end function Sub AccessLicenseRequest RequestLicense if result > "" then ' upslicense = cstr(result) ' upslicense = right(upslicense, len(upslicense) - instr(upslicense, "") - 18) ' upslicense = left(upslicense, instrrev(upslicense, "") - 1) Dim xmldoc Set xmlDoc = Server.CreateObject("MSXML2.DOMDocument") xmlDoc.async = False If xmlDoc.loadxml(result) Then xmlDoc.setProperty "SelectionLanguage", "XPath" Set upslicense = xmlDoc.selectSingleNode("AccessLicenseAgreementResponse/AccessLicenseText") else response.write "LICENSE ERROR reading XML: " & xmldoc.parseError.reason & " (line: " & xmldoc.parseError.line & ")" response.end statuscode = 0 exit sub end if else response.write "LICENSE ERROR reading result" response.end statuscode = 0 exit sub end if xmlstring = xmlstring & "" ' encoding=""ISO-8859-1"" xmlstring = xmlstring & "" ' xml:lang=""en-US"" xmlstring = xmlstring & "" xmlstring = xmlstring & "" xmlstring = xmlstring & "Access Key Request" xmlstring = xmlstring & "1.0001" xmlstring = xmlstring & "" xmlstring = xmlstring & "AccessLicense" xmlstring = xmlstring & "AllTools" xmlstring = xmlstring & "" xmlstring = xmlstring & ""& getsess("companyname")&"" xmlstring = xmlstring & "
" xmlstring = xmlstring & ""& getsess("streetaddress")&"" xmlstring = xmlstring & ""& getsess("City")&"" xmlstring = xmlstring & ""&getsess("strState")&"" xmlstring = xmlstring & ""&getsess("PostalCode")&"" xmlstring = xmlstring & ""&getsess("strCountry")&"" xmlstring = xmlstring & "
" xmlstring = xmlstring & "" xmlstring = xmlstring & ""& getsess("ContactName")&"" xmlstring = xmlstring & ""& getsess("Title")&"" xmlstring = xmlstring & ""&getsess("phonenumber")&"" xmlstring = xmlstring & ""&getsess("emailaddress")&"" xmlstring = xmlstring & "" xmlstring = xmlstring & ""&getsess("websiteurl")&"" xmlstring = xmlstring & ""&getsess("upsaccountno")&"" xmlstring = xmlstring & "" & GetUPSConfig("developerkey", true, myconn) & "" xmlstring = xmlstring & "" xmlstring = xmlstring & ""&getsess("strCountry")&"" xmlstring = xmlstring & "EN" xmlstring = xmlstring & ""& Server.HTMLEncode(upslicense.nodeTypedValue) &"" xmlstring = xmlstring & "" xmlstring = xmlstring & "" xmlstring = xmlstring & "TrackXML" xmlstring = xmlstring & "1.0" xmlstring = xmlstring & "" xmlstring = xmlstring & "" xmlstring = xmlstring & "RateXML" xmlstring = xmlstring & "1.0" xmlstring = xmlstring & "" xmlstring = xmlstring & "" xmlstring = xmlstring & ""&getsess("upscontact")&"" xmlstring = xmlstring & "VP-ASP" xmlstring = xmlstring & "Rock Salt International Pty Ltd" xmlstring = xmlstring & "6.00" xmlstring = xmlstring & "" xmlstring = xmlstring & "" Shopxmlhttp getupsconfig("xml",false, myconn), getupsconfig("gatewaylocation_license",false, myconn), xmlstring, result, "POST", xmlerror AnalyzeLicenseRequestXML ' xmlstring ="" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "License Test" ' xmlstring = xmlstring & "1.0001" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "AccessLicense" ' xmlstring = xmlstring & "AllTools" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "" & request("companyname") & "" ' xmlString = xmlstring & "
" ' xmlString = xmlstring & "" & request("streetaddress") & "" ' xmlString = xmlstring & "" & request("city") & "" ' xmlString = xmlstring & "" & request("strstate") & "" ' xmlString = xmlstring & "" & request("postalcode") & "" ' xmlString = xmlstring & "" & request("strcountry") & "" ' xmlString = xmlstring & "
" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "" & request("contactname") & "" ' xmlString = xmlstring & "" & request("title") & "" ' xmlString = xmlstring & "" & request("emailaddress") & "" ' xmlString = xmlstring & "" & request("phonenumber") & "" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "" & request("websiteurl") & "" ' xmlstring = xmlstring & "" & request("upsaccountno") & "" ' xmlstring = xmlstring & "" & GetUPSConfig("developerkey", true, myconn) & "" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "US" ' xmlstring = xmlstring & "EN" ' xmlstring = xmlstring & "" & upslicense.text ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & "RateXML" ' xmlstring = xmlstring & "1.0" ' xmlstring = xmlstring & "" ' xmlstring = xmlstring & ""' '' ' Shopxmlhttp getupsconfig("xml",false, myconn), getupsconfig("gatewaylocation_license",false, myconn), xmlstring, result, "POST", xmlerror ' AnalyzeXML End Sub Sub AddFormToSession 'VP-ASP 6.50 - precautionary security fix setsess "contactname", cleanchars(request("contactname")) setsess "title", cleanchars(request("title")) setsess "companyname", cleanchars(request("companyname")) setsess "streetaddress", cleanchars(request("streetaddress")) setsess "city", cleanchars(request("city")) setsess "strState", cleanchars(request("strState")) setsess "strCountry", cleanchars(request("strCountry")) setsess "postalcode", cleanchars(request("postalcode")) setsess "phonenumber", cleanchars(request("phonenumber")) setsess "websiteurl", cleanchars(request("websiteurl")) setsess "emailaddress", cleanchars(request("emailaddress")) setsess "upsaccountno", cleanchars(request("upsaccountno")) setsess "upscontact", cleanchars(request("upscontact")) End Sub Sub LicenseError %>
There has been an error:
<%=statusmessage%>
Please click the Back button on your browser to try again.

UPS, UPS brandmark, and the Color Brown are trademarks of United Parcel Service of America, Inc. All Rights Reserved.
<% End sub Sub RegistrationRequest Dim xmlstring 'Create request doc xmlstring=xmlstring&"" xmlstring=xmlstring&"" xmlstring=xmlstring&"" xmlstring=xmlstring&"" xmlstring=xmlstring&"x893" xmlstring=xmlstring&"1.0001" xmlstring=xmlstring&"" xmlstring=xmlstring&"Register" xmlstring=xmlstring&"suggest" xmlstring=xmlstring&"" setsess "username", generaterandomthing xmlstring=xmlstring&"" & getsess("username") & "" setsess "password", generaterandomthing xmlstring=xmlstring&"" & getsess("password") & "" xmlstring=xmlstring&"" xmlstring=xmlstring&"" & getsess("contactname") & "" xmlstring=xmlstring&"" & getsess("companyname") & "" xmlstring=xmlstring&"" & getsess("title") & "" xmlstring=xmlstring&"
" xmlstring=xmlstring&"" & getsess("streetaddress") & "" xmlstring=xmlstring&"" & getsess("city") & "" xmlstring=xmlstring&"" & getsess("strstate") & "" xmlstring=xmlstring&"" & getsess("postalcode") & "" xmlstring=xmlstring&"" & getsess("strcountry") & "" xmlstring=xmlstring&"
" xmlstring=xmlstring&"" & getsess("phonenumber") & "" xmlstring=xmlstring&"" & getsess("emailaddress") & "" xmlstring=xmlstring&"" & getsess("upsaccountno") & "" xmlstring=xmlstring&"" & getsess("postalcode") & "" xmlstring=xmlstring&"" & getsess("strcountry") & "" xmlstring=xmlstring&"" xmlstring=xmlstring&"" Shopxmlhttp getupsconfig("xml",false, myconn), getupsconfig("gatewaylocation_register",false, myconn), xmlstring, result, "POST", xmlerror AnalyzeXML End Sub Function generaterandomthing dim randomnumber randomize() randomnumber = Int((9999 - 1000 + 1) * Rnd + 1000) generateRandomThing = left(replace(getsess("contactname")," ",""), 3) & randomnumber & left(replace(getsess("phonenumber"), " ", ""), 3) end Function Sub AddMerchantInfoToConfig dim sql, rs 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then sql = "select * from ups_config limit 0,1" else sql = "select TOP 1 * from ups_config" end if Set rs = Server.CreateObject("ADODB.RecordSet") rs.open SQL, myconn, adOpenKeyset, adLockOptimistic, adcmdText if not rs.eof then 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then 'VP-ASP 6.50 - precautionary security fix sql = "update ups_config set xMerchantCountry = '" & cleanchars(request("strCountry")) & "', xMerchantState = '" & cleanchars(request("strState")) & "', " sql = sql & "xMerchantCity = '" & cleanchars(request("city")) & "', xMerchantPostcode = '" & cleanchars(request("postalcode")) & "'" myconn.execute sql else 'VP-ASP 6.50 - precautionary security fix rs("xMerchantCountry") = cleanchars(request("strCountry")) rs("xMerchantState") = cleanchars(request("strState")) rs("xMerchantCity") = cleanchars(request("city")) rs("xMerchantPostcode") = cleanchars(request("postalcode")) rs.update end if end if closerecordset rs End Sub Sub ReloadConfig() dim initname initname="init" & "_" & xshopid application(initname)="" LoadApplicationVariables setconfig shoplcname,"" End Sub %>