NNTP component for newsserver communication

[jassing]

Tdo you know section / endsection . I searhed forum but not found.

I would bet they are for code folding..
I would just comment them out.

[uwekel]

Sorry for the inconvenience! I updated the code and removed the macro.

[uwekel]

Yes, Section/EndSection are just for code folding and can be removed. Code updated again.

[cptdark]

Will you add support for SSL on 563 (default port I believe) ?

It depends on the PB network commands and there is no SSL support. I have no idea how to implement it by my own. And yes, Port 563 is the default SSL port supported by all major news service providers.

I've developed a simple openssl interface to use for smtp/pop3. Since NNTP could use STARTTLS as of RFC-4642, it may be useful for you.

Look here for download: http://forums.purebasic.com/german/view ... =8&t=27120

It's still work in progress but I succesfully used it for example to connect to gmail.

[Didaktik]

ForEach Item(*ah, *Reply\Headers()) - items not found. Tested on all PB version.

[uwekel]

I am sorry. It is a macro in a resident. I am updating the code this evening.

[uwekel]

Code fixed. It should work now.

[Didaktik]

Thx!

Full fixed code with example:

Code: Select all

;NNTP-Library, 7.9.2013, written by Uwe Keller

EnableExplicit

Macro ifdo( boolean, command )
  If boolean
    command
  EndIf
EndMacro

Enumeration ;attributes
  #NntpAttributeReceived
  #NntpAttributeSent
EndEnumeration
Enumeration ;multi part collector flags
  #NntpMultiPartByNumber = 1
  #NntpMultiPartRemoveYenc = 2
  #NntpMultiPartRemoveEmail = 4
  #NntpMultiPartKeepZeros = 8
EndEnumeration
Enumeration ;attachment encodings
  #NntpEncodingBase64
  #NntpEncodingUU
  #NntpEncodingYenc
EndEnumeration

Structure NntpReply
  Reply.s
EndStructure
Structure NntpListItem
  Newsgroup.s
  first.q
  last.q
  flag.s
EndStructure
Structure NntpListReply Extends NntpReply
  List Items.NntpListItem()
EndStructure
Structure NntpGroupReply Extends NntpReply
  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 NntpXoverReply Extends NntpReply
  List Items.NntpXoverItem()
EndStructure
Structure NntpXhdrItem
  number.q
  Value.s
EndStructure
Structure NntpXhdrReply Extends NntpReply
  List Items.NntpXhdrItem()
EndStructure
Structure NntpArticleHeader
  name.s
  Value.s
EndStructure
Structure NntpArticleAttachment
  name.s
  List Data.a()
  Encoding.b
EndStructure
Structure NntpArticleReply Extends NntpReply
  List Headers.NntpArticleHeader()
  text.s
  List Attachments.NntpArticleAttachment()
EndStructure
Structure NntpPostReply Extends NntpReply
  MessageId.s
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 NntpEncodeResult
  PartCount.i
  TotalBytes.q
  EncodedBytes.q
  CRC.l ;check-sum of whole file
EndStructure
Structure _Nntp
  Connection.i
  Host.s
  Received.q
  Sent.q
  *Buffer
  List Lines.s()
EndStructure

Global Dim _Nntps._Nntp(31)

CompilerIf #PB_Compiler_Unicode
  #CHARSIZE = 2
CompilerElse
  #CHARSIZE = 1
CompilerEndIf

