Tcl Library Source Code

Check-in [ca6a84e367]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added sqlite-based storage driver, and application to transfer messages between stores.
Timelines: family | ancestors | extended-nntp-examples
Files: files | file ages | folders
SHA1: ca6a84e36797a72fb706a230f81ecd8d5814aa39
User & Date: aku 2015-02-25 08:26:29
Context
2015-02-25
08:26
Added sqlite-based storage driver, and application to transfer messages between stores. Leaf check-in: ca6a84e367 user: aku tags: extended-nntp-examples
2015-02-24
23:20
Ticket [8e643b5d66] - coroutine, coroutine::auto. Fixed mishandling of "gets" when called without any arguments. Version bumped to 1.1.3 (both). check-in: 45c988bdfc user: andreask tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to examples/nntp/dirstore.

11
12
13
14
15
16
17

18


19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34


35
36
37
38
39
40
41
42
43
44
..
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
..
68
69
70
71
72
73
74
75












76
77
78
79
80
81
82
83
84















85
86
87
88
89
#
# The application supports the API expected by 'pullnews' for saving
# and id handling.

# Signature (syntax) of the storage command:
#
# (1) <cmd> last      => Returns last id processed.

# (2) <cmd> save <id> => Take message through stdin, and save, mark <id> as last.






proc main {} {
    if {![cmdline]} usage
    $::method
}

proc cmdline {} {
    global argv directory method saveid

    if {[llength $argv] < 2} {return 0}

    # Retrieve arguments
    lassign $argv directory method



    if {$method eq "save"} {
	if {[llength $argv] != 3} {return 0}
	set saveid [lindex $argv 2]
    } else {
	if {[llength $argv] != 2} {return 0}
    }

    validatedir store $directory
    return 1
}
................................................................................
    if {![file isdirectory $path]} { stop "$which not a file: $path" }
    if {![file readable    $path]} { stop "$which not readable: $path" }
    if {![file writable    $path]} { stop "$which not writable: $path" }
}

proc usage {} {
    global argv0
    puts stderr "$argv0: wrong # args, should be \"$argv0 last|(save <id>)\""
    exit 1
}

proc stop {text} {
    global argv0
    puts stderr "$argv0: $text"
    exit 1
................................................................................
	set id {}
    } else {
	set id [string trim [fileutil::cat $directory/last]]
    }
    puts $id
    return
}













proc save {} {
    global directory saveid

    set dst [open $directory/current w]
    fcopy stdin $dst
    close $dst
    file rename -force $directory/current $directory/q$saveid

    fileutil::writeFile $directory/last $saveid















    return
}

main
exit






>
|
>
>
|
<
>







|






>
>
|

|







 







|







 








>
>
>
>
>
>
>
>
>
>
>
>

|




|

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
..
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#
# The application supports the API expected by 'pullnews' for saving
# and id handling.

# Signature (syntax) of the storage command:
#
# (1) <cmd> last      => Returns last id processed.
# (2) <cmd> names     => Returns list of all known ids
# (3) <cmd> save <id> => Take message through stdin, and save, mark <id> as last.
# (4) <cmd> get  <id> => Return message <id> through stdout.
# (5) <cmd> has  <id> => Return boolean indicating existence of message <id>
#

# Here, <cmd> = dirstore <path-to-archive-directory>

proc main {} {
    if {![cmdline]} usage
    $::method
}

proc cmdline {} {
    global argv directory method theid theid

    if {[llength $argv] < 2} {return 0}

    # Retrieve arguments
    lassign $argv directory method

    if {$method ni {last save get has names}} {return 0}

    if {$method in {save get has}} {
	if {[llength $argv] != 3} {return 0}
	set theid [lindex $argv 2]
    } else {
	if {[llength $argv] != 2} {return 0}
    }

    validatedir store $directory
    return 1
}
................................................................................
    if {![file isdirectory $path]} { stop "$which not a file: $path" }
    if {![file readable    $path]} { stop "$which not readable: $path" }
    if {![file writable    $path]} { stop "$which not writable: $path" }
}

proc usage {} {
    global argv0
    puts stderr "$argv0: wrong # args, should be \"$argv0 <directory> last|names|(save <id>)|(get <id>)\""
    exit 1
}

proc stop {text} {
    global argv0
    puts stderr "$argv0: $text"
    exit 1
................................................................................
	set id {}
    } else {
	set id [string trim [fileutil::cat $directory/last]]
    }
    puts $id
    return
}

