<%
const CVNDisplay="Yes"
const CVNRequired="No"
const xcardissuenumber="No"
const MYSITE="" ' CHANGE THIS TO BE YOUR WEB ADDRESS - ALWAYS HAVE A FORWARD SLASH AT THE END
const xEncryptkey="agabAhjBcG" ' YOU MUST CHANGE THIS TO MATCH THE xencryptkey SETTING IN THE SHOP$CONFIG.ASP FILE
const xlanguage="" ' INSERT DEFAULT LANGUAGE HERE
Const Creditcards="Visa,Mastercard,American Express"
Const Otherpayments="Check,Cash,Phone Order"
Const AllowCreditCards="Yes" ' Select credit Cards
const AllowOtherPayment="Yes" ' Other payment types
Const AllowInvalidCreditCards="No" ' validate credit card information
'**************************************************************************
' Version 6.50 obtain Payment details Avoid security popup
' Used when SSL is on a different Server.
' Goes to sslresult.asp Task=CC, task=NOCC, task=Cancel
' oid=nnn
' add solo, switch and new subroutine to validate credit cards
' Sept 11, 2004 fix setsess lang
'*************************************************************************
' Change this line
'
Dim PaymentURL, resultinfo
Dim Serror
Dim CardTypes(10),OtherTypes(10),OtherCount,CardCount
Parserecord creditcards, cardtypes, cardcount,","
Parserecord otherpayments, othertypes, othercount,","
PaymentURL= MYSITE & "sslresult.asp" ' to authorize payment
dim oid
dim dbc
dim rstemp
Dim strOcardtype
Dim strOcardno
Dim strOcardname
Dim strOcardexpires
Dim strOcardaddress
Dim strOOther
Dim StroMore
Dim StrOAuthorization
dim strOCardCVN
Dim strvalidfrom,strocardissue
Dim sAction
dim strocardmm,strocardyy
dim websess
'
SetSess "CurrentURL","sslshopcheckout.asp"
GetOrderInfo ' get orderid
sError=Session("PaymentError") ' on return for authorization there may be an error
SetSess "PaymentError","" ' reset
sAction=Request.form("Action")
If sAction = "" Then
NewShopPageHeader ' put out normal header
DisplayForm() ' credit card form
NewShopPagetrailer ' trailer
Else
GetFormFields
ValidateData
if sError = "" Then
UpdateCreditInfo ' add payment to daat base
GenerateLink paymenturl & "?" & Resultinfo
'response.write PaymentURL & "?" & ResultInfo
else
NewShopPageHeader
DisplayForm
NewShopPageTrailer
end if
end if
Sub DisplayForm
Response.Write(largeinfofont & LangCheckout01 & largeinfoend & " ")
If SError<>"" then
Response.Write(errorfontstart & " " & sError & errorfontend)
end if
AddCreditCard
DisplayOtherPayment
Displaycancelbutton
End Sub
'
Sub AddCreditCard
If AllowCreditCards<>"Yes" then exit sub
'AddCreditImages
Response.Write(""
end Sub
'
'***************************************************
' Non credit card form
'***************************************************
Sub DisplayOtherPayment
If AllowOtherPayment<>"Yes" Then exit sub
Response.Write(""
end Sub
'***************************************************
' Non credit card form
'***************************************************
Sub DisplayCancelButton
Response.Write(""
end Sub
Sub GetorderInfo
' Either comes on querystring or on rentry is in session variables
oid=request("oid")
'VP-ASP 6.50 - precautionary security fix
if not isnumeric(oid) then oid = ""
exit sub
if oid="" then
oid=Session("oid")
else
Session("oid") = oid
end if
If oid="" then
' Response.Redirect MYSITE & "/shoperror.asp?msg=" & Server.URLEncode (LangCheckoutProcessed)
end if
end sub
'
Sub ValidateData
' see if user cancelled order
dim rc, action
dim cancelaction
action = ucase(left(request.form("action"),6))
cancelaction=ucase(left(langCommonCancelOrder,6))
if action = cancelaction then
DeleteOrders ' delete order from database
response.redirect PaymentURL & "?" & ResultInfo
exit sub
end if
If stroCardtype=LangCommonSelect then
stroCardtype=""
end if
if stroOther=LangCommonSelect then
stroOther=""
end if
If stroOther="" and stroCardType="" then
sError=LangCheckoutError01 & " "
exit sub
end if
If AllowCreditCards="Yes" and stroCardtype<>"" Then
ValidateCreditCards
exit sub
end if
If AllowOtherPayment="Yes" and stroOther<>"" Then
ValidateOtherPayment
exit sub
end if
end sub
'
Sub ValidateOtherPayment
' No validate needed we just accept it
end sub
'
Sub ValidateCreditCards
If strOcardtype = "" then
sError = sError & LangCheckoutCardType & " "
End if
If strOcardno = "" Then
sError = sError & LangCheckoutCardNumber & " "
end if
If strOcardname = "" Then
sError = sError & LangCheckoutCardName & " "
End If
If strOcardexpires = "" Then
sError = sError & LangCheckoutExpiry & " "
end if
If strOcardaddress = "" Then
sError = sError & Langcheckoutaddress & " "
End If
If CVNRequired="Yes" and strOCardCVN = "" Then
sError = sError & LangcheckoutCVN & " "
end if
If Serror<>"" then
Serror = LangCommonrequired & " " & Serror
exit sub
end if
VerifyCreditCard
ValidateExpiry
ValidateCVN
ValidateSwitch
End Sub
'
Sub VerifyCreditCard
If AllowInvalidCreditCards="Yes" then
exit sub
end if
ShopValidatecreditcard strocardno, strocardtype, serror
end sub
' add credit card info to order
Sub UpdateCreditInfo
dim hashkey, CVN
dim oauthorization
hashkey=xEncryptKey
dim temp
if strOCardType<> "" then
' Credit card
Resultinfo="Task=CC&oid=" & oid
UpdateField "Ocardtype",strOcardtype
temp=enDecrypt(strocardno, hashkey)
temp=Converttoplain(temp)
UpdateField "Ocardno",temp
UpdateField "Ocardname", strocardname
UpdateField "Ocardexpires",strOcardexpires
UpdateField "Ocardaddress", strOcardaddress
if strOCardCVN<>"" then
CVN="CVN " & stroCardCVN
oauthorization=cvn
end if
if strocardissue<>"" Then
If oauthorization="" Then
oauthorization=langcardissue &"=" & strocardissue
else
oauthorization=oauthorization & " " & langcardissue &"=" & strocardissue
end if
end if
if strvalidfrom<>"" then
oauthorization=oauthorization & " " & langvalidfromdate &"=" & strvalidfrom
end if
UpdateField "OAuthorization", oauthorization
else
' Other payment
Resultinfo="Task=NOCC&oid=" & oid
UpdateField "Ocardtype",strOOther
UpdateField "Ocardname", strOMore
end if
UpdateField "websess", websess
End Sub
'
Sub UpdateField (fieldname, fieldvalue)
if fieldvalue="" then
exit sub
end if
Resultinfo=Resultinfo & "&" & fieldname & "=" & Server.urlencode(fieldvalue)
end sub
'
Sub DeleteOrders
resultinfo="Task=Cancel&oid=" & Session("oid")
end sub
'
Sub GetFormFields
'VP-ASP 6.50 - precautionary security fix
strOcardtype = cleanchars(Request.Form("strOcardtype"))
strOcardno = cleanchars(Request.Form("strOcardno"))
strOcardname = cleanchars(Request.Form("strOcardname"))
strOcardmm = cleanchars(Request.Form("strOcardmm"))
strOcardyy = cleanchars(Request.Form("strOcardyy"))
strocardexpires=strocardmm & "/" & strocardyy
strOcardaddress = cleanchars(Request.Form("strOcardaddress"))
StroOther=cleanchars(Request.Form("stroOther"))
StroMore=cleanchars(Request.form("StroMore"))
stroCardcvn=cleanchars(request.form("strOCardCVN"))
stroCardIssue=cleanchars(request.form("strOCardIssue"))
strvalidfrom=cleanchars(request.form("strvalidfrom"))
websess=cleanchars(request("websess"))
End Sub
Sub NewShopPageHeader
%>
Shopping Cart Secure Checkout
<%
end sub
Sub NewShopPageTrailer
%>
<%
End Sub
Sub GenerateSelectNV (iFieldnames,currentvalue,selectname, count,firstfield)
' Generates select with no values
dim i
%>
<%
end sub
Function LanguageGet
if session("Language")="" then
Setsess "Language",xlanguage
end if
languageGet=Session("Language")
end function
'*****************************************************
' Validate credit cards
' VP-ASP 5.00
'*****************************************************
Sub ShopValidatecreditcard (strocardno, strocardtype, serror)
dim cctype, ctype, cclength, ccprefix, prefixes, lengths
dim ccNumber, number, prefixvalid, lengthvalid, prefix
Dim cccheck, length, result, qsum, x, ch, sum, checkcc
dim testtype
ccType = ucase(Left(StrocardType,1))
testtype=left(strocardtype,5)
if testtype="DINER" then cctype=I
ccnumber=strocardno
ctype=ucase(cctype)
select case ctype
case "V" ' Visa
cclength="13;16"
ccprefix="4"
case "M" ' Mastercard
cclength="16"
ccprefix="51;52;53;54;55"
case "A" ' American express
cclength="15"
ccprefix="34;37"
case "I" ' Diners
cclength="14"
ccprefix="300;301;302;303;304;305;36;38"
case "D" ' discover/Novus
cclength="16"
ccprefix="6011"
case "E" ' ?
cclength="15"
ccprefix="2014;2149"
case "J" ' JCB
cclength="15;16"
ccprefix="3;2131;1800"
case "C" ' Connect
cclength="16"
ccprefix="4539"
case "S" ' Solo Switch
cclength="16;18;19" 'VP-ASP 6.50 - added extra card lengths
ccprefix="6759"
case "B" ' Bankcard
cclength="16"
ccprefix="5610"
case else
cclength=""
ccprefix=""
end select
prefixes=split(ccprefix,";",-1)
lengths=split(cclength,";",-1)
number=trimtodigits(ccnumber)
prefixvalid=false
lengthvalid=false
if ccprefix<>"" then
for each prefix in prefixes
if instr(number,prefix)=1 then
prefixvalid=true
end if
next
else
prefixvalid=true
end if
for each length in lengths
if cstr(len(number))=length then
lengthvalid=true
end if
next
result=0
if not prefixvalid then
result=result+1
end if
if not lengthvalid then
result=result+2
end if
qsum=0
for x=1 to len(number)
ch=mid(number,len(number)-x+1,1)
'response.write ch
if x mod 2=0 then
sum=2*cint(ch)
qsum=qsum+(sum mod 10)
if sum>9 then
qsum=qsum+1
end if
else
qsum=qsum+cint(ch)
end if
next
'response.write qsum
if qsum mod 10<>0 then
result=result+4
end if
if cclength="" then
result=result+8
end if
checkcc=result
if checkcc<> 0 then
SError= SError & LangCheckoutError02 & " "
exit sub
end if
if right(strocardno,8)="11111111" then
SError= SError & LangCheckoutError02 & " "
end if
end sub
function trimtodigits(tstring)
'removes all chars except of 0-9
s=""
ts=tstring
for x=1 to len(ts)
ch=mid(ts,x,1)
if asc(ch)>=48 and asc(ch)<=57 then
s=s & ch
end if
next
trimtodigits=s
end function
'VP-ASP 6.09 - replaced with a new sub which validates expiry dates
Sub ValidateExpiry_ARCHIVE
dim mm
dim yy
If len(strocardexpires)<>5 then
Serror = Serror & LangCheckoutExpiryError & " "
exit sub
end if
mm = left(strocardexpires,2)
yy=right(strocardexpires,2)
if not IsNumeric(mm) or Not Isnumeric(yy) then
Serror = Serror & LangCheckoutExpiryNum & " "
end if
end sub
Sub ValidateExpiry
dim mm
dim yy
dim yearnum, year
If len(strocardexpires)<>5 then
Serror = Serror & LangCheckoutExpiryError & " "
exit sub
end if
mm = left(strocardexpires,2)
yy=right(strocardexpires,2)
if not IsNumeric(mm) or Not Isnumeric(yy) then
Serror = Serror & LangCheckoutExpiryNum & " "
end if
If serror="" then
monthnum=month(date())
year=datepart("yyyy",date())
yearnum=right(year,2)
if clng(yearnum)=clng(yy) then
if clng(monthnum)> clng(mm) then
Serror = Serror & "Invalid Date "
end if
end if
end if
end sub
'
Sub ValidateCVN
If CVNRequired<>"Yes" then
exit sub
end if
If len(strocardCVN)>4 then
Serror = Serror & LangCheckoutCVNError & " "
exit sub
end if
if not isnumeric(strOCardCVN) then
Serror = Serror & LangCheckoutCVNError & " "
exit sub
end if
end sub
'
Sub ValidateSWitch
if ucase(strocardtype)<>"SWITCH" then exit sub
if strocardissue="" then
serror=serror & "Issue number is required for Switch "
else
if not isnumeric(strocardissue) then
Serror = Serror & "Issue Number must be numeric" & " "
end if
end if
'VP-ASP 6.50 - From date no longer required
'If strvalidfrom="" then
' serror=serror & "Valid From date is required for Switch "
'end if
end sub
Sub GenerateLink (url)
'NewShopPageHeader
%>
VP-ASP Shopping Cart
Please use this >Link if you are not automatically transferred.
<%
NewShopPageTrailer
end sub
Sub ParseRecord (record,words,wordcount,delimiter)
Dim pos
Dim recordl
Dim bytex
Dim temprec
Dim maxwords
Dim i
maxwords = 10
temprec = record
Dim maxentries
pos = 1
wordcount = 0
' make sure word array is null
maxentries = UBound(words)
For i = 0 To maxentries - 1
words(i) = ""
Next
recordl = Len(temprec)
' first eliminate leading blanks
Do
bytex = Mid(temprec, pos, 1)
While bytex = " " And pos <= recordl
pos = pos + 1
bytex = Mid(temprec, pos, 1)
Wend
' copy word into word array
While bytex <> delimiter And pos <= recordl
words(wordcount) = words(wordcount) & bytex
pos = pos + 1
bytex = Mid(temprec, pos, 1)
Wend
wordcount = wordcount + 1
pos = pos + 1
If wordcount > maxentries Then Exit Sub
Loop Until pos > recordl
End Sub
'***********************************************************************
' Generate a select list for months
'*************************************************************************
Function GenerateMM (name, currentvalue)
dim value
value=""
generatemm=value
end function
'***********************************************************************
' Generate a select list for Years
'*************************************************************************
Function GenerateYY (name, currentvalue)
dim value
dim i, year, currentyear, selected, yearpart
value=""
Generateyy=value
end function
'VP-ASP 6.5.1 - clean invalid characters from strings - moved in here from shop$db.asp
function CleanChars(strWords)
'VP-ASP 6.5.1 - exit function if strwords is nothing
if strwords = "" then
exit function
end if
if isnull(strwords) then
exit function
end if
'VP-ASP 6.50 - replace '' with ' in case function has been run twice on same string
strWords = replace(strWords, "''", "'")
dim badChars,i
dim newChars, decodeChars
badChars = array("select ", "drop ", "--", "insert into", "delete from","update ","xp_","union ","char(","@@","|","0 then
newchars=""
cleanchars=newchars
exit function
end If
if instr(1,lcase(decodeChars),lcase(badchars(i)),1)>0 then
decodeChars=""
cleanchars=decodeChars
exit function
end If
next
newchars=replace(newchars,"'","''")
newchars=replace(newchars,"""",""")
newchars=Replace(newchars,"%22","") 'remove any encoded double quotes
cleanChars = newChars
end function
function URLDecode(sText)
Dim sDecoded,oRegExpr,oMatchCollection,oMatch
sDecoded = sText
Set oRegExpr = Server.CreateObject("VBScript.RegExp")
oRegExpr.Pattern = "%[0-9,A-F]{2}"
oRegExpr.Global = True
Set oMatchCollection = oRegExpr.Execute(sText)
For Each oMatch In oMatchCollection
sDecoded = Replace(sDecoded,oMatch.value,Chr(CInt("&H" & Right(oMatch.Value,2))))
Next
URLDecode = sDecoded
end function
%>