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