<%
'========================================================================
' MODULE:    cCreateAtomFeed.asp
' AUTHOR:   Terje Hauger
' HOME:       © www.u229.no/stuff/atom/
' CREATED:  February 2006
'========================================================================
' COMMENT:

' Create valid Atom 1.0 feeds with classic ASP.
' Atom 1.0 reference: http://www.ietf.org/rfc/rfc4287

' This class supports most features described by the Atom 1.0 reference.

' NOT SUPPORTED:
' No support for multiple authors
' No support for multiple contributors
' Category element: No support for attributes scheme and label.
' Link element: support only for the self and alternate types, and not the attributes.
' Limited support for the content element.
' No support for adding namespaces

'========================================================================
' ROUTINES:

' - Public Property Let SavePath(s)
' - Public Property Let Updated(s)
' - Public Property Let Stylesheet(s)
' - Public Property Let Language(s)
' - Public Sub Title(s, t)
' - Public Sub SubTitle(s, t)
' - Public Property Let LinkSelf(s)
' - Public Property Let LinkAlternate(s)
' - Public Sub Author(n, e, u)
' - Public Sub Contributor(n, e, u)
' - Public Property Let ID(s)
' - Public Sub Rights(s, t)
' - Public Sub Generator(n, u, v)
' - Public Property Let Category(s)
' - Public Property Let Icon(s)
' - Public Property Let Logo(s)

' - Private Sub Class_Initialize()
' - Public Function CreateAtomFeed(oRS)
' - Private Sub UTF8(sXml)
' - Public Function CreateAtomTime()
' - Private Function ConvertUTCMonth(sMonth)
'========================================================================

Const XMLDOM_PROGID = "Msxml2.DOMDocument"

'========================================================================
Class cCreateAtomFeed
'========================================================================

'// MODULE VARIABLES FOR FEED
Private m_sFeedSavePath
Private m_sFeedUpdated
Private m_sFeedStylesheet
Private m_sFeedLanguage
Private m_sFeedTitle
Private m_sFeedTitleType
Private m_sFeedSubTitle
Private m_sFeedSubTitleType
Private m_sFeedLinkSelf
Private m_sLinkAlternate
Private m_sFeedAuthorName
Private m_sFeedAuthorEmail
Private m_sFeedAuthorURI
Private m_sFeedID
Private m_sFeedRights
Private m_sFeedRightsType
Private m_sFeedGeneratorName
Private m_sFeedGeneratorURI
Private m_sFeedGeneratorVersion
Private m_sFeedCategory
Private m_sFeedContributorName
Private m_sFeedContributorEmail
Private m_sFeedContributorURI
Private m_sFeedIcon
Private m_sFeedLogo

'// MODULE VARIABLES FOR ENTRY
Private m_sEntryContentType
Private m_sEntryTitleType
Private m_sEntrySummaryType
Private m_sEntryRightsType


'// MODULE PROPERTIES
Public Property Let SavePath(s)
    m_sFeedSavePath = s
End Property
Public Property Let Updated(s)
    m_sFeedUpdated = s
End Property
Public Property Let Stylesheet(s)
    m_sFeedStylesheet = s
End Property
Public Property Let Language(s)
    m_sFeedLanguage = s
End Property
Public Sub Title(s, t)
    m_sFeedTitle = s
    m_sFeedTitleType = t
End Sub
Public Sub SubTitle(s, t)
    m_sFeedSubTitle = s
    m_sFeedSubTitleType = t
End Sub
Public Property Let LinkSelf(s)
    m_sFeedLinkSelf = s
End Property
Public Property Let LinkAlternate(s)
    m_sLinkAlternate = s
End Property
Public Sub Author(n, e, u)
    m_sFeedAuthorName = n
    m_sFeedAuthorEmail = e
    m_sFeedAuthorURI = u
End Sub
Public Sub Contributor(n, e, u)
    m_sFeedContributorName = n
    m_sFeedContributorEmail = e
    m_sFeedContributorURI = u
End Sub
Public Property Let ID(s)
    m_sFeedID = s
End Property
Public Sub Rights(s, t)
    m_sFeedRights = s
    m_sFeedRightsType = t
End Sub
Public Sub Generator(n, u, v)
    m_sFeedGeneratorName = n
    m_sFeedGeneratorURI = u
    m_sFeedGeneratorVersion = v
End Sub
Public Property Let Category(s)
    m_sFeedCategory = s
End Property
Public Property Let Icon(s)
    m_sFeedIcon = s
End Property
Public Property Let Logo(s)
    m_sFeedLogo = s
End Property

