json/json_write.tcl

   1 # json_write.tcl --
   2 #
   3 #       Commands for the generation of JSON (Java Script Object Notation).
   4 #
   5 # Copyright (c) 2009-2011 Andreas Kupries <andreas_kupries@sourceforge.net>
   6 #
   7 # See the file "license.terms" for information on usage and redistribution
   8 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   9 #
  10 # RCS: @(#) $Id: json_write.tcl,v 1.2 2011/08/24 20:09:44 andreas_kupries Exp $
  11
  12 # ### ### ### ######### ######### #########
  13 ## Requisites
  14
  15 package require Tcl 8.5
  16
  17 namespace eval ::json::write {
  18     namespace export \
  19         string array object indented aligned
  20
  21     namespace ensemble create
  22 }
  23
  24 # ### ### ### ######### ######### #########
  25 ## API.
  26
  27 proc ::json::write::indented {{bool {}}} {
  28     variable indented
  29
  30     if {[llength [info level 0]] > 2} {
  31         return -code error {wrong # args: should be "json::write indented ?bool?"}
  32     } elseif {[llength [info level 0]] == 2} {
  33         if {![::string is boolean -strict $bool]} {
  34             return -code error "Expected boolean, got \"$bool\""
  35         }
  36         set indented $bool
  37         if {!$indented} {
  38             variable aligned 0
  39         }
  40     }
  41
  42     return $indented
  43 }
  44
  45 proc ::json::write::aligned {{bool {}}} {
  46     variable aligned
  47
  48     if {[llength [info level 0]] > 2} {
  49         return -code error {wrong # args: should be "json::write aligned ?bool?"}
  50     } elseif {[llength [info level 0]] == 2} {
  51         if {![::string is boolean -strict $bool]} {
  52             return -code error "Expected boolean, got \"$bool\""
  53         }
  54         set aligned $bool
  55         if {$aligned} {
  56             variable indented 1
  57         }
  58     }
  59
  60     return $aligned
  61 }
  62
  63 proc ::json::write::string {s} {
  64     variable quotes
  65     return "\"[::string map $quotes $s]\""
  66 }
  67
  68 proc ::json::write::array {args} {
  69     # always compact form.
  70     return "\[[join $args ,]\]"
  71 }
  72
  73 proc ::json::write::object {args} {
  74     # The dict in args maps string keys to json-formatted data. I.e.
  75     # we have to quote the keys, but not the values, as the latter are
  76     # already in the proper format.
  77
  78     variable aligned
  79     variable indented
  80
  81     if {[llength $args] %2 == 1} {
  82         return -code error {wrong # args, expected an even number of arguments}
  83     }
  84
  85     set dict {}
  86     foreach {k v} $args {
  87         lappend dict [string $k] $v
  88     }
  89
  90     if {$aligned} {
  91         set max [MaxKeyLength $dict]
  92     }
  93
  94     if {$indented} {
  95         set content {}
  96         foreach {k v} $dict {
  97             if {$aligned} {
  98                 set k [AlignLeft $max $k]
  99             }
 100             if {[::string match *\n* $v]} {
 101                 # multi-line value
 102                 lappend content "    $k : [Indent $v {    } 1]"
 103             } else {
 104                 # single line value.
 105                 lappend content "    $k : $v"
 106             }
 107         }
 108         if {[llength $content]} {
 109             return "\{\n[join $content ,\n]\n\}"
 110         } else {
 111             return "\{\}"
 112         }
 113     } else {
 114         # ultra compact form.
 115         set tmp {}
 116         foreach {k v} $dict {
 117             lappend tmp "$k:$v"
 118         }
 119         return "\{[join $tmp ,]\}"
 120     }
 121 }
 122
 123 # ### ### ### ######### ######### #########
 124 ## Internals.
 125
 126 proc ::json::write::Indent {text prefix skip} {
 127     set pfx ""
 128     set result {}
 129     foreach line [split $text \n] {
 130         if {!$skip} { set pfx $prefix } else { incr skip -1 }
 131         lappend result ${pfx}$line
 132     }
 133     return [join $result \n]
 134 }
 135
 136 proc ::json::write::MaxKeyLength {dict} {
 137     # Find the max length of the keys in the dictionary.
 138
 139     set lengths 0 ; # This will be the max if the dict is empty, and
 140                     # prevents the mathfunc from throwing errors for
 141                     # that case.
 142
 143     foreach str [dict keys $dict] {
 144         lappend lengths [::string length $str]
 145     }
 146
 147     return [tcl::mathfunc::max {*}$lengths]
 148 }
 149
 150 proc ::json::write::AlignLeft {fieldlen str} {
 151     return [format %-${fieldlen}s $str]
 152     #return $str[::string repeat { } [expr {$fieldlen - [::string length $str]}]]
 153 }
 154
 155 # ### ### ### ######### ######### #########
 156
 157 namespace eval ::json::write {
 158     # Configuration of the layout to write.
 159
 160     # indented = boolean. objects are indented.
 161     # aligned  = boolean. object keys are aligned vertically.
 162
 163     # aligned  => indented.
 164
 165     # Combinations of the format specific entries
 166     # I A |
 167     # - - + ---------------------
 168     # 0 0 | Ultracompact (no whitespace, single line)
 169     # 1 0 | Indented
 170     # 0 1 | Not possible, per the implications above.
 171     # 1 1 | Indented + vertically aligned keys
 172     # - - + ---------------------
 173
 174     variable indented 1
 175     variable aligned  1
 176
 177     variable quotes \
 178         [list "\"" "\\\"" / \\/ \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t]
 179 }
 180
 181 # ### ### ### ######### ######### #########
 182 ## Ready
 183
 184 package provide json::write 1.0.1
 185 return