<%@LANGUAGE="VBSCRIPT"%>
<%
OPTION EXPLICIT
Response.Buffer=false
'
%>
<%
DIM sURL, bLinkLeaving, sLeavingMsg, iLinkLeavingFormResponse, sLinkLeaving
sURL=Request.QueryString
IF InStr(sURL,"&URL=")>0 THEN sURL=Mid(sURL,InStr(sURL,"&URL=")+1)
'response.Write "-->"&sURL&"<--": response.end
iLinkLeavingFormResponse=0
IF Request.Form("LinkLeaveProceed")<>"" THEN iLinkLeavingFormResponse=1
IF Request.Form("LinkLeaveCancel")<>"" THEN
iLinkLeavingFormResponse=2
Response.Write ""&vbCRLF
Response.End
END IF
'sLinkLeaving=GetDBConstraint(iNetworkID,"LeavingDomain","Disable")
'IF CompareStr()
IF Not(LeavingDomain) THEN iLinkLeavingFormResponse=1
'Response.Write LeavingDomain&"-"&iLinkLeavingFormResponse&" ": Response.End
IF iLinkLeavingFormResponse=0 THEN
bLinkLeaving=WarningLeavingLinkCheck(sURL)
'Response.Write bLinkLeaving&" ": Response.End
IF bLinkLeaving THEN
'sLeavingMsg=GetDBConstraint(iNetworkID,"LeavingDomainMsg","link leaving domain message")
sLeavingMsg=LeavingDomainMsg
IF Len(sLeavingMsg)>0 THEN
'Halt Redirection and ask
ShowLeavingMessage sLeavingMsg
Response.End
END IF
END IF
END IF
IF Len(sURL)>4 THEN
sURL=Mid(sURL,5)
IF (StrComp(Left(sURL,4),"www.",1)=0) THEN sURL="http://"&sURL
'response.Write "-->"&Unescape(sURL)&"<-- -->"&sURL&"<--": response.end
Response.Redirect Unescape(sURL)
END IF
FUNCTION WarningLeavingLinkCheck(byVal destURL)
'Purpose - to pop a "Warning - you are leaving site" message
'Will return true if leaving
'If referential, not further checking is required
'Else, determine server names -
'also compare name with IP Address, ie http://CSS/x.htm is same as http://192.168.0.2/y.htm
'however, it will fail with routing - not much can be done about this unless we set Variable in e_Connect
destURL=Replace(destURL,"\","/") '"
IF (Left(destURL,4)="URL=") THEN destURL=Mid(destURL,5)
DIM bResult, sCurrentDomain, sCurrentIP, URIParse, sHost
'response.write destURL&" "&InStr(destURL,"../")&" "&InStr(Left(destURL,InStr(destURL,"/")),".")&"-"&Left(destURL,InStr(destURL,"/")): response.end
IF (InStr(destURL,"/")=1) OR (InStr(destURL,"../")=1) OR (InStr(destURL,"./")=1) THEN
bResult=false 'starts with / or ../ or ./, ie referential or relative
ELSEIF InStr(Left(destURL,InStr(1,destURL,".asp",1)),"/")=0 AND Len(Left(destURL,InStr(1,destURL,".asp",1)))>0 THEN
bResult=false
ELSEIF InStr(Left(destURL,InStr(1,destURL,".htm",1)),"/")=0 AND Len(Left(destURL,InStr(1,destURL,".htm",1)))>0 THEN
bResult=false
ELSEIF IsRelativeSubdirectory(destURL) THEN
bResult=false
'ELSEIF InStr(Left(destURL,InStr(destURL,"/")),".")=0 THEN 'No dots in the first part or URL string upto first / is considered a subdirectory
' bResult=false
ELSEIF InStr(destURL,":")=2 THEN '2nd car is a : - this is drive letter - (we do not wish to encourage this practice)
bResult=false
ELSE
sCurrentDomain=Request.ServerVariables("SERVER_NAME")
sCurrentIP=Request.ServerVariables("LOCAL_ADDR")
'Set URIParse=New URIParser
'response.write destURL&" "
'URIParse.ParseURI destURL
'sHost=URIParse.Host
'response.write URIParse.Host&" "
'Set URIParse=Nothing
sHost=destURL
IF (StrComp(sCurrentDomain,sHost,1)=0) OR (sCurrentIP=sHost) THEN
bResult=false
'May have to check subdirectories at some stage to warn if going out of instance
ELSE
bResult=true
'May have to check domain a little more if say prod.acme.com is be = to test.acme.com
END IF
'response.Write sHost&"-"&bResult: Response.End
END IF
IF bResult THEN
DIM sDomains,aDomains,k
'sDomains=GetDBConstraint(iNetworkID,"LeavingDomainList","")
sDomains=LeavingDomainList
'Response.Write sDomains&"--"&sHost&" "
sDomains=Replace(sDomains,", ","|")
sDomains=Replace(sDomains," ","|") 'So users may use friendlier delimiters
sDomains=Replace(sDomains,",","|")
IF Len(sDomains)>0 THEN
IF InStr(sDomains,"|")>0 THEN
aDomains=Split(sDomains,"|")
For k=0 to UBound(aDomains)
bResult=bResult AND (InStr(1,sHost,aDomains(k),1)=0)
Next
ELSE
bResult=InStr(1,sHost,sDomains,1)=0
END IF
ELSE 'Leaving Domain List is empty
END IF
END IF
'Response.Write bResult&" ": Response.End
WarningLeavingLinkCheck=bResult
END FUNCTION
SUB ShowLeavingMessage(sMsg)
DIM aMsg, k, sLinkLeaveProceed, sLinkLeaveCancel
sMsg=Replace(sMsg,vbCRLF," ")
aMsg=Split(sMsg,"|")
sLinkLeaveProceed="Proceed"
IF UBound(aMsg)>0 THEN sLinkLeaveProceed=aMsg(1)
sLinkLeaveCancel="Cancel"
IF UBound(aMsg)>1 THEN sLinkLeaveCancel=aMsg(2)
'Response.write ""
Response.Write ""
Response.Write ""
Response.write "External Link"
'Response.Write ""
Response.write ""&vbCRLF
Response.Write "
"
Response.write ""&vbCRLF
END SUB
FUNCTION IsRelativeSubdirectory(byVal destURL)
DIM bResult
bResult=false
IF InStr(destURL,"://")>0 THEN destURL=Mid(destURL,InStr(destURL,"://")+3)
'Response.Write destURL&"--" : Response.End
'No dots in the first part or URL string upto first / is considered a subdirectory - AFTER Protocol is removed, AND contains at least 1 /
IF (InStr(destURL,"/")>0) AND (InStr(Left(destURL,InStr(destURL,"/")),".")=0) THEN bResult=true
IsRelativeSubdirectory=bResult
END FUNCTION
%>