proc names {} {
    global directory
    set ids {}
    if {[file exists $directory]} {
	foreach id [lsort -dict [glob -nocomplain -directory $directory -tails q*]] {
	    lappend ids [string range $id 1 end]
	}
    }
    puts [join $ids \n]
    return
}

proc save {} {
    global directory theid

    set dst [open $directory/current w]
    fcopy stdin $dst
    close $dst
    file rename -force $directory/current $directory/q$theid

    fileutil::writeFile $directory/last $theid
    return
}

proc get {} {
    global directory theid

    set src [open $directory/q$theid r]
    fcopy $src stdout
    close $src
    return
}

proc has {} {
    global directory theid
    puts -nonewline stdout [file exists  $directory/q$theid]
    return
}

main
exit

Added examples/nntp/movenews.




























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#!/usr/bin/env tclsh
## -*- tcl -*-

package require Tcl 8.5

# This application talks to two stores and transfers the messages from
# the source to the destination.

proc main {} {
    if {![cmdline]} usage
    movemessages
}

proc cmdline {} {
    global argv src dst keepid conflict

    set keepid no
    set conflict error

    while {[string match -* [set o [lindex $argv 0]]]} {
	switch -exact $o {
	    -K - --keepid { set keepid   yes }
	    -I - --ignore { set conflict ignore }
	    default { return 0 }
	}
	set argv [lrange $argv 1 end]
    }

    if {[llength $argv] != 2} {return 0}

    # Retrieve arguments
    set argv [lassign $argv src dst]

    if {![llength $src]} { return 0 }
    if {![llength $dst]} { return 0 }

    return 1
}

proc usage {} {
    global argv0
    puts stderr "$argv0: wrong # args, should be \"$argv0 ?--keepid|-K? ?--plain|-P? src-cmd dst-cmd\""
    exit 1
}

proc stop {text} {
    global argv0
    puts stderr "$argv0: $text"
    exit 1
}

proc log {text} {
    puts -nonewline $text
    flush stdout
    return
}

proc movemessages {} {
    global src dst keepid conflict

    set ids [store_cmd $src {} names]

    set lasthandled [store_cmd $dst {} last]
    if {$lasthandled eq {}} {
	set  lasthandled -1
    }

    foreach id $ids {
	incr lasthandled
	if {$keepid} {
	    if {($id < $lasthandled) || [store_cmd $dst {} has $id]} {
		switch -exact $conflict {
		    error {
			log "conflict $id\n"
			exit 1
		    }
		    ignore {
			log "ignoring $id\n"
			incr lasthandled -1
			continue
		    }
		}
	    }
	    set lasthandled $id
	}

	log "reading $id ... "
	set msg [store_cmd $src {} get $id]

	log "saving to $lasthandled ..."
	set r [store_cmd $dst $msg save $lasthandled]

	if {$r ne {}} { log " $r" }
	log \n
    }
    return
}

proc store_cmd {storecommand si args} {
    #puts "run: [list {*}$storecommand {*}$args]"

    if {$si ne {}} {
	return [exec << $si {*}$storecommand {*}$args]
    } else {
	return [exec {*}$storecommand {*}$args]
    }
}

main
exit

Changes to examples/nntp/pullnews.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# command specified as the third and further arguments, via a pipe.
# That command is responsible for storing the message as it sees fit.

# Signature (syntax) of the storage command:
#
# (1) <cmd> last      => Returns last id processed.
# (2) <cmd> save <id> => Take message through stdin, and save, mark <id> as last.



proc main {} {
    if {![cmdline]} usage
    pullmessages
}