Procedure.s DecodeHtml(text.s)
  Protected XL, xr, encode.s, code.s, ascii
  ;decode HTML
  Repeat
    XL = FindString(text, "&", XL + 1)
    If Not XL
      Break
    EndIf
    xr = FindString(text, ";", XL)
    If Not xr
      Break
    EndIf
    encode = Mid(text, XL + 1, xr - XL - 1)
    Restore HtmlCodes
    Repeat
      Read.s code
      If code = ""
        Break
      EndIf
      Read.a ascii
      If code = encode
        text = ReplaceString(text, "&" + code + ";", Chr(ascii))
        Break
      EndIf
    ForEver
    ;not found
    If code = "" And Left(encode, 1) = "#"
      ascii = Val(Mid(encode, 2))
      If ascii
        text = ReplaceString(text, "&" + encode + ";", Chr(ascii))
      EndIf
    EndIf
  ForEver
  ProcedureReturn text
  DataSection
    HtmlCodes:
    Data.s "nbsp": Data.a 32
    Data.s "quot": Data.a 34
    Data.s "amp": Data.a 38
    Data.s "lt": Data.a 60
    Data.s "gt": Data.a 62
    Data.s "iexcl": Data.a 161
    Data.s "cent": Data.a 162
    Data.s "pound": Data.a 163
    Data.s "curren": Data.a 164
    Data.s "yen": Data.a 165
    Data.s "brvbar": Data.a 166
    Data.s "sect": Data.a 167
    Data.s "uml": Data.a 168
    Data.s "copy": Data.a 169
    Data.s "ordf": Data.a 170
    Data.s "laquo": Data.a 171
    Data.s "not": Data.a 172
    Data.s "shy": Data.a 173
    Data.s "reg": Data.a 174
    Data.s "macr": Data.a 175
    Data.s "deg": Data.a 176
    Data.s "plusmn": Data.a 177
    Data.s "sup2": Data.a 178
    Data.s "sup3": Data.a 179
    Data.s "acute": Data.a 180
    Data.s "micro": Data.a 181
    Data.s "para": Data.a 182
    Data.s "middot": Data.a 183
    Data.s "cedil": Data.a 184
    Data.s "sup1": Data.a 185
    Data.s "ordm": Data.a 186
    Data.s "raquo": Data.a 187
    Data.s "frac14": Data.a 188
    Data.s "frac12": Data.a 189
    Data.s "frac34": Data.a 190
    Data.s "iquest": Data.a 191
    Data.s "Agrave": Data.a 192
    Data.s "Aacute": Data.a 193
    Data.s "Acirc": Data.a 194
    Data.s "Atilde": Data.a 195
    Data.s "Auml": Data.a 196
    Data.s "Aring": Data.a 197
    Data.s "AElig": Data.a 198
    Data.s "Ccedil": Data.a 199
    Data.s "Egrave": Data.a 200
    Data.s "Eacute": Data.a 201
    Data.s "Ecirc": Data.a 202
    Data.s "Euml": Data.a 203
    Data.s "lgrave": Data.a 204
    Data.s "lacute": Data.a 205
    Data.s "lcirc": Data.a 206
    Data.s "luml": Data.a 207
    Data.s "ETH": Data.a 208
    Data.s "Ntilde": Data.a 209
    Data.s "Ograve": Data.a 210
    Data.s "Oacute": Data.a 211
    Data.s "Ocirc": Data.a 212
    Data.s "Otilde": Data.a 213
    Data.s "Ouml": Data.a 214
    Data.s "times": Data.a 215
    Data.s "Oslash": Data.a 216
    Data.s "Ugrave": Data.a 217
    Data.s "Uacute": Data.a 218
    Data.s "Ucirc": Data.a 219
    Data.s "Uuml": Data.a 220
    Data.s "Yacute": Data.a 221
    Data.s "THORN": Data.a 222
    Data.s "szlig": Data.a 223
    Data.s "agrave": Data.a 224
    Data.s "aacute": Data.a 225
    Data.s "acirc": Data.a 226
    Data.s "atilde": Data.a 227
    Data.s "auml": Data.a 228
    Data.s "aring": Data.a 229
    Data.s "aelig": Data.a 230
    Data.s "ccedil": Data.a 231
    Data.s "egrave": Data.a 232
    Data.s "eacute": Data.a 233
    Data.s "ecirc": Data.a 234
    Data.s "euml": Data.a 235
    Data.s "igrave": Data.a 236
    Data.s "iacute": Data.a 237
    Data.s "icirc": Data.a 238
    Data.s "iuml": Data.a 239
    Data.s "eth": Data.a 240
    Data.s "ntilde": Data.a 241
    Data.s "ograve": Data.a 242
    Data.s "oacute": Data.a 243
    Data.s "ocirc": Data.a 244
    Data.s "otilde": Data.a 245
    Data.s "ouml": Data.a 246
    Data.s "divide": Data.a 247
    Data.s "oslash": Data.a 248
    Data.s "ugrave": Data.a 249
    Data.s "uacute": Data.a 250
    Data.s "ucirc": Data.a 251
    Data.s "uuml": Data.a 252
    Data.s "yacute": Data.a 253
    Data.s "thorn": Data.a 254
    Data.s "yuml": Data.a 255
    Data.s ""
  EndDataSection
EndProcedure
Procedure.s DecodeQuotedPrintable(text.s)
  ;decodes a text encoded as quoted-printable.
  ;http://tools.ietf.org/html/rfc2045#section-6.7
  Protected x, v, h.s
  Repeat
    x = FindString(text, "=", x + 1)
    If Not x
      Break
    EndIf
    ;cut out hex value
    h = Mid(text, x + 1, 2)
    ;get value
    If Len(h) = 2
      v = Val("$" + h)
      If v
        text = Left(text, x - 1) + Chr(v) + Mid(text, x + 3)
      EndIf
    EndIf
  ForEver
  ProcedureReturn text
