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