tcvJSON.tcl

   1 ######################################################################
   2 ###                                                                ###
   3 ###  Copyright (c) 2009 Taylor Christopher Venable                 ###
   4 ###  Made available under the Simplified BSD License.              ###
   5 ###                                                                ###
   6 ######################################################################
   7
   8 # CVS Path: /Programs/Libraries/Tcl/tcvJSON/tcvJSON.tcl
   9 # Last Change: $Date$
  10 # Revision: $Revision$
  11
  12 ## The parser part of this code is derived from that found in Tcllib, and which
  13 ## bears this copyright information:
  14 ##
  15 ## Copyright 2006 ActiveState Software Inc.
  16 ##
  17 ## See also the accompanying license.terms file which describes the rules for
  18 ## licensing and distributing Tcllib code.
  19
  20 package provide tcvJSON 1.0
  21
  22 namespace eval tcvJSON {}
  23
  24 # This namespace is called tcvJSON because json is already in tcllib and other
  25 # programs which use this module may need to access that alternative json.  The
  26 # problem with tcllib's json is that it doesn't offer a way to write JSON, only
  27 # to read it.  The inherent difficulty here is that most Tcl values can be
  28 # simultaneously representable by more than one type: most values can be shown
  29 # as strings.  Examples: "quick brown fox" is both a string and a list of three
  30 # elements.  Similarly, "true" is both a boolean (as interpreted by [expr]) and
  31 # a string.  So how do we encode such things?  Well we punt on it and force
  32 # data to be added to JSON via a special interface.  This produces an internal
  33 # representation of tuples {TYPE VALUE} where TYPE indicates how to show the
  34 # data.  For example, a list could be
  35 #
  36 # {list {str "quick brown fox"} {list {num 1} {num 2}}}
  37 #
  38 # --> ["quick brown fox", [1, 2]]
  39 #
  40 # In this scheme, objects are represented as follows:
  41 #
  42 # {obj "foo" {str "bar"} "tcl" {num 8.6}}
  43 #
  44 # --> {"foo" : "bar",
  45 #      "tcl" : 8.6}
  46 #
  47 # Because keys in objects can only be strings, there's no need to tag them as
  48 # such.  Thus, an object is a list of key-value pairs.
  49
  50 proc tcvJSON::create {type} {
  51     switch -- $type {
  52         {list} {
  53             return {list}
  54         }
  55
  56         {obj} -
  57         {object} {
  58             return {obj}
  59         }
  60     }
  61 }
  62
  63 # Synopsis: add! ?-type TYPE? JSONNAME VALUE
  64 # Appends the VALUE (possibly explicitly qualified to be of the given TYPE) to
  65 # the end of a JSON list stored in the caller in the variable JSONNAME.
  66 # Signals an error if the value of JSONNAME is not a JSON list.
  67
  68 proc tcvJSON::add! {args} {
  69     set location ""
  70     set value ""
  71
  72     set offset 0
  73
  74     if {[lindex $args 0] eq "-type"} {
  75         set type [lindex $args 1]
  76         set offset 2
  77     }
  78
  79     set location [lindex $args [expr {$offset + 0}]]
  80     set value [lindex $args [expr {$offset + 1}]]
  81
  82     if {![info exists type]} {
  83         if {[string is double -strict $value]} {
  84             set type "num"
  85         } elseif {$value eq "true" || $value eq "false"} {
  86             set type "bool"
  87         } elseif {$value eq "null"} {
  88             set type "null"
  89         } else {
  90             set type "str"
  91         }
  92     } elseif {$type eq "auto"} {
  93         set type [lindex $value 0]
  94         if {$type ne "list" && $type ne "obj"} {
  95             set value [lindex $value 1]
  96         } else {
  97             set value [lrange $value 1 end]
  98         }
  99     }
 100
 101     upvar $location json
 102
 103     if {[lindex $json 0] ne "list"} {
 104         error "can only \"add\" to lists: received $json"
 105     }
 106
 107     if {$type eq "null"} {
 108         lappend json "null"
 109     } else {
 110         if {$type eq "list" || $type eq "obj"} {
 111             lappend json [list $type {*}$value]
 112         } else {
 113             lappend json [list $type $value]
 114         }
 115     }
 116 }
 117
 118 # Synopsis: put! ?-type TYPE? JSONNAME KEY VALUE
 119 # Adds the relationship KEY → VALUE (possibly explicitly qualified to be of the
 120 # given TYPE) into the JSON object stored in the caller in the variable
 121 # JSONNAME.  Signals an error if the value of JSONNAME is not a JSON object.
 122 # KEY is treated as a string, both internally and for encoding.
 123
 124 proc tcvJSON::put! {args} {
 125     set location ""
 126
 127     set key ""
 128     set value ""
 129
 130     set offset 0
 131
 132     if {[lindex $args 0] eq "-type"} {
 133         set type [lindex $args 1]
 134         set offset 2
 135     }
 136
 137     set location [lindex $args [expr {$offset + 0}]]
 138     set key [lindex $args [expr {$offset + 1}]]
 139     set value [lindex $args [expr {$offset + 2}]]
 140
 141     if {![info exists type]} {
 142         if {[string is double -strict $value]} {
 143             set type "num"
 144         } elseif {$value eq "true" || $value eq "false"} {
 145             set type "bool"
 146         } elseif {$value eq "null"} {
 147             set type "null"
 148         } else {
 149             set type "str"
 150         }
 151     } elseif {$type eq "auto"} {
 152         set type [lindex $value 0]
 153         if {$type ne "list" && $type ne "obj"} {
 154             set value [lindex $value 1]
 155         } else {
 156             set value [lrange $value 1 end]
 157         }
 158     }
 159
 160     upvar $location json
 161
 162     if {[lindex $json 0] ne "obj"} {
 163         error "can only \"put\" to objects: received $json"
 164     }
 165
 166     for {set i 1} {$i < [llength $json]} {incr i 2} {
 167         if {[lindex $json $i] eq $key} {
 168             set json [lreplace $json $i $i+1]
 169         }
 170     }
 171
 172     lappend json $key
 173     if {$type eq "null"} {
 174         lappend json null
 175     } else {
 176         if {$type eq "list" || $type eq "obj"} {
 177             lappend json [list $type {*}$value]
 178         } else {
 179             lappend json [list $type $value]
 180         }
 181     }
 182 }
 183
 184 # Synopsis: unparse JSONTHING
 185 # Encodes / writes / prints / unparses some kind of JSON composite or scalar
 186 # value JSONTHING into a string representation which can be sent over the wire
 187 # or written to a file.
 188
 189 proc tcvJSON::unparse {thing args} {
 190     set output ""
 191     set type [lindex $thing 0]
 192     set indent 2
 193     set indentIncr 2
 194
 195     if {[llength $args] > 0} {
 196         set indent [lindex $args 0]
 197     }
 198
 199     switch -- $type {
 200         {list} {
 201             append output "\[\n[string repeat " " $indent]"
 202             set tmp {}
 203             foreach element [lrange $thing 1 end] {
 204                 lappend tmp [unparse $element [expr {$indent + $indentIncr}]]
 205             }
 206             append output [join $tmp ",\n[string repeat " " $indent]"]
 207             append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\]"
 208         }
 209
 210         {obj} {
 211             append output "\{\n[string repeat " " $indent]"
 212             set tmp {}
 213             for {set i 1} {$i < [llength $thing]} {incr i} {
 214                 set key [lindex $thing $i]
 215                 set value [lindex $thing [incr i]]
 216                 lappend tmp "\"$key\": [unparse $value [expr {$indent + $indentIncr}]]"
 217             }
 218             append output [join $tmp ",\n[string repeat " " $indent]"]
 219             append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\}"
 220         }
 221
 222         {str} {
 223             append output "\"[lindex $thing 1]\""
 224         }
 225
 226         {bool} -
 227         {num} {
 228             append output "[lindex $thing 1]"
 229         }
 230
 231         {null} {
 232             append output "null"
 233         }
 234
 235         {default} {
 236             error "unknown type \"$type\""
 237         }
 238     }
 239     return $output
 240 }
 241
 242 proc tcvJSON::write {args} {
 243     if {[llength $args] == 1} {
 244         set channel stdout
 245         set jsonName [lindex $args 0]
 246     } elseif {[llength $args] == 2} {
 247         set channel [lindex $args 0]
 248         set jsonName [lindex $args 1]
 249     } else {
 250         error "wrong # args: expected \"write ?channel? jsonName\""
 251     }
 252
 253     upvar $jsonName json
 254     puts $channel [unparse $json]
 255 }
 256
 257 # Shamelessly lifted from Tcllib's json::getc proc.
 258
 259 proc tcvJSON::getc {{txtvar txt}} {
 260     # pop single char off the front of the text
 261     upvar 1 $txtvar txt
 262     if {$txt eq ""} {
 263         return -code error "unexpected end of text"
 264     }
 265
 266     set c [string index $txt 0]
 267     set txt [string range $txt 1 end]
 268     return $c
 269 }
 270
 271 proc tcvJSON::parse {txt} {
 272     return [Parse]
 273 }
 274
 275 # Modified from Tcllib's json::_json2dict proc.
 276
 277 proc tcvJSON::Parse {{txtvar txt}} {
 278     upvar 1 $txtvar txt
 279
 280     set state TOP
 281     set current {}
 282
 283     set txt [string trimleft $txt]
 284     while {$txt ne ""} {
 285         set c [string index $txt 0]
 286
 287         # skip whitespace
 288         while {[string is space $c]} {
 289             getc
 290             set c [string index $txt 0]
 291         }
 292
 293         if {$c eq "\{"} {
 294             # object
 295             switch -- $state {
 296                 TOP {
 297                     # This is the toplevel object.
 298                     getc
 299                     set state OBJECT
 300                     set current [create obj]
 301                 }
 302                 VALUE {
 303                     # We are inside an object looking at the value, which is another object.
 304                     put! -type auto current $name [Parse]
 305                     set state COMMA
 306                 }
 307                 LIST {
 308                     # We are inside a list and the next element is an object.
 309                     add! -type auto current [Parse]
 310                     set state COMMA
 311                 }
 312                 default {
 313                     return -code error "unexpected open brace in $state mode"
 314                 }
 315             }
 316         } elseif {$c eq "\}"} {
 317             getc
 318             if {$state ne "OBJECT" && $state ne "COMMA"} {
 319                 return -code error "unexpected close brace in $state mode"
 320             }
 321             return $current
 322         } elseif {$c eq ":"} {
 323             # name separator
 324             getc
 325
 326             if {$state eq "COLON"} {
 327                 set state VALUE
 328             } else {
 329                 return -code error "unexpected colon in $state mode"
 330             }
 331         } elseif {$c eq ","} {
 332             # element separator
 333             if {$state eq "COMMA"} {
 334                 getc
 335                 if {[lindex $current 0] eq "list"} {
 336                     set state LIST
 337                 } elseif {[lindex $current 0] eq "obj"} {
 338                     set state OBJECT
 339                 }
 340             } else {
 341                 return -code error "unexpected comma in $state mode"
 342             }
 343         } elseif {$c eq "\""} {
 344             # string
 345             # capture quoted string with backslash sequences
 346             set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
 347             set string ""
 348             if {![regexp $reStr $txt string]} {
 349                 set txt [string replace $txt 32 end ...]
 350                 return -code error "invalid formatted string in $txt"
 351             }
 352             set txt [string range $txt [string length $string] end]
 353             # chop off outer ""s and substitute backslashes
 354             # This does more than the RFC-specified backslash sequences,
 355             # but it does cover them all
 356             set string [subst -nocommand -novariable \
 357                             [string range $string 1 end-1]]
 358
 359             switch -- $state {
 360                 TOP {
 361                     return $string
 362                 }
 363                 OBJECT {
 364                     set name $string
 365                     set state COLON
 366                 }
 367                 LIST {
 368                     add! -type str current $string
 369                     set state COMMA
 370                 }
 371                 VALUE {
 372                     put! -type str current $name $string
 373                     unset name
 374                     set state COMMA
 375                 }
 376             }
 377         } elseif {$c eq "\["} {
 378             # JSON array == Tcl list
 379             switch -- $state {
 380                 TOP {
 381                     getc
 382                     set current [create list]
 383                     set state LIST
 384                 }
 385                 LIST {
 386                     add! -type auto current [Parse]
 387                     set state COMMA
 388                 }
 389                 VALUE {
 390                     put! -type auto current $name [Parse]
 391                     set state COMMA
 392                 }
 393                 default {
 394                     return -code error "unexpected open bracket in $state mode"
 395                 }
 396             }
 397         } elseif {$c eq "\]"} {
 398             # end of list
 399             getc
 400             return $current
 401         } elseif {[string match {[-0-9]} $c]} {
 402             # one last check for a number, no leading zeros allowed,
 403             # but it may be 0.xxx
 404             string is double -failindex last $txt
 405             if {$last > 0} {
 406                 set num [string range $txt 0 [expr {$last - 1}]]
 407                 set txt [string range $txt $last end]
 408
 409                 switch -- $state {
 410                     TOP {
 411                         return $num
 412                     }
 413                     LIST {
 414                         add! -type num current $num
 415                         set state COMMA
 416                     }
 417                     VALUE {
 418                         put! -type num current $name $num
 419                         set state COMMA
 420                     }
 421                     default {
 422                         getc
 423                         return -code error "unexpected number '$c' in $state mode"
 424                     }
 425                 }
 426             } else {
 427                 getc
 428                 return -code error "unexpected '$c' in $state mode"
 429             }
 430         } elseif {[string match {[ftn]} $c]
 431                   && [regexp {^(true|false|null)} $txt val]} {
 432             # bare word value: true | false | null
 433             set txt [string range $txt [string length $val] end]
 434
 435             switch -- $state {
 436                 TOP {
 437                     return $val
 438                 }
 439                 LIST {
 440                     add! current $val
 441                     set state COMMA
 442                 }
 443                 VALUE {
 444                     put! current $name $val
 445                     set state COMMA
 446                 }
 447                 default {
 448                     getc
 449                     return -code error "unexpected '$c' in $state mode"
 450                 }
 451             }
 452         } else {
 453             # error, incorrect format or unexpected end of text
 454             return -code error "unexpected '$c' in $state mode"
 455         }
 456     }
 457 }
 458
 459 # Synopsis: objForEach KEY VALUE OBJ SCRIPT
 460 # Iterates through the key/value pairs in the supplied JSON object OBJ and sets
 461 # KEY and VALUE in the environment of SCRIPT, then running SCRIPT at the
 462 # caller's level.
 463
 464 proc tcvJSON::objForEach {k v obj script} {
 465     if {[lindex $obj 0] ne "obj"} {
 466         error "this is not an object"
 467     }
 468
 469     for {set i 1} {$i < [llength $obj]} {incr i 2} {
 470         uplevel [list set $k [lindex $obj $i]]
 471         uplevel [list set $v [lindex $obj $i+1]]
 472         uplevel $script
 473     }
 474
 475     if {[llength $obj] > 1} {
 476         # Clean up after ourselves.
 477         uplevel [list unset $k]
 478         uplevel [list unset $v]
 479     }
 480 }
 481
 482 # Synopsis: exists? JSON THING
 483 # Indicates whether THING exists within JSON.  If JSON is an object, then we
 484 # treat THING like a key.  If JSON is a list, we treat THING like an element.
 485 # It is an error for the value of JSON to be a non-composite type.
 486
 487 proc tcvJSON::exists? {json thing} {
 488     if {[lindex $json 0] eq "obj"} {
 489         set increment 2
 490     } elseif {[lindex $json 0] eq "list"} {
 491         set increment 1
 492     } else {
 493         error "not a composite type"
 494     }
 495     for {set i 1} {$i < [llength $json]} {incr i $increment} {
 496         if {[lindex $json $i] == $thing} {
 497             return 1
 498         }
 499     }
 500     return 0
 501 }
 502
 503 # Synopsis: listForEach ELT LIST SCRIPT
 504 # Iterates through all the elements in the supplied JSON list LIST and sets ELT
 505 # appropriately in the environment of SCRIPT, then running SCRIPT at the
 506 # caller's level.
 507
 508 proc tcvJSON::listForEach {e lst script} {
 509     if {[lindex $lst 0] ne "list"} {
 510         error "this is not a list"
 511     }
 512
 513     for {set i 1} {$i < [llength $lst]} {incr i} {
 514         uplevel [list set $e [lindex $obj $i]]
 515         uplevel $script
 516     }
 517
 518     # Don't leave the variables set.
 519     uplevel [list unset $e]
 520 }