EndProcedure
Procedure.s DecodeString(text.s)
  ;decodes message headers of Non-ASCII text
  ;http://tools.ietf.org/html/rfc2047
  Protected XL, xr, left.s, right.s, center.s, a, b, Encoding.s, encoded.s, decoded.s
  XL = FindString(text, "=?")
  If XL
    For xr = Len(text) - 1 To XL + 2 Step -1
      If Mid(text, xr, 2) = "?="
        left = Mid(text, 1, XL - 1)
        right = Mid(text, xr + 2)
        XL + 2
        center = Mid(text, 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 + DecodeQuotedPrintable(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 text
EndProcedure
Procedure DecodeUU(text.s, List Out.a())
  ;decodes an UU encoded text
  ;http://en.wikipedia.org/wiki/Uuencoding
  Protected i, j, n, count, *a
  Static Dim c.a(3)
  *a = @text
  ;first char contains number of bytes to be decoded
  count = (PeekA(*a) - 32) & %111111
  n = count
  For i = 2 To Len(text) Step 4
    ;read 4 characters
    For j = 0 To 3
      *a + #CHARSIZE
      c(j) = (PeekA(*a) - 32) & %111111
    Next
    ;write bytes
    AddElement(Out())
    Out() = c(0) << 2 | c(1) >> 4
    n - 1
    IfDo(n = 0, Break)
    AddElement(Out())
    Out() = c(1) << 4 | c(2) >> 2
    n - 1
    IfDo(n = 0, Break)
    AddElement(Out())
    Out() = c(2) << 6 | c(3)
    n - 1
  Next
  ;return number of decoded bytes
  ProcedureReturn count
EndProcedure
Procedure DecodeBase64(text.s, List Out.a())
  ;decode a Base64 encoded line
  Protected b64.a, chars.s, i, j, n, *a
  Static Dim c.a(3)
  ;setup Base64 array on very first call
  Static Dim b64(255)
  If Not b64('B')
    chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    For i = 1 To Len(chars)
      b64(Asc(Mid(chars, i, 1))) = i - 1
    Next
  EndIf
  ;decode line
  *a = @text
  For i = 1 To Len(text) Step 4
    ;get 4 bytes
    For j = 0 To 3
      c(j) = b64(PeekA(*a))
      *a + #CHARSIZE
    Next
    ;write bytes
    AddElement(Out())
    Out() = c(0) << 2 | c(1) >> 4
    n + 1
    If c(2) > 0
      AddElement(Out())
      Out() = c(1) << 4 | c(2) >> 2
      n + 1
      If c(3) > 0
        AddElement(Out())
        Out() = c(2) << 6 | c(3)
        n + 1
      EndIf
    EndIf
  Next
  ;return number of decoded bytes
  ProcedureReturn n
EndProcedure
Procedure DecodeYenc(text.s, List Out.a())
  ;decode an yEnc encoded line
  ;http://www.yenc.org/yenc-draft.1.3.txt
  Protected i, n, a.a, special.b, *a
  *a = @text
  For i = 1 To Len(text)
    ;get byte
    a = PeekA(*a)
    *a + #CHARSIZE
    ;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
    AddElement(Out())
    Out() = a
    n + 1
  Next
  ;return number of decoded bytes
  ProcedureReturn n
EndProcedure
Procedure.l DecodeDate(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, ":"))
  ; seconds are optional
  ss = Val(StringField(time, 3, ":"))
  ;return real date
  ProcedureReturn Date(YY, mm, dd, hh, ii, ss)
EndProcedure

;public

Procedure.q NntpAttribute(id, Attribute)
  ;returns an NNTP attribute value
  With _Nntps(id)
    Select Attribute
      Case #NntpAttributeReceived
        ProcedureReturn \Received
      Case #NntpAttributeSent
        ProcedureReturn \Sent
    EndSelect
  EndWith
EndProcedure
Procedure.s NntpFindFilename(Subject.s)
  ;return the filename mentioned in the subject
  Protected XL, xm, xr, quotes.b, letters.a, digits.a, Length
  ;get length of string
  Length = Len(Subject)
  ;lookup extension dot
  For xm = Length To 1 Step -1
    If Asc(Mid(Subject, xm, 1)) = '.'
      ;reset
      digits = 0
      quotes = #False
      letters = #False
      ;lookup extension
      For xr = xm + 1 To Length
        Select Asc(Mid(Subject, xr, 1))
          Case '"'
            quotes = #True
            Break
          Case ' ', '/' ;space or invalid slash
            Break
          Case '0' To '9'
            digits + 1
          Default
            letters + 1
        EndSelect
      Next
      ;extension ok
      Select digits + letters
        Case 1 To 5
          ;lookup name
          For XL = xm - 1 To 1 Step -1
            Select Asc(Mid(Subject, XL, 1))
              Case ' '
                If Not quotes
                  Break
                EndIf
              Case '"'
                If quotes
                  Break
                EndIf
              Case '0' To '9', ',', '.'
                ;ok
              Default
                letters + 1
            EndSelect
          Next
          ;the full filename must at least have one letter
          If letters
            XL + 1
            If XL < xm
              ProcedureReturn Mid(Subject, XL, xr - XL)
              Break
            EndIf
          EndIf
      EndSelect
    EndIf
  Next
EndProcedure
Procedure NntpFindFileInfo(Subject.s, *Reply.NntpFileInfo)
  ;returns the file number and count
  Protected ci, x, XL, xr, idxlen, cntlen, center.s, a.a
  For ci = 1 To 3
    center.s = StringField("of|/|von", ci, "|")
    x = 0
    Repeat
      ;reset
      ClearStructure(*Reply, NntpFileInfo)
      ;lookup occurance
      x = FindString(Subject, center, x + 1, #PB_String_NoCase)
      ;limiter not found
      If Not x
        Break
      EndIf
      ;index
      idxlen = 0
      For XL = x - 1 To 1 Step -1
        a = Asc(Mid(Subject, XL, 1))
        If a >= '0' And a <= '9'
          *Reply\Index + (a - '0') * Pow(10, idxlen)
          idxlen + 1
        ElseIf idxlen > 0 Or a <> ' ' ;skip space between limiter and count
          Break
        EndIf
      Next
      ;count
      cntlen = 0
      For xr = x + Len(center) To Len(Subject)
        a = Asc(Mid(Subject, xr, 1))
        If a >= '0' And a <= '9'
          *Reply\count * 10
          *Reply\count + (a - '0')
          cntlen + 1
        ElseIf cntlen > 0 Or a <> ' ' ;skip space between limiter and count
          Break
        EndIf
      Next
      ;index and count found
      If idxlen > 0 And cntlen > 0
        ProcedureReturn #True
      EndIf
    ForEver
  Next
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 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
Procedure.s NntpFindHeader(List Headers.NntpArticleHeader(), name.s)
  ;returns a header by name
  ForEach Headers()
    If Headers()\name = name
      ProcedureReturn Headers()\Value
    EndIf
  Next
EndProcedure
Procedure NntpEncode(filename.s, List Body.s(), part, *Result.NntpEncodeResult)
  ;encodes a file into several parts using yenc
  Protected f, name.s, start.q, ende.q, pcrc.l, b.a
  #NntpPostPartSize = 500000
  With *Result
    \TotalBytes = FileSize(filename)
    If \TotalBytes > 0
      start = (part - 1) * #NntpPostPartSize
      If start <= \TotalBytes
        f = ReadFile(#PB_Any, filename)
        If f
          ;number of parts
          \PartCount = 1 + (\TotalBytes - 1) / #NntpPostPartSize
          start = (part - 1) * #NntpPostPartSize
          FileSeek(f, start)
          name.s = GetFilePart(filename)
          ;header
          AddElement(Body())
          If \PartCount = 1 ;single-part
            Body() = "=ybegin line=128 size=" + Str(\TotalBytes) + " name=" + name
            ende = \TotalBytes - 1
          Else ;multi-part
            Body() = "=ybegin line=128 part=" + Str(part) + " total=" + Str(\PartCount) + " size=" + Str(Lof(f)) + " name=" + name
            ende = Loc(f) + #NntpPostPartSize - 1
            If ende > \TotalBytes - 1
              ende = \TotalBytes - 1
            EndIf
            AddElement(Body())
            Body() = "=ypart begin=" + Str(Loc(f) + 1) + " end=" + Str(ende + 1)
          EndIf
          ;write yEnc lines
          AddElement(Body())
          pcrc = 0
          While Loc(f) <= ende
            ;encode a byte
            b = ReadByte(f) + 42
            ;calculate CRC's
            \CRC = CRC32Fingerprint(@b, 1, \CRC)
            pcrc = CRC32Fingerprint(@b, 1, pcrc)
            ;encode byte
            Select b
              Case #NUL, #TAB, #LF, #CR, '=' ;is special
                Special:
                Body() + "=" + Chr(b + 64)
              Case ' ' ;space not allowed at the end of a line
                If Len(Body()) = 127
                  Goto Special
                Else
                  Goto Normal
                EndIf
              Case '.' ;dot not allowed on the very first column (valid for yEnc but invalid for NNTP)
                If Len(Body()) = 0
                  Goto Special
                Else
                  Goto Normal
                EndIf
              Default ;no special
                Normal:
                Body() + Chr(b)
            EndSelect
            ;make new line line
            If Len(Body()) >= 128
              AddElement(Body())
            EndIf
          Wend
          ;footer
          AddElement(Body())
          Body() = "=yend size=" + Str(Lof(f))
          ;attach part number and part CRC if multi-part
          If \PartCount > 1
            Body() + " part=" + Str(part) + " pcrc32=" + Hex(pcrc, #PB_Long)
          EndIf
          ;attach CRC of whole file to last part
          If part = \PartCount
            Body() + " crc32=" + Hex(\CRC, #PB_Long)
          EndIf
          CloseFile(f)
          ;set number of encoded bytes
          \EncodedBytes = 1 + ende - start
          ;return #True on success
          ProcedureReturn #True
        EndIf
      EndIf
    EndIf
  EndWith
EndProcedure

;private

Procedure.s _NntpReceive(id)
  ;receive response from newsserver
  With _Nntps(id)
    Protected len, a, b, e, Line.s, rest.s, first.s
    ;clear previous data
    ClearList(\Lines())
    ;receive all lines
    Repeat
      ;receive new data
      len = ReceiveNetworkData(\Connection, \Buffer, 1440)
      ;network error or no more data
      If len < 1
        Break
      EndIf
      ;count amount of received bytes
      \Received + len
      ;split received data by line ($CRLF#)
      a = \Buffer
      e = \Buffer + 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 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
    ForEver
    ;return first line of response
    ProcedureReturn first
  EndWith
EndProcedure
Procedure _NntpSend(id, Line.s)
  ;Debug "S: " + Line
  With _Nntps(id)
    ;attach line feed
    Line + #CRLF$
    ;send command
    If SendNetworkString(\Connection, Line, #PB_Ascii)
      ;add sent bytes
      \Sent + Len(Line)
      ProcedureReturn #True
    EndIf
  EndWith
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

;client

Procedure NntpConnect(id, Host.s, port, User.s, pass.s, *Reply.NntpReply)
  ;open network connection and return connection id
  Protected i, Reply.s
  ;clear previous result
  ClearStructure(*Reply, NntpReply)
  ;try multiple accounts if available
  With _Nntps(id)
    ;init some data
    \Host = Host
    \Buffer = AllocateMemory(1440, #PB_Memory_NoClear)
    \Received = 0
    \Sent = 0
    ClearList(\Lines())
    ;network must be available
    If InitNetwork()
      ;init NNTP object data
      \Connection = OpenNetworkConnection(Host, port)
      If \Connection
        ;read response
        *Reply\Reply = _NntpReceive(id)
        ;check login result
        Select Left(*Reply\Reply, 3)
          Case "200", "201"
            ;authenticate if user/pass given
            If User = ""
              ProcedureReturn #True
            ElseIf _NntpSend(id, "AUTHINFO USER " + User)
              Reply = _NntpReceive(id)
              If Left(Reply, 3) <> "381"
                *Reply\Reply = Reply
              ElseIf _NntpSend(id, "AUTHINFO PASS " + pass)
                Reply = _NntpReceive(id)
                If Left(Reply, 3) <> "281"
                  *Reply\Reply = Reply
                Else
                  ProcedureReturn #True
                EndIf
              EndIf
            EndIf
        EndSelect
      EndIf
    EndIf
  EndWith
EndProcedure
Procedure NntpDisconnect(id)
  ;close connection and free up some resources
  With _Nntps(id)
    If \Connection
      CloseNetworkConnection(\Connection)
      ClearList(\Lines())
      FreeMemory(\Buffer)
      \Connection = 0
      ;keep remain fields for further use (host, received, sent)
    EndIf
  EndWith
EndProcedure
Procedure NntpList(id, Active.s, *Reply.NntpListReply)
  ;receive newsgroups list from news server
  ;http://tools.ietf.org/html/rfc977#section-3.6.1
  ;http://tools.ietf.org/html/rfc2980#section-2.1.2
  Protected *li.NntpListItem
  With _Nntps(id)
    ;clear result
    ClearStructure(*Reply, NntpListReply)
    InitializeStructure(*Reply, NntpListReply)
    ;build command string
    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
      *Reply\Reply = _NntpReceive(id)
      If Left(*Reply\Reply, 3) = "215"
        ForEach \Lines()
          *li = AddElement(*Reply\Items())
          *li\Newsgroup = StringField(\Lines(), 1, " ")
          *li\last = Val(StringField(\Lines(), 2, " "))
          *li\first = Val(StringField(\Lines(), 3, " "))
          *li\flag = StringField(\Lines(), 4, " ")
        Next
        ;sort groups by name
        SortStructuredList(*Reply\Items(), #PB_Sort_Ascending, OffsetOf(NntpListItem\Newsgroup), #PB_String)
        ProcedureReturn #True
      EndIf
    EndIf
  EndWith
EndProcedure
Procedure NntpGroup(id, Newsgroup.s, *Reply.NntpGroupReply)
  ;http://tools.ietf.org/html/rfc977#section-3.2.1
  ClearStructure(*Reply, NntpGroupReply)
  If _NntpSend(id, "GROUP " + Newsgroup)
    With *Reply
      \Reply = _NntpReceive(id)
      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 NntpArticle(id, NumberOrId.s, *Reply.NntpArticleReply)
  ;http://tools.ietf.org/html/rfc977#section-3.1.1
  Protected state.b, *ah.NntpArticleHeader, *aa.NntpArticleAttachment, x
  Protected.s content_name, boundary, content_transfer_encoding
  ;local constants
  #_NntpStateHeader = 0
  #_NntpStateText = 1
  #_NntpStateBase64 = 2
  #_NntpStateUU = 3
  #_NntpStateYenc = 4
  ;short access
  With _Nntps(id)
    If _NntpSend(id, "ARTICLE " + NumberOrId)
      ;clear previous result
      ClearStructure(*Reply, NntpArticleReply)
      InitializeStructure(*Reply, NntpArticleReply)
      ;retrieve article
      *Reply\Reply = _NntpReceive(id)
      If Left(*Reply\Reply, 3) = "220"
        ForEach \Lines()
          Select state
            Case #_NntpStateHeader
              ;decodes an article header
              Select Asc(Left(\Lines(), 1))
                Case 'A' To 'Z'
                  ;add new header which must start with a letter
                  x = FindString(\Lines(), ":")
                  *ah = AddElement(*Reply\Headers())
                  *ah\name = Left(\Lines(), x - 1)
                  *ah\Value = DecodeString(Mid(\Lines(), x + 2))
                Case #TAB, ' '
                  ;append folded header to previous header (remove eventually tabs by spaces)
                  *ah\Value + ReplaceString(DecodeString(\Lines()), #TAB$, " ")
                Case #NUL
                  ;header/body split
                  ;read thru all headers and get the latest value for Content-Type, content_name and Content-Transfer-Encoding
                  ForEach *Reply\Headers()
                    *ah = *Reply\Headers()
                    Select LCase(*ah\name)
                      Case "content-type"
                        content_name = _NntpHeaderSubValue(*ah\Value, "name")
                        ;get boundary if multipart
                        If LCase(Left(*ah\Value, 10)) = "multipart/"
                          boundary = _NntpHeaderSubValue(*ah\Value, "boundary")
                        EndIf
                      Case "content-disposition"
                        content_name = _NntpHeaderSubValue(*ah\Value, "filename")
                      Case "content-transfer-encoding"
                        content_transfer_encoding = LCase(*ah\Value)
                    EndSelect
                  Next
                  ;create new Base64 attachment
                  If content_transfer_encoding = "base64"
                    *aa = AddElement(*Reply\Attachments())
                    *aa\name = Trim(content_name)
                    *aa\Encoding = #NntpEncodingYenc
                    state = #_NntpStateBase64
                  Else
                    state = #_NntpStateText
                  EndIf
              EndSelect
            Case #_NntpStateText
              ;decode as text but find binaries or mime parts
              ;new MIME part
              If Left(\Lines(), 2) = "--" And boundary And Mid(\Lines(), 3, Len(boundary)) = boundary
                ;return to headers will read additional multi-part headers
                state = #_NntpStateHeader
              ElseIf Left(\Lines(), 8) = "=ybegin "
                *aa = AddElement(*Reply\Attachments())
                *aa\name = Trim(Mid(\Lines(), FindString(\Lines(), "name=", 1) + 5))
                *aa\Encoding = #NntpEncodingYenc
                state = #_NntpStateYenc
              ElseIf Left(\Lines(), 6) = "begin " And Val(Mid(\Lines(), 7, 3)) > 0
                *aa = AddElement(*Reply\Attachments())
                *aa\name = Trim(Mid(\Lines(), 11))
                *aa\Encoding = #NntpEncodingUU
                state = #_NntpStateUU
              ElseIf \Lines() And (Asc(Left(\Lines(), 1)) - 32) / 3 = (Len(\Lines()) - 1) / 4
                *aa = AddElement(*Reply\Attachments())
                DecodeUU(\Lines(), *aa\Data())
                *aa\Encoding = #NntpEncodingUU
                state = #_NntpStateUU
              ElseIf \Lines() = "This is a multi-part message in MIME format."
                ;skip multi part message text
                ;add text (but do not start with empty lines)
              ElseIf *Reply\text Or \Lines()
                ;quoted-printable
                If content_transfer_encoding = "quoted-printable"
                  ;decode specials (=##)
                  \Lines() = DecodeQuotedPrintable(\Lines())
                  ;soft line-breaks with = at the end of the line
                  If Right(\Lines(), 1) = "="
                    *Reply\text + Left(\Lines(), Len(\Lines()) - 1)
                  Else
                    *Reply\text + \Lines() + #CRLF$
                  EndIf
                Else
                  ;normal text
                  If *Reply\text
                    *Reply\text + #CRLF$
                  EndIf
                  *Reply\text + \Lines()
                EndIf
              EndIf
            Case #_NntpStateBase64
              ;return to text state on empty line
              If \Lines() = ""
                state = #_NntpStateText
              ElseIf Left(\Lines(), 2) = "--" And Mid(\Lines(), 3, Len(boundary)) = boundary
                ;return to normal text end MIME part
                state = #_NntpStateText
              Else
                DecodeBase64(\Lines(), *aa\Data())
              EndIf
            Case #_NntpStateUU
              ;decode an UU encoded line
              If \Lines() = "" Or \Lines() = "end"
                ;return to text if UU data ended (normal or unexpected)
                state = #_NntpStateText
              Else
                DecodeUU(\Lines(), *aa\Data())
              EndIf
            Case #_NntpStateYenc
              ;decode an yEnc encoded line
              If Left(\Lines(), 6) = "=yend "
                ;return to text after Yenc has ended
                state = #_NntpStateText
                ;skip second yenc header line
              ElseIf Left(\Lines(), 7) <> "=ypart "
                DecodeYenc(\Lines(), *aa\Data())
              EndIf
          EndSelect
        Next
        ProcedureReturn #True
      EndIf
    EndIf
  EndWith
EndProcedure
Procedure NntpStat(id, NumberOrId.s, *Reply.NntpReply)
  If _NntpSend(id, "STAT " + NumberOrId)
    *Reply\Reply = _NntpReceive(id)
    If Left(*Reply\Reply, 3) = "223"
      ProcedureReturn #True
    EndIf
  EndIf
EndProcedure
Procedure NntpXover(id, first.q, last.q, *Reply.NntpXoverReply)
  ;returns information from the overview database for a range of articles (see RFV 2980 para 2.8)
  Protected *xi.NntpXoverItem
  With _Nntps(id)
    ;clear previous result
    ClearStructure(*Reply, NntpXoverReply)
    InitializeStructure(*Reply, NntpXoverReply)
    ;send XOVER command
    If _NntpSend(id, "XOVER " + Str(first) + "-" + Str(last))
      *Reply\Reply = _NntpReceive(id)
      If Left(*Reply\Reply, 3) = "224"
        ForEach \Lines()
          *xi = AddElement(*Reply\Items())
          *xi\number = Val(StringField(\Lines(), 1, #TAB$))
          *xi\Subject = DecodeString(StringField(\Lines(), 2, #TAB$))
          *xi\Author = DecodeString(StringField(\Lines(), 3, #TAB$))
          *xi\date = DecodeDate(StringField(\Lines(), 4, #TAB$))
          *xi\id = StringField(\Lines(), 5, #TAB$)
          *xi\References = StringField(\Lines(), 6, #TAB$)
          *xi\Bytes = Val(StringField(\Lines(), 7, #TAB$))
          *xi\Xref = StringField(\Lines(), 9, #TAB$)
        Next
        ProcedureReturn #True
      EndIf
    EndIf
  EndWith
EndProcedure
Procedure NntpXhdr(id, header.s, first.q, last.q, MatchCode.s, *Reply.NntpXhdrReply)
  ;retrieve specific headers from a range of articles (see RFC 2980 para 2.6, 2.9 and 3.3)
  Protected *xi.NntpXhdrItem, cmd.s, x
  With _Nntps(id)
    ;clear previous result
    ClearStructure(*Reply, NntpXhdrReply)
    InitializeStructure(*Reply, NntpXhdrReply)
    ;build command (use XHDR without or XPAT with matchcode)
    If MatchCode = ""
      cmd = "XHDR " + header + " " + Str(first) + "-" + Str(last)
    Else
      cmd = "XPAT " + header + " " + Str(first) + "-" + Str(last) + " " + MatchCode
    EndIf
    ;send command
    If _NntpSend(id, cmd)
      *Reply\Reply = _NntpReceive(id)
      If Left(*Reply\Reply, 3) = "221"
        ForEach \Lines()
          If Right(\Lines(), 6) <> "(none)"
            *xi = AddElement(*Reply\Items())
            x = FindString(\Lines(), " ")
            *xi\number = Val(Left(\Lines(), x - 1))
            *xi\Value = DecodeString(Mid(\Lines(), x + 1))
          EndIf
        Next
        ProcedureReturn #True
      EndIf
    EndIf
  EndWith
EndProcedure
Procedure NntpDate(id)
  ;returns the servers current date and time (see RFC 2980 para 3.2)
  Protected Reply.s
  If _NntpSend(id, "DATE")
    Reply = _NntpReceive(id)
    If Left(Reply, 3) = "111"
      ProcedureReturn ParseDate("%yyyy%mm%dd%hh%ii%ss", Mid(Reply, 5))
    EndIf
  EndIf
EndProcedure
Procedure NntpPost(id, Newsgroup.s, from.s, Subject.s, List Body.s(), *Reply.NntpPostReply)
  ;http://tools.ietf.org/html/rfc977#section-3.10.1
  Protected XL, xr
  With *Reply
    ;invoke POST command
    _NntpSend(id, "POST")
    \Reply = _NntpReceive(id)
    If Left(\Reply, 3) = "340"
      ;catch message-id
      XL = FindString(\Reply, "<")
      xr = FindString(\Reply, ">", XL + 1)
      If XL > 0 And xr > XL
        ;take message-id from news server
        \MessageId = Mid(\Reply, XL, xr - XL + 1)
      Else
        ;make own message-id if not provided
        ;http://tools.ietf.org/html/rfc850#section-2.1.7
        \MessageId = "<" + FormatDate("%yyyy%mm%dd%hh%ii%ss", Date()) + Hex(Random($FFFF), #PB_Integer) + "@" + _Nntps(id)\Host + ">"
        _NntpSend(id, "Message-Id: " + \MessageId)
      EndIf
      ;send header
      ;http://tools.ietf.org/html/rfc850#section-2.1.5
      _NntpSend(id, "Newsgroups: " + Newsgroup)
      ;http://tools.ietf.org/html/rfc850#section-2.1.3
      _NntpSend(id, "From: " + from)
      ;http://tools.ietf.org/html/rfc850#section-2.1.6
      _NntpSend(id, "Subject: " + Subject)
      _NntpSend(id, "")
      ;send body
      ForEach Body()
        If Left(Body(), 1) = "."
          _NntpSend(id, "." + Body())
        Else
          _NntpSend(id, Body())
        EndIf
      Next
      ;finally send a dot on a line itself to finish post
      _NntpSend(id, ".")
      ;check return code
      \Reply = _NntpReceive(id)
      If Left(\Reply, 3) = "240"
        ProcedureReturn #True
      EndIf
    EndIf
  EndWith
EndProcedure

DisableExplicit
  
#NntpHost = "freenews.netfront.net" ;enter the host name of your news service provider here
#NntpUser = "" ;enter your user name here
#NntpPass = "" ;enter your password here
  
If NntpConnect(0, #NntpHost, 119, #NntpUser, #NntpPass, cr.NntpReply)
  
  Debug cr\Reply
  
  If NntpGroup(0, "alt.binaries.pictures.rail", gr.NntpGroupReply)
    
    ; ;download 100 most recent headers
    If NntpXover(0, gr\last - 100, gr\last, xr.NntpXoverReply)

      ;displays the subject line for all headers
      ForEach xr\Items()
        Debug xr\Items()\Subject
      Next
      
    EndIf
    
    Debug gr\Reply
    
  EndIf  
  
  NntpDisconnect(0)
EndIf

[Didaktik]

Code fixed. It should work now.

You did a great job! thx! tell me please, how i can download the entire archive messages desired group?

I played with the parameters NntpXover first and last. But always got the last 100 posts.

how to download older?

[uwekel]

Sorry Didaktik, i have not seen your posting until now

With the following code, you can download all messages from a newsgroup at once:

Code: Select all

If NntpConnect(0, #Host, #User, #Pass, cr.NntpReply)
  If NntpGroup(0, #Newsgroup, gr.NntpGroupReply)
    If NntpXover(0, gr\First, gr\Last, xr.NntpXoverReply)
      ForEach xr\Items()
        ;...
      Next
    EndIf
  EndIf
  NntpDisconnect(0)
EndIf

Of course, you have to declare the used constants with approprate values. But, in most cases, you cannot download all headers at once. Some newsgroups have billions of headers. If i download headers with my newsreader, i get a batch of 5000 and process them, then get the next batch and so on.