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