as promised in another thread, today i want to share my NNTP component. With this module, you can connect to a newsserver, download a list of newsgroups and headers, download and decode articles and all you need to handle messages with binary attachments.
Each command or constant in this library starts with Nntp or #Nntp. Private things have an underscore at the beginning and are not supposed to be called from externals. A command always returns #True on success or #False if it failed. The data returned by the news server is stored in a structure, which will also be handed over by argument.
Later i am going to make some examples how to communicate with a news server.
Update 7.9.2013: Minor Bug Fixes
Update 30.5.2013: Library now works with Unicode, Port added.
Update 22.2.2013: Adapted to PB 5.10, some bug fixes and new NntpPost() command.
Here is the source code:
Code: Select all
;NNTP-Library, 7.9.2013, written by Uwe Keller
EnableExplicit
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(#MaxInt), #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
CompilerIf #PB_Compiler_IsMainFile
#NntpHost = "" ;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)
;place your test code here
NntpDisconnect(0)
EndIf
CompilerEndIf