Программируем читалку новостных лент, выходящих в RSS формате // © Rabusov Online Service. 2004 // Рабусов С.В.
Живые и Твёрдые Издательский Дом Коммерсантъ
Аудиокниги // AudioBooks

Программируем читалку новостных лент, выходящих в RSS формате

Для простоты изложения воспользуемся скриптовым вариантом языка Visual Basic ( Windows Scripting Host - WSH ). Он поддерживает классы, с ним можно работать в любом текстовом редакторе и запускать непосредственно в Windows.

Прежде всего следует взглянуть на спецификацию формата данных RSS . По результатам анализа формата данных создаем три очень простых класса, описывающих формат RSS.

1. Класс описывающий RSS канал


Class RssClass
	Public title
	Public link
	Public description
	Public language
	Public copyright
	Public lastBuildDate
	Public img_title
	Public img_url
	Public img_link
	public sub SetEmpty
		title = ""
		link = ""
		description = ""
		language = ""
		copyright = ""
		lastBuildDate = ""
		img_title = ""
		img_url = ""
		img_link = ""
	End Sub
End Class

2. Класс описывающий свойства отдельной записи RSS канала


Class RssProp
	Public title
	Public guid
	Public link
	Public description
	Public pubdate
	Public id
	Public aDate
	Public numbers
	Public category
	Public stmt
	public sub SetEmpty
		id = 0
		title = ""
		guid = ""
		link = ""
		description = ""
		pubdate = ""
		aDate = ""
		numbers = ""
		category = ""
		stmt = ""
	End Sub
End Class

3. Класс описывающий свойства вложений к отдельной записи RSS канала


Class RssEnclosure
	Public url
	Public length
	Public mime
	public sub SetEmpty
		url = ""
		length = ""
		mime = ""
	End Sub
End Class

3. Пишем функцию, которая вычитывает указанный RSS поток с указанием кодировки и возвращает этот поток в виде текста


' Параметры
' url - сслыка на RSS поток
' charset - кодировка RSS потока
function getResponseBody( url, charset )
	Dim xmlHttp ' объявляем переменную под объект запроса к серверу, где хранится RSS поток
    ' создаем объект для выполнения запрноса
    Set xmlHttp = CreateObject("MSXML2.ServerxmlHttp")
    ' формируем запрос
	xmlHttp.open "GET", url, false
	xmlHttp.setRequestHeader "Pragma", "no-cache"
	xmlHttp.setRequestHeader "Cache-Control", "no-cache, must-revalidate"
	xmlHttp.setRequestHeader "Expires", "Mon, 12 Mar 1960 05:00:00 GMT"
    ' выполняем запрос
	xmlHttp.send
    ' проверяем результат выполнения запроса
	if xmlHttp.status<>200 then
		WScript.Echo "Не могу подключиться к серверу: " & url _
              & "
При подключении к серверу возникла ошибка: " & err.description getResponseBody = "" exit function end if if err<>0 then WScript.Echo "При подключении к серверу возникла ошибка: " & err.description err.clear getResponseBody = "" exit function end if ' текст, пришедший в ответ на запрос, находится в xmlHttp.responseBody ' но его ещё надо преобразовать в соответствии с заданной кодировкой Set Stream = CreateObject("ADODB.Stream") Stream.Type = 1 ' открываем поток Stream.Open ' записываем в поток ответ сервера с RSS потоком Stream.Write xmlHttp.responseBody Stream.Position = 0 Stream.Type = 2 Stream.Charset = charset ' поместим текст в возвращаемую переменную getResponseBody = Stream.ReadText Stream.Close Set Stream = nothing Set xmlHttp = nothing end Function

4. Класс для работы в базой данных - CConnectionClass


