<%@ LANGUAGE = VBScript %>
<%
Dim c, txt, ttr, p, ch, x, loadct
Dim sourceFile, source
Dim xEl, objLst, objHdl, baseEl, lnkLst
Dim titleEl, imageEl, title, link, desc, imgTitle, imgURL, imgLink, imgW, imgH, imgCaption, noOfHeadlines, strRetval, imgStuff, shorten, imgAlign, tz, tzAdj, tzZone, target, newErrStr
set source = Server.CreateObject("MSXML2.DOMDocument")
Set objLst = Server.CreateObject("MSXML2.DOMDocument")
Set objHdl = Server.CreateObject("MSXML2.DOMDocument")
set baseEl = Server.CreateObject("MSXML2.DOMDocument")
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Dim flDebug
flDebug=false
if request.querystring("debug")&""="true" then
flDebug=true
end if
sub writeWholeFile(ptf, txt)
Dim uf, tarr, i
mydebug("writeWholeFile ptf: " & ptf)
' mydebug("txt:" & txt)
txt=replace(cstr(txt), vblf, "", 1, -1,1)
tarr=split(txt, vbcr)
On Error Resume Next
Set uf = fso.OpenTextFile (ptf, 2, True)
mydebug "open for writing file"
for i = 0 to Ubound(tarr,1)
uf.Write(tarr(i) & vbnewline)
next
'uf.Write txt
mydebug "written file"
uf.Close
mydebug("closing")
Set uf = Nothing
mydebug("done writing")
end sub
function cleanUrl(ch)
myArr=Array ("/", "\", ":", "*", "?", """", "<", ">", "|")
for each x in myArr
ch=Replace(ch, x, "_", 1, -1, 1)
next
cleanUrl=ch
end function
sub mydebug(strnote)
if flDebug then
response.write(strnote & vbnewline)
if err.number<>0 then
response.write("ERROR with " & strnote & vbnewline)
response.write("Error Number: " & err.number & vbnewline)
response.write("Error Description: " & err.description & vbnewline)
err.clear
end if
end if
end sub
loadct=0
sub loadUrl(ptf, url)
Dim srvXmlHttp, s, result
s=""
ptf=Trim(ptf)
mydebug ("load url: " & ptf)
mydebug ("load url: " & url)
Set srvXmlHttp = Server.CreateObject("MSXML2.ServerXMLHTTP.4.0")
srvXmlHttp.open "GET", Trim(url), false
srvXmlHttp.send
on error resume next
mydebug ("Status: " & srvXmlHttp.status)
teststatus=srvXmlHttp.status & ""
if teststatus = "200" Then
s = srvXmlHttp.responseText
mydebug("s is responseText")
else
if (srvXmlHttp.status = "301" OR srvXmlHttp.status = "302" OR srvXmlHttp.status = "307") AND loadct<5 then
loadct=loadct+1
dim stat
stat=srvXmlHttp.statusText&""
debug("Status text: " & stat)
set srvXmlHttp=nothing
loadUrl ptf, stat
end if
StrRetVal=StrRetVal & ("Status code for the RSS url: " & srvXmlHttp.status)
StrRetVal=StrRetVal & ("
Status text for the RSS url: " & srvXmlHttp.statusText)
StrRetVal=StrRetVal & (" Check the URL you submitted.
")
s = readwholefile(ptf)
end if
' mydebug(s)
source.async = false
source.validateOnParse = false
source.resolveExternals = false
mydebug("ready to write temp file and try loading")
call writeWholeFile (ptf & ".temp", s)
mydebug("wrote file")
source.load(Trim(url))
if source.parseError.errorCode <> 0 Then
mydebug("cannot load url directly, so load local file")
source.load(ptf & ".temp")
end if
dim flErr
flErr=false
If source.parseError.errorCode <> 0 Then
mydebug("initial parsing error on temporary file")
s=cleanXML(s)
call writeWholeFile (ptf & ".temp", s)
source.load(ptf & ".temp")
If source.parseError.errorCode <> 0 Then
flErr=true
end if
end if
if flErr then
mydebug("error in loading cleaned xml")
' how do we encode the error in the xml file?
' aha! don't delete the temp file, then detect for it.
'StrRetVal=StrRetVal & ("Error parsing the code from the original URL:
")
'StrRetVal=StrRetVal & ("Line: " & source.parseError.line & "
")
'StrRetVal=StrRetVal & ("Line Position: " & source.parseError.linepos & "
")
'StrRetVal=StrRetVal & ("Reason: " & source.parseError.reason & "
")
'StrRetVal=StrRetVal & ("Source of the Problem: " & server.htmlencode(source.parseError.srcText) & "
")
newErrStr=Server.htmlencode(source.parseError.reason)
mydebug("newErrStr2:" & newErrStr)
else
mydebug("all okay, delete file")
fso.DeleteFile(ptf & ".temp")
mydebug("all okay, save xml")
source.save(ptf)
end if
mydebug(ptf)
set srvXmlHttp=nothing
end sub
dim lastUpdate
sub updateChannel(c, f)
mydebug("c:" & c)
mydebug("f:" & f)
if flDebug then
lastUpdate = dateadd("yyyy", -2, Date)
end if
' if its a userland.com file, c = the channel id and f = the local file
' if its a url, c = the url and f = the local file
Dim f1, modDate, refreshsource, refreshsourcefile, theNode, url, websource
if Lcase(request.querystring("refresh") & "")="true" then
mydebug("refresh initiated")
if not request.querystring("refreshTime") & ""="" then
dim timedelay
timedelay=cint(request.querystring("refreshTime"))
mydebug("timedelay: " & timedelay)
mydebug("refreshtime datediff: " & datediff("h", lastUpdate,now))
if datediff("h", lastUpdate,now)>timedelay then
lastUpdate = dateadd("yyyy", -2, Date)
end if
else
mydebug("5 minute update test: " & datediff("n", lastUpdate,now))
if datediff("n", lastUpdate,now)>5 then
lastUpdate = dateadd("yyyy", -2, Date)
mydebug("5 minute update")
end if
end if
end if
if Instr(c, "http:")=0 then
' mydebug(modDate)
if datediff("d", lastUpdate, date)>0 then
' code copied from refresh page
set refreshsource = Server.CreateObject("MSXML2.DOMDocument")
refreshsourceFile = Server.MapPath("myserviceList4.xml")
' Load the XML
refreshsource.async = false
refreshsource.validateOnParse = false
refreshsource.resolveExternals = false
refreshsource.load(refreshsourceFile)
set theNode = refreshsource.documentElement.childNodes(0).selectSingleNode("service[id=" & c &"]")
url = getText("url", theNode)
' mydebug(url)
set theNode=nothing
set refreshsource=nothing
if err.number=0 then
dim ptf
ptf = server.mappath("xml/" & c & ".xml")
loadUrl ptf, url
' get the image?
'if NOT imgURL & "" = "" then
'Dim objXMLHttp
'Dim strFext
'Set objXMLHttp = Server.CreateObject ("MSXML2.XMLHTTP.3.0")
'objXMLHttp.Open "GET", imgURL,False
'objXMLHttp.Send
'strFext=Mid(imgURL, instrrev(imgURL, "."))
'writeWholeFile(server.mappath("xml/" & ch & "." & strFext, objXMLHttp.ResponseText))
'Set objXMLHttp = Nothing
'end if
end if
end if
else
mydebug ("updatechannel")
mydebug("datediff: " & lastupdate & " -- " & date)
mydebug(datediff("d", lastUpdate, date))
if datediff("d", lastUpdate, date)>0 then
' mydebug("datediff successful: " & lastupdate & " -- " & date)
loadUrl f, c
end if
end if
end sub
function imgExists(imgURL)
Dim f1, strFext, strFpath
imgExists=imgURL
strFext=Mid(imgURL, instrrev(imgURL, "."))
strFpath=server.mappath("xml/" & ch & "." & strFext)
if fso.fileexists(strFpath) then
imgExists="http://www.wc.cc.va.us/services/news/xml/" & ch & "." & strFext
end if
end function
function getMod(f)
Dim f1, gDate
if Instr(f, "http:")=0 then
Set f1 = fso.GetFile(f)
gDate= f1.DateLastModified
lastUpdate=gDate
set f1=nothing
else ' f should always be a file path, so this should be out of the picture now
gDate=Now
end if
' convert to GMT
gDate=dateAdd("h", 5, gDate)
' convert using tz variable
gDate=dateAdd("h", tzAdj, gDate)
getMod=Monthname(Month(gDate)) & " " & Day(gDate) & ", " & Year(gDate) & " " & FormatDateTime(gDate, vbLongTime) & " " & tzZone
end function
function getText(ttg, xmlObj)
set xEl = xmlObj.selectSingleNode(ttg)
if not xEl is Nothing then
mydebug("xml: " & xEl.xml)
getText=xEl.text
else
getText=""
end if
end function
'Get js/asp headers right
Response.buffer=true
Response.ContentType = "application/x-javascript"
Response.Expires=0
Response.CacheControl="no-cache"
Response.ExpiresAbsolute=#May 31,1996 13:30:15#
Response.addHeader "Pragma", "no-cache"
' gather requested attributes
c=request.querystring("c")&""
c=replace(c, " ", "+", 1, -1, 1)
if c="" then
c="1212"
end if
border=request.querystring("border")&""
if border="" then
border="1"
end if
bgcolor=request.querystring("bg")&""
if bgcolor="" then
bgcolor="D2B48C"
end if
bgcolor="#" & bgcolor
limit=""
if not request.querystring("limit")&""="" then
limit=CInt(request.querystring("limit"))
end if
shorten=request.querystring("short")&""
imgAlign="right"
if not request.querystring("imgAlign")&""="" then
imgAlign=request.querystring("imgAlign")
end if
target=""
if not request.querystring("target")&""="" then
target=" target=""" & request.querystring("target") &""""
end if
if not request.querystring("refresh") & ""="" then
lastUpdate = dateadd("yyyy", -2, Date)
' this in fact gets overwritten by the getMod function later
end if
tz="-5,EST"
if not request.querystring("tz")&""="" then
tz=request.querystring("tz")
end if
tzAdj=Cint(left(tz, instr(tz,",")))
tzZone=Mid(tz, instr(tz,",")+1)
carr=split(c, ",")
' set up regular expression
'Set regEx = New RegExp ' Create regular expression.
'regEx.IgnoreCase = True ' Make case insensitive.
'regEx.Global = True ' Make global
'regEx.Pattern = "<[aA] +[^>]*>[^<]+" ' Set pattern.
for p = 0 to (UBound(carr))
ch=carr(p)
on error resume next
' load the source file
' Set the source and style sheet locations here
if Instr(ch, "http:")>0 then
sourceFile=ch
sourceFile=Server.MapPath("xml/urls/" & cleanUrl(sourceFile) & ".xml")
mydebug(sourceFile)
If not (fso.FileExists(sourceFile)) Then
mydebug("doesn't exist")
lastUpdate = dateadd("yyyy", -2, Date)
updateChannel ch, sourceFile
end if
else
sourceFile = Server.MapPath("xml/" & ch & ".xml")
end if
' Load the XML
source.async = false
source.validateOnParse = false
source.resolveExternals = false
source.load(sourceFile)
' parse it out
If source.parseError.errorCode <> 0 Then
mydebug("parse error - try to read as a text stream")
Set f1 = fso.GetFile(sourceFile)
Set ts = f1.OpenAsTextStream(1, 0)
allText = ts.ReadAll
ts.Close
set ts=nothing
set f1=nothing
allText=cleanXML(allText)
source.loadXML(allText)
end if
If source.parseError.errorCode <> 0 Then
strRetVal="Channel #"
if instr(ch, "http:")=1 then
strRetVal= strRetVal & "" & ch & ""
else
strRetVal= strRetVal & ch
end if
strRetVal= strRetVal & "
"
strRetVal= strRetVal & "
There is something wrong with our copy of the RSS file for this channel. " & source.parseError.reason & "
The source of the problem is: " & Server.htmlencode(source.parseError.srcText)
' strRetVal= strRetVal & ("Error Code: " & source.parseError.errorCode & "
")
' strRetVal= strRetVal & ("File Position: " & source.parseError.filepos & "
")
strRetVal= strRetVal & ("Line: " & source.parseError.line & "
")
strRetVal= strRetVal & ("Line Position: " & source.parseError.linepos & "
")
strRetVal= strRetVal & ("Reason: " & source.parseError.reason & "
")
newErrStr=Server.htmlencode(source.parseError.reason)
mydebug("newErrStr")
strRetVal= strRetVal & ("Source of the Problem: " & Server.htmlencode(source.parseError.srcText) & "
")
strRetVal= strRetVal & ("The problem can be debugged here: http://www.wcc.vccs.edu/services/news/preview.asp?c=" & ch & "&refresh=true
")
' strRetVal= strRetVal & ("URL: " & Server.htmlencode(source.parseError.url) & "
")
modification=getMod(sourceFile)
else
set baseEl = source.documentElement.childNodes(0)
' get header elements
set titleEl = baseEl.selectSingleNode("title")
if NOT titleEl is Nothing then
title=title & "-" & getText("title", baseEl)
link=link & "-" & getText("link", baseEl)
desc=desc & "-" & getText("description", baseEl)
set imageEl = baseEl.selectSingleNode("image")
if imageEl is Nothing then
set imageEl = source.documentElement.selectSingleNode("image")
end if
if NOT imageEl is Nothing then
imgTitle=getText("title", imageEl)
imgURL=getText("url", imageEl)
imgLink=getText("link", imageEl)
imgW=getText("width", imageEl)
imgH=getText("height", imageEl)
imgCaption=getText("description", imageEl)
if imgW="" then
imgW=getText("rss091:width", imageEl)
imgH=getText("rss091:height", imageEl)
imgCaption=getText("rss091:description", imageEl)
end if
end if
Set objLst = source.getElementsByTagName("item")
noOfHeadlines = objLst.length
if limit" & getText("title", objHdl) & ""
if NOT shorten="true" then
itemdesc=""
itemdesc=getText("description", objHdl)
if itemdesc="" then
itemdesc=getText("content:encoded", objHdl)
end if
txt = txt & "
" & itemdesc & "
"
end if
ttr = ttr & ("" & txt & "
")
Next
else
title=title & "-" & getText("channelTitle", baseEl)
link=link & "-" & getText("channelLink", baseEl)
desc=desc & "-" & getText("channelDescription", baseEl)
imgTitle=getText("imageTitle", baseEl)
imgURL=getText("imageUrl", baseEl)
imgLink=getText("imageLink", baseEl)
imgW=getText("imageWidth", baseEl)
imgH=getText("imageHeight", baseEl)
imgCaption=getText("imageCaption", baseEl)
Set objLst = source.getElementsByTagName("item")
noOfHeadlines = objLst.length
if limit" & lookFor & ""
if x>1 then
newtxt=txt
txt=""
do
' get 3 chunks, the bit before "& "<--atext=" & atext & "-->"& "<--restoftext=" & restoftext & "-->"
if NOT texttoworkon&""="" then
texttoworkon=Replace(texttoworkon, lookFor, replaceWith, 1, -1, 1)
end if
txt=txt & texttoworkon & atext
newtxt=restoftext
end if
loop
else
txt = Replace(txt, lookFor, replaceWith, 1, -1, 1)
end if
next
end if
ttr = ttr & ("" & txt & "
")
sth=""
Next
end if
title=right(title, len(title)-1)
link=right(link, len(link)-1)
desc=right(desc, len(desc)-1)
modification=getMod(sourceFile)
imgStuff=""
img=""
if NOT imgURL & "" ="" then
'imgURL=imgExists(imgURL)
img="![]()
"
imgStuff="" & img & ""
end if
strRetval=("" & modification & " |
|---|
| " & imgStuff & " " & ttr & " " & desc & " |
")
if LCase(Request.QueryString("feedtype")&"")="advantgo" then
strRetval=("" & title & " " & modification & " |
|---|
| " & img & " " & ttr & " " & desc & " |
")
end if
if LCase(Request.QueryString("feedtype")&"")="notable" then
strRetval=("" & title & "
" & modification & "
" & img & "
" & ttr & "
" & desc & "
", 1, -1,1)
end if
next
if request.querystring("ns")&""="true" then ' netscape 4.x style sheet compatibility
strRetval=Replace(strRetval, "class=""ch_", "class=""ch", 1, -1, 1)
strRetval=Replace(strRetval, "chitem_link", "chitemlink", 1, -1, 1)
strRetval=Replace(strRetval, "chitem_description", "chitemdescription", 1, -1, 1)
end if
strRetval=Replace(strRetval, vbCr, "\r", 1, -1, 1)
strRetval=Replace(strRetval, vbLF, "\n", 1, -1, 1)
strRetval=Replace(strRetval, """", "\""", 1, -1, 1)
' response.write("document.writeln(""" & strRetval & """);" & vbnewline)
strRetval=Replace(strRetval, "<", """);" & vbnewline & "document.writeln(""<", 1, -1, 1)
strRetval=Replace(strRetval, """);" & vbnewline, "", 1, 1, 1) & """);" & vbnewline
strRetval=Replace(strRetval, "document.writeln(""