;NNTP-Library 1.0, written by Uwe Keller, 15.12.2011

EnableExplicit

DisableDebugger
InitNetwork()
EnableDebugger

Enumeration ;attributes
  #NntpAttributeTimeout
  #NntpAttributeReceived
  #NntpAttributeSent
EndEnumeration
Enumeration ;article decode states
  #_NntpStateHeader
  #_NntpStateText
  #_NntpStateBase64
  #_NntpStateUU
  #_NntpStateYenc
EndEnumeration
Enumeration ;multi part collector flags
  #NntpMultiPartByNumber = 1
  #NntpMultiPartRemoveYenc = 2
  #NntpMultiPartRemoveEmail = 4
  #NntpMultiPartKeepZeros = 8
EndEnumeration

Structure NntpConnectResult
  Reply.s
  Authinfo.s
EndStructure
Structure NntpListItem
  Newsgroup.s
  First.q
  Last.q
  Flag.s
EndStructure
Structure NntpListResult
  Reply.s
  List Items.NntpListItem()
EndStructure
Structure NntpGroupResult
  Reply.s
  Newsgroup.s
  First.q
  Last.q
  Count.q
EndStructure
Structure NntpXoverItem
  Number.q
  Subject.s
  Author.s
  Date.l
  Id.s
  References.s
  Bytes.l
  Xref.s
EndStructure
Structure NntpXoverResult
  Reply.s
  List Items.NntpXoverItem()
EndStructure
Structure NntpXhdrItem
  Number.q
  Value.s
EndStructure
Structure NntpXhdrResult
  Reply.s
  List Items.NntpXhdrItem()
EndStructure
Structure NntpArticleHeader
  Name.s
  Value.s
EndStructure
Structure NntpArticleAttachment
  Name.s
  List Data.a()
EndStructure
Structure NntpArticleResult
  Reply.s
  List Headers.NntpArticleHeader()
  Text.s
  List Attachments.NntpArticleAttachment()
EndStructure
Structure NntpXpatItem
  Number.q
  Value.s
EndStructure
Structure NntpXpatResult
  Reply.s
  List Items.NntpXpatItem()
EndStructure
Structure NntpMultiPart
  Subject.s
  Author.s
  Date.l
  Bytes.q
  Array Ids.s(0)
  Count.i ; number of retrieved parts
EndStructure
Structure NntpFileInfo
  Index.l
  Count.l
EndStructure
Structure _NntpItem
  Connection.i
  Timeout.i
  Received.q
  Sent.q
EndStructure

Global Dim _NntpItems._NntpItem(31)