Class CConnectionClass
	Public p_conn, p_rs
	Private p_connectionstring, p_login, p_password
	Public opened
	''
	PUBLIC PROPERTY LET login (byval value)
	  p_login = value
	  CLOSE
	END PROPERTY
	
	PUBLIC PROPERTY GET login
	  login = p_login
	END PROPERTY
	'''''''''''''''''''''''''''''''''''''''''''''''''
	PUBLIC PROPERTY LET password (byval value)
	  p_password = value
	  CLOSE
	END PROPERTY
	
	PUBLIC PROPERTY GET password
	  password = p_password
	END PROPERTY
	''''''''''''''''''''''''''''''''''''''''''''''''''
	PUBLIC PROPERTY LET connectionstring (byval value)
	  p_connectionstring = value
	  CLOSE
	END PROPERTY
	PUBLIC PROPERTY GET connectionstring
	  connectionstring = p_connectionstring
	END PROPERTY
	''''''''''''''''''''''''''''''''''''''''''''''''''
	PUBLIC PROPERTY GET rs
         set rs = p_rs
	END PROPERTY
	''
	PUBLIC FUNCTION Field(index)
		Field = Empty
		if opened then
		  if not p_rs.EOF then
		    if index >= 0 and index < p_rs.Fields.count then
		      Field = p_rs(index)
		    end if 
		  end if
		end if
	END FUNCTION
	''
	PUBLIC FUNCTION FieldByName(fieldname)
		FieldByName = Empty
		if opened then
		  if not p_rs.EOF then
		      FieldByName = p_rs(fieldname)
		  end if
		end if
	END FUNCTION
	''
	PUBLIC FUNCTION MoveNext
		MoveNext = FALSE
		if opened then
		  if not p_rs.EOF then p_rs.MoveNext
		  MoveNext = p_rs.EOF
		end if
	END FUNCTION

	''''''''''''''''''''''''''''''''''''''''''''''''''
	PUBLIC FUNCTION Execute ( sqlstring )
		if not opened then OPEN
		set Execute = p_conn.Execute (sqlstring)
		set p_rs = Execute
	END FUNCTION
	''''''''''''''''''''''''''''''''''''''''''''''''''
	PRIVATE SUB CLOSE
	  if opened then p_conn.Close
	  opened = FALSE
	END SUB
	'''''''''''''''''''''''''''''''''''''''''''''''''
	PRIVATE SUB OPEN
	  if opened then p_conn.Close 
	  opened = FALSE
	  p_conn.open p_connectionstring, p_login, p_password
	  If p_conn.State = 1 then opened = TRUE
	END SUB	
	'''''''''''''''''''''''''''''''''''''''''''''''''
	SUB Class_Initialize
	  opened = FALSE
	  set p_conn = CreateObject("ADODB.Connection")
	  set p_rs = CreateObject("ADODB.RecordSet")
      '' здесь можно задать доступ к БД с параметрами по умочанию
	  p_connectionstring = "Provider=SQLOLEDB.1;Persist Security Info=False;" _
                         & "Initial Catalog=defaultdb;Data Source=DBSTORE;"_
                         & "Connect Timeout=120;Use Procedure for Prepare=1;"
	  p_login = "user"
	  p_password = "password"
	END SUB
	'''''''''''''''''''''''''''''''''''''''''''''''''
	SUB Class_Terminate
	  if opened then p_conn.Close
	   set p_rs = nothing
	  set p_conn = nothing
	END SUB
END CLASS

5. Обращаемся к серверу и вычитывем содержимое RSS потока

В нижеприведенном примере, в процессе разборки RSS потока, мы будем записывать данные из этого источника в базу данных, чтобы, в дальнейшем, можно было работать без непосредственного обращения к указанному RSS потоку, например, при недоступности сервера, хранящего RSS поток.

Далее, в тексте программы, предполагается, что в базе данных присутствуют процедуры :
  • RSS_add - добавление описания RSS потока
  • RSSItems_add - добавление записи
  • RSSItemsEnclosure_add - добавление вложения к записи
Подготовительные объявления переменных.

	Public doc, text, conn, url, rs, isDebug
	Dim rootNode, itemscount, i, itemNodes, root
	Set conn = New CConnectionClass
	set rs = CreateObject("ADODB.RecordSet")
	conn.connectionstring = ВАША_СТРОКА_ПОДСОЕДИНЕНИЯ_К_БД
	conn.login = ВАШ_ЛОГИН
	conn.password = ВАШ_ПАРОЛЬ
	
	isDebug	= false
Для этого нам нужно знать URL новостной ленты, содержание которой требуется прочитать и кодировка её содержимого. Создадим переменные url и url_codepage и присвоим им, соответственно ссылку на новостную ленту и её кодировку:

    dim url, url_codepage
    url = "http://www.kommersant.ru/rss/section-business.xml"
    url_codepage = "utf-8"

