import json package

[scpubgit/TenDotTcl.git] / json / json_write.tcl

diff --git a/json/json_write.tcl b/json/json_write.tcl
new file mode 100644 (file)
index 0000000..7310172
--- /dev/null
+++ b/json/json_write.tcl
@@ -0,0 +1,185 @@
+# json_write.tcl --
+#
+#      Commands for the generation of JSON (Java Script Object Notation).
+#
+# Copyright (c) 2009-2011 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: json_write.tcl,v 1.2 2011/08/24 20:09:44 andreas_kupries Exp $
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+
+namespace eval ::json::write {
+    namespace export \
+       string array object indented aligned
+
+    namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::json::write::indented {{bool {}}} {
+    variable indented
+
+    if {[llength [info level 0]] > 2} {
+       return -code error {wrong # args: should be "json::write indented ?bool?"}
+    } elseif {[llength [info level 0]] == 2} {
+       if {![::string is boolean -strict $bool]} {
+           return -code error "Expected boolean, got \"$bool\""
+       }
+       set indented $bool
+       if {!$indented} {
+           variable aligned 0
+       }
+    }
+
+    return $indented
+}
+
+proc ::json::write::aligned {{bool {}}} {
+    variable aligned
+
+    if {[llength [info level 0]] > 2} {
+       return -code error {wrong # args: should be "json::write aligned ?bool?"}
+    } elseif {[llength [info level 0]] == 2} {
+       if {![::string is boolean -strict $bool]} {
+           return -code error "Expected boolean, got \"$bool\""
+       }
+       set aligned $bool
+       if {$aligned} {
+           variable indented 1
+       }
+    }
+
+    return $aligned
+}
+
+proc ::json::write::string {s} {
+    variable quotes
+    return "\"[::string map $quotes $s]\""
+}
+
+proc ::json::write::array {args} {
+    # always compact form.
+    return "\[[join $args ,]\]"
+}
+
+proc ::json::write::object {args} {
+    # The dict in args maps string keys to json-formatted data. I.e.
+    # we have to quote the keys, but not the values, as the latter are
+    # already in the proper format.
+
+    variable aligned
+    variable indented
+
+    if {[llength $args] %2 == 1} {
+       return -code error {wrong # args, expected an even number of arguments}
+    }
+
+    set dict {}
+    foreach {k v} $args {
+       lappend dict [string $k] $v
+    }
+
+    if {$aligned} {
+       set max [MaxKeyLength $dict]
+    }
+
+    if {$indented} {
+       set content {}
+       foreach {k v} $dict {
+           if {$aligned} {
+               set k [AlignLeft $max $k]
+           }
+           if {[::string match *\n* $v]} {
+               # multi-line value
+               lappend content "    $k : [Indent $v {    } 1]"
+           } else {
+               # single line value.
+               lappend content "    $k : $v"
+           }
+       }
+       if {[llength $content]} {
+           return "\{\n[join $content ,\n]\n\}"
+       } else {
+           return "\{\}"
+       }
+    } else {
+       # ultra compact form.
+       set tmp {}
+       foreach {k v} $dict {
+           lappend tmp "$k:$v"
+       }
+       return "\{[join $tmp ,]\}"
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Internals.
+
+proc ::json::write::Indent {text prefix skip} {
+    set pfx ""
+    set result {}
+    foreach line [split $text \n] {
+       if {!$skip} { set pfx $prefix } else { incr skip -1 }
+       lappend result ${pfx}$line
+    }
+    return [join $result \n]
+}
+
+proc ::json::write::MaxKeyLength {dict} {
+    # Find the max length of the keys in the dictionary.
+
+    set lengths 0 ; # This will be the max if the dict is empty, and
+                   # prevents the mathfunc from throwing errors for
+                   # that case.
+
+    foreach str [dict keys $dict] {
+       lappend lengths [::string length $str]
+    }
+
+    return [tcl::mathfunc::max {*}$lengths]
+}
+
+proc ::json::write::AlignLeft {fieldlen str} {
+    return [format %-${fieldlen}s $str]
+    #return $str[::string repeat { } [expr {$fieldlen - [::string length $str]}]]
+}
+
+# ### ### ### ######### ######### #########
+
+namespace eval ::json::write {
+    # Configuration of the layout to write.
+
+    # indented = boolean. objects are indented.
+    # aligned  = boolean. object keys are aligned vertically.
+
+    # aligned  => indented.
+
+    # Combinations of the format specific entries
+    # I A |
+    # - - + ---------------------
+    # 0 0 | Ultracompact (no whitespace, single line)
+    # 1 0 | Indented
+    # 0 1 | Not possible, per the implications above.
+    # 1 1 | Indented + vertically aligned keys
+    # - - + ---------------------
+
+    variable indented 1
+    variable aligned  1
+
+    variable quotes \
+       [list "\"" "\\\"" / \\/ \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide json::write 1.0.1
+return