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