Объявляем переменную rssStr и помещаем в неё текст, возвращаемый функцией getResponseBody, которую вызываем передав ей два параметра с указанием ссылки на RSS канал и его кодировку:

    dim rssStr : rssStr = getResponseBody ( url , url_codepage)

Объявляем переменную doc и создаём объект для работы с XML документом

	dim doc
    Set doc = WScript.CreateObject("MSXML2.DOMDocument")
	doc.async = False
    ' загружаем XML объект из переменной rssStr
	doc.loadXML( rssStr )
    ' объявляем переменные для дальнейше работы
	Dim aRss, image, attribute, stmt, id_rss, id_item

Далее проверим, действительно ли в объекте doc есть текст XML документа

	If ( Len(doc.text) > 0 ) Then
        ' текст есть
        ' получим узел rss
		Set rss = doc.selectSingleNode("rss")
        ' получим узел с наименованием channel
		Set channel = rss.selectSingleNode("channel")
		If channel Is Nothing Then
			WScript.Echo "channel is nothing"
		Else
			Set aRss = new RssClass
			If channel.hasChildNodes Then
				Set chnode = channel.firstChild
				Do While Not chnode Is Nothing
					If isDebug then WScript.Echo chnode.nodeName
					If chnode.nodeName = "title" Then aRss.title = chnode.text
					If chnode.nodeName = "link" Then aRss.link = chnode.text
					If chnode.nodeName = "description" Then aRss.description = chnode.text
					If chnode.nodeName = "language" Then aRss.language = chnode.text
					If chnode.nodeName = "copyright" Then aRss.copyright = chnode.text
					If chnode.nodeName = "lastBuildDate" Then aRss.lastBuildDate = chnode.text
					If chnode.nodeName = "item" Then Exit Do
					Set chnode = chnode.nextSibling
				Loop
				''
				'' Разберём узел IMAGE
				''
				Set image = channel.selectNodes("image")
				If Not image Is Nothing Then
					itemscount = image.length
					For i = 0 To itemscount-1
						Set img = image(i).childNodes
						For iProp = 0 To img.length-1
							Set p = img.nextNode
							If p.nodeName = "title" Then aRss.img_title = p.text
							If p.nodeName = "url" Then aRss.img_url = p.text
							If p.nodeName = "link" Then aRss.img_link = p.text
						Next
					Next		
				End If
				stmt = "RSS_add @url='" & url & "'" _
					& ",@title='" & Convert39(aRss.title) & "'" _
					& ",@link='" & aRss.link & "'" _
					& ",@description='" & Convert39(aRss.description) & "'" _
					& ",@language='" & aRss.language & "'" _
					& ",@copyright='" & Convert39(aRss.copyright) & "'" _
					& ",@img_title='" & Convert39(aRss.img_title) & "'" _
					& ",@img_url='" & Convert39(aRss.img_url) & "'" _
					& ",@img_link='" & Convert39(aRss.img_link) & "'" _
					& ",@lastBuildDate='" & Convert39(aRss.lastBuildDate) & "'"
				If isDebug Then WScript.Echo stmt
				Set rs = conn.execute( stmt )
				If Not rs.eof Then
					id_rss = rs("id")
					'' массив для вложений: картинки, музыка ...
					Dim arrOfRssItemEnclosure
					arrOfRssItemEnclosure = Array()
					''
					'' Пройдём по всем записям ITEM
					''
					Set items = channel.selectNodes("item")
					If Not items Is Nothing Then
						''
						'' class RssProp declared in procedures/GetResponse.vbs
						''
						Set pitem = new RssProp
						itemscount = items.length
						If isDebug Then WScript.Echo "itemscount=" & itemscount
						Dim eCount, enclosure
						For i = 0 To itemscount-1
							Set item = items(i).childNodes
							pitem.SetEmpty
							eCount = 0 '' счётчик вложений (enclosure)
							ReDim arrOfRssItemEnclosure(0)
							For iProp = 0 To item.length-1
								Set p = item.nextNode
								If p.nodeName = "category" Then pitem.category = p.text
								If p.nodeName = "link" Then pitem.link = p.text
								If p.nodeName = "title" Then pitem.title = p.text
								If p.nodeName = "guid" Then pitem.guid = p.text
								If p.nodeName = "description" Then pitem.description = p.text
								If p.nodeName = "pubDate" Then pitem.pubdate = p.text
								If p.nodeName = "enclosure" Then 
									eCount = eCount + 1
									ReDim Preserve arrOfRssItemEnclosure(eCount)
									Set enclosure = New RssEnclosure
									Set attribute = p.attributes
									For j = 0 To attribute.length-1
										If attribute(j).name = "url" Then enclosure.url = attribute(j).value
										If attribute(j).name = "length" Then enclosure.length = attribute(j).value
										If attribute(j).name = "type" Then enclosure.mime = attribute(j).value
									Next
									''WScript.Echo enclosure.url & vbCrLf & enclosure.length & vbCrLf & enclosure.mime
									Set arrOfRssItemEnclosure(eCount-1) = enclosure
								End If
							Next
							'' Запись разобрана
							pitem.stmt = "RSSItems_add "_
								&" @id_rss=" & id_rss _
								&",@category='" & Convert39(pitem.category) & "'" _
								&",@link='" & Convert39(pitem.link) & "'" _
								&",@title='" & Convert39(pitem.title) & "'" _
								&",@description='" & Convert39(pitem.description) & "'" _
								&",@guid='" & Convert39(pitem.guid) & "'" _
								&",@pubDate='" & Convert39(pitem.pubdate) & "'"
							If isDebug Then WScript.Echo pitem.stmt
							set rs = conn.execute (pitem.stmt)
							If Not rs.eof Then
								id_item = rs("id")
								jmax = UBound(arrOfRssItemEnclosure) - 1
								For j = 0 To jmax
									Set enclosure = arrOfRssItemEnclosure(j)
									'' добавляем в БД вложения для записи
									stmt = "RSSItemsEnclosure_add" _
									&" @id_rssitems=" & id_item _
									&",@url='" & Convert39(enclosure.url) & "'" _
									&",@length=" & enclosure.length _
									&",@type='" & enclosure.mime & "'"
									If isDebug Then WScript.Echo stmt
									conn.execute ( stmt )
								next
							End if
						Next
					Else
						WScript.Echo "no items found"
					End If
				End If '' rs.eof
			End If '' channel
		End If
		Set channel = Nothing
		Set rss = Nothing
		Set rootNode = Nothing
	Else
		WScript.Echo "cannot load"
	End If
	Set conn = Nothing
	Set doc = Nothing