'------------------------------------------------------------------------------------------------------------
' Comment:
'------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
    On Error Resume Next
    
    '// Set defaults
    m_sFeedLanguage = "en-gb"
    m_sFeedTitleType = "text"
    m_sFeedSubTitleType = "text"
    m_sFeedRightsType = "text"
    m_sEntryContentType = "text"
    m_sEntryTitleType = "text"
    m_sEntrySummaryType = "text"
    m_sEntryRightsType = "text"

End Sub

'------------------------------------------------------------------------------------------------------------
' Comment: Create a Atom 1.0 feed.
'------------------------------------------------------------------------------------------------------------
Public Sub CreateAtomFeed(oRS)
'    On Error Resume Next
         
    Dim sXml
    Dim sArr
    Dim iCounter
    Dim arrTmp

    '// BUILD THE FEED HEADER:

    sXml = "<?xml version=""1.0"" encoding=""utf-8""?>"

    If Len(m_sFeedStylesheet) > 0 Then
        sXml = sXml & "<?xml-stylesheet href=""" & m_sFeedStylesheet & """ type=""text/css""?>"
    End If

    sXml = sXml & "<feed xmlns=""http://www.w3.org/2005/Atom"" xml:lang=""" & m_sFeedLanguage & """>"
    sXml = sXml & "<div class=""info"" xmlns=""http://www.w3.org/1999/xhtml"">"
    sXml = sXml & "This is an Atom formatted XML feed. It is intended to be viewed in a Newsreader or syndicated to another site."
    sXml = sXml & "Please visit <a href=""http://www.atomenabled.org/"">atomenabled.org</a> for more info.</div>"

    '---------------------------- REQUIRED:

    sXml = sXml & "<title type=""" & m_sFeedTitleType & """>" & Escape(m_sFeedTitleType, m_sFeedTitle) & "</title>"
    sXml = sXml & "<id>" & m_sFeedID & "</id>"

    If Len(m_sFeedUpdated) > 0 Then
        sXml = sXml & "<updated>" & m_sFeedUpdated & "</updated>"
    Else
        sXml = sXml & "<updated>" & CreateAtomTime & "</updated>"
    End If

    '---------------------------- RECOMMENDED:

    If Len(m_sFeedAuthorName) > 0 Then
        sXml = sXml & "<author><name>" & m_sFeedAuthorName & "</name>"

        If Len(m_sFeedAuthorEmail) > 0 Then sXml = sXml & "<email>" & m_sFeedAuthorEmail & "</email>"
        If Len(m_sFeedAuthorURI) > 0 Then sXml = sXml & "<uri>" & m_sFeedAuthorURI & "</uri>"
        sXml = sXml & "</author>"
    End If

    If Len(m_sFeedLinkSelf) > 0 Then
        sXml = sXml & "<link rel=""self"" type=""application/atom+xml"" href=""" & m_sFeedLinkSelf & """/>"
    End If
    
    '---------------------------- OPTIONAL:

    If Len(m_sLinkAlternate) > 0 Then
        sXml = sXml & "<link rel=""alternate"" href=""" & m_sLinkAlternate & """ title=""" & m_sLinkAlternate & """ type=""text/html""/>"
    End If

    If Len(m_sFeedSubTitleType) > 0 Then
        sXml = sXml & "<subtitle type=""" & m_sFeedSubTitleType & """>" & Escape(m_sFeedSubTitleType, m_sFeedSubTitle) & "</subtitle>"
    End If

    If Len(m_sFeedRights) > 0 Then
        sXml = sXml & "<rights type=""" & m_sFeedRightsType & """>" & Escape(m_sFeedRightsType, m_sFeedRights) & "</rights>"
    End If

    If Len(m_sFeedGeneratorName) > 0 Then
        sXml = sXml & "<generator"

        If Len(m_sFeedGeneratorURI) > 0 Then sXml = sXml & Chr(32) & "uri=""" & m_sFeedGeneratorURI & """"
        If Len(m_sFeedGeneratorVersion) > 0 Then sXml = sXml & Chr(32) & "version=""" & m_sFeedGeneratorVersion & """"
        sXml = sXml & ">" & m_sFeedGeneratorName & "</generator>"
    End If

    If Len(m_sFeedCategory) > 0 Then
        If InStr(m_sFeedCategory, ",") > 0 Then
            arrTmp = Split(m_sFeedCategory, ",")

            For iCounter = 0 To UBound(arrTmp)
                sXml = sXml & "<category term=""" & Trim(arrTmp(iCounter)) & """/>"
            Next

        Else
            sXml = sXml & "<category term=""" & m_sFeedCategory & """/>"
        End If
    End If

    If Len(m_sFeedContributorName) > 0 Then
        sXml = sXml & "<contributor><name>" & m_sFeedContributorName & "</name>"

        If Len(m_sFeedContributorEmail) > 0 Then sXml = sXml & "<email>" & m_sFeedContributorEmail & "</email>"
        If Len(m_sFeedContributorURI) > 0 Then sXml = sXml & "<uri>" & Server.HTMLEncode(m_sFeedContributorURI) & "</uri>"
        sXml = sXml & "</contributor>"
    End If

    If Len(m_sFeedIcon) > 0 Then sXml = sXml & "<icon>" & m_sFeedIcon & "</icon>"
    If Len(m_sFeedLogo) > 0 Then sXml = sXml & "<logo>" & m_sFeedLogo & "</logo>"

    '// LOOP THE RECORDSET FOR THE ENTRY ELEMENTS:
    Do While Not oRS.EOF

        '---------------------------- REQUIRED:

        sXml = sXml & "<entry xmlns=""http://www.w3.org/2005/Atom"">"
        sXml = sXml & "<id>" & oRS("entry_id") & "</id>"
        
        If Len(oRS("title_datatype")) > 0 Then m_sEntryTitleType = oRS("title_datatype")
        sXml = sXml & "<title type=""" & m_sEntryTitleType & """>" & Escape(m_sEntryTitleType, oRS("title")) & "</title>"

        If Len(oRS("updated")) > 0 Then
            sXml = sXml & "<updated>" & oRS("updated") & "</updated>"
        Else
            sXml = sXml & "<updated>" & CreateAtomTime & "</updated>"
        End If

        '---------------------------- RECOMMENDED:

        If Len(oRS("author_name")) > 0 Then
            sXml = sXml & "<author><name>" & oRS("author_name") & "</name>"

            If Len(oRS("author_email")) > 0 Then sXml = sXml & "<email>" & oRS("author_email") & "</email>"
            If Len(oRS("author_uri")) > 0 Then sXml = sXml & "<uri>" & Server.HTMLEncode(oRS("author_uri")) & "</uri>"
            sXml = sXml & "</author>"
        End If

        '// Contains or links to the complete content of the entry.
        If Len(oRS("content")) > 0 Then
            If Len(oRS("content_datatype")) > 0 Then m_sEntryContentType = oRS("content_datatype")
            sXml = sXml & "<content type=""" & m_sEntryContentType & """>" & Escape(m_sEntryContentType, oRS("content")) & "</content>"
        End If

        If Len(oRS("summary")) > 0 Then
            If Len(oRS("summary_datatype")) > 0 Then m_sEntrySummaryType = oRS("summary_datatype")
            sXml = sXml & "<summary type=""" & m_sEntrySummaryType & """>" & Escape(m_sEntrySummaryType, oRS("summary")) & "</summary>"
        End If

        If Len(oRS("link_alternate")) > 0 Then
            sXml = sXml & "<link rel=""alternate"" href=""" & Server.HTMLEncode(oRS("link_alternate")) & """/>"
        End If

        '---------------------------- OPTIONAL:

        If Len(oRS("category")) > 0 Then
            If InStr(oRS("category"), ",") > 0 Then
                arrTmp = Split(oRS("category"), ",")

                For iCounter = 0 To UBound(arrTmp)
                    sXml = sXml & "<category term=""" & Trim(arrTmp(iCounter)) & """/>"
                Next

            Else
                sXml = sXml & "<category term=""" & oRS("category") & """/>"
            End If
        End If

        If Len(oRS("contributor_name")) > 0 Then
            sXml = sXml & "<contributor><name>" & oRS("contributor_name") & "</name>"

            If Len(oRS("contributor_email")) > 0 Then sXml = sXml & "<email>" & oRS("contributor_email") & "</email>"
            If Len(oRS("contributor_uri")) > 0 Then sXml = sXml & "<uri>" & Server.HTMLEncode(oRS("contributor_uri")) & "</uri>"
            sXml = sXml & "</contributor>"
        End If

        If Len(oRS("published")) > 0 Then
            sXml = sXml & "<published>" & oRS("published") & "</published>"
        End If
                
        If Len(oRS("rights_datatype")) > 0 Then m_sEntryRightsType = oRS("rights_datatype")
        If Len(oRS("rights")) > 0 Then
            sXml = sXml & "<rights type=""" & m_sEntryRightsType & """>" & Escape(m_sEntryRightsType, oRS("rights")) & "</rights>"
        End If
        
        '// The source element is designed to allow the aggregation of entries from different feeds
        '// while retaining information about the entry's source feed.
        If Len(oRS("source_title")) > 0 Then
            sXml = sXml & "<source><title>" & oRS("source_title") & "</title>"

            If Len(oRS("source_id")) > 0 Then sXml = sXml & "<id>" & oRS("source_id") & "</id>"
            If Len(oRS("source_updated")) > 0 Then sXml = sXml & "<link>" & Server.HTMLEncode(oRS("source_updated")) & "</link>"

            If Len(oRS("source_rights")) > 0 Then sXml = sXml & "<rights>" & oRS("source_rights") & "</rights>"
            sXml = sXml & "</source>"
        End If

        sXml = sXml & "</entry>"

        oRS.MoveNext
    Loop

    sXml = sXml & "</feed>"

    '// Save the resulting Atom 1.0 feed to file as utf-8.
    Call UTF8(sXml)

End Sub

'------------------------------------------------------------------------------------------------------------
' Comment: Save Atom Feed to file. Default encoding for Xmldom is utf-8.
'------------------------------------------------------------------------------------------------------------
Private Sub UTF8(sXml)
'    On Error Resume Next

    Dim oXML

    Set oXML = Server.CreateObject(XMLDOM_PROGID)

    With oXML
        .async = False
        .loadXML (sXml)
        .save m_sFeedSavePath
    End With

    If (oXML.parseError.errorCode <> 0) Then
        Response.Write "XML parseError errorCode " & oXML.parseError.errorCode & "<br />"
        Response.Write "XML parseError on line " & oXML.parseError.Line & "<br />"
        Response.Write "XML parseError linepos " & oXML.parseError.linepos & "<br />"
        Response.Write "XML parseError reason " & oXML.parseError.reason & "<br />"
    End If

    Set oXML = Nothing

End Sub

'------------------------------------------------------------------------------------------------------------
' Comment: Some elements have a data type attribute: text, html or xhtml.
'------------------------------------------------------------------------------------------------------------
Private Function Escape(sType, sValue)
'    On Error Resume Next

    Dim sXml

    Select Case UCase(sType)
        Case "TEXT"
            '// Plain text
            sXml = sValue
        Case "HTML"
            '// Escaped HTML
            sXml = Server.HTMLEncode(sValue)
        Case "XHTML"
            '// Well-formed XHTML
            sXml = "<div xmlns=""http://www.w3.org/1999/xhtml"">" & sValue & "</div>"
        Case Else
            '// Arbitrary XML
            '// Base-64 encoded binary content
            '// URI pointers to content not included directly within the feed
    End Select

    Escape = sXml

End Function

'------------------------------------------------------------------------------------------------------------
' Comment: Create valid RFC3339 timestamp for Atom 1.0. Example: 2006-04-12T23:20:50Z
'------------------------------------------------------------------------------------------------------------
Public Function CreateAtomTime()
'    On Error Resume Next

    Dim sYear, sMonth, sDay, sHour, sMinute, sSecond
    Dim arrUTC, arrUTCTime

    '// Use JScript to get the current UTC (GMT) timestamp and store it in Session("ServerGMT")
    '// Session("ServerGMT") should have this format: Wed, 1 Feb 2006 15:00:00 UTC
    Server.Execute "GetServerGMT.asp"

    arrUTC = Split(Session("ServerGMT"), Chr(32))
    arrUTCTime = Split(arrUTC(4), ":")

    sYear = arrUTC(3)
    sMonth = Right("0" & ConvertUTCMonth(arrUTC(2)), 2)
    sDay = Right("0" & arrUTC(1), 2)
    sHour = arrUTCTime(0)
    sMinute = arrUTCTime(1)
    sSecond = arrUTCTime(2)

    CreateAtomTime = sYear & "-" & sMonth & "-" & sDay & "T" & sHour & ":" & sMinute & ":" & sSecond & "Z"

End Function

'------------------------------------------------------------------------------------------------------------
' Comment: A helper routine for CreateAtomTime.
'------------------------------------------------------------------------------------------------------------
Private Function ConvertUTCMonth(sMonth)
'    On Error Resume Next

    Dim sOut

    Select Case UCase(sMonth)
        Case "JAN"
            sOut = 1
        Case "FEB"
            sOut = 2
        Case "MAR"
            sOut = 3
        Case "APR"
            sOut = 4
        Case "MAY"
            sOut = 5
        Case "JUN"
            sOut = 6
        Case "JUL"
            sOut = 7
        Case "AUG"
            sOut = 8
        Case "SEP"
            sOut = 9
        Case "OCT"
            sOut = 10
        Case "NOV"
            sOut = 11
        Case "DEC"
            sOut = 12
        Case Else
    End Select

    ConvertUTCMonth = sOut

End Function

'========================================================================
End Class
'========================================================================
%>