00001 # TKE - Advanced Programmer's Editor 00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com) 00003 # 00004 # This program is free software; you can redistribute it and/or modify 00005 # it under the terms of the GNU General Public License as published by 00006 # the Free Software Foundation; either version 2 of the License, or 00007 # (at your option) any later version. 00008 # 00009 # This program is distributed in the hope that it will be useful, 00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of 00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00012 # GNU General Public License for more details. 00013 # 00014 # You should have received a copy of the GNU General Public License along 00015 # with this program; if not, write to the Free Software Foundation, Inc., 00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 00017 00018 ###################################################################### 00019 # Name: tkedat.tcl 00020 # Author: Trevor Williams (trevorw@sgi.com) 00021 # Date: 08/08/2013 00022 # Brief: Namespace for reading .tkedat files. 00023 ###################################################################### 00024 00025 namespace eval tkedat { 00026 00027 variable bcount 0 00028 00029 ###################################################################### 00030 # Counts the number of curly brackets found in the given string. 00031 proc bracket_count {line line_num start_col} { 00032 00033 variable bcount 00034 00035 while {[regexp -indices -start $start_col {([\{\}])(.*)$} $line -> char]} { 00036 set start [lindex $char 0] 00037 if {![regexp {(\\+)$} [string range $line 0 [expr $start - 1]] -> escapes] || ([expr [string length $escapes] % 2] == 0)} { 00038 if {[string index $line $start] eq "\{"} { 00039 incr bcount 00040 } else { 00041 if {$bcount == 0} { 00042 return -code error "Bad tkedat format (line: $line_num, col: $start)" 00043 } 00044 incr bcount -1 00045 } 00046 } 00047 set start_col [expr $start + 1] 00048 } 00049 00050 return $bcount 00051 00052 } 00053 00054 ###################################################################### 00055 # Reads the given tkedat file, stripping/storing comments and verifying 00056 # that no Tcl commands are called. 00057 proc read {fname {include_comments 1}} { 00058 00059 set contents "" 00060 00061 # Open the file for reading and return an error if we have an issue 00062 if {[catch { open $fname r } rc]} { 00063 return -code error [format "%s %s" [msgcat::mc "Unable to read"] $fname] 00064 } 00065 00066 # Read the file contents 00067 set contents [::read $rc] 00068 close $rc 00069 00070 return [parse $contents $include_comments] 00071 00072 } 00073 00074 ###################################################################### 00075 # Parses the given string for tkedat formatted text. 00076 proc parse {str {include_comments 1}} { 00077 00078 array set contents [list] 00079 00080 set comments [list] 00081 set value_ip 0 00082 set linenum 1 00083 00084 foreach line [split $str \n] { 00085 00086 if {!$value_ip && [regexp {^\s*#(.*)$} $line -> comment]} { 00087 00088 lappend comments $comment 00089 00090 } elseif {!$value_ip && [regexp -indices {^\s*(\{[^\}]*\}|\S+)\s+(\{.*)$} $line -> key value]} { 00091 00092 set key [string map {\{ {} \} {}} [string range $line {*}$key]] 00093 00094 if {[bracket_count $line $linenum [lindex $value 0]] == 0} { 00095 set contents($key) [string range [string trim [string range $line {*}$value]] 1 end-1] 00096 if {[regexp {\[.*\]} $contents($key)]} { 00097 unset contents($key) 00098 } elseif {$include_comments} { 00099 set contents($key,comment) $comments 00100 } 00101 set comments [list] 00102 } else { 00103 set contents($key) [string range [string range $line {*}$value] 1 end] 00104 set value_ip 1 00105 } 00106 00107 } elseif {!$value_ip && [regexp {^\s*(\{[^\}]*\}|\S+)\s+(\S+)$} $line -> key value]} { 00108 00109 set key [string map {\{ {} \} {}} $key] 00110 set contents($key) [string trim $value] 00111 00112 if {[regexp {\[.*\]} $contents($key)]} { 00113 unset contents($key) 00114 } elseif {$include_comments} { 00115 set contents($key,comment) $comments 00116 } 00117 set comments [list] 00118 00119 } elseif {$value_ip} { 00120 00121 if {[bracket_count $line $linenum 0] == 0} { 00122 append contents($key) " [string range [string trim $line] 0 end-1]" 00123 if {[regexp {\[.*\]} $contents($key)]} { 00124 unset contents($key) 00125 } elseif {$include_comments} { 00126 set contents($key,comment) $comments 00127 } 00128 set comments [list] 00129 set value_ip 0 00130 } else { 00131 if {$include_comments} { 00132 append contents($key) "$line\n" 00133 } else { 00134 append contents($key) " [string trim $line]" 00135 } 00136 } 00137 00138 } 00139 00140 incr linenum 00141 00142 } 00143 00144 return [array get contents] 00145 00146 } 00147 00148 ###################################################################### 00149 # Writes the given array to the given tkedat file, adding the comments 00150 # back to the file. 00151 proc write {fname contents {include_comments 1} {multi {}}} { 00152 00153 if {![catch { open $fname w } rc]} { 00154 00155 array set content $contents 00156 array set multiline $multi 00157 00158 foreach name [lsort [array names content]] { 00159 if {![regexp {,comment$} $name]} { 00160 if {$include_comments} { 00161 if {[info exists content($name,comment)]} { 00162 foreach comment $content($name,comment) { 00163 puts $rc "#$comment" 00164 } 00165 } 00166 if {([llength $content($name)] == 0) || ![info exists multiline($name)]} { 00167 puts $rc "\n{$name} {$content($name)}\n" 00168 } elseif {$multiline($name) eq "array"} { 00169 puts $rc "\n{$name} {" 00170 foreach {key value} $content($name) { 00171 puts $rc [format " %s" [list $key $value]] 00172 } 00173 puts $rc "}\n" 00174 } else { 00175 puts $rc "\n{$name} {" 00176 foreach line $content($name) { 00177 puts $rc [format " %s" [list $line]] 00178 } 00179 puts $rc "}\n" 00180 } 00181 } else { 00182 puts $rc "{$name} {$content($name)}" 00183 } 00184 } 00185 } 00186 00187 close $rc 00188 00189 } else { 00190 00191 return -code error [format "%s %s" [msgcat::mc "Unable to write"] $fname] 00192 00193 } 00194 00195 } 00196 00197 }