6. Вспомогательные функции


' VBScript source code
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' from str-functions ''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ClearTags(Text)
Dim i, bOpenTag, char

bOpenTag = FALSE : NoTags = "" : ClearTags = ""
if not isNull(Text) then
  For i = 1 To Len(Text)
	char = Mid(Text, i, 1)
	If char = "<" Then bOpenTag = TRUE
	If NOT bOpenTag Then ClearTags = ClearTags & char
	If char = ">" Then bOpenTag = FALSE
  Next
end if
End Function

Public function SqlStrOrNull(st)
  if isEmpty(st) or IsNull(st) or len(Trim(st)) = 0 or Trim(st)="null" then
    SqlStrOrNull = "null"
  else
    SqlStrOrNull = "'" & Convert39(st) & "'"
  end if
end function

Public function SqlStrOrEmpty(st)
  if isEmpty(st) or IsNull(st) or len(Trim(st)) = 0 or Trim(st)="null" then
    SqlStrOrEmpty = "''"
  else
    SqlStrOrEmpty = "'" & Convert39(st) & "'"
  end if
end Function

Public function AddLastSlash (astr)
   AddLastSlash = astr
   If Mid(astr, Len(astr)) <> "\" THEN
     AddLastSlash = astr & "\"
   End if
End Function

Const BegData = "![CDATA["
Const EndData = "]]"

function GetSQLStringOrNull( s)
    dim rc : rc = "null"
    if (( Not IsNull(s)) And (Len(s) > 0)) Then
        if (InStr(s, BegData) = 0) Then
            s = Replace(s, BegData, "")
            s = Replace(s, EndData, "")
        End if
        s = Replace(s, "'", "''")
        rc = "'" & s & "'"
    End If
    GetSQLStringOrNull = rc
End Function

Function GetSQLIntOrNull( s)
    dim rc : rc = "null"
    if (( Not IsNull(s)) And (Len(s) > 0)) Then rc = s
    GetSQLIntOrNull = rc
End Function

Public function Convert39(astring)
	Convert39 = Trim(replace("" & astring,"'","''"))
End Function
Рейтинг@Mail.ru Фотограф Фотограф Рабусов С.В. ссср