Procedure.s _NntpDecodeQP(text.s)
  ;TODO use in Article when quoted-printable
  Protected n, i, char.s
  ;decodes a text encoded as quoted-printable.
  Static qprx
  If Not qprx
    qprx = CreateRegularExpression(#PB_Any, "(?i)\=[0-9A-F][0-9A-F]")
  EndIf
  ;check occurances
  Dim r.s(0)
  n = ExtractRegularExpression(qprx, text, r())
  For i = 0 To n - 1
    char = Chr(Val("$" + Mid(r(i), 2)))
    text = ReplaceString(text, r(i), char)
  Next
  ProcedureReturn text
EndProcedure
Procedure.s _NntpDecodeString(Subject.s)
  ;decodes text according RFC 2047
  Protected xl, xr, left.s, right.s, center.s, a, b, encoding.s, encoded.s, decoded.s
  xl = FindString(Subject, "=?")
  If xl
    For xr = Len(Subject) - 1 To xl + 2 Step -1
      If Mid(Subject, xr, 2) = "?="
        left = Mid(Subject, 1, xl - 1)
        right = Mid(Subject, xr + 2)
        xl + 2
        center = Mid(Subject, xl, xr - xl)
        ;get encoding
        a = FindString(center, "?")
        If a
          b = FindString(center, "?", a + 1)
          If b
            encoding = Mid(center, a + 1, b - a - 1)
            encoded = Mid(center, b + 1)
            Select encoding
              Case "Q", "q" ;quoted-printable
                ProcedureReturn left + _NntpDecodeQP(encoded) + right
              Case "B", "b" ;base64
                decoded = Space(Len(encoded))
                Base64Decoder(@encoded, Len(encoded), @decoded, Len(decoded))
                ProcedureReturn left + decoded + right
            EndSelect
          EndIf
        EndIf
        Break
      EndIf
    Next
  EndIf
  ProcedureReturn subject
EndProcedure
Procedure.s _NntpHeaderSubValue(Value.s, Name.s)
  Protected i, x, subitem.s, subname.s, subvalue.s
  ;returns sub-values from header value by name
  For i = 1 To CountString(Value, ";")
    subitem = StringField(Value, 1 + i, ";")
    x = FindString(subitem, "=")
    If x > 0
      subname = LCase(Trim(Left(subitem, x - 1)))
      If subname = Name
        subvalue = Trim(Trim(Mid(subitem, x + 1)), Chr(34))
        ProcedureReturn subvalue
      EndIf
    EndIf
  Next
EndProcedure
Procedure _NntpDecodeHeader(Line.s, *Boundary.s, *ContentTransferEncoding.s, *Result.NntpArticleResult)
  Protected x, ContentName.s
  ;decodes an article header
  Select Asc(Left(Line, 1))
    Case 65 To 90 ;A-Z
      ;add new header which must start with a letter
      AddElement(*Result\Headers())
      x = FindString(Line, ":")
      *Result\Headers()\Name = Left(Line, x - 1)
      *Result\Headers()\Value = _NntpDecodeString(Mid(Line, x + 2))
    Case #TAB, 32
      ;append folded header to previous header (remove eventually tabs by spaces)
      *Result\Headers()\Value + ReplaceString(_NntpDecodeString(Line), #TAB$, " ")
    Case 0
      ;header/body split
      ;read thru all headers and get the latest value for Content-Type, ContentName and Content-Transfer-Encoding
      ForEach *Result\Headers()
        With *Result\Headers()
          Select LCase(\Name)
            Case "content-type"
              ContentName = _NntpHeaderSubValue(\Value, "name")
              ;get boundary if multipart
              If LCase(Left(\Value, 10)) = "multipart/"
                *Boundary = _NntpHeaderSubValue(\Value, "boundary")
              EndIf
            Case "content-disposition"
              ContentName = _NntpHeaderSubValue(\Value, "filename")
            Case "content-transfer-encoding"
              *ContentTransferEncoding = LCase(\Value)
          EndSelect
        EndWith
      Next
      ;create new Base64 attachment
      If *ContentTransferEncoding = "base64"
        AddElement(*Result\Attachments())
        *Result\Attachments()\Name = ContentName
        ProcedureReturn #_NntpStateBase64
      Else
        ProcedureReturn #_NntpStateText
      EndIf
  EndSelect
  ;keep header state
  ProcedureReturn #_NntpStateHeader
EndProcedure
Procedure _NntpDecodeCheckUU(Line.s)
  Protected i
  ;check whether it is a valid uu-encoded line
  If Len(Line) And (PeekA(@Line) - 32) / 3 = (Len(Line) - 1) / 4
    ;check each character whether it is valid
    For i = 1 To Len(Line) - 1
      Select PeekA(@Line + i)
        Case 33 To 96
          ;valid character
        Default
          ;invalid character
          ProcedureReturn #False
      EndSelect
    Next
    ;this is a valid UU-encoded line
    ProcedureReturn #True
  EndIf
  ;this is not a valid UU encoded line
EndProcedure
Procedure _NntpDecodeUU(Line.s, *Result.NntpArticleResult)
  Protected i, n, c1.a, c2.a, c3.a, c4.a, b1.a, b2.a, b3.a
  ;decode an UU encoded line
  If Line = "" Or Line = "end"
    ;return to text if UU data ended (normally or unexpectively)
    ProcedureReturn #_NntpStateText
  ElseIf Line <> "`" ;this is an empty line
    n = PeekA(@Line) - 32
    For i = 1 To Len(Line) - 4 Step 4
      ;decode 4 characters
      c1 = (PeekA(@Line + i) - 32) & %111111
      c2 = (PeekA(@Line + i + 1) - 32) & %111111
      c3 = (PeekA(@Line + i + 2) - 32) & %111111
      c4 = (PeekA(@Line + i + 3) - 32) & %111111
      ;convert them into 3 bytes
      b1 = c1 << 2 | c2 >> 4
      b2 = c2 << 4 | c3 >> 2
      b3 = c3 << 6 | c4
      ;write bytes
      With *Result\Attachments()
        AddElement(\Data())
        \Data() = b1
        n - 1
        If n > 0
          AddElement(\Data())
          \Data() = b2
          n - 1
          If n > 0
            AddElement(\Data())
            \Data() = b3
            n - 1
          EndIf
        EndIf
      EndWith
    Next
    ;keep UU state
    ProcedureReturn #_NntpStateUU
  EndIf
EndProcedure
Procedure _NntpDecodeBase64(Line.s, *Boundary.s, *Result.NntpArticleResult)
  ;decode a Base64 encoded line
  Protected b64.a, chars.s, i, c1.a, c2.a, c3.a, c4.a, b1.a, b2.a, b3.a
  ;setup Base64 array on very first call
  Static Dim b64(255)
  If Not b64(66)
    chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    For i = 0 To Len(chars) - 1
      b64(PeekA(@chars + i)) = i
    Next
  EndIf
  ;return to text state on empty line
  If Not Line
    ProcedureReturn #_NntpStateText
  ElseIf Left(Line, 2) = "--" And Mid(Line, 3, Len(*Boundary)) = *Boundary
    ;return to normal text end MIME part
    ProcedureReturn #_NntpStateText
  Else
    ;decode line
    For i = 0 To Len(Line) - 1 Step 4
      ;get 4 bytes
      c1 = b64(PeekA(@Line + i))
      c2 = b64(PeekA(@Line + i + 1))
      c3 = b64(PeekA(@Line + i + 2))
      c4 = b64(PeekA(@Line + i + 3))
      ;convert them into 3 bytes
      b1 = c1 << 2 | c2 >> 4
      b2 = c2 << 4 | c3 >> 2
      b3 = c3 << 6 | c4
      ;write bytes
      With *Result\Attachments()
        AddElement(\Data())
        \Data() = b1
        If c3 > -1 ;kann nicht gehen da c nie -1 ist
          AddElement(\Data())
          \Data() = b2
          If c4 > -1
            AddElement(\Data())
            \Data() = b3
          EndIf
        EndIf
      EndWith
    Next
    ;keep Base64 state
    ProcedureReturn #_NntpStateBase64
  EndIf
EndProcedure
Procedure _NntpDecodeYenc(Line.s, *Result.NntpArticleResult)
  ;decode an yEnc encoded line
  Protected i, a.a, special.b
  ;return to text after Yenc has ended
  If Left(Line, 6) = "=yend "
    ProcedureReturn #_NntpStateText
    ;skip second yenc header line
  ElseIf Left(Line, 7) <> "=ypart "
    ;decode one yEnc line (but skip second header line)
    For i = 0 To Len(Line) - 1
      ;get byte
      a = PeekA(@Line + i)
      ;check special character
      If special
        Special = #False
        ;subtract 64 modulo 256
        a - 64
      ElseIf a = 61
        special = #True
        ;this was the special so do not store into container
        Continue
      EndIf
      ;subtract 42 modulo 256
      a - 42
      ;append byte to data array
      With *Result\Attachments()
        AddElement(\Data())
        \Data() = a
      EndWith
    Next
  EndIf
  ;keep yenc state
  ProcedureReturn #_NntpStateYenc
EndProcedure
Procedure _NntpDecodeText(Line.s, *Boundary.s, *ContentTransferEncoding.s, *Result.NntpArticleResult)
  ;decode as text but find binaries or mime parts
  ;new MIME part
  If Left(Line, 2) = "--" And *Boundary And Mid(Line, 3, Len(*Boundary)) = *Boundary
    ;return to headers will read additional multi-part headers
    ProcedureReturn #_NntpStateHeader
  ElseIf Left(Line, 8) = "=ybegin "
    AddElement(*Result\Attachments())
    *Result\Attachments()\Name = Mid(Line, FindString(Line, "name=", 1) + 5)
    ProcedureReturn #_NntpStateYenc
  ElseIf Left(Line, 6) = "begin " And Val(Mid(Line, 7, 3)) > 0
    AddElement(*Result\Attachments())
    *Result\Attachments()\Name = Mid(Line, 11)
    ProcedureReturn #_NntpStateUU
  ElseIf _NntpDecodeCheckUU(Line)
    AddElement(*Result\Attachments())
    _NntpDecodeUU(Line, *Result)
    ProcedureReturn #_NntpStateUU
    ;skip multi part message text
  ElseIf Line = "This is a multi-part message in MIME format."
    ;add text (but do not start with empty lines)
  ElseIf *Result\Text <> "" Or Line <> ""
    ;quoted-printable
    If *ContentTransferEncoding = "quoted-printable"
      ;decode specials (=##)
      Line = _NntpDecodeQP(Line)
      ;soft line-breaks with = at the end of the line
      If Right(Line, 1) = "="
        *Result\Text + Left(Line, Len(Line) - 1)
      Else
        *Result\Text + Line + #CRLF$
      EndIf
    Else
      ;normal text
      If *Result\Text <> ""
        *Result\Text + #CRLF$
      EndIf
      *Result\Text + Line
    EndIf
  EndIf
  ;keep text state
  ProcedureReturn #_NntpStateText
EndProcedure
Procedure.s _NntpReceive(Id, List Lines.s())
  ;receive response from newsserver
  Protected *buf, started, ended, len, a, b, e, alive, line.s, rest.s, first.s
  With _NntpItems(Id)
    *buf = AllocateMemory(1440)
    started = ElapsedMilliseconds()
    alive = started
    Repeat
      If NetworkClientEvent(\Connection) = #PB_NetworkEvent_Data
        ;receive new data
        len = ReceiveNetworkData(\Connection, *buf, 1440)
        ;network error or no more data
        If len < 1
          Break
        EndIf
        ;remember last time of data receival
        alive = ElapsedMilliseconds()
        ;count amount of received bytes
        \Received + len
        ;split received data by line ($CRLF#)
        a = *buf
        e = *buf + len - 1
        For b = a To e
          Select PeekA(b)
            Case #LF
              ;set line start behind LF (#CRLF$ was splitted caused by block data)
              a = b + 1
            Case #CR
              ;cut line
              line = PeekS(a, b - a, #PB_Ascii)
              ;check rest
              If rest
                line = rest + line
                rest = ""
              EndIf
              ;ready
              If line = "."
                Break 2
              EndIf
              ;remove the very first dot
              If Left(line, 1) = "."
                line = Mid(line, 2)
              EndIf
              ;keep first line as response
              If Not first
                ;Debug "R: " + line
                first = line
                Select Left(line, 3)
                  Case "215", "220", "221", "224"
                    ;continue until "."
                  Default
                    ;reply is not a list so stop here
                    Break 2
                EndSelect
              Else
                ;add line to collection
                AddElement(Lines())
                Lines() = line
              EndIf
              ;set new line start
              a = b + 1
          EndSelect
        Next
        ;keep the rest to stick it before next line (important: add rest to probably existing rest from previous batch)
        If b > a
          rest + PeekS(a, b - a, #PB_Ascii)
        EndIf
      Else
        ;no data received so wait a short while
        Delay(1)
        ;check for timeout
        If ElapsedMilliseconds() - alive > \Timeout
          ClearList(Lines())
          first = "503 Timeout"
          Break
        EndIf
      EndIf
    ForEver
    ended = ElapsedMilliseconds()
    FreeMemory(*buf)
    ;return first line of response
    ProcedureReturn first
  EndWith
EndProcedure
Procedure _NntpSend(Id, Line.s)
  Protected *buf, ascii.s, length
  ;Debug "S: " + Line
  ;attach line feed
  Line + #CRLF$
  ;convert to ascii in unicode mode
  CompilerIf #PB_Compiler_Unicode
    ascii.s = Space(Len(Line))
    PokeS(@ascii, Line, Len(Line), #PB_Ascii)
    *buf = @ascii
  CompilerElse
    *buf = @Line
  CompilerEndIf
  ;get connection
  With _NntpItems(Id)
    ;send command
    length = Len(Line)
    If SendNetworkData(\Connection, *buf, length) = length
      ;add sent bytes
      \Sent + Len(Line)
      ProcedureReturn #True
    EndIf
  EndWith
EndProcedure
Procedure NntpParseDate(date.s)
  ;return a valid date of a string ([Weekday, ][0]1 Jan [20]03 00:00:00 [GMT|[+|-]0000) according RFC822 5.1
  Protected i, s.s, dd, mm, yy, hh, ii, ss, month.s, time.s
  ;get day but overread weekday
  i = 1
  Repeat
    s = StringField(date, i, " ")
    dd = Val(s)
    i + 1
  Until i = 3 Or dd > 0
  ;init months
  Static NewMap months(), m
  If Not m
    For m = 1 To 12
      s = Mid("janfebmaraprmayjunjulaugsepoctnovdec", m * 3 - 2, 3)
      months(s) = m
    Next
  EndIf
  ;parse month
  month = LCase(StringField(date, i, " "))
  mm = Months(month)
  i + 1
  ;year
  yy = Val(StringField(date, i, " "))
  i + 1
  ;time
  time = StringField(date, i, " ")
  hh = Val(StringField(time, 1, ":"))
  ii = Val(StringField(time, 2, ":"))
  ss = Val(StringField(time, 3, ":"))
  ;return real date
  ProcedureReturn Date(yy, mm, dd, hh, ii, ss)
EndProcedure
Procedure NntpConnect(Id, Host.s, User.s, Pass.s, *Result.NntpConnectResult)
  ;open network connection and return connection id
  Static NewList empty.s()
  ;try multiple accounts if available
  With _NntpItems(Id)
    ;clear previous result
    *Result\Reply = ""
    *Result\Authinfo = ""
    ;reset NNTP object data
    \Received = 0
    \Sent = 0
    \Timeout = 60000
    \Connection = OpenNetworkConnection(Host, 119)
    If \Connection
      ;read response
      *Result\Reply = _NntpReceive(Id, empty())
      ;check login result
      Select Left(*Result\Reply, 3)
        Case "200", "201"
          ;authenticate if user/pass given
          If Not User
            ProcedureReturn #True
          ElseIf _NntpSend(Id, "AUTHINFO USER " + User)
            *Result\Authinfo = _NntpReceive(Id, empty())
            If Left(*Result\Authinfo, 3) = "381"
              If _NntpSend(Id, "AUTHINFO PASS " + Pass)
                *Result\Authinfo = _NntpReceive(Id, empty())
                If Left(*Result\Authinfo, 3) = "281"
                  ProcedureReturn #True
                EndIf
              EndIf
            EndIf
          EndIf
      EndSelect
    EndIf
  EndWith
EndProcedure
Procedure NntpDisconnect(Id)
  ;close connection
  With _NntpItems(Id)
    If \Connection
      CloseNetworkConnection(\Connection)
    EndIf
  EndWith
EndProcedure
Procedure NntpList(Id, Active.s, *Result.NntpListResult)
  ;receive newsgroups list from news server (see RFC 977 para 3.6 and RFC 2980 para 2.1.2)
  Protected cmd.s
  If Active = ""
    cmd = "LIST"
  Else
    cmd = "LIST ACTIVE " + Active
  EndIf
  ;send request to news server
  If _NntpSend(Id, cmd)
    ;receive and store newsgroups
    Protected NewList Lines.s()
    *Result\Reply = _NntpReceive(Id, Lines())
    ClearList(*Result\Items())
    If Left(*Result\Reply, 3) = "215"
      ForEach Lines()
        AddElement(*Result\Items())
        With *Result\Items()
          \Newsgroup = StringField(Lines(), 1, " ")
          \Last = Val(StringField(Lines(), 2, " "))
          \First = Val(StringField(Lines(), 3, " "))
          \Flag = StringField(Lines(), 4, " ")
        EndWith
      Next
      ;sort groups by name
      SortStructuredList(*Result\Items(), #PB_Sort_Ascending, OffsetOf(NntpListItem\Newsgroup), #PB_Sort_String)
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure
Procedure NntpGroup(Id, Newsgroup.s, *Result.NntpGroupResult)
  ;select a newsgroup (see RFC 977 para 3.2)
  Static NewList empty.s()
  ClearStructure(*Result, NntpGroupResult)
  If _NntpSend(Id, "GROUP " + Newsgroup)
    With *Result
      \Reply = _NntpReceive(Id, empty())
      If Left(\Reply, 3) = "211"
        \Count = Val(StringField(\Reply, 2, " "))
        \First = Val(StringField(\Reply, 3, " "))
        \Last = Val(StringField(\Reply, 4, " "))
        \Newsgroup = StringField(\Reply, 5, " ")
        ProcedureReturn #True
      EndIf
    EndWith
  EndIf
EndProcedure
Procedure NntpXover(Id, First.q, Last.q, *Result.NntpXoverResult, Flags=0)
  ;returns information from the overview database for a range of articles (see RFV 2980 para 2.8)
  If _NntpSend(Id, "XOVER " + Str(First) + "-" + Str(Last))
    Protected NewList Lines.s()
    *Result\Reply = _NntpReceive(Id, Lines())
    ClearList(*Result\Items())
    If Left(*Result\Reply, 3) = "224"
      ForEach Lines()
        AddElement(*Result\Items())
        With *Result\Items()
          \Number = Val(StringField(Lines(), 1, #TAB$))
          \Subject = _NntpDecodeString(StringField(Lines(), 2, #TAB$))
          \Author = _NntpDecodeString(StringField(Lines(), 3, #TAB$))
          \Date = NntpParseDate(StringField(Lines(), 4, #TAB$))
          \Id = StringField(Lines(), 5, #TAB$)
          \References = StringField(Lines(), 6, #TAB$)
          \Bytes = Val(StringField(Lines(), 7, #TAB$))
          \XRef = StringField(Lines(), 9, #TAB$)
        EndWith
      Next
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure
Procedure NntpXhdr(Id, Header.s, First.q, Last.q, *Result.NntpXhdrResult)
  ;retrieve specific headers from a range of articles (see RFC 2980 para 2.6)
  Protected x
  If _NntpSend(Id, "XHDR " + Header + " " + Str(First) + "-" + Str(Last))
    Protected NewList Lines.s()
    *Result\Reply = _NntpReceive(Id, Lines())
    ClearList(*Result\Items())
    If Left(*Result\Reply, 3) = "221"
      ForEach Lines()
        AddElement(*Result\Items())
        With *Result\Items()
          x = FindString(Lines(), " ")
          \Number = Val(Left(Lines(), x - 1))
          \Value = _NntpDecodeString(Trim(Mid(Lines(), x + 1)))
        EndWith
      Next
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure
Procedure NntpArticle(Id, NumberOrId.s, *Result.NntpArticleResult)
  ;receive an article and decode it (see RFC 977 para 3.1)
  Protected state.b, Boundary.s, ContentTransferEncoding.s
  If _NntpSend(Id, "ARTICLE " + NumberOrId)
    Protected NewList Lines.s()
    ClearList(*Result\Headers())
    ClearList(*Result\Attachments())
    *Result\Reply = _NntpReceive(Id, Lines())
    If Left(*Result\Reply, 3) = "220"
      state = #_NntpStateHeader
      Boundary = ""
      ContentTransferEncoding = ""
      ForEach Lines()
        Select state
          Case #_NntpStateHeader
            state = _NntpDecodeHeader(Lines(), @Boundary, @ContentTransferEncoding, *Result)
          Case #_NntpStateText
            state = _NntpDecodeText(Lines(), @Boundary, @ContentTransferEncoding, *Result)
          Case #_NntpStateBase64
            state = _NntpDecodeBase64(Lines(), @Boundary, *Result)
          Case #_NntpStateUU
            state = _NntpDecodeUU(Lines(), *Result)
          Case #_NntpStateYenc
            state = _NntpDecodeYenc(Lines(), *Result)
        EndSelect
      Next
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure
Procedure NntpXpat(Id, Header.s, First.q, Last.q, MatchCode.s, *Result.NntpXpatResult)
  ;request a special header (see RFC 2980 para 2.9 and para 3.3)
  Protected x
  If _NntpSend(Id, "XPAT " + Header + " " + Str(First) + "-" + Str(Last) + " " + MatchCode)
    Protected NewList Lines.s()
    *Result\Reply = _NntpReceive(Id, Lines())
    ClearList(*Result\Items())
    If Left(*Result\Reply, 3) = "221"
      ForEach Lines()
        x = FindString(Lines(), " ")
        AddElement(*Result\Items())
        With *Result\Items()
          \Number = Val(Left(Lines(), x))
          \Value = Mid(Lines(), x + 1)
        EndWith
      Next
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure
Procedure NntpDate(Id)
  ;returns the servers current date and time (see RFC 2980 para 3.2)
  Static NewList empty.s()
  Protected reply.s
  If _NntpSend(Id, "DATE")
    reply = _NntpReceive(Id, empty())
    If Left(reply, 3) = "111"
      ProcedureReturn ParseDate("%yyyy%mm%dd%hh%ii%ss", Mid(reply, 5))
    EndIf
  EndIf
EndProcedure
Procedure.q NntpGetAttribute(Id, Attribute)
  ;returns an NNTP attribute value
  With _NntpItems(Id)
    Select Attribute
      Case #NntpAttributeTimeout
        ProcedureReturn \Timeout
      Case #NntpAttributeReceived
        ProcedureReturn \Received
      Case #NntpAttributeSent
        ProcedureReturn \Sent
    EndSelect
  EndWith
EndProcedure
Procedure NntpSetAttribute(Id, Attribute, Value.q)
  ;sets an NNTP attribute value
  With _NntpItems(Id)
    Select Attribute
      Case #NntpAttributeTimeout
        \Timeout = Value
      Case #NntpAttributeReceived
        \Received = Value
      Case #NntpAttributeSent
        \Sent = Value
    EndSelect
  EndWith
EndProcedure
Procedure.s NntpFindFilename(Subject.s)
  ;return the filename mentioned in the subject
  Protected lo, hi, xl, xm, xr, quoted.b, letters.b
  lo = @Subject
  hi = @Subject + Len(Subject) - 1
  ;lookup extension dot
  For xm = hi To lo Step -1
    If PeekA(xm) = 46 ;.
      ;lookup extension
      quoted = #False
      letters = #False
      For xr = xm + 1 To hi
        Select PeekA(xr)
          Case 34
            quoted = #True
            Break
          Case 32, 47 ;space or invalid slash
            Break
          Case 48 To 57 ;0-9
            ;ok
          Default
            letters.b = #True
        EndSelect
      Next
      ;lookup name
      If xr - xm < 6 ;extension must be less than 5 digits
        For xl = xm - 1 To lo Step -1
          Select PeekA(xl)
            Case 32 ;space
              If Not quoted
                Break
              EndIf
            Case 34
              If quoted
                Break
              EndIf
            Case 48 To 57, 44, 46 ;0-9,.
              ;ok
            Default
              letters = #True
          EndSelect
        Next
        ;the full filename must at least have one letter
        If letters
          xl + 1
          If xl < xm
            ProcedureReturn PeekS(xl, xr - xl)
            Break
          EndIf
        EndIf
      EndIf
    EndIf
  Next
EndProcedure
Procedure NntpFindFileInfo(Subject.s, *Result.NntpFileInfo)
  ;finds the file index And file count in a subject line.
  Protected n
  ;create regular expressions
  Static rx1, rx2
  If Not rx1
    rx1 = CreateRegularExpression(#PB_Any, "\d+ *(of|/|von) *\d+")
    rx2 = CreateRegularExpression(#PB_Any, "\d+")
  EndIf
  ;find file index and count
  Dim s.s(0)
  If ExtractRegularExpression(rx1, Subject, s())
    ;get index and count
    Dim t.s(0)
    If ExtractRegularExpression(rx2, s(0), t())
      *Result\Index = Val(t(0))
      *Result\Count = Val(t(1))
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure
Procedure.s NntpAuthorName(Author.s)
  ;return the name of an author
  Protected xl, xr
  xl = FindString(Author, "<")
  If xl > 0
    ;new format
    ProcedureReturn Trim(ReplaceString(Left(Author, xl - 1), Chr(34), " "))
  Else
    ;old format
    xl = FindString(Author, "(")
    If xl
      xl + 1
      xr = FindString(Author, ")", xl)
      If xr
        ProcedureReturn Mid(Author, xl, xr - xl)
      EndIf
    Else
      ;name missing, use first part of mail instead
      xl = FindString(Author, "@")
      If xl > 0
        ProcedureReturn Left(Author, xl - 1)
      EndIf
    EndIf
  EndIf
EndProcedure
Procedure NntpMultiPartAdd(List Items.NntpMultiPart(), *Xover.NntpXoverItem, Flags.b=0)
  ;add an Xover item to the collection
  Protected i, n, xl, xm, xr, index, count, reverse, found, subject.s
  ;lookup part index and count
  For i = Len(*Xover\Subject) To 1 Step -1
    Select Mid(*Xover\Subject, i, 1)
      Case ")"
        xr = i
      Case "/"
        xm = i
      Case "("
        xl = i
        Break
    EndSelect
  Next
  ;get index and count
  If xl > 0 And xm > xl And xr > xm
    index = Val(Mid(*Xover\Subject, xl + 1, xm - xl - 1))
    count = Val(Mid(*Xover\Subject, xm + 1, xr - xm - 1))
  EndIf
  ;is zero part (0/*)
  If index = 0 And count > 0
    If Flags & #NntpMultiPartKeepZeros ;convert to normal single part
      index = 1
      count = 1
    Else
      ProcedureReturn #False ;do not add
    EndIf
  EndIf
  ;validate index and count
  If index < 1 Or index > 9999
    index = 1
  EndIf
  If count < 1 Or count > 9999
    count = 1
  EndIf
  ;cut partinfo and trailing spaces from subject
  If xl = 0
    subject = *Xover\Subject
  Else
    Repeat
      xl - 1
    Until xl = 0 Or Mid(*Xover\Subject, xl, 1) <> " "
    subject = Left(*Xover\Subject, xl)
  EndIf
  ;remove yEnc
  If Flags & #NntpMultiPartRemoveYenc
    If LCase(Right(subject, 4)) = "yenc"
      subject = Left(subject, Len(subject) - 5)
    EndIf
  EndIf
  ;try to locate existing multi-part
  If count > 1 And LastElement(Items())
    reverse = 500 + count * 10 ;for larger files the entry must be searched in a larger range
    Repeat
      If Items()\Subject = subject
        found = #True
      EndIf
      n + 1
    Until found Or n > reverse Or Not PreviousElement(Items())
  EndIf
  ;create new multi-part
  If Not found
    LastElement(Items())
    AddElement(Items())
    Items()\Subject = subject
    If Flags & #NntpMultiPartRemoveEmail
      Items()\Author = NntpAuthorName(*Xover\Author)
    Else
      Items()\Author = *Xover\Author
    EndIf
    Items()\Date = *Xover\Date
    ReDim Items()\Ids(count - 1)
  EndIf
  ;store id/number and cumulate size
  index - 1
  If index <= ArraySize(Items()\Ids()) And Not Items()\Ids(index)
    If Flags & #NntpMultiPartByNumber
      Items()\Ids(index) = Str(*Xover\Number)
    Else
      Items()\Ids(index) = *Xover\Id
    EndIf
    Items()\Bytes + *Xover\Bytes
    Items()\Count + 1
    ;return true if multi-part is complete
    If Items()\Count > ArraySize(Items()\Ids())
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure

DisableExplicit