=== Code Start ===
  # Code by Zarutian here is hereby free to everyone to use if they satisfy the following conditions:
  #   1. Dont blame me if this doesnt work for any purpose you intented.
  #   2. Attribute your use of this code
  #   3. Any and all modifications of this code must be shared under these conditions.
  #   4. Any patent infrightment (anywhere and anywhen) is the sole responsibility of the patent holder.
  #      I am sorry if your patent was too obvious or too broad to be infrighted upon but it is no concern of mine.
  package require Tcl 8.5
  package require thingy 1.2
  package provide SEXP 1.0

  thingy SEXP
  SEXP set ignore_whitespaces yes
  SEXP proc parse {input} {
    # returns: <parsed SEXP>
    # <parsed SEXP> := [list <type> <contents>]
    # <type>        := "bytestring" | "sequence"
    # <contents>    := <bytestring> | <parsed SEXP>
    # <bytestring>  is an abirity long string of 8 bit bytes most significant bit first

    set stackpointer 0
    set stack($stackpointer) {}
    set bytestring_length 0
    set length [string length $input]
    for {set index 0} {$index < $length]} {incr index} {
      set char [string index $input $index]
      switch -exact -- $char {
        "0" - "1" - "2" - "3" - "4" - "5" - "6" - "7" - "8" - "9" {
          if {($bytestring_length == 0) && ($char == "0")} {
            error "SEXP parse: length field of an bytestring cannot be zero!"
          }
          set bytestring_length [expr ($bytestring_length * 10) + $char]
        }
        ":" {
          if {$bytestring_length == 0} {
            error "SEXP parse: length field ender (:) must have an length field before it"
          }
          lappend stack($stackpointer) [list bytestring \
             [string range $input [expr {$index + 1}] [expr {$index + $bytestring_length}]]]
          incr index $bytestring_length
          set bytestring_length 0
        }
        "(" {
          incr stackpointer
          set stack($stackpointer) {}
        }
        ")" {
          if {$stackpointer == 0} {
            error "SEXP parse: too many ( or missing )"
          }
          set t $stack($stackpointer)
          unset stack($stackpointer)
          incr stackpointer -1
          lappend stack($stackpointer) [list sequence $t]
        }
        default {
          variable ignore_whitespaces
          if {[set ignore_whitespaces]} {
            if {($char != " ") && ($char != "\t") && ($char != "\n") && ($char != "\x00")} {
              error "SEXP complete?: unknown op char $char"
            }          
          } else {
            error "SEXP complete?: unknown op char $char"
          }
        }
      }
    }
    if {$stackpointer < 0} {
      error "SEXP parse: too many ) or missing ("
    }
    return $stack(0)
  }
  SEXP proc serialize {input} {
    set type [lindex $input 0]
    set data [lindex $input 1]
    if {$type == "bytestring"} {
      return "[string length $data]:[set data]"
    } elseif {$type == "sequence"} {
      set res {}
      foreach item $data {
        append res [[lindex [info level 0] 0] $item]
      }
      return "([set res])"
    } else {
      error "#debug"
      return [[lindex [info level 0] 0] [lindex $input 0]]
    }
  }
  SEXP proc complete? {input} {
    # returns -1 if input isnt complete S-EXPRESSION
    # otherwise it returns the index where such complete expression ends
    set bytestring_length 0
    set level 0
  
    set index 0
    set length [string length $input]
    while true {
      set char [string index $input $index]
      switch -exact -- $char {
        "0" - "1" - "2" - "3" - "4" - "5" - "6" - "7" - "8" - "9" {
          if {($bytestring_length == 0) && ($char == "0")} {
            error "SEXP complete?: length field of an bytestring cannot be zero!"
          }
          set bytestring_length [expr ($bytestring_length * 10) + $char]
        }
        ":" {
          incr index $bytestring_length
          set bytestring_length 0
          if {$level == 0} { return [incr index] }
        }
        "(" {
          incr level +1
        }
        ")" {
          incr level -1
          if {$level == 0} { return [incr index] }
          if {$level <  0} { error "SEXP complete?: is ) missing somewhere in the s-expression?" }
        }
        default {
          variable ignore_whitespaces
          if {[set ignore_whitespaces]} {
            if {($char != " ") && ($char != "\t") && ($char != "\n") && ($char != "\x00")} {
              error "SEXP complete?: unknown op char $char"
            }          
          } else {
            error "SEXP complete?: unknown op char $char"
          }
        }
      }
      incr index
      if {!($index < $length)} { return -1 }
    }
  }
  SEXP proc sequence args {
    return [list sequence $args]
  }
  SEXP proc bytestring {arg} {
    return [list bytestring $arg]
  }
  
  # Binary Hex Symbol
  # 0000 0  0
  # 0001 1  1
  # 0010 2  2
  # 0011 3  3
  # 0100 4  4
  # 0101 5  5
  # 0110 6  6
  # 0111 7  7
  # 1000 8  8
  # 1001 9  9
  # 1010 a 10
  # 1011 b 11
  # 1100 c 12
  # 1101 d  (
  # 1110 e  )
  # 1111 f  :
  SEXP proc compactHexParse {input} {
    # returns: <parsed SEXP>
    # <parsed SEXP> := [list <type> <contents>]
    # <type>        := "bytestring" | "sequence"
    # <contents>    := <bytestring> | <parsed SEXP>
    if {![string is hexdigit $data]} {
      error "SEXP compactHexParse expects string of hex numbers"
    }

    set stackpointer 0
    set stack($stackpointer) {}
    set bytestring_length 0
    for {set index 0} {$index < [string length $input]} {incr index} {
      set char [string index $input $index]
      switch -exact -- $char {
        "0" - "1" - "2" - "3" - "4" - "5" - "6" - "7" - "8" - "9" - "a" - "b" - "c" {
          if {($bytestring_length == 0) && ($char == "0")} {
            error "SEXP compactHexParse: length field of an bytestring cannot be zero!"
          }
          set bytestring_length [expr {($bytestring_length * 13) + 0x[set char]}]
        }
        "d" {
          # (
          incr stackpointer
          set stack($stackpointer) {}
        }
        "e" {
          # )
          set t $stack($stackpointer)
          unset stack($stackpointer)
          incr stackpointer -1
          lappend stack($stackpointer) [list sequence $t]
        }
        "f" {
          # :
          set str [string range $input [+ $index 1] [+ $index $bytestring_length]]
          set str [binary format H* $str]
          lappend stack($stackpointer) [list string $str]
          incr index $bytestring_length
          set current_bs_len 0
        }
      }
    }
    if {$stackpointer != 0} {
      error "SEXP compactHexParse stackpointer != 0"
    }
    return $stack(0)
  }
  SEXP proc compactHexSerialize {input} {
    set type [lindex $input 0]
    set data [lindex $input 1]
    if {$type == "bytestring"} {
      binary scan $data H* data
      set length [compactHexSerialize_sub1 [string length $data]]
      return "[set length]f[set data]"
    } elseif {$type == "sequence"} {
      set res {}
      foreach item $data {
        append res [[lindex [info level 0] 0] $item]
      }
      return "d[set res]e"
    } else {
      return [[lindex [info level 0] 0] [lindex $input 0]]
    }
  }
  SEXP proc compactHexSerialize_sub1 {number} {
    set result ""
    set base 13
    while true {
      set digit  [expr $number % $base]
      set number [expr $number / $base]
      set t [format "%x" $digit]
      set result "[set t][set result]"
      if {$number <= 0} { break }
    }
    return $result
  }

=== Code End ===

[Zarutian] 02:59 14. oktober 2006: this package requires [Zarutian's Thingy Package]. Please do not change the above code block without conferring with me first. Comments are welcome below.

[Category Packages] [Category Pure-Tcl]