1# nntp.tcl --
2#
3#       nntp implementation for Tcl.
4#
5# Copyright (c) 1998-2000 by Ajuba Solutions.
6# All rights reserved.
7#
8# RCS: @(#) $Id: nntp.tcl,v 1.13 2004/05/03 22:56:25 andreas_kupries Exp $
9
10package require Tcl 8.2
11package provide nntp 0.2.1
12
13namespace eval ::nntp {
14    # The socks variable holds the handle to the server connections
15    variable socks
16
17    # The counter is used to help create unique connection names
18    variable counter 0
19
20    # commands is the list of subcommands recognized by nntp
21    variable commands [list \
22            "article"     \
23            "authinfo"    \
24            "body"        \
25            "date"        \
26            "group"       \
27            "head"        \
28            "help"        \
29            "last"        \
30            "list"        \
31            "listgroup"   \
32            "mode_reader" \
33            "newgroups"   \
34            "newnews"     \
35            "next"        \
36            "post"        \
37            "stat"        \
38            "quit"        \
39            "xgtitle"     \
40            "xhdr"        \
41            "xover"       \
42            "xpat"        \
43            ]
44
45    set ::nntp::eol "\n"
46
47    # only export one command, the one used to instantiate a new
48    # nntp connection
49    namespace export nntp
50
51}
52
53# ::nntp::nntp --
54#
55#       Create a new nntp connection.
56#
57# Arguments:
58#        server -   The name of the nntp server to connect to (optional).
59#        port -     The port number to connect to (optional).
60#        name -     The name of the nntp connection to create (optional).
61#
62# Results:
63#    Creates a connection to the a nntp server.  By default the
64#    connection is established with the machine 'news' at port '119'
65#    These defaults can be overridden with the environment variables
66#    NNTPPORT and NNTPHOST, or can be passed as optional arguments
67
68proc ::nntp::nntp {{server ""} {port ""} {name ""}} {
69    global env
70    variable connections
71    variable counter
72    variable socks
73
74    # If a name wasn't specified for the connection, create a new 'unique'
75    # name for the connection
76
77    if { [llength [info level 0]] < 4 } {
78        set counter 0
79        set name "nntp${counter}"
80        while {[lsearch -exact [info commands] $name] >= 0} {
81            incr counter
82            set name "nntp${counter}"
83        }
84    }
85
86    if { ![string equal [info commands ::$name] ""] } {
87        error "command \"$name\" already exists, unable to create nntp connection"
88    }
89
90    upvar 0 ::nntp::${name}data data
91
92    set socks($name) [list ]
93
94    # Initialize instance specific variables
95
96    set data(debug) 0
97    set data(eol) "\n"
98
99    # Logic to determine whether to use the specified nntp server, or to use
100    # the default
101
102    if {$server == ""} {
103        if {[info exists env(NNTPSERVER)]} {
104            set data(host) "$env(NNTPSERVER)"
105        } else {
106            set data(host) "news"
107        }
108    } else {
109        set data(host) $server
110    }
111
112    # Logic to determine whether to use the specified nntp port, or to use the
113    # default.
114
115    if {$port == ""} {
116        if {[info exists env(NNTPPORT)]} {
117            set data(port) $env(NNTPPORT)
118        } else {
119            set data(port) 119
120        }
121    } else {
122        set data(port) $port
123    }
124
125    set data(code) 0
126    set data(mesg) ""
127    set data(addr) ""
128    set data(binary) 0
129
130    set sock [socket $data(host) $data(port)]
131
132    set data(sock) $sock
133
134    # Create the command to manipulate the nntp connection
135
136    interp alias {} ::$name {} ::nntp::NntpProc $name
137
138    ::nntp::response $name
139
140    return $name
141}
142
143# ::nntp::NntpProc --
144#
145#       Command that processes all nntp object commands.
146#
147# Arguments:
148#       name    name of the nntp object to manipulate.
149#       args    command name and args for the command.
150#
151# Results:
152#       Calls the appropriate nntp procedure for the command specified in
153#       'args' and passes 'args' to the command/procedure.
154
155proc ::nntp::NntpProc {name {cmd ""} args} {
156
157    # Do minimal args checks here
158
159    if { [llength [info level 0]] < 3 } {
160        error "wrong # args: should be \"$name option ?arg arg ...?\""
161    }
162
163    # Split the args into command and args components
164
165    if { [llength [info commands ::nntp::_$cmd]] == 0 } {
166        variable commands
167        set optlist [join $commands ", "]
168        set optlist [linsert $optlist "end-1" "or"]
169        error "bad option \"$cmd\": must be $optlist"
170    }
171
172    # Call the appropriate command with its arguments
173
174    return [eval [linsert $args 0 ::nntp::_$cmd $name]]
175}
176
177# ::nntp::okprint --
178#
179#       Used to test the return code stored in data(code) to
180#       make sure that it is alright to right to the socket.
181#
182# Arguments:
183#       name    name of the nntp object.
184#
185# Results:
186#       Either throws an error describing the failure, or
187#       'args' and passes 'args' to the command/procedure or
188#       returns 1 for 'OK' and 0 for error states.
189
190proc ::nntp::okprint {name} {
191    upvar 0 ::nntp::${name}data data
192
193    if {$data(code) >=400} {
194        set val [expr {(0 < $data(code)) && ($data(code) < 400)}]
195        error "NNTPERROR: $data(code) $data(mesg)"
196    }
197
198    # Codes less than 400 are good
199
200    return [expr {(0 < $data(code)) && ($data(code) < 400)}]
201}
202
203# ::nntp::message --
204#
205#       Used to format data(mesg) for printing to the socket
206#       by appending the appropriate end of line character which
207#       is stored in data(eol).
208#
209# Arguments:
210#       name    name of the nntp object.
211#
212# Results:
213#       Returns a string containing the message from data(mesg) followed
214#       by the eol character(s) stored in data(eol)
215
216proc ::nntp::message {name} {
217    upvar 0 ::nntp::${name}data data
218
219    return "$data(mesg)$data(eol)"
220}
221
222#################################################
223#
224# NNTP Methods
225#
226
227proc ::nntp::_cget {name option} {
228    upvar 0 ::nntp::${name}data data
229
230    if {[string equal $option -binary]} {
231	return $data(binary)
232    } else {
233	return -code error \
234		"Illegal option \"$option\", expected \"-binary\""
235    }
236}
237
238proc ::nntp::_configure {name args} {
239    upvar 0 ::nntp::${name}data data
240
241    if {[llength $args] == 0} {
242	return [list -binary $data(binary)]
243    }
244    if {[llength $args] == 1} {
245	return [_cget $name [lindex $args 0]]
246    }
247    if {([llength $args] % 2) == 1} {
248	return -code error \
249		"wrong#args: expected even number of elements"
250    }
251    foreach {o v} $args {
252	if {[string equal $o -binary]} {
253	    if {![string is boolean -strict $v]} {
254		return -code error \
255			"Expected boolean, got \"$v\""
256	    }
257	    set data(binary) $v
258	} else {
259	    return -code error \
260		    "Illegal option \"$o\", expected \"-binary\""
261	}
262    }
263    return {}
264}
265
266
267# ::nntp::_article --
268#
269#       Internal article proc.  Called by the 'nntpName article' command.
270#       Retrieves the article specified by msgid, in the group specified by
271#       the 'nntpName group' command.  If no msgid is specified the current
272#       (or first) article in the group is retrieved
273#
274# Arguments:
275#       name    name of the nntp object.
276#       msgid   The article number to retrieve
277#
278# Results:
279#       Returns the message (if there is one) from the specified group as
280#       a valid tcl list where each element is a line of the message.
281#       If no article is found, the "" string is returned.
282#
283# According to RFC 977 the responses are:
284#
285#   220 n  article retrieved - head and body follow
286#           (n = article number,  = message-id)
287#   221 n  article retrieved - head follows
288#   222 n  article retrieved - body follows
289#   223 n  article retrieved - request text separately
290#   412 no newsgroup has been selected
291#   420 no current article has been selected
292#   423 no such article number in this group
293#   430 no such article found
294#
295
296proc ::nntp::_article {name {msgid ""}} {
297    upvar 0 ::nntp::${name}data data
298
299    set data(cmnd) "fetch"
300    return [::nntp::command $name "ARTICLE $msgid"]
301}
302
303# ::nntp::_authinfo --
304#
305#       Internal authinfo proc.  Called by the 'nntpName authinfo' command.
306#       Passes the username and password for a nntp server to the nntp server.
307#
308# Arguments:
309#       name    Name of the nntp object.
310#       user    The username for the nntp server.
311#       pass    The password for 'username' on the nntp server.
312#
313# Results:
314#       Returns the result of the attempts to set the username and password
315#       on the nntp server ( 1 if successful, 0 if failed).
316
317proc ::nntp::_authinfo {name {user "guest"} {pass "foobar"}} {
318    upvar 0 ::nntp::${name}data data
319
320    set data(cmnd) ""
321    set res [::nntp::command $name "AUTHINFO USER $user"]
322    if {$res} {
323        set res [expr {$res && [::nntp::command $name "AUTHINFO PASS $pass"]}]
324    }
325    return $res
326}
327
328# ::nntp::_body --
329#
330#       Internal body proc.  Called by the 'nntpName body' command.
331#       Retrieves the body of the article specified by msgid from the group
332#       specified by the 'nntpName group' command. If no msgid is specified
333#       the current (or first) message body is returned
334#
335# Arguments:
336#       name    Name of the nntp object.
337#       msgid   The number of the body of the article to retrieve
338#
339# Results:
340#       Returns the body of article 'msgid' from the group specified through
341#       'nntpName group'. If msgid is not specified or is "" then the body of
342#       the current (or the first) article in the newsgroup will be returned
343#       as a valid tcl list.  The "" string will be returned if there is no
344#       article 'msgid' or if no group has been specified.
345
346proc ::nntp::_body {name {msgid ""}} {
347    upvar 0 ::nntp::${name}data data
348
349    set data(cmnd) "fetch"
350    return [::nntp::command $name "BODY $msgid"]
351}
352
353# ::nntp::_group --
354#
355#       Internal group proc.  Called by the 'nntpName group' command.
356#       Sets the current group on the nntp server to the group passed in.
357#
358# Arguments:
359#       name    Name of the nntp object.
360#       group   The name of the group to set as the default group.
361#
362# Results:
363#    Sets the default group to the group specified. If no group is specified
364#    or if an invalid group is specified an error is thrown.
365#
366# According to RFC 977 the responses are:
367#
368#  211 n f l s group selected
369#           (n = estimated number of articles in group,
370#           f = first article number in the group,
371#           l = last article number in the group,
372#           s = name of the group.)
373#  411 no such news group
374
375proc ::nntp::_group {name {group ""}} {
376    upvar 0 ::nntp::${name}data data
377
378    set data(cmnd) "groupinfo"
379    if {$group == ""} {
380        set group $data(group)
381    }
382    return [::nntp::command $name "GROUP $group"]
383}
384
385# ::nntp::_head --
386#
387#       Internal head proc.  Called by the 'nntpName head' command.
388#       Retrieves the header of the article specified by msgid from the group
389#       specified by the 'nntpName group' command. If no msgid is specified
390#       the current (or first) message header is returned
391#
392# Arguments:
393#       name    Name of the nntp object.
394#       msgid   The number of the header of the article to retrieve
395#
396# Results:
397#       Returns the header of article 'msgid' from the group specified through
398#       'nntpName group'. If msgid is not specified or is "" then the header of
399#       the current (or the first) article in the newsgroup will be returned
400#       as a valid tcl list.  The "" string will be returned if there is no
401#       article 'msgid' or if no group has been specified.
402
403proc ::nntp::_head {name {msgid ""}} {
404    upvar 0 ::nntp::${name}data data
405
406    set data(cmnd) "fetch"
407    return [::nntp::command $name "HEAD $msgid"]
408}
409
410# ::nntp::_help --
411#
412#       Internal help proc.  Called by the 'nntpName help' command.
413#       Retrieves a list of the valid nntp commands accepted by the server.
414#
415# Arguments:
416#       name    Name of the nntp object.
417#
418# Results:
419#       Returns the NNTP commands expected by the NNTP server.
420
421proc ::nntp::_help {name} {
422    upvar 0 ::nntp::${name}data data
423
424    set data(cmnd) "fetch"
425    return [::nntp::command $name "HELP"]
426}
427
428proc ::nntp::_ihave {name {msgid ""} args} {
429    upvar 0 ::nntp::${name}data data
430
431    set data(cmnd) "fetch"
432    if {![::nntp::command $name "IHAVE $msgid"]} {
433        return ""
434    }
435    return [::nntp::squirt $name "$args"]
436}
437
438# ::nntp::_last --
439#
440#       Internal last proc.  Called by the 'nntpName last' command.
441#       Sets the current message to the message before the current message.
442#
443# Arguments:
444#       name    Name of the nntp object.
445#
446# Results:
447#       None.
448
449proc ::nntp::_last {name} {
450    upvar 0 ::nntp::${name}data data
451
452    set data(cmnd) "msgid"
453    return [::nntp::command $name "LAST"]
454}
455
456# ::nntp::_list --
457#
458#       Internal list proc.  Called by the 'nntpName list' command.
459#       Lists all groups or (optionally) all groups of a specified type.
460#
461# Arguments:
462#       name    Name of the nntp object.
463#       Type    The type of groups to return (active active.times newsgroups
464#               distributions distrib.pats moderators overview.fmt
465#               subscriptions) - optional.
466#
467# Results:
468#       Returns a tcl list of all groups or the groups that match 'type' if
469#       a type is specified.
470
471proc ::nntp::_list {name {type ""}} {
472    upvar 0 ::nntp::${name}data data
473
474    set data(cmnd) "fetch"
475    return [::nntp::command $name "LIST $type"]
476}
477
478# ::nntp::_newgroups --
479#
480#       Internal newgroups proc.  Called by the 'nntpName newgroups' command.
481#       Lists all new groups since a specified time.
482#
483# Arguments:
484#       name    Name of the nntp object.
485#       since   The time to find new groups since.  The time can be in any
486#               format that is accepted by 'clock scan' in tcl.
487#
488# Results:
489#       Returns a tcl list of all new groups added since the time specified.
490
491proc ::nntp::_newgroups {name since args} {
492    upvar 0 ::nntp::${name}data data
493
494    set since [clock format [clock scan "$since"] -format "%y%m%d %H%M%S"]
495    set dist ""
496    set data(cmnd) "fetch"
497    return [::nntp::command $name "NEWGROUPS $since $dist"]
498}
499
500# ::nntp::_newnews --
501#
502#       Internal newnews proc.  Called by the 'nntpName newnews' command.
503#       Lists all new news in the specified group since a specified time.
504#
505# Arguments:
506#       name    Name of the nntp object.
507#       group   Name of the newsgroup to query.
508#       since   The time to find new groups since.  The time can be in any
509#               format that is accepted by 'clock scan' in tcl. Defaults to
510#               "1 day ago"
511#
512# Results:
513#       Returns a tcl list of all new messages since the time specified.
514
515proc ::nntp::_newnews {name {group ""} {since ""}} {
516    upvar 0 ::nntp::${name}data data
517
518    if {$group != ""} {
519        if {[regexp -- {^[\w\.\-]+$} $group] == 0} {
520            set since $group
521            set group ""
522        }
523    }
524    if {![info exists group] || ($group == "")} {
525        if {[info exists data(group)] && ($data(group) != "")} {
526            set group $data(group)
527        } else {
528            set group "*"
529        }
530    }
531    if {"$since" == ""} {
532        set since [clock format [clock scan "now - 1 day"]]
533    }
534    set since [clock format [clock scan $since] -format "%y%m%d %H%M%S"]
535    set dist ""
536    set data(cmnd) "fetch"
537    return [::nntp::command $name "NEWNEWS $group $since $dist"]
538}
539
540# ::nntp::_next --
541#
542#       Internal next proc.  Called by the 'nntpName next' command.
543#       Sets the current message to the next message after the current message.
544#
545# Arguments:
546#       name    Name of the nntp object.
547#
548# Results:
549#       None.
550
551proc ::nntp::_next {name} {
552    upvar 0 ::nntp::${name}data data
553
554    set data(cmnd) "msgid"
555    return [::nntp::command $name "NEXT"]
556}
557
558# ::nntp::_post --
559#
560#       Internal post proc.  Called by the 'nntpName post' command.
561#       Posts a message to a newsgroup.
562#
563# Responses (according to RFC 977) to a post request:
564#  240 article posted ok
565#  340 send article to be posted. End with .
566#  440 posting not allowed
567#  441 posting failed
568#
569# Arguments:
570#       name    Name of the nntp object.
571#       article A message of the form specified in RFC 850
572#
573# Results:
574#       None.
575
576proc ::nntp::_post {name article} {
577
578    if {![::nntp::command $name "POST"]} {
579        return ""
580    }
581    return [::nntp::squirt $name "$article"]
582}
583
584# ::nntp::_slave --
585#
586#       Internal slave proc.  Called by the 'nntpName slave' command.
587#       Identifies a connection as being made from a slave nntp server.
588#       This might be used to indicate that the connection is serving
589#       multiple people and should be given priority.  Actual use is
590#       entirely implementation dependant and may vary from server to
591#       server.
592#
593# Arguments:
594#       name    Name of the nntp object.
595#
596# Results:
597#       None.
598#
599# According to RFC 977 the only response is:
600#
601#    202 slave status noted
602
603proc ::nntp::_slave {name} {
604    return [::nntp::command $name "SLAVE"]
605}
606
607# ::nntp::_stat --
608#
609#       Internal stat proc.  Called by the 'nntpName stat' command.
610#       The stat command is similar to the article command except that no
611#       text is returned.  When selecting by message number within a group,
612#       the stat command serves to set the current article pointer without
613#       sending text. The returned acknowledgement response will contain the
614#       message-id, which may be of some value.  Using the stat command to
615#       select by message-id is valid but of questionable value, since a
616#       selection by message-id does NOT alter the "current article pointer"
617#
618# Arguments:
619#       name    Name of the nntp object.
620#       msgid   The number of the message to stat (optional) default is to
621#               stat the current article
622#
623# Results:
624#       Returns the statistics for the article.
625
626proc ::nntp::_stat {name {msgid ""}} {
627    upvar 0 ::nntp::${name}data data
628
629    set data(cmnd) "status"
630    return [::nntp::command $name "STAT $msgid"]
631}
632
633# ::nntp::_quit --
634#
635#       Internal quit proc.  Called by the 'nntpName quit' command.
636#       Quits the nntp session and closes the socket.  Deletes the command
637#       that was created for the connection.
638#
639# Arguments:
640#       name    Name of the nntp object.
641#
642# Results:
643#       Returns the return value from the quit command.
644
645proc ::nntp::_quit {name} {
646    upvar 0 ::nntp::${name}data data
647
648    set ret [::nntp::command $name "QUIT"]
649    close $data(sock)
650    rename ${name} {}
651    return $ret
652}
653
654#############################################################
655#
656# Extended methods (not available on all NNTP servers
657#
658
659proc ::nntp::_date {name} {
660    upvar 0 ::nntp::${name}data data
661
662    set data(cmnd) "msg"
663    return [::nntp::command $name "DATE"]
664}
665
666proc ::nntp::_listgroup {name {group ""}} {
667    upvar 0 ::nntp::${name}data data
668
669    set data(cmnd) "fetch"
670    return [::nntp::command $name "LISTGROUP $group"]
671}
672
673proc ::nntp::_mode_reader {name} {
674    upvar 0 ::nntp::${name}data data
675
676    set data(cmnd) "msg"
677    return [::nntp::command $name "MODE READER"]
678}
679
680proc ::nntp::_xgtitle {name {group_pattern ""}} {
681    upvar 0 ::nntp::${name}data data
682
683    set data(cmnd) "fetch"
684    return [::nntp::command $name "XGTITLE $group_pattern"]
685}
686
687proc ::nntp::_xhdr {name {header "message-id"} {list ""} {last ""}} {
688    upvar 0 ::nntp::${name}data data
689
690    if {![regexp -- {\d+-\d+} $list]} {
691        if {"$last" != ""} {
692            set list "$list-$last"
693        } else {
694            set list ""
695	}
696    }
697    set data(cmnd) "fetch"
698    return [::nntp::command $name "XHDR $header $list"]
699}
700
701proc ::nntp::_xindex {name {group ""}} {
702    upvar 0 ::nntp::${name}data data
703
704    if {("$group" == "") && [info exists data(group)]} {
705        set group $data(group)
706    }
707    set data(cmnd) "fetch"
708    return [::nntp::command $name "XINDEX $group"]
709}
710
711proc ::nntp::_xmotd {name {since ""}} {
712    upvar 0 ::nntp::${name}data data
713
714    if {"$since" != ""} {
715        set since [clock seconds]
716    }
717    set since [clock format [clock scan $since] -format "%y%m%d %H%M%S"]
718    set data(cmnd) "fetch"
719    return [::nntp::command $name "XMOTD $since"]
720}
721
722proc ::nntp::_xover {name {list ""} {last ""}} {
723    upvar 0 ::nntp::${name}data data
724    if {![regexp -- {\d+-\d+} $list]} {
725        if {"$last" != ""} {
726            set list "$list-$last"
727        } else {
728            set list ""
729	}
730    }
731    set data(cmnd) "fetch"
732    return [::nntp::command $name "XOVER $list"]
733}
734
735proc ::nntp::_xpat {name {header "subject"} {list 1} {last ""} args} {
736    upvar 0 ::nntp::${name}data data
737
738    set patterns ""
739
740    if {![regexp -- {\d+-\d+} $list]} {
741        if {("$last" != "") && ([string is digit $last])} {
742            set list "$list-$last"
743        }
744    } elseif {"$last" != ""} {
745        set patterns "$last"
746    }
747
748    if {[llength $args] > 0} {
749        set patterns "$patterns $args"
750    }
751
752    if {"$patterns" == ""} {
753        set patterns "*"
754    }
755
756    set data(cmnd) "fetch"
757    return [::nntp::command $name "XPAT $header $list $patterns"]
758}
759
760proc ::nntp::_xpath {name {msgid ""}} {
761    upvar 0 ::nntp::${name}data data
762
763    set data(cmnd) "msg"
764    return [::nntp::command $name "XPATH $msgid"]
765}
766
767proc ::nntp::_xsearch {name args} {
768    set res [::nntp::command $name "XSEARCH"]
769    if {!$res} {
770        return ""
771    }
772    return [::nntp::squirt $name "$args"]
773}
774
775proc ::nntp::_xthread {name args} {
776    upvar 0 ::nntp::${name}data data
777
778    if {[llength $args] > 0} {
779        set filename "dbinit"
780    } else {
781        set filename "thread"
782    }
783    set data(cmnd) "fetchbinary"
784    return [::nntp::command $name "XTHREAD $filename"]
785}
786
787######################################################
788#
789# Helper methods
790#
791
792proc ::nntp::cmd {name cmd} {
793    upvar 0 ::nntp::${name}data data
794
795    set eol "\015\012"
796    set sock $data(sock)
797    if {$data(debug)} {
798        puts stderr "$sock command $cmd"
799    }
800    puts $sock "$cmd"
801    flush $sock
802    return
803}
804
805proc ::nntp::command {name args} {
806    set res [eval [linsert $args 0 ::nntp::cmd $name]]
807
808    return [::nntp::response $name]
809}
810
811proc ::nntp::msg {name} {
812    upvar 0 ::nntp::${name}data data
813
814    set res [::nntp::okprint $name]
815    if {!$res} {
816        return ""
817    }
818    return $data(mesg)
819}
820
821proc ::nntp::groupinfo {name} {
822    upvar 0 ::nntp::${name}data data
823
824    set data(group) ""
825
826    if {[::nntp::okprint $name] && [regexp -- {(\d+)\s+(\d+)\s+(\d+)\s+([\w\.]+)} \
827            $data(mesg) match count first last data(group)]} {
828        return [list $count $first $last $data(group)]
829    }
830    return ""
831}
832
833proc ::nntp::msgid {name} {
834    upvar 0 ::nntp::${name}data data
835
836    set result ""
837    if {[::nntp::okprint $name] && \
838            [regsub -- {\s+<[^>]+>} $data(mesg) {} result]} {
839        return $result
840    } else {
841        return ""
842    }
843}
844
845proc ::nntp::status {name} {
846    upvar 0 ::nntp::${name}data data
847
848    set result ""
849    if {[::nntp::okprint $name] && \
850            [regexp -- {\d+\s+<[^>]+>} $data(mesg) result]} {
851        return $result
852    } else {
853        return ""
854    }
855}
856
857proc ::nntp::fetch {name} {
858    upvar 0 ::nntp::${name}data data
859
860    set eol "\012"
861
862    if {![::nntp::okprint $name]} {
863        return ""
864    }
865    set sock $data(sock)
866
867    if {$data(binary)} {
868	set oldenc [fconfigure $sock -encoding]
869	fconfigure $sock -encoding binary
870    }
871
872    set result [list ]
873    while {![eof $sock]} {
874        gets $sock line
875        regsub -- {\015?\012$} $line $data(eol) line
876
877        if {[string match "." $line]} {
878            break
879        }
880	if { [string match "..*" $line] } {
881	    lappend result [string range $line 1 end]
882	} else {
883	    lappend result $line
884	}
885    }
886
887    if {$data(binary)} {
888	fconfigure $sock -encoding $oldenc
889    }
890
891    return $result
892}
893
894proc ::nntp::response {name} {
895    upvar 0 ::nntp::${name}data data
896
897    set eol "\012"
898
899    set sock $data(sock)
900
901    gets $sock line
902    set data(code) 0
903    set data(mesg) ""
904
905    if {$line == ""} {
906        error "nntp: unexpected EOF on $sock\n"
907    }
908
909    regsub -- {\015?\012$} $line "" line
910
911    set result [regexp -- {^((\d\d)(\d))\s*(.*)} $line match \
912            data(code) val1 val2 data(mesg)]
913
914    if {$result == 0} {
915        puts stderr "nntp garbled response: $line\n";
916        return ""
917    }
918
919    if {$val1 == 20} {
920        set data(post) [expr {!$val2}]
921    }
922
923    if {$data(debug)} {
924        puts stderr "val1 $val1 val2 $val2"
925        puts stderr "code '$data(code)'"
926        puts stderr "mesg '$data(mesg)'"
927        if {[info exists data(post)]} {
928            puts stderr "post '$data(post)'"
929        }
930    }
931
932    return [::nntp::returnval $name]
933}
934
935proc ::nntp::returnval {name} {
936    upvar 0 ::nntp::${name}data data
937
938    if {([info exists data(cmnd)]) \
939            && ($data(cmnd) != "")} {
940        set command $data(cmnd)
941    } else {
942        set command okprint
943    }
944
945    if {$data(debug)} {
946        puts stderr "returnval command '$command'"
947    }
948
949    set data(cmnd) ""
950    return [::nntp::$command $name]
951}
952
953proc ::nntp::squirt {name {body ""}} {
954    upvar 0 ::nntp::${name}data data
955
956    set body [split $body \n]
957
958    if {$data(debug)} {
959        puts stderr "$data(sock) sending [llength $body] lines\n";
960    }
961
962    foreach line $body {
963        # Print each line, possibly prepending a dot for lines
964        # starting with a dot and trimming any trailing \n.
965	if { [string match ".*" $line] } {
966	    set line ".$line"
967	}
968        puts $data(sock) $line
969    }
970    puts $data(sock) "."
971    flush $data(sock)
972
973    if {$data(debug)} {
974        puts stderr "$data(sock) is finished sending"
975    }
976    return [::nntp::response $name]
977}
978#eof
979
980