proc cmdline {} {






<
<







11
12
13
14
15
16
17


18
19
20
21
22
23
24
# command specified as the third and further arguments, via a pipe.
# That command is responsible for storing the message as it sees fit.

# Signature (syntax) of the storage command:
#
# (1) <cmd> last      => Returns last id processed.
# (2) <cmd> save <id> => Take message through stdin, and save, mark <id> as last.



proc main {} {
    if {![cmdline]} usage
    pullmessages
}

proc cmdline {} {

Added examples/nntp/sqlitestore.








































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
#!/usr/bin/env tclsh
## -*- tcl -*-

package require Tcl 8.5
package require fileutil
package require sqlite3
package require dbutil
package require try

# Tcl 8.5 (de)compression support
package require zlibtcl
package require Trf

proc zipit   {msg} { zip -mode compress -level 9 $msg }
proc unzipit {msg} { zip -mode decompress        $msg }

# This application stores received nntp messages into a named directory.
# That name is specified on the command line.
# The article is read from stdin.
#
# The application supports the API expected by 'pullnews' for saving
# and id handling.

# Signature (syntax) of the storage command:
#
# (1) <cmd> last      => Returns last id processed.
# (2) <cmd> names     => Returns list of all known ids
# (3) <cmd> save <id> => Take message through stdin, and save, mark <id> as last.
# (4) <cmd> get  <id> => Return message <id> through stdout.
# (5) <cmd> has  <id> => Return boolean indicating existence of message <id>
#
# Here, <cmd> = sqlitestore <path-to-database> <peer-code>
#
# The peer-code is used to identify the origin of the messages in the
# database. It is chosen by the user. This means that sqlitestore is
# able to handle multiple incoming streams of messages and yet keep
# them separate. Messages are actually identified by their
# 'Message-Id:' header.

proc main {} {
    if {![cmdline]} usage
    $::method
}

proc cmdline {} {
    global argv database peer method handle compress conflict

    set compress yes
    set conflict error

    while {[string match -* [set o [lindex $argv 0]]]} {
	switch -exact $o {
	    -P - --plain  { set compress no }
	    -I - --ignore { set conflict ignore }
	    default { return 0 }
	}
	set argv [lrange $argv 1 end]
    }

    if {[llength $argv] < 3} {return 0}

    # Retrieve arguments
    set argv [lassign $argv database peer method]

    if {$method ni {last save get has names}} {return 0}

    if {$method in {save get has}} {
	if {[llength $argv] != 1} {return 0}
	set handle [lindex $argv 0]
    } else {
	if {[llength $argv] != 0} {return 0}
    }

    validate store $database
    return 1
}

proc validate {which path} {
    if {![file exists   $path]} { stop "$which does not exist: $path" }
    if {![file isfile   $path]} { stop "$which not a file: $path" }
    if {![file readable $path]} { stop "$which not readable: $path" }
    if {![file writable $path]} { stop "$which not writable: $path" }

    sqlite3 MSTORE $path

    # peer <-1:n- message_peer -m:1-> message
    # - message_peer is the materialized n:m relation between peers and messages.
    # - It further holds the id information we are getting from the peer, i.e.
    #   the peer-specific identification of a message.

    if {[dbutil initialize-schema MSTORE error \
	message {
	    {
		-- Message data. Identified by the message-id value
		-- from the message headers. The blob may be stored
		-- zlib compressed.

		id    INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
		msgid TEXT    NOT NULL UNIQUE,
		msg   BLOB    NOT NULL
	    } {
		{id    INTEGER 1 {} 1}
		{msgid TEXT    1 {} 0}
		{msg   BLOB    1 {} 0}
	    } {}
	} peer {
	    {
		-- Peers. Represent hosts from which message are
		-- coming into the system. Just names.

		id   INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
		name TEXT    NOT NULL UNIQUE
	    } {
		{id   INTEGER 1 {} 1}
		{name TEXT    1 {} 0}
	    } {}
	} message_peer {
	    {
		-- Linkage between peers and messages. Each peer
		-- identifies messages by a unique numeric handle
		-- specific to the peer. Across multiple peers the
		-- same message may (and likely will) have different
		-- handles.

		pid    INTEGER NOT NULL REFERENCES peer,
		handle INTEGER NOT NULL,
		mid    INTEGER NOT NULL REFERENCES message,
		PRIMARY KEY (pid,handle),
		UNIQUE      (pid,mid)
	    } {
		{pid    INTEGER 1 {} 1}
		{handle INTEGER 1 {} 2}
		{mid    INTEGER 1 {} 0}
	    } {}
	} header {
	    {
		-- Header keys. Just names.

		id   INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
		name TEXT    NOT NULL UNIQUE
	    } {
		{id   INTEGER 1 {} 1}
		{name TEXT    1 {} 0}
	    } {}
	} message_header {
	    {
		-- Linkage between headers and messages, plus the
		-- value of the header in the message.

		hid   INTEGER NOT NULL REFERENCES header,
		mid   INTEGER NOT NULL REFERENCES message,
		value TEXT    NOT NULL,
		PRIMARY KEY (hid,mid)
	    } {
		{hid   INTEGER 1 {} 1}
		{mid   INTEGER 1 {} 2}
		{value TEXT    1 {} 0}
	    } {{hid value}}
	}]} return
    stop "$which: $error"
    return
}

proc usage {} {
    global argv0
    puts stderr "$argv0: wrong # args, should be \"$argv0 <db> <peer> last|names|(save <id>)|(get <id>)\""
    exit 1
}

proc stop {text} {
    global argv0
    puts stderr "$argv0: $text"
    exit 1
}

proc last {} {
    set pid [getpid]

    set id [MSTORE onecolumn {
	SELECT MAX(handle)
	FROM message_peer
	WHERE pid = :pid
    }]

    puts $id
    return
}

proc names {} {
    set pid [getpid]

    puts [join [MSTORE eval {
	SELECT handle
	FROM message_peer
	WHERE pid = :pid
	ORDER BY handle
    }] \n]
    return
}

proc save {} {
    global peer handle conflict

    set msg [read stdin]
    set mid [getmid $msg]
    set pid [getpid]

    # Link message to peer, under the given id.

    try {
	MSTORE eval {
	    INSERT INTO message_peer
	    VALUES (:pid, :handle, :mid)
	}
    } on error {e o} {
	if {$conflict eq "error"} {
	    # Rethrow
	    return {*}$o $e
	} else {
	    puts -nonewline ignored
	}
    }

    return
}

proc get {} {
    global handle

    set pid [getpid]
    set id [MSTORE eval {
	SELECT mid
	FROM   message_peer
	WHERE  pid    = :pid
	AND    handle = :handle
    }]

    set msg [getblob $id]

    puts -nonewline stdout $msg
    return
}

proc has {} {
    global handle

    set pid [getpid]
    set id [MSTORE onecolumn {
	SELECT handle
	FROM   message_peer
	WHERE  pid    = :pid
	AND    handle = :handle
    }]
    puts -nonewline stdout [expr {$id ne {}}]
    return
}

proc getblob {id} {
    set src [MSTORE incrblob -readonly message msg $id]
    fconfigure $src -translation binary -encoding binary
    set msg [read $src]
    close $src

    # Try to decompress. Failure simply means that data was stored
    # plain.
    catch {
	set msg [unzipit $msg]
    }
    return $msg
}

proc getmid {msg} {
    global compress

    lassign [process $msg] header body

    set msgid [dict get $header message-id]
    set date  [dict get $header date]

    set date [clock scan $date]

    dict unset header message-id
    dict set   header date       $date

    MSTORE transaction {
	set id [MSTORE onecolumn {
	    SELECT id
	    FROM   message
	    WHERE  msgid = :msgid
	}]
	if {$id eq {}} {
	    # Save unknown message.

	    if {$compress} {
		set msg [zipit $msg]
	    }
	    MSTORE eval {
		INSERT INTO message
		VALUES (NULL, :msgid, @msg)
	    }
	    set id [MSTORE last_insert_rowid]

	    # Save and link all headers for searches
	    foreach k [lsort -dict [dict keys $header]] {
		linkheader [gethid $k] $id [dict get $header $k]
	    }
	}
    }
    return $id
}

proc getpid {} {
    global peer

    MSTORE transaction {
	set id [MSTORE onecolumn {
	    SELECT id
	    FROM   peer
	    WHERE  name = :peer
	}]
	if {$id eq {}} {
	    # Save unknown peer.
	    MSTORE eval {
		INSERT INTO peer
		VALUES (NULL, :peer)
	    }
	    set id [MSTORE last_insert_rowid]
	}
    }
    return $id
}

proc gethid {key} {
    MSTORE transaction {
	set id [MSTORE onecolumn {
	    SELECT id
	    FROM   header
	    WHERE  name = :key
	}]
	if {$id eq {}} {
	    # Save unknown header
	    MSTORE eval {
		INSERT INTO header
		VALUES (NULL, :key)
	    }
	    set id [MSTORE last_insert_rowid]
	}
    }
    return $id
}

proc linkheader {key msg value} {
    MSTORE eval {
	INSERT INTO message_header
	VALUES (:key, :msg, :value)
    }
    return
}

proc process {msg} {
    set head {}
    set body {}
    set inBody 0
    set lastheader {}

    foreach line [split $msg "\n"] {
	if {$inBody} {
	    lappend body $line
	} elseif {[string length $line] == 0} {
	    set inBody 1
	} elseif {[regexp {^([^ :]+): +(.*)} $line => header value]} {
	    set header [string tolower $header]
	    set value  [string trim $value]
	    if {[string length $value]} {
		dict set head $header "$value "
	    }
	    set lastheader $header
	} else {
	    dict append head $lastheader "[string trim $line] "
	}
    }

    return [list $head $body]
}


main
exit