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: utils.tcl
00020 # Author: Trevor Williams (phase1geo@gmail.com)
00021 # Date: 5/11/2013
00022 # Brief: Namespace for general purpose utility procedures
00023 ######################################################################
00024
00025 namespace eval utils {
00026
00027 variable bin_rx {[\x00-\x08\x0b\x0e-\x1f]}
00028 variable eol_rx {\r\n|\n|\r}
00029
00030 array set xignore {}
00031 array set xignore_id {}
00032 array set vars {}
00033
00034 array set c2k_map {
00035 { } space
00036 ! exclam
00037 \" quotedbl
00038 \# numbersign
00039 \$ dollar
00040 % percent
00041 & ampersand
00042 ' quoteright
00043 ( parenleft
00044 ) parenright
00045 * asterisk
00046 + plus
00047 , comma
00048 - minus
00049 . period
00050 / slash
00051 : colon
00052 \; semicolon
00053 < less
00054 = equal
00055 > greater
00056 ? question
00057 @ at
00058 \[ bracketleft
00059 \\ backslash
00060 \] bracketright
00061 ^ asciicircum
00062 _ underscore
00063 ` quoteleft
00064 \{ braceleft
00065 | bar
00066 \} braceright
00067 ~ asciitilde
00068 \n Return
00069 }
00070
00071 array set code2sym {
00072 32 space
00073 33 exclam
00074 34 quotedbl
00075 35 numbersign
00076 36 dollar
00077 37 percent
00078 38 ampersand
00079 39 quoteright
00080 40 parenleft
00081 41 parenright
00082 42 asterisk
00083 43 plus
00084 44 comma
00085 45 minus
00086 46 period
00087 47 slash
00088 48 0
00089 49 1
00090 50 2
00091 51 3
00092 52 4
00093 53 5
00094 54 6
00095 55 7
00096 56 8
00097 57 9
00098 58 colon
00099 59 semicolon
00100 60 less
00101 61 equal
00102 62 greater
00103 63 question
00104 64 at
00105 65 A
00106 66 B
00107 67 C
00108 68 D
00109 69 E
00110 70 F
00111 71 G
00112 72 H
00113 73 I
00114 74 J
00115 75 K
00116 76 L
00117 77 M
00118 78 N
00119 79 O
00120 80 P
00121 81 Q
00122 82 R
00123 83 S
00124 84 T
00125 85 U
00126 86 V
00127 87 W
00128 88 X
00129 89 Y
00130 90 Z
00131 91 bracketleft
00132 92 backslash
00133 93 bracketright
00134 94 asciicircum
00135 95 underscore
00136 96 quoteleft
00137 97 a
00138 98 b
00139 99 c
00140 100 d
00141 101 e
00142 102 f
00143 103 g
00144 104 h
00145 105 i
00146 106 j
00147 107 k
00148 108 l
00149 109 m
00150 110 n
00151 111 o
00152 112 p
00153 113 q
00154 114 r
00155 115 s
00156 116 t
00157 117 u
00158 118 v
00159 119 w
00160 120 x
00161 121 y
00162 122 z
00163 123 braceleft
00164 124 bar
00165 125 braceright
00166 126 asciitilde
00167 65288 BackSpace
00168 65289 Tab
00169 65293 Return
00170 65307 Escape
00171 65360 Home
00172 65361 Left
00173 65362 Up
00174 65363 Right
00175 65364 Down
00176 65365 Prior
00177 65366 Next
00178 65367 End
00179 65535 Delete
00180 }
00181
00182 if {[tk windowingsystem] eq "aqua"} {
00183 array set code2sym {
00184 127 BackSpace
00185 9 Tab
00186 13 Return
00187 27 Escape
00188 63273 Home
00189 63234 Left
00190 63232 Up
00191 63235 Right
00192 63233 Down
00193 63276 Prior
00194 63277 Next
00195 63275 End
00196 63272 Delete
00197 }
00198 }
00199
00200 array set tablelistopts {
00201 selectbackground RoyalBlue1
00202 selectforeground white
00203 stretch all
00204 stripebackground #EDF3FE
00205 relief flat
00206 border 0
00207 showseparators yes
00208 takefocus 0
00209 setfocus 1
00210 activestyle none
00211 }
00212
00213 ##########################################################
00214 # Useful process for debugging.
00215 proc stacktrace {} {
00216
00217 set stack "Stack trace:\n"
00218
00219 catch {
00220 for {set i 1} {$i < [info level]} {incr i} {
00221 set lvl [info level -$i]
00222 set pname [lindex $lvl 0]
00223 if {[namespace which -command $pname] eq ""} {
00224 for {set j [expr $i + 1]} {$j < [info level]} {incr j} {
00225 if {[namespace which -command [lindex [info level -$j] 0]] ne ""} {
00226 set pname "[namespace qualifiers [lindex [info level -$j] 0]]::$pname"
00227 break
00228 }
00229 }
00230 }
00231 append stack [string repeat " " $i]$pname
00232 foreach value [lrange $lvl 1 end] arg [info args $pname] {
00233 if {$value eq ""} {
00234 info default $pname $arg value
00235 }
00236 append stack " $arg='$value'"
00237 }
00238 append stack \n
00239 }
00240 }
00241
00242 return $stack
00243
00244 }
00245
00246 ######################################################################
00247 # Looks up the given keycode value based on the provided keysym.
00248 proc sym2code {sym} {
00249
00250 variable code2sym
00251
00252 set code2sym_list [array get code2sym]
00253
00254 if {[set index [lsearch -exact $code2sym_list $sym]] != -1} {
00255 return [lindex $code2sym_list [expr $index - 1]]
00256 }
00257
00258 }
00259
00260 ######################################################################
00261 # Configure global tablelist options.
00262 proc tablelist_configure {w} {
00263
00264 variable tablelistopts
00265
00266 foreach {key value} [array get tablelistopts] {
00267 $w configure -$key $value
00268 }
00269
00270 }
00271
00272 ###########################################################################
00273 # Performs the set operation on a given yscrollbar.
00274 proc set_yscrollbar {sb first last} {
00275
00276 # If everything is displayed, hide the scrollbar
00277 if {($first == 0) && (($last == 1) || ($last == 0))} {
00278 grid remove $sb
00279 } else {
00280 grid $sb
00281 $sb set $first $last
00282 }
00283
00284 }
00285
00286 ######################################################################
00287 # Performs the set operation on a given xscrollbar.
00288 proc set_xscrollbar {sb first last} {
00289
00290 variable xignore
00291 variable xignore_id
00292
00293 if {($first == 0) && ($last == 1)} {
00294 grid remove $sb
00295 set_xignore $sb 1 0
00296 set xignore_id($sb) [after 1000 [list utils::set_xignore $sb 0 1]]
00297 } else {
00298 if {![info exists xignore($sb)] || !$xignore($sb)} {
00299 grid $sb
00300 $sb set $first $last
00301 }
00302 set_xignore $sb 0 0
00303 }
00304
00305 }
00306
00307 ######################################################################
00308 # Clears the xignore and xignore_id values.
00309 proc set_xignore {sb value auto} {
00310
00311 variable xignore
00312 variable xignore_id
00313
00314 # Clear the after (if it exists)
00315 if {[info exists xignore_id($sb)]} {
00316 after cancel $xignore_id($sb)
00317 unset xignore_id($sb)
00318 }
00319
00320 # Set the xignore value to the specified value
00321 set xignore($sb) $value
00322
00323 }
00324
00325 ######################################################################
00326 # Returns the mark of the anchor.
00327 proc text_anchor {w} {
00328
00329 if {[info procs ::tk::TextAnchor] ne ""} {
00330 return [::tk::TextAnchor $w]
00331 } else {
00332 return tk::anchor$w
00333 }
00334
00335 }
00336
00337 ######################################################################
00338 # Parses the given string for any variables and substitutes those
00339 # variables with their respective values. If a variable was found that
00340 # has not been defined, no substitution occurs for it. The fully
00341 # substituted string is returned.
00342 proc perform_substitutions {str} {
00343
00344 variable vars
00345
00346 return [subst [regsub -all {\$([a-zA-Z0-9_]+)} $str {[expr {[info exists vars(\1)] ? $vars(\1) : {&}}]}]]
00347
00348 }
00349
00350 ######################################################################
00351 # Adds the given environment variables to the environment.
00352 proc set_environment {var_list} {
00353
00354 variable vars
00355
00356 array unset vars
00357
00358 # Pre-load the vars with the environment variables
00359 array set vars [array get ::env]
00360
00361 # Load the var_list into vars
00362 foreach var_pair $var_list {
00363 set vars([string toupper [lindex $var_pair 0]]) [perform_substitutions [lindex $var_pair 1]]
00364 }
00365
00366 # Set the environment
00367 array set ::env [array get vars]
00368
00369 }
00370
00371 ######################################################################
00372 # Returns true if the given string looks like a URL.
00373 proc is_url {str} {
00374
00375 return [regexp {^(([a-zA-Z0-9]+:
00376
00377 }
00378
00379 ######################################################################
00380 # Returns true if the specified URL returns a status of ok and an ncode
00381 # value of 200; otherwise, returns a value of false;
00382 proc test_url {url} {
00383
00384 # Attempt to open the URL
00385 if {[catch { http::geturl $url -validate 1 } token]} {
00386 return 0
00387 }
00388
00389 # Check the return status
00390 set retval [expr {([http::status $token] eq "ok") && ([http::ncode $token] == 200)}]
00391
00392 # Cleanup the token
00393 http::cleanup $token
00394
00395 return $retval
00396
00397 }
00398
00399 ######################################################################
00400 # Downloads the file specified by the given URL to a temporary file
00401 # which is returned. If there is any error downloading the URL file,
00402 # returns the empty string.
00403 proc download_url {url} {
00404
00405 # Get the URL type
00406 if {![regexp {^(ftp|https?):
00407 return ""
00408 }
00409
00410 # Create a temporary file that will store binary data
00411 if {[catch { open [set fname [file tempfile]] w } rc]} {
00412 return ""
00413 }
00414
00415 fconfigure $rc -encoding binary
00416
00417 # Make sure that the proxy information is programmed correctly
00418 http::config -proxyhost [preferences::get General/ProxyHost] -proxyport [preferences::get General/ProxyPort]
00419
00420 # Attempt to open the URL
00421 if {[catch { http::geturl $url -channel $rc } token]} {
00422 close $rc
00423 file delete -force $fname
00424 return ""
00425 }
00426
00427 # Closes temporary file
00428 close $rc
00429
00430 # Check the return status
00431 if {([http::status $token] eq "ok") && ([http::ncode $token] == 200)} {
00432 http::cleanup $token
00433 return $fname
00434 } else {
00435 http::cleanup $token
00436 file delete -force $fname
00437 return ""
00438 }
00439
00440 }
00441
00442 ######################################################################
00443 # Opens the given filename in an external application, using one of the
00444 # open terminal commands to determine the proper application to use.
00445 # Returns true if the file/command failed to open; otherwise, returns 0.
00446 proc open_file_externally {fname {in_background 0}} {
00447
00448 set opts ""
00449
00450 # If the file to be viewed is located in the installation file system in freewrap,
00451 # unpack the file so that we can act on it via exec.
00452 if {[namespace exists ::freewrap] && [zvfs::exists $fname]} {
00453 set fname [freewrap::unpack $fname]
00454 }
00455
00456 switch -glob $::tcl_platform(os) {
00457 Darwin {
00458 if {$in_background} {
00459 set opts "-g"
00460 }
00461 return [catch { exec open {*}$opts $fname }]
00462 }
00463 Linux* {
00464 if {$in_background} {
00465 return [catch { exec -ignorestderr xdg-open $fname & }]
00466 } else {
00467 return [catch { exec -ignorestderr xdg-open $fname }]
00468 }
00469 }
00470 *Win* {
00471 if {[string range $fname 0 3] eq "http"} {
00472 return [catch { exec {*}[auto_execok start] {} $fname }]
00473 } else {
00474 return [catch { exec {*}[auto_execok start] {} [file nativename $fname] }]
00475 }
00476 }
00477 }
00478
00479 }
00480
00481 ######################################################################
00482 # Get relative path to target file from current path
00483 # First argument is a file name, second a directory name (not checked)
00484 proc relative_to {targetfile currentpath} {
00485 set cc [file split [file normalize $currentpath]]
00486 set tt [file split [file normalize $targetfile]]
00487 if {![string equal [lindex $cc 0] [lindex $tt 0]]} {
00488 return $targetfile
00489 }
00490 while {[string equal [lindex $cc 0] [lindex $tt 0]] && ([llength $cc] > 0)} {
00491 # discard matching components from the front
00492 set cc [lreplace $cc 0 0]
00493 set tt [lreplace $tt 0 0]
00494 }
00495 set prefix ""
00496 if {[llength $cc] == 0} {
00497 # just the file name, so targetfile is lower down (or in same place)
00498 set prefix "."
00499 }
00500 # step up the tree
00501 for {set i 0} {$i < [llength $cc]} {incr i} {
00502 append prefix " .."
00503 }
00504 # stick it all together (the eval is to flatten the targetfile list)
00505 return [eval file join $prefix $tt]
00506 }
00507
00508 ######################################################################
00509 # Returns the default foreground color.
00510 proc get_default_foreground {} {
00511
00512 return [ttk::style configure "." -foreground]
00513
00514 }
00515
00516 ######################################################################
00517 # Returns the default background color.
00518 proc get_default_background {} {
00519
00520 return [ttk::style configure "." -background]
00521
00522 }
00523
00524 ######################################################################
00525 # Converts the given color to an RGB list.
00526 proc color_to_rgb {color} {
00527
00528 lassign [winfo rgb . $color] r g b
00529
00530 return [list [expr $r >> 8] [expr $g >> 8] [expr $b >> 8]]
00531
00532 }
00533
00534 ######################################################################
00535 # Returns the color black or white such that the returned color
00536 # will be visible next to the given color (the given color does not
00537 # need to be monochrome).
00538 proc get_complementary_mono_color {color} {
00539
00540 lassign [color_to_rgb $color] r g b
00541
00542 # Calculate lightness (adjust the blue value to get a better result)
00543 set sorted [lsort -real [list $r $g [expr $b & 0xfc]]]
00544
00545 return [expr {((([lindex $sorted 0] + [lindex $sorted 2]) / 2) < 127) ? "white" : "black"}]
00546
00547 }
00548
00549 ######################################################################
00550 # Converts an RGB value into an HSV value.
00551 proc rgb_to_hsv {r g b} {
00552
00553 set sorted [lsort -real [list $r $g $b]]
00554 set temp [lindex $sorted 0]
00555 set v [lindex $sorted 2]
00556
00557 set bottom [expr {$v-$temp}]
00558 if {$bottom == 0} {
00559 set h 0
00560 set s 0
00561 set v $v
00562 } else {
00563 if {$v == $r} {
00564 set top [expr {$g-$b}]
00565 if {$g >= $b} {
00566 set angle 0
00567 } else {
00568 set angle 360
00569 }
00570 } elseif {$v == $g} {
00571 set top [expr {$b-$r}]
00572 set angle 120
00573 } elseif {$v == $b} {
00574 set top [expr {$r-$g}]
00575 set angle 240
00576 }
00577 set h [expr { round( 60 * ( double($top) / $bottom ) + $angle ) }]
00578 }
00579
00580 if {$v == 0} {
00581 set s 0
00582 } else {
00583 set s [expr { round( 255 - 255 * ( double($temp) / $v ) ) }]
00584 }
00585
00586 return [list $h $s $v]
00587
00588 }
00589
00590 ######################################################################
00591 # Converts an HSV value into an RGB value.
00592 proc hsv_to_rgb {h s v} {
00593
00594 set hi [expr { int( double($h) / 60 ) % 6 }]
00595 set f [expr { double($h) / 60 - $hi }]
00596 set s [expr { double($s)/255 }]
00597 set v [expr { double($v)/255 }]
00598 set p [expr { double($v) * (1 - $s) }]
00599 set q [expr { double($v) * (1 - $f * $s) }]
00600 set t [expr { double($v) * (1 - (1 - $f) * $s) }]
00601
00602 switch -- $hi {
00603 0 {
00604 set r $v
00605 set g $t
00606 set b $p
00607 }
00608 1 {
00609 set r $q
00610 set g $v
00611 set b $p
00612 }
00613 2 {
00614 set r $p
00615 set g $v
00616 set b $t
00617 }
00618 3 {
00619 set r $p
00620 set g $q
00621 set b $v
00622 }
00623 4 {
00624 set r $t
00625 set g $p
00626 set b $v
00627 }
00628 5 {
00629 set r $v
00630 set g $p
00631 set b $q
00632 }
00633 default {
00634 error "Wrong hi value in hsv_to_rgb procedure! This should never happen!"
00635 }
00636 }
00637
00638 set r [expr {round($r*255)}]
00639 set g [expr {round($g*255)}]
00640 set b [expr {round($b*255)}]
00641
00642 return [list $r $g $b]
00643
00644 }
00645
00646 ######################################################################
00647 # Converts an RGB value into an HSL value.
00648 proc rgb_to_hsl {r g b} {
00649
00650 set r [expr double($r) / 255]
00651 set g [expr double($g) / 255]
00652 set b [expr double($b) / 255]
00653
00654 lassign [lsort -real [list $r $g $b]] m unused M
00655 set C [expr $M - $m]
00656
00657 # Calculate hue
00658 if {$C == 0.0} {
00659 set h 0
00660 } elseif {$M == $r} {
00661 set h [expr round( fmod( (($g - $b) / $C), 6.0 ) * 60 )]
00662 } elseif {$M == $g} {
00663 set h [expr round( ((($b - $r) / $C) + 2.0) * 60 )]
00664 } else {
00665 set h [expr round( ((($r - $g) / $C) + 4.0) * 60 )]
00666 }
00667
00668 # Calculate light
00669 set l [expr ($M + $m) / 2]
00670
00671 # Calculate saturation
00672 if {$C == 0.0} {
00673 set s 0
00674 } else {
00675 set s [expr $C / (1.0 - abs( (2 * $l) - 1 ))]
00676 }
00677
00678 return [list $h $s $l]
00679
00680 }
00681
00682 ######################################################################
00683 # Converts an HSL value into an RGB value.
00684 proc hsl_to_rgb {h s l} {
00685
00686 set s [expr $s / 100.0]
00687 set l [expr $l / 100.0]
00688 set c [expr (1 - abs( (2 * $l) - 1 )) * $s]
00689 set m [expr ($l - ($c / 2)) * 255]
00690 set x [expr $c * (1 - abs( fmod( ($h / 60.0), 2 ) - 1))]
00691
00692 if {$h < 60} {
00693 lassign [list [expr ($c * 255) + $m] [expr ($x * 255) + $m] $m] r g b
00694 } elseif {$h < 120} {
00695 lassign [list [expr ($x * 255) + $m] [expr ($c * 255) + $m] $m] r g b
00696 } elseif {$h < 180} {
00697 lassign [list $m [expr ($c * 255) + $m] [expr ($x * 255) + $m]] r g b
00698 } elseif {$h < 240} {
00699 lassign [list $m [expr ($x * 255) + $m] [expr ($c * 255) + $m]] r g b
00700 } elseif {$h < 300} {
00701 lassign [list [expr ($x * 255) + $m] $m [expr ($c * 255) + $m]] r g b
00702 } else {
00703 lassign [list [expr ($c * 255) + $m] $m [expr ($x * 255) + $m]] r g b
00704 }
00705
00706 return [list [expr round( $r )] [expr round( $g )] [expr round( $b )]]
00707
00708 }
00709
00710 ######################################################################
00711 # Returns the value of the given color
00712 proc get_color_values {color} {
00713
00714 lassign [rgb_to_hsv {*}[set rgb [color_to_rgb $color]]] hue saturation value
00715
00716 return [list $value {*}$rgb [format "#%02x%02x%02x" {*}$rgb]]
00717
00718 }
00719
00720 ######################################################################
00721 # Automatically adjusts the given color by a value equal to diff such
00722 # that if color is a darker color, the value will be lightened and if
00723 # color is a lighter color, the value will be darkened.
00724 proc auto_adjust_color {color diff {mode "auto"}} {
00725
00726 lassign [rgb_to_hsv {*}[color_to_rgb $color]] hue saturation value
00727
00728 switch $mode {
00729 "auto" { set value [expr ($value < 128) ? ($value + $diff) : ($value - $diff)] }
00730 "manual" { set value [expr $value + $diff] }
00731 }
00732
00733 return [format {#%02x%02x%02x} {*}[hsv_to_rgb $hue $saturation $value]]
00734
00735 }
00736
00737 ######################################################################
00738 # Adjusts the hue of the given color by the value of difference.
00739 proc auto_mix_colors {color type diff} {
00740
00741 # Create the lighter version of the primary color
00742 lassign [color_to_rgb $color] r g b
00743
00744 switch $type {
00745 r {
00746 if {[set odiff [expr 255 - ($r + $diff)]] >= 0} {
00747 incr r $diff
00748 } else {
00749 set d [expr abs($odiff) / 2]
00750 set r 255
00751 set g [expr (($g - $d) > 0) ? ($g - $d) : 0]
00752 set b [expr (($b - $d) > 0) ? ($b - $d) : 0]
00753 }
00754 }
00755 g {
00756 if {[set odiff [expr 255 - ($g + $diff)]] >= 0} {
00757 incr g $diff
00758 } else {
00759 set d [expr abs($odiff) / 2]
00760 set g 255
00761 set r [expr (($r - $d) > 0) ? ($r - $d) : 0]
00762 set b [expr (($b - $d) > 0) ? ($b - $d) : 0]
00763 }
00764 }
00765 b {
00766 if {[set odiff [expr 255 - ($b + $diff)]] >= 0} {
00767 incr b $diff
00768 } else {
00769 set d [expr abs($odiff) / 2]
00770 set b 255
00771 set r [expr (($r - $d) > 0) ? ($r - $d) : 0]
00772 set g [expr (($g - $d) > 0) ? ($g - $d) : 0]
00773 }
00774 }
00775 }
00776
00777 return [format {#%02x%02x%02x} $r $g $b]
00778
00779 }
00780
00781 ######################################################################
00782 # Returns the RGB color which is between the two specified colors.
00783 proc color_difference {color1 color2} {
00784
00785 lassign [color_to_rgb $color1] r1 g1 b1
00786 lassign [color_to_rgb $color2] r2 g2 b2
00787
00788 return [format {#%02x%02x%02x} [expr ($r1 + $r2) / 2] [expr ($g1 + $g2) / 2] [expr ($b1 + $b2) / 2]]
00789
00790 }
00791
00792 ######################################################################
00793 # Converts a character to its associated keysym. Note: Only printable
00794 # string values are supported.
00795 proc string_to_keysym {str} {
00796
00797 variable c2k_map
00798
00799 return [string map [array get c2k_map] $str]
00800
00801 }
00802
00803 ######################################################################
00804 # Convers a keysym to a character.
00805 proc sym2char {sym} {
00806
00807 variable c2k_map
00808
00809 set map_list [array get c2k_map]
00810
00811 if {[set index [lsearch -exact $map_list $sym]] != -1} {
00812 return [lindex $map_list [expr $index - 1]]
00813 } elseif {[string length $sym] == 1} {
00814 return $sym
00815 } else {
00816 return ""
00817 }
00818
00819 }
00820
00821 ######################################################################
00822 # Helper procedure for the egrep utility procedure. Performs the equivalent
00823 # of a POSIX egrep command with the given information.
00824 proc egrep_file {pattern fname context opts} {
00825
00826 set result ""
00827
00828 # If the file cannot be read, skip the file grep
00829 if {[catch { open $fname r } rc]} {
00830 return ""
00831 }
00832
00833 # Grab the file contents
00834 set lines [split [read $rc] \n]
00835 close $rc
00836
00837 # Initialize some variables
00838 set i 0
00839 set last_output -1
00840 set last_match -1
00841
00842 foreach line $lines {
00843 if {[regexp {*}$opts -- $pattern $line]} {
00844 if {($last_output != -1) && (($i - $last_output) < $context)} {
00845 set j [expr $last_output + 1]
00846 } else {
00847 append result "--\n--\n"
00848 set j [expr $i - $context]
00849 }
00850 foreach cline [lrange $lines $j [expr $i - 1]] {
00851 append result "$fname-[expr $j + 1]-$cline\n"
00852 incr j
00853 }
00854 append result "$fname:[expr $i + 1]:$line\n"
00855 set last_match $i
00856 set last_output $i
00857 } elseif {($last_match != -1) && (($i - $last_match) <= $context)} {
00858 append result "$fname-[expr $i + 1]-$line\n"
00859 set last_output $i
00860 }
00861 incr i
00862 }
00863
00864 return $result
00865
00866 }
00867
00868 ######################################################################
00869 # Takes a list of files and performs the equivalent of a POSIX egrep
00870 # with the given pattern, options and context information.
00871 proc egrep {pattern paths context opts} {
00872
00873 set result ""
00874
00875 foreach path $paths {
00876 append result [egrep_file $pattern $path $context $opts]
00877 }
00878
00879 return $result
00880
00881 }
00882
00883 ######################################################################
00884 # Returns true if the given filename is a binary file; otherwise,
00885 # returns false to indicate that the file is a text file. This code
00886 # is lifted from the fileutil::fileType procedure, but should perform
00887 # better since we are not interested in all of the file information.
00888 proc is_binary {fname} {
00889
00890 variable bin_rx
00891
00892 # Open the file for reading
00893 if {[catch { open $fname r } rc]} {
00894 return -code error "utils::is_binary: $rc"
00895 }
00896
00897 # Read the first 1024 bytes
00898 fconfigure $rc -translation binary -buffersize 1024 -buffering full
00899 set test [read $rc 1024]
00900 close $rc
00901
00902 # If the code segment contains any of the characters in bin_rx, indicate that it is a binary file
00903 return [regexp $bin_rx $test]
00904
00905 }
00906
00907 ######################################################################
00908 # Returns crlf, lf or cr to specify which EOL character was used for the
00909 # given file.
00910 proc get_eol_char {fname} {
00911
00912 variable eol_rx
00913
00914 if {[catch { open $fname r } rc]} {
00915 return -code error "utils::get_eol_char: $rc"
00916 }
00917
00918 # Read the first 1024 bytes
00919 fconfigure $rc -translation binary -buffersize 1024 -buffering full
00920 set test [read $rc 1024]
00921 close $rc
00922
00923 return [string map {\{ {} \} {} \r\n crlf \n lf \r cr} [regexp -inline $eol_rx $test]]
00924
00925 }
00926
00927 ######################################################################
00928 # Performs a glob command for files within the installation in
00929 # the given directory with the given pattern. Takes into account
00930 # whether we are running within freewrap or not.
00931 proc glob_install {path pattern {tails 0}} {
00932
00933 if {[namespace exists ::freewrap]} {
00934 if {$tails} {
00935 return [lmap item [zvfs::list [file join $path $pattern]] { file tail $item }]
00936 } else {
00937 return [zvfs::list [file join $path $pattern]]
00938 }
00939 } else {
00940 if {$tails} {
00941 return [glob -nocomplain -directory $path -tails $pattern]
00942 } else {
00943 return [glob -nocomplain -directory $path $pattern]
00944 }
00945 }
00946
00947 }
00948
00949 ######################################################################
00950 # Returns the full language name at the current insertion index.
00951 proc get_current_lang {txt} {
00952
00953 if {[set lang [ctext::getLang $txt insert]] eq ""} {
00954 set lang [syntax::get_language $txt]
00955 }
00956
00957 return $lang
00958
00959 }
00960
00961 ######################################################################
00962 # Centers the specified window on the screen.
00963 proc center_on_screen {win} {
00964
00965 set screenwidth [winfo screenwidth $win]
00966 set screenheight [winfo screenheight $win]
00967 set width [winfo width $win]
00968 set height [winfo height $win]
00969
00970 # Place the window in the middle of the screen
00971 wm geometry $win +[expr ($screenwidth / 2) - ($width / 2)]+[expr ($screenheight / 2) - ($height / 2)]
00972
00973 }
00974
00975 ######################################################################
00976 # Returns a list containing the character range of the basename within
00977 # the given filename.
00978 proc basename_range {fname} {
00979
00980 if {[regexp -indices "^.*([file tail $fname])\$" $fname -> range]} {
00981 return [list [lindex $range 0] [expr [lindex $range 1] + 1]]
00982 }
00983
00984 return [list]
00985
00986 }
00987
00988 ######################################################################
00989 # Returns a string giving the size of the given file using B, KB, MB, etc.
00990 proc get_file_size {fname} {
00991
00992 set size [file size $fname]
00993
00994 if {$size < 1024} {
00995 return "$size bytes"
00996 } elseif {$size < pow(1024, 2)} {
00997 return [format {%0.1f KB} [expr $size.0 / 1024]]
00998 } elseif {$size < pow(1024, 3)} {
00999 return [format {%0.1f MB} [expr $size.0 / pow(1024, 2)]]
01000 } else {
01001 return [format {%0.1f GB} [expr $size.0 / pow(1024, 3)]]
01002 }
01003
01004 }
01005
01006 ######################################################################
01007 # Returns the file permissions a string in the form of "rwxrwxrwx".
01008 proc get_file_permissions {fname} {
01009
01010 if {$::tcl_platform(platform) eq "windows"} {
01011
01012 append str [expr {[file readable $fname] ? "r" : "-"}]
01013 append str [expr {[file writable $fname] ? "w" : "-"}]
01014 append str [expr {[file executable $fname] ? "x" : "-"}]
01015 set str [string repeat $str 3]
01016
01017 } else {
01018
01019 array set perms [list 0 "---" 1 "--x" 2 "-w-" 3 "-wx" 4 "r--" 5 "r-x" 6 "rw-" 7 "rwx"]
01020 set perm [file attributes $fname -permissions]
01021 set str "$perms([string index $perm end-2])$perms([string index $perm end-1])$perms([string index $perm end])"
01022
01023 }
01024
01025 return [format "%s%s" [expr {[file isdirectory $fname] ? "d" : ""}] $str]
01026
01027 }
01028
01029 ######################################################################
01030 # Returns the owner of the given file.
01031 proc get_file_owner {fname} {
01032
01033 array set attrs [file attributes $fname]
01034
01035 return [expr {[info exists attrs(-owner)] ? $attrs(-owner) : ""}]
01036
01037 }
01038
01039 ######################################################################
01040 # Returns the group associated with the given file.
01041 proc get_file_group {fname} {
01042
01043 array set attrs [file attributes $fname]
01044
01045 return [expr {[info exists attrs(-group)] ? $attrs(-group) : ""}]
01046
01047 }
01048
01049 ######################################################################
01050 # Returns the given file count information. The value values for type
01051 # are:
01052 # - line (counts the number of lines in the file)
01053 # - word (counts the number of words in the file)
01054 # - char (counts the number of characters in the file)
01055 proc get_file_count {fname type} {
01056
01057 if {[file isfile $fname] && ![is_binary $fname]} {
01058
01059 # Open the file
01060 set rc [open $fname r]
01061 set contents [read $rc]
01062 close $rc
01063
01064 switch $type {
01065 line {
01066 return [expr [string length $contents] - [string length [string map {\n {}} $contents]]]
01067 }
01068 word {
01069 return [llength [string map {\{ {} \} {} \" {} \[ {} \] {}} $contents]]
01070 }
01071 char {
01072 return [string length $contents]
01073 }
01074 }
01075
01076 }
01077
01078 return ""
01079
01080 }
01081
01082 ######################################################################
01083 # Returns the specified checksum value in hexidecimal format. Supported
01084 # values for type include:
01085 # - md5
01086 # - sha1
01087 # - sha224
01088 # - sha256
01089 proc get_file_checksum {fname type} {
01090
01091 array set cmds {
01092 md5 ::md5::md5
01093 sha1 ::sha1::sha1
01094 sha224 ::sha2::sha224
01095 sha256 ::sha2::sha256
01096 }
01097
01098 if {[file isfile $fname] && [info exists cmds($type)]} {
01099 if {![catch { $cmds($type) -hex -file $fname } rc]} {
01100 return $rc
01101 }
01102 }
01103
01104 return ""
01105
01106 }
01107
01108 ######################################################################
01109 # Exports the given string to the given filename.
01110 proc export {str lang fname} {
01111
01112 # Perform any snippet substitutions
01113 set str [snippets::substitute $str $lang]
01114
01115 if {$lang eq "Markdown"} {
01116 set md [file join $::tke_dir lib ptwidgets1.2 common Markdown_1.0.1 Markdown.pl]
01117 set opts [list]
01118 if {[file extension $fname] ne ".xhtml"} {
01119 lappend opts "--html4tags"
01120 }
01121 if {[catch { file tempfile tfile } rc]} {
01122 return -code error $rc
01123 }
01124 puts $rc $str
01125 close $rc
01126 if {[catch { exec perl $md {*}$opts $tfile } str]} {
01127 file delete -force $tfile
01128 return -code error $str
01129 }
01130 file delete -force $tfile
01131 }
01132
01133 # Open the file for writing
01134 if {[catch { open $fname w } rc]} {
01135 return -code error $rc
01136 }
01137
01138 # Write and the close the file
01139 puts $rc $str
01140 close $rc
01141
01142 }
01143
01144 ######################################################################
01145 # Implements a do ... while style loop using Tcl syntax.
01146 proc dowhile {body cond} {
01147
01148 while {1} {
01149 uplevel $body
01150 if {![uplevel [linsert $cond 0 expr]]} {
01151 return 0
01152 }
01153 }
01154
01155 }
01156
01157 ######################################################################
01158 # Performs a word-by-word translation of the given string to title case
01159 # (ex. "The new PLANET" -> "The New Planet").
01160 proc str2titlecase {str} {
01161
01162 set start 0
01163 while {[regexp -indices -start $start -- {\S+} $str match]} {
01164 set str [string replace $str {*}$match [string totitle [string range $str {*}$match]]]
01165 set start [expr [lindex $match 1] + 1]
01166 }
01167
01168 return $str
01169
01170 }
01171
01172 ######################################################################
01173 # Recursively updates permissions starting at the given path such that
01174 # all directories will have a permission value of 700 and all files will
01175 # have a permission value of 600.
01176 proc update_permissions {path} {
01177
01178 if {[file isdirectory $path]} {
01179 catch { file attributes $path -permissions rwx------ }
01180 foreach item [glob -directory $path *] {
01181 update_permissions $item
01182 }
01183 } else {
01184 catch { file attributes $path -permissions rw------- }
01185 }
01186
01187 }
01188
01189 }
01190
01191 # We will override the mouse events defined within htmllib
01192 array unset HMevents
01193
01194 ######################################################################
01195 # Initializes the given text widget to render HTML via htmllib.
01196 proc HMinitialize {win} {
01197
01198 # Initialize the text widget to display HTML
01199 HMinit_win $win
01200
01201 # Set <ul> symbols
01202 HMset_state $win -symbols [string repeat \u2022\u2023\u25e6\u2043 5]
01203
01204 # Change the cursor when the mouse cursor enters/leaves a link
01205 $win tag bind link <Enter> [list $win configure -cursor [ttk::cursor link]]
01206 $win tag bind link <Leave> [list $win configure -cursor [ttk::cursor standard]]
01207
01208 }
01209
01210 ######################################################################
01211 # Handles the creation of an image.
01212 proc HMhandle_image {win handle src} {
01213
01214 variable animation_ids
01215
01216 # Initialize tfile to indicate that it was not used
01217 set tfile ""
01218
01219 # If the file is from the web, download it
01220 if {[string first "http" $src] == 0} {
01221 set tfile [file join / tmp tmp.[pid]]
01222 set outfl [open $tfile w]
01223 http::geturl $src -channel $outfl
01224 close $outfl
01225 set src $tfile
01226 }
01227
01228 # Load the GIF information
01229 set depth 0
01230 if {![catch { gifblock::gif.load blocks $tfile } rc]} {
01231 set depth [llength [set gc_blocks [lsearch -all [gifblock::gif.blocknames blocks] {Graphic Control}]]]
01232 }
01233
01234 # Create the image from the file
01235 if {$depth == 0} {
01236 if {[catch { image create photo -file $src } img_list]} {
01237 puts $::errorInfo
01238 return
01239 }
01240 } else {
01241 for {set i 0} {$i < $depth} {incr i} {
01242 if {![catch { image create photo -file $tfile -format "gif -index $i" } img]} {
01243 lappend img_list [list $img [expr [gifblock::gif.get blocks [lindex $gc_blocks $i] {delay time}] * 10]]
01244 }
01245 }
01246 }
01247
01248 # Delete the temporary file if set
01249 if {$tfile ne ""} {
01250 file delete $tfile
01251 }
01252
01253 # If this is an animated GIF, display the next image in the series after the given period of time
01254 if {[llength $img_list] > 1} {
01255 set animation_ids($handle) [after [lindex $img_list 0 1] [list specl::utils::HMcycle_image $handle 1 $img_list]]
01256 }
01257
01258 # Display the image
01259 HMgot_image $handle [lindex $img_list 0 0]
01260
01261 }
01262
01263 ######################################################################
01264 # Handles an animated GIF.
01265 proc HMcycle_image {handle pos img_list} {
01266
01267 variable animation_ids
01268
01269 if {[winfo exists $handle]} {
01270
01271 lassign [lindex $img_list $pos] img delay
01272
01273 # Display the image
01274 HMgot_image $handle $img
01275
01276 # Increment the position
01277 incr pos
01278 if {$pos >= [llength $img_list]} { set pos 0 }
01279
01280 # Cycle again
01281 set animation_ids($handle) [after $delay [list specl::utils::HMcycle_image $handle $pos $img_list]]
01282
01283 }
01284
01285 }
01286
01287 ######################################################################
01288 # Cancels all animations for the current window.
01289 proc HMcancel_animations {} {
01290
01291 variable animation_ids
01292
01293 # Cancel all of the outstanding IDs
01294 foreach {handle id} [array get animation_ids] {
01295 after cancel $id
01296 }
01297
01298 # Clear all of the IDs
01299 array unset animation_ids
01300
01301 }
01302
01303 # Handles a click on a link
01304 proc HMlink_callback {win href} {
01305
01306 utils::open_file_externally $href 1
01307
01308 }
01309
01310 # Handles an image
01311 proc HMset_image {win handle src} {
01312
01313 ::HMhandle_image $win $handle $src
01314
01315 }
01316