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         if {[llength $args] > 1} {
 198           set indentIncr [lindex $args 1]
 199         } else {
 200           set indentIncr $indent
 201         }
 202     }
 203
 204     switch -- $type {
 205         {list} {
 206             append output "\[\n[string repeat " " $indent]"
 207             set tmp {}
 208             foreach element [lrange $thing 1 end] {
 209                 lappend tmp [unparse $element [expr {$indent + $indentIncr}] $indentIncr]
 210             }
 211             append output [join $tmp ",\n[string repeat " " $indent]"]
 212             append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\]"
 213         }
 214
 215         {obj} {
 216             append output "\{\n[string repeat " " $indent]"
 217             set tmp {}
 218             for {set i 1} {$i < [llength $thing]} {incr i} {
 219                 set key [lindex $thing $i]
 220                 set value [lindex $thing [incr i]]
 221                 lappend tmp "\"$key\": [unparse $value [expr {$indent + $indentIncr}] $indentIncr]"
 222             }
 223             append output [join $tmp ",\n[string repeat " " $indent]"]
 224             append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\}"
 225         }
 226
 227         {str} {
 228             append output "\"[lindex $thing 1]\""
 229         }
 230
 231         {bool} -
 232         {num} {
 233             append output "[lindex $thing 1]"
 234         }
 235
 236         {null} {
 237             append output "null"
 238         }
 239
 240         {default} {
 241             error "unknown type \"$type\""
 242         }
 243     }
 244     return $output
 245 }
 246
 247 proc tcvJSON::write {args} {
 248     if {[llength $args] == 1} {
 249         set channel stdout
 250         set jsonName [lindex $args 0]
 251     } elseif {[llength $args] == 2} {
 252         set channel [lindex $args 0]
 253         set jsonName [lindex $args 1]
 254     } else {
 255         error "wrong # args: expected \"write ?channel? jsonName\""
 256     }
 257
 258     upvar $jsonName json
 259     puts $channel [unparse $json]
 260 }
 261
 262 # Shamelessly lifted from Tcllib's json::getc proc.
 263
 264 proc tcvJSON::getc {{txtvar txt}} {
 265     # pop single char off the front of the text
 266     upvar 1 $txtvar txt
 267     if {$txt eq ""} {
 268         return -code error "unexpected end of text"
 269     }
 270
 271     set c [string index $txt 0]
 272     set txt [string range $txt 1 end]
 273     return $c
 274 }
 275
 276 proc tcvJSON::parse {txt} {
 277     return [Parse]
 278 }
 279
 280 # Modified from Tcllib's json::_json2dict proc.
 281
 282 proc tcvJSON::Parse {{txtvar txt}} {
 283     upvar 1 $txtvar txt
 284
 285     set state TOP
 286     set current {}
 287
 288     set txt [string trimleft $txt]
 289     while {$txt ne ""} {
 290         set c [string index $txt 0]
 291
 292         # skip whitespace
 293         while {[string is space $c]} {
 294             getc
 295             set c [string index $txt 0]
 296         }
 297
 298         if {$c eq "\{"} {
 299             # object
 300             switch -- $state {
 301                 TOP {
 302                     # This is the toplevel object.
 303                     getc
 304                     set state OBJECT
 305                     set current [create obj]
 306                 }
 307                 VALUE {
 308                     # We are inside an object looking at the value, which is another object.
 309                     put! -type auto current $name [Parse]
 310                     set state COMMA
 311                 }
 312                 LIST {
 313                     # We are inside a list and the next element is an object.
 314                     add! -type auto current [Parse]
 315                     set state COMMA
 316                 }
 317                 default {
 318                     return -code error "unexpected open brace in $state mode"
 319                 }
 320             }
 321         } elseif {$c eq "\}"} {
 322             getc
 323             if {$state ne "OBJECT" && $state ne "COMMA"} {
 324                 return -code error "unexpected close brace in $state mode"
 325             }
 326             return $current
 327         } elseif {$c eq ":"} {
 328             # name separator
 329             getc
 330
 331             if {$state eq "COLON"} {
 332                 set state VALUE
 333             } else {
 334                 return -code error "unexpected colon in $state mode"
 335             }
 336         } elseif {$c eq ","} {
 337             # element separator
 338             if {$state eq "COMMA"} {
 339                 getc
 340                 if {[lindex $current 0] eq "list"} {
 341                     set state LIST
 342                 } elseif {[lindex $current 0] eq "obj"} {
 343                     set state OBJECT
 344                 }
 345             } else {
 346                 return -code error "unexpected comma in $state mode"
 347             }
 348         } elseif {$c eq "\""} {
 349             # string
 350             # capture quoted string with backslash sequences
 351             set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
 352             set string ""
 353             if {![regexp $reStr $txt string]} {
 354                 set txt [string replace $txt 32 end ...]
 355                 return -code error "invalid formatted string in $txt"
 356             }
 357             set txt [string range $txt [string length $string] end]
 358             # chop off outer ""s and substitute backslashes
 359             # This does more than the RFC-specified backslash sequences,
 360             # but it does cover them all
 361             set string [subst -nocommand -novariable \
 362                             [string range $string 1 end-1]]
 363
 364             switch -- $state {
 365                 TOP {
 366                     return $string
 367                 }
 368                 OBJECT {
 369                     set name $string
 370                     set state COLON
 371                 }
 372                 LIST {
 373                     add! -type str current $string
 374                     set state COMMA
 375                 }
 376                 VALUE {
 377                     put! -type str current $name $string
 378                     unset name
 379                     set state COMMA
 380                 }
 381             }
 382         } elseif {$c eq "\["} {
 383             # JSON array == Tcl list
 384             switch -- $state {
 385                 TOP {
 386                     getc
 387                     set current [create list]
 388                     set state LIST
 389                 }
 390                 LIST {
 391                     add! -type auto current [Parse]
 392                     set state COMMA
 393                 }
 394                 VALUE {
 395                     put! -type auto current $name [Parse]
 396                     set state COMMA
 397                 }
 398                 default {
 399                     return -code error "unexpected open bracket in $state mode"
 400                 }
 401             }
 402         } elseif {$c eq "\]"} {
 403             # end of list
 404             getc
 405             return $current
 406         } elseif {[string match {[-0-9]} $c]} {
 407             # one last check for a number, no leading zeros allowed,
 408             # but it may be 0.xxx
 409             string is double -failindex last $txt
 410             if {$last > 0} {
 411                 set num [string range $txt 0 [expr {$last - 1}]]
 412                 set txt [string range $txt $last end]
 413
 414                 switch -- $state {
 415                     TOP {
 416                         return $num
 417                     }
 418                     LIST {
 419                         add! -type num current $num
 420                         set state COMMA
 421                     }
 422                     VALUE {
 423                         put! -type num current $name $num
 424                         set state COMMA
 425                     }
 426                     default {
 427                         getc
 428                         return -code error "unexpected number '$c' in $state mode"
 429                     }
 430                 }
 431             } else {
 432                 getc
 433                 return -code error "unexpected '$c' in $state mode"
 434             }
 435         } elseif {[string match {[ftn]} $c]
 436                   && [regexp {^(true|false|null)} $txt val]} {
 437             # bare word value: true | false | null
 438             set txt [string range $txt [string length $val] end]
 439
 440             switch -- $state {
 441                 TOP {
 442                     return $val
 443                 }
 444                 LIST {
 445                     add! current $val
 446                     set state COMMA
 447                 }
 448                 VALUE {
 449                     put! current $name $val
 450                     set state COMMA
 451                 }
 452                 default {
 453                     getc
 454                     return -code error "unexpected '$c' in $state mode"
 455                 }
 456             }
 457         } else {
 458             # error, incorrect format or unexpected end of text
 459             return -code error "unexpected '$c' in $state mode"
 460         }
 461     }
 462 }
 463
 464 # Synopsis: objForEach KEY VALUE OBJ SCRIPT
 465 # Iterates through the key/value pairs in the supplied JSON object OBJ and sets
 466 # KEY and VALUE in the environment of SCRIPT, then running SCRIPT at the
 467 # caller's level.
 468
 469 proc tcvJSON::objForEach {k v obj script} {
 470     if {[lindex $obj 0] ne "obj"} {
 471         error "this is not an object"
 472     }
 473
 474     for {set i 1} {$i < [llength $obj]} {incr i 2} {
 475         uplevel [list set $k [lindex $obj $i]]
 476         uplevel [list set $v [lindex $obj $i+1]]
 477         uplevel $script
 478     }
 479
 480     if {[llength $obj] > 1} {
 481         # Clean up after ourselves.
 482         uplevel [list unset $k]
 483         uplevel [list unset $v]
 484     }
 485 }
 486
 487 # Synopsis: exists? JSON THING
 488 # Indicates whether THING exists within JSON.  If JSON is an object, then we
 489 # treat THING like a key.  If JSON is a list, we treat THING like an element.
 490 # It is an error for the value of JSON to be a non-composite type.
 491
 492 proc tcvJSON::exists? {json thing} {
 493     if {[lindex $json 0] eq "obj"} {
 494         set increment 2
 495     } elseif {[lindex $json 0] eq "list"} {
 496         set increment 1
 497     } else {
 498         error "not a composite type"
 499     }
 500     for {set i 1} {$i < [llength $json]} {incr i $increment} {
 501         if {[lindex $json $i] == $thing} {
 502             return 1
 503         }
 504     }
 505     return 0
 506 }
 507
 508 # Synopsis: listForEach ELT LIST SCRIPT
 509 # Iterates through all the elements in the supplied JSON list LIST and sets ELT
 510 # appropriately in the environment of SCRIPT, then running SCRIPT at the
 511 # caller's level.
 512
 513 proc tcvJSON::listForEach {e lst script} {
 514     if {[lindex $lst 0] ne "list"} {
 515         error "this is not a list"
 516     }
 517
 518     for {set i 1} {$i < [llength $lst]} {incr i} {
 519         uplevel [list set $e [lindex $obj $i]]
 520         uplevel $script
 521     }
 522
 523     # Don't leave the variables set.
 524     uplevel [list unset $e]
 525 }