source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/bee/bee.tcl

devel
Last change on this file was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@2556 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 23.6 KB
RevLine 
[8597867d]1# bee.tcl --
2#
3#       BitTorrent Bee de- and encoder.
4#
5# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
6# See the file license.terms.
7
8package require Tcl 8.4
9
10namespace eval ::bee {
11    # Encoder commands
12    namespace export \
13            encodeString encodeNumber \
14            encodeListArgs encodeList \
15            encodeDictArgs encodeDict
16
17    # Decoder commands.
18    namespace export \
19            decode \
20            decodeChannel \
21            decodeCancel \
22            decodePush
23
24    # Channel decoders, reference to state information, keyed by
25    # channel handle.
26
27    variable  bee
28    array set bee {}
29
30    # Counter for generation of names for the state variables.
31
32    variable count 0
33
34    # State information for the channel decoders.
35
36    # stateN, with N an integer number counting from 0 on up.
37    # ...(chan)   Handle of channel the decoder is for.
38    # ...(cmd)    Command prefix, completion callback
39    # ...(exact)  Boolean flag, set for exact processing.
40    # ...(read)   Buffer for new characters to process.
41    # ...(type)   Type of current value (integer, string, list, dict)
42    # ...(value)  Buffer for assembling the current value.
43    # ...(pend)   Stack of pending 'value' buffers, for nested
44    #             containers.
45    # ...(state)  Current state of the decoding state machine.
46
47    # States of the finite automaton ...
48    # intro  - One char, type of value, or 'e' as stop of container.
49    # signum - sign or digit, for integer.
50    # idigit - digit, for integer, or 'e' as stop
51    # ldigit - digit, for length of string, or :
52    # data   - string data, 'get' characters.
53    # Containers via 'pend'.
54
55    #Debugging help, nesting level
56    #variable X 0
57}
58
59
60# ::bee::encodeString --
61#
62#       Encode a string to bee-format.
63#
64# Arguments:
65#       string  The string to encode.
66#
67# Results:
68#       The bee-encoded form of the string.
69
70proc ::bee::encodeString {string} {
71    return "[string length $string]:$string"
72}
73
74
75# ::bee::encodeNumber --
76#
77#       Encode an integer number to bee-format.
78#
79# Arguments:
80#       num     The integer number to encode.
81#
82# Results:
83#       The bee-encoded form of the integer number.
84
85proc ::bee::encodeNumber {num} {
86    if {![string is integer -strict $num]} {
87        return -code error "Expected integer number, got \"$num\""
88    }
89
90    # The reformatting deals with hex, octal and other tcl
91    # representation of the value. In other words we normalize the
92    # string representation of the input value.
93
94    set num [format %d $num]
95    return "i${num}e"
96}
97
98
99# ::bee::encodeList --
100#
101#       Encode a list of bee-coded values to bee-format.
102#
103# Arguments:
104#       list    The list to encode.
105#
106# Results:
107#       The bee-encoded form of the list.
108
109proc ::bee::encodeList {list} {
110    return "l[join $list ""]e"
111}
112
113
114# ::bee::encodeListArgs --
115#
116#       Encode a variable list of bee-coded values to bee-format.
117#
118# Arguments:
119#       args    The values to encode.
120#
121# Results:
122#       The bee-encoded form of the list of values.
123
124proc ::bee::encodeListArgs {args} {
125    return [encodeList $args]
126}
127
128
129# ::bee::encodeDict --
130#
131#       Encode a dictionary of keys and bee-coded values to bee-format.
132#
133# Arguments:
134#       dict    The dictionary to encode.
135#
136# Results:
137#       The bee-encoded form of the dictionary.
138
139proc ::bee::encodeDict {dict} {
140    if {([llength $dict] % 2) == 1} {
141        return -code error "Expected even number of elements, got \"[llength $dict]\""
142    }
143    set temp [list]
144    foreach {k v} $dict {
145        lappend temp [list $k $v]
146    }
147    set res "d"
148    foreach item [lsort -index 0 $temp] {
149        foreach {k v} $item break
150        append res [encodeString $k]$v
151    }
152    append res "e"
153    return $res
154}
155
156
157# ::bee::encodeDictArgs --
158#
159#       Encode a variable dictionary of keys and bee-coded values to bee-format.
160#
161# Arguments:
162#       args    The keys and values to encode.
163#
164# Results:
165#       The bee-encoded form of the dictionary.
166
167proc ::bee::encodeDictArgs {args} {
168    return [encodeDict $args]
169}
170
171
172# ::bee::decode --
173#
174#       Decode a bee-encoded value and returns the embedded tcl
175#       value. For containers this recurses into the contained value.
176#
177# Arguments:
178#       value   The string containing the bee-encoded value to decode.
179#       evar    Optional. If set the name of the variable to store the
180#               index of the first character after the decoded value to.
181#       start   Optional. If set the index of the first character of the
182#               value to decode. Defaults to 0, i.e. the beginning of the
183#               string.
184#
185# Results:
186#       The tcl value embedded in the encoded string.
187
188proc ::bee::decode {value {evar {}} {start 0}} {
189    #variable X
190    #puts -nonewline "[string repeat "    " $X]decode @$start" ; flush stdout
191
192    if {$evar ne ""} {upvar 1 $evar end} else {set end _}
193
194    if {[string length $value] < ($start+2)} {
195        # This checked that the 'start' index is still in the string,
196        # and the end of the value most likely as well. Note that each
197        # encoded value consists of at least two characters (the
198        # bracketing characters for integer, list, and dict, and for
199        # string at least one digit length and the colon).
200
201        #puts \t[string length $value]\ <\ ($start+2)
202        return -code error "String not large enough for value"
203    }
204
205    set type [string index $value $start]
206
207    #puts -nonewline " $type=" ; flush stdout
208
209    if {$type eq "i"} {
210        # Extract integer
211        #puts -nonewline integer ; flush stdout
212
213        incr start ; # Skip over intro 'i'.
214        set end [string first e $value $start]
215        if {$end < 0} {
216            return -code error "End of integer number not found"
217        }
218        incr end -1 ; # Get last character before closing 'e'.
219        set num [string range $value $start $end]
220        if {
221            [regexp {^-0+$} $num] ||
222            ![string is integer -strict $num] ||
223            (([string length $num] > 1) && [string match 0* $num])
224        } {
225            return -code error "Expected integer number, got \"$num\""
226        }
227        incr end 2 ; # Step after closing 'e' to the beginning of
228        # ........ ; # the next bee-value behind the current one.
229
230        #puts " ($num) @$end"
231        return $num
232
233    } elseif {($type eq "l") || ($type eq "d")} {
234        #puts -nonewline $type\n ; flush stdout
235
236        # Extract list or dictionary, recursively each contained
237        # element. From the perspective of the decoder this is the
238        # same, the tcl representation of both is a list, and for a
239        # dictionary keys and values are also already in the correct
240        # order.
241
242        set result [list]
243        incr start ; # Step over intro 'e' to beginning of the first
244        # ........ ; # contained value, or behind the container (if
245        # ........ ; # empty).
246
247        set end $start
248        #incr X
249        while {[string index $value $start] ne "e"} {
250            lappend result [decode $value end $start]
251            set start $end
252        }
253        #incr X -1
254        incr end
255
256        #puts "[string repeat "    " $X]($result) @$end"
257
258        if {$type eq "d" && ([llength $result] % 2 == 1)} {
259            return -code error "Dictionary has to be of even length"
260        }
261        return $result
262
263    } elseif {[string match {[0-9]} $type]} {
264        #puts -nonewline string ; flush stdout
265
266        # Extract string. First the length, bounded by a colon, then
267        # the appropriate number of characters.
268
269        set end [string first : $value $start]
270        if {$end < 0} {
271            return -code error "End of string length not found"
272        }
273        incr end -1
274        set length [string range $value $start $end]
275        incr end 2 ;# Skip to beginning of the string after the colon
276
277        if {![string is integer -strict $length]} {
278            return -code error "Expected integer number for string length, got \"$length\""
279        } elseif {$length < 0} {
280            # This cannot happen. To happen "-" has to be first character,
281            # and this is caught as unknown bee-type.
282            return -code error "Illegal negative string length"
283        } elseif {($end + $length) > [string length $value]} {
284            return -code error "String not large enough for value"
285        }
286
287        #puts -nonewline \[$length\] ; flush stdout
288        if {$length > 0} {
289            set  start $end
290            incr end $length
291            incr end -1
292            set result [string range $value $start $end]
293            incr end
294        } else {
295            set result ""
296        }
297
298        #puts " ($result) @$end"
299        return $result
300
301    } else {
302        return -code error "Unknown bee-type \"$type\""
303    }
304}
305
306# ::bee::decodeIndices --
307#
308#       Similar to 'decode', but does not return the decoded tcl values,
309#       but a structure containing the start- and end-indices for all
310#       values in the structure.
311#
312# Arguments:
313#       value   The string containing the bee-encoded value to decode.
314#       evar    Optional. If set the name of the variable to store the
315#               index of the first character after the decoded value to.
316#       start   Optional. If set the index of the first character of the
317#               value to decode. Defaults to 0, i.e. the beginning of the
318#               string.
319#
320# Results:
321#       The structure of the value, with indices and types for all
322#       contained elements.
323
324proc ::bee::decodeIndices {value {evar {}} {start 0}} {
325    #variable X
326    #puts -nonewline "[string repeat "    " $X]decode @$start" ; flush stdout
327
328    if {$evar ne ""} {upvar 1 $evar end} else {set end _}
329
330    if {[string length $value] < ($start+2)} {
331        # This checked that the 'start' index is still in the string,
332        # and the end of the value most likely as well. Note that each
333        # encoded value consists of at least two characters (the
334        # bracketing characters for integer, list, and dict, and for
335        # string at least one digit length and the colon).
336
337        #puts \t[string length $value]\ <\ ($start+2)
338        return -code error "String not large enough for value"
339    }
340
341    set type [string index $value $start]
342
343    #puts -nonewline " $type=" ; flush stdout
344
345    if {$type eq "i"} {
346        # Extract integer
347        #puts -nonewline integer ; flush stdout
348
349        set begin $start
350
351        incr start ; # Skip over intro 'i'.
352        set end [string first e $value $start]
353        if {$end < 0} {
354            return -code error "End of integer number not found"
355        }
356        incr end -1 ; # Get last character before closing 'e'.
357        set num [string range $value $start $end]
358        if {
359            [regexp {^-0+$} $num] ||
360            ![string is integer -strict $num] ||
361            (([string length $num] > 1) && [string match 0* $num])
362        } {
363            return -code error "Expected integer number, got \"$num\""
364        }
365        incr end
366        set stop $end
367        incr end 1 ; # Step after closing 'e' to the beginning of
368        # ........ ; # the next bee-value behind the current one.
369
370        #puts " ($num) @$end"
371        return [list integer $begin $stop]
372
373    } elseif {$type eq "l"} {
374        #puts -nonewline $type\n ; flush stdout
375
376        # Extract list, recursively each contained element.
377
378        set result [list]
379
380        lappend result list $start @
381
382        incr start ; # Step over intro 'e' to beginning of the first
383        # ........ ; # contained value, or behind the container (if
384        # ........ ; # empty).
385
386        set end $start
387        #incr X
388
389        set contained [list]
390        while {[string index $value $start] ne "e"} {
391            lappend contained [decodeIndices $value end $start]
392            set start $end
393        }
394        lappend result $contained
395        #incr X -1
396        set stop $end
397        incr end
398
399        #puts "[string repeat "    " $X]($result) @$end"
400
401        return [lreplace $result 2 2 $stop]
402
403    } elseif {($type eq "l") || ($type eq "d")} {
404        #puts -nonewline $type\n ; flush stdout
405
406        # Extract dictionary, recursively each contained element.
407
408        set result [list]
409
410        lappend result dict $start @
411
412        incr start ; # Step over intro 'e' to beginning of the first
413        # ........ ; # contained value, or behind the container (if
414        # ........ ; # empty).
415
416        set end $start
417        set atkey 1
418        #incr X
419
420        set contained [list]
421        set val       [list]
422        while {[string index $value $start] ne "e"} {
423            if {$atkey} {
424                lappend contained [decode $value {} $start]
425                lappend val       [decodeIndices $value end $start]
426                set atkey 0
427            } else {
428                lappend val       [decodeIndices $value end $start]
429                lappend contained $val
430                set val [list]
431                set atkey 1
432            }
433            set start $end
434        }
435        lappend result $contained
436        #incr X -1
437        set stop $end
438        incr end
439
440        #puts "[string repeat "    " $X]($result) @$end"
441
442        if {[llength $result] % 2 == 1} {
443            return -code error "Dictionary has to be of even length"
444        }
445        return [lreplace $result 2 2 $stop]
446
447    } elseif {[string match {[0-9]} $type]} {
448        #puts -nonewline string ; flush stdout
449
450        # Extract string. First the length, bounded by a colon, then
451        # the appropriate number of characters.
452
453        set end [string first : $value $start]
454        if {$end < 0} {
455            return -code error "End of string length not found"
456        }
457        incr end -1
458        set length [string range $value $start $end]
459        incr end 2 ;# Skip to beginning of the string after the colon
460
461        if {![string is integer -strict $length]} {
462            return -code error "Expected integer number for string length, got \"$length\""
463        } elseif {$length < 0} {
464            # This cannot happen. To happen "-" has to be first character,
465            # and this is caught as unknown bee-type.
466            return -code error "Illegal negative string length"
467        } elseif {($end + $length) > [string length $value]} {
468            return -code error "String not large enough for value"
469        }
470
471        #puts -nonewline \[$length\] ; flush stdout
472        incr end -1
473        if {$length > 0} {
474            incr end $length
475            set stop $end
476        } else {
477            set stop $end
478        }
479        incr end
480
481        #puts " ($result) @$end"
482        return [list string $start $stop]
483
484    } else {
485        return -code error "Unknown bee-type \"$type\""
486    }
487}
488
489
490# ::bee::decodeChannel --
491#
492#       Attach decoder for a bee-value to a channel. See the
493#       documentation for details.
494#
495# Arguments:
496#       chan                    Channel to attach to.
497#       -command cmdprefix      Completion callback. Required.
498#       -exact                  Keep running after completion.
499#       -prefix data            Seed for decode buffer.
500#
501# Results:
502#       A token to use when referring to the decoder.
503#       For example when canceling it.
504
505proc ::bee::decodeChannel {chan args} {
506    variable bee
507    if {[info exists bee($chan)]} {
508        return -code error "bee-Decoder already active for channel"
509    }
510
511    # Create state and token.
512
513    variable  count
514    variable  [set st state$count]
515    array set $st {}
516    set       bee($chan) $st
517    upvar 0  $st state
518    incr count
519
520    # Initialize the decoder state, process the options. When
521    # encountering errors here destroy the half-baked state before
522    # throwing the message.
523
524    set       state(chan) $chan
525    array set state {
526        exact  0
527        type   ?
528        read   {}
529        value  {}
530        pend   {}
531        state  intro
532        get    1
533    }
534
535    while {[llength $args]} {
536        set option [lindex $args 0]
537        set args [lrange $args 1 end]
538        if {$option eq "-command"} {
539            if {![llength $args]} {
540                unset bee($chan)
541                unset state
542                return -code error "Missing value for option -command."
543            }
544            set state(cmd) [lindex $args 0]
545            set args       [lrange $args 1 end]
546
547        } elseif {$option eq "-prefix"} {
548            if {![llength $args]} {
549                unset bee($chan)
550                unset state
551                return -code error "Missing value for option -prefix."
552            }
553            set state(read) [lindex $args 0]
554            set args        [lrange $args 1 end]
555
556        } elseif {$option eq "-exact"} {
557            set state(exact) 1
558        } else {
559            unset bee($chan)
560            unset state
561            return -code error "Illegal option \"$option\",\
562                    expected \"-command\", \"-prefix\", or \"-keep\""
563        }
564    }
565
566    if {![info exists state(cmd)]} {
567        unset bee($chan)
568        unset state
569        return -code error "Missing required completion callback."
570    }
571
572    # Set up the processing of incoming data.
573
574    fileevent $chan readable [list ::bee::Process $chan $bee($chan)]
575
576    # Return the name of the state array as token.
577    return $bee($chan)
578}
579
580# ::bee::Parse --
581#
582#       Internal helper. Fileevent handler for a decoder.
583#       Parses input and handles both error and eof conditions.
584#
585# Arguments:
586#       token   The decoder to run on its input.
587#
588# Results:
589#       None.
590
591proc ::bee::Process {chan token} {
592    if {[catch {Parse $token} msg]} {
593        # Something failed. Destroy and report.
594        Command $token error $msg
595        return
596    }
597
598    if {[eof $chan]} {
599        # Having data waiting, either in the input queue, or in the
600        # output stack (of nested containers) is a failure. Report
601        # this instead of the eof.
602
603        variable $token
604        upvar 0  $token state
605
606        if {
607            [string length $state(read)] ||
608            [llength       $state(pend)] ||
609            [string length $state(value)] ||
610            ($state(state) ne "intro")
611        } {
612            Command $token error "Incomplete value at end of channel"
613        } else {
614            Command $token eof
615        }
616    }
617    return
618}
619
620# ::bee::Parse --
621#
622#       Internal helper. Reading from the channel and parsing the input.
623#       Uses a hardwired state machine.
624#
625# Arguments:
626#       token   The decoder to run on its input.
627#
628# Results:
629#       None.
630
631proc ::bee::Parse {token} {
632    variable $token
633    upvar 0  $token state
634    upvar 0  state(state) current
635    upvar 0  state(read)  input
636    upvar 0  state(type)  type
637    upvar 0  state(value) value
638    upvar 0  state(pend)  pend
639    upvar 0  state(exact) exact
640    upvar 0  state(get)   get
641    set chan $state(chan)
642
643    #puts Parse/$current
644
645    if {!$exact} {
646        # Add all waiting characters to the buffer so that we can process as
647        # much as is possible in one go.
648        append input [read $chan]
649    } else {
650        # Exact reading. Usually one character, but when in the data
651        # section for a string value we know for how many characters
652        # we are looking for.
653
654        append input [read $chan $get]
655    }
656
657    # We got nothing, do nothing.
658    if {![string length $input]} return
659
660
661    if {$current eq "data"} {
662        # String data, this can be done faster, as we read longer
663        # sequences of characters for this.
664        set l [string length $input]
665        if {$l < $get} {
666            # Not enough, wait for more.
667            append value $input
668            incr get -$l
669            return
670        } elseif {$l == $get} {
671            # Got all, exactly. Prepare state machine for next value.
672
673            if {[Complete $token $value$input]} return
674
675            set current intro
676            set get 1
677            set value ""
678            set input ""
679
680            return
681        } else {
682            # Got more than required (only for !exact).
683
684            incr get -1
685            if {[Complete $token $value[string range $input 0 $get]]} {return}
686
687            incr get
688            set input [string range $input $get end]
689            set get 1
690            set value ""
691            set current intro
692            # This now falls into the loop below.
693        }
694    }
695
696    set where 0
697    set n [string length $input]
698
699    #puts Parse/$n
700
701    while {$where < $n} {
702        # Hardwired state machine. Get current character.
703        set ch [string index $input $where]
704
705        #puts Parse/@$where/$current/$ch/
706        if {$current eq "intro"} {
707            # First character of a value.
708
709            if {$ch eq "i"} {
710                # Begin reading integer.
711                set type    integer
712                set current signum
713            } elseif {$ch eq "l"} {
714                # Begin a list.
715                set type list
716                lappend pend list {}
717                #set current intro
718
719            } elseif {$ch eq "d"} {
720                # Begin a dictionary.
721                set type dict
722                lappend pend dict {}
723                #set current intro
724
725            } elseif {$ch eq "e"} {
726                # Close a container. Throw an error if there is no
727                # container to close.
728
729                if {![llength $pend]} {
730                    return -code error "End of container outside of container."
731                }
732
733                set v    [lindex $pend end]
734                set t    [lindex $pend end-1]
735                set pend [lrange $pend 0 end-2]
736
737                if {$t eq "dict" && ([llength $v] % 2 == 1)} {
738                    return -code error "Dictionary has to be of even length"
739                }
740
741                if {[Complete $token $v]} {return}
742                set current intro
743
744            } elseif {[string match {[0-9]} $ch]} {
745                # Begin reading a string, length section first.
746                set type    string
747                set current ldigit
748                set value   $ch
749
750            } else {
751                # Unknown type. Throw error.
752                return -code error "Unknown bee-type \"$ch\""
753            }
754
755            # To next character.
756            incr where
757        } elseif {$current eq "signum"} {
758            # Integer number, a minus sign, or a digit.
759            if {[string match {[-0-9]} $ch]} {
760                append value $ch
761                set current idigit
762            } else {
763                return -code error "Syntax error in integer,\
764                        expected sign or digit, got \"$ch\""
765            }
766            incr where
767
768        } elseif {$current eq "idigit"} {
769            # Integer number, digit or closing 'e'.
770
771            if {[string match {[-0-9]} $ch]} {
772                append value $ch
773            } elseif {$ch eq "e"} {
774                # Integer closes. Validate and report.
775                #puts validate
776                if {
777                    [regexp {^-0+$} $value] ||
778                    ![string is integer -strict $value] ||
779                    (([string length $value] > 1) && [string match 0* $value])
780                } {
781                    return -code error "Expected integer number, got \"$value\""
782                }
783
784                if {[Complete $token $value]} {return}
785                set value ""
786                set current intro
787            } else {
788                return -code error "Syntax error in integer,\
789                        expected digit, or 'e', got \"$ch\""
790            }
791            incr where
792
793        } elseif {$current eq "ldigit"} {
794            # String, length section, digit, or :
795
796            if {[string match {[-0-9]} $ch]} {
797                append value $ch
798
799            } elseif {$ch eq ":"} {
800                # Length section closes, validate,
801                # then perform data processing.
802
803                set num $value
804                if {
805                    [regexp {^-0+$} $num] ||
806                    ![string is integer -strict $num] ||
807                    (([string length $num] > 1) && [string match 0* $num])
808                } {
809                    return -code error "Expected integer number as string length, got \"$num\""
810                }
811
812                set value ""
813
814                # We may have already part of the data in
815                # memory. Process that piece before looking for more.
816
817                incr where
818                set have [expr {$n - $where}]
819                if {$num < $have} {
820                    # More than enough in the buffer.
821
822                    set  end $where
823                    incr end $num
824                    incr end -1
825
826                    if {[Complete $token [string range $input $where $end]]} {return}
827
828                    set where   $end ;# Further processing behind the string.
829                    set current intro
830
831                } elseif {$num == $have} {
832                    # Just enough.
833
834                    if {[Complete $token [string range $input $where end]]} {return}
835
836                    set where   $n
837                    set current intro
838                } else {
839                    # Not enough. Initialize value with the data we
840                    # have (after the colon) and stop processing for
841                    # now.
842
843                    set value   [string range $input $where end]
844                    set current data
845                    set get     $num
846                    set input   ""
847                    return
848                }
849            } else {
850                return -code error "Syntax error in string length,\
851                        expected digit, or ':', got \"$ch\""
852            }
853            incr where
854        } else {
855            # unknown state = internal error
856            return -code error "Unknown decoder state \"$current\", internal error"
857        }
858    }
859
860    set input ""
861    return
862}
863
864# ::bee::Command --
865#
866#       Internal helper. Runs the decoder command callback.
867#
868# Arguments:
869#       token   The decoder invoking its callback
870#       how     Which method to invoke (value, error, eof)
871#       args    Arguments for the method.
872#
873# Results:
874#       A boolean flag. Set if further processing has to stop.
875
876proc ::bee::Command {token how args} {
877    variable $token
878    upvar 0  $token state
879
880    #puts Report/$token/$how/$args/
881
882    set cmd  $state(cmd)
883    set chan $state(chan)
884
885    # We catch the fileevents because they will fail when this is
886    # called from the 'Close'. The channel will already be gone in
887    # that case.
888
889    set stop 0
890    if {($how eq "error") || ($how eq "eof")} {
891        variable bee
892
893        set stop 1
894        fileevent $chan readable {}
895        unset bee($chan)
896        unset state
897
898        if {$how eq "eof"} {
899            #puts \tclosing/$chan
900            close $chan
901        }
902    }
903
904    lappend cmd $how $token
905    foreach a $args {lappend cmd $a}
906    uplevel #0 $cmd
907
908    if {![info exists state]} {
909        # The decoder token was killed by the callback, stop
910        # processing.
911        set stop 1
912    }
913
914    #puts /$stop/[file channels]
915    return $stop
916}
917
918# ::bee::Complete --
919#
920#       Internal helper. Reports a completed value.
921#
922# Arguments:
923#       token   The decoder reporting the value.
924#       value   The value to report.
925#
926# Results:
927#       A boolean flag. Set if further processing has to stop.
928
929proc ::bee::Complete {token value} {
930    variable $token
931    upvar 0  $token state
932    upvar 0   state(pend) pend
933
934    if {[llength $pend]} {
935        # The value is part of a container. Add the value to its end
936        # and keep processing.
937
938        set pend [lreplace $pend end end \
939                [linsert [lindex $pend end] end \
940                $value]]
941
942        # Don't stop.
943        return 0
944    }
945
946    # The value is at the top, report it. The callback determines if
947    # we keep processing.
948
949    return [Command $token value $value]
950}
951
952# ::bee::decodeCancel --
953#
954#       Destroys the decoder referenced by the token.
955#
956# Arguments:
957#       token   The decoder to destroy.
958#
959# Results:
960#       None.
961
962proc ::bee::decodeCancel {token} {
963    variable bee
964    variable $token
965    upvar 0  $token state
966    unset bee($state(chan))
967    unset state
968    return
969}
970
971# ::bee::decodePush --
972#
973#       Push data into the decoder input buffer.
974#
975# Arguments:
976#       token   The decoder to extend.
977#       string  The characters to add.
978#
979# Results:
980#       None.
981
982proc ::bee::decodePush {token string} {
983    variable $token
984    upvar 0  $token state
985    append state(read) $string
986    return
987}
988
989
990package provide bee 0.1
Note: See TracBrowser for help on using the repository browser.