TKE  3.6
Advanced code editor for programmers
utils Namespace Reference

Functions

 stacktrace
 
 sym2code sym
 
 tablelist_configure w
 
 set_yscrollbar sb first last
 
 set_xscrollbar sb first last
 
 set_xignore sb value auto
 
 text_anchor w
 
 perform_substitutions str
 
 set_environment var_list
 
 is_url str
 
 test_url url
 
 download_url url
 
 open_file_externally fname ?in_background?
 
 relative_to targetfile currentpath
 
 get_default_foreground
 
 get_default_background
 
 color_to_rgb color
 
 get_complementary_mono_color color
 
 rgb_to_hsv r g b
 
 hsv_to_rgb h s v
 
 rgb_to_hsl r g b
 
 hsl_to_rgb h s l
 
 get_color_values color
 
 auto_adjust_color color diff ?mode?
 
 auto_mix_colors color type diff
 
 color_difference color1 color2
 
 string_to_keysym str
 
 sym2char sym
 
 egrep_file pattern fname context opts
 
 egrep pattern paths context opts
 
 is_binary fname
 
 get_eol_char fname
 
 glob_install path pattern ?tails?
 
 get_current_lang txt
 
 center_on_screen win
 
 basename_range fname
 
 get_file_size fname
 
 get_file_permissions fname
 
 get_file_owner fname
 
 get_file_group fname
 
 get_file_count fname type
 
 get_file_checksum fname type
 
 export str lang fname
 
 dowhile body cond
 
 str2titlecase str
 
 update_permissions path
 

Function Documentation

§ auto_adjust_color()

utils::auto_adjust_color   color diff ?mode?  

Definition at line 724 of file utils.tcl.

724  proc auto_adjust_color {color diff {mode "auto"}} {
725 
726  lassign [rgb_to_hsv {*}[color_to_rgb $color]] hue saturation value
727 
728  switch $mode {
729  "auto" { set value [expr ($value < 128) ? ($value + $diff) : ($value - $diff)]}
730  "manual" { set value [expr $value + $diff]}
731  }
732 
733  return [format {#%02x%02x%02x} {*}[hsv_to_rgb $hue $saturation $value]]
734 
735  }

§ auto_mix_colors()

utils::auto_mix_colors   color type diff  

Definition at line 739 of file utils.tcl.

739  proc auto_mix_colors {color type diff} {
740 
741  # Create the lighter version of the primary color
742  lassign [color_to_rgb $color] r g b
743 
744  switch $type {
745  r {
746  if {[set odiff [expr 255 - ($r + $diff)]] >= 0} {
747  incr r $diff
748  } else {
749  set d [expr abs($odiff) / 2]
750  set r 255
751  set g [expr (($g - $d) > 0) ? ($g - $d) : 0]
752  set b [expr (($b - $d) > 0) ? ($b - $d) : 0]
753  }
754  }
755  g {
756  if {[set odiff [expr 255 - ($g + $diff)]] >= 0} {
757  incr g $diff
758  } else {
759  set d [expr abs($odiff) / 2]
760  set g 255
761  set r [expr (($r - $d) > 0) ? ($r - $d) : 0]
762  set b [expr (($b - $d) > 0) ? ($b - $d) : 0]
763  }
764  }
765  b {
766  if {[set odiff [expr 255 - ($b + $diff)]] >= 0} {
767  incr b $diff
768  } else {
769  set d [expr abs($odiff) / 2]
770  set b 255
771  set r [expr (($r - $d) > 0) ? ($r - $d) : 0]
772  set g [expr (($g - $d) > 0) ? ($g - $d) : 0]
773  }
774  }
775  }
776 
777  return [format {#%02x%02x%02x} $r $g $b]
778 
779  }

§ basename_range()

utils::basename_range   fname  

Definition at line 978 of file utils.tcl.

978  proc basename_range {fname} {
979 
980  if {[regexp -indices "^.*([file tail $fname])\$" $fname -> range]} {
981  return [list [lindex $range 0] [expr [lindex $range 1] + 1]]
982  }
983 
984  return [list]
985 
986  }

§ center_on_screen()

utils::center_on_screen   win  

Definition at line 963 of file utils.tcl.

963  proc center_on_screen {win} {
964 
965  set screenwidth [winfo screenwidth $win]
966  set screenheight [winfo screenheight $win]
967  set width [winfo width $win]
968  set height [winfo height $win]
969 
970  # Place the window in the middle of the screen
971  wm geometry $win +[expr ($screenwidth / 2) - ($width / 2)]+[expr ($screenheight / 2) - ($height / 2)]
972 
973  }

§ color_difference()

utils::color_difference   color1 color2  

Definition at line 783 of file utils.tcl.

783  proc color_difference {color1 color2} {
784 
785  lassign [color_to_rgb $color1] r1 g1 b1
786  lassign [color_to_rgb $color2] r2 g2 b2
787 
788  return [format {#%02x%02x%02x} [expr ($r1 + $r2) / 2] [expr ($g1 + $g2) / 2] [expr ($b1 + $b2) / 2]]
789 
790  }

§ color_to_rgb()

utils::color_to_rgb   color  

Definition at line 526 of file utils.tcl.

526  proc color_to_rgb {color} {
527 
528  lassign [winfo rgb . $color] r g b
529 
530  return [list [expr $r >> 8] [expr $g >> 8] [expr $b >> 8]]
531 
532  }

§ dowhile()

utils::dowhile   body cond  

Definition at line 1146 of file utils.tcl.

1146  proc dowhile {body cond} {
1147 
1148  while {1} {
1149  uplevel $body
1150  if {![uplevel [linsert $cond 0 expr]]} {
1151  return 0
1152  }
1153  }
1154 
1155  }

§ download_url()

utils::download_url   url  

Definition at line 403 of file utils.tcl.

403  proc download_url {url} {
404 
405  # Get the URL type
406  if {![regexp {^(ftp|https?)://} $url -> type]} {
407  return ""
408  }
409 
410  # Create a temporary file that will store binary data
411  if {[catch { open [set fname [file tempfile]] w} rc]} {
412  return ""
413  }
414 
415  fconfigure $rc -encoding binary
416 
417  # Make sure that the proxy information is programmed correctly
418  http::config -proxyhost [preferences::get General/ProxyHost] -proxyport [preferences::get General/ProxyPort]
419 
420  # Attempt to open the URL
421  if {[catch { http::geturl $url -channel $rc} token]} {
422  close $rc
423  file delete -force $fname
424  return ""
425  }
426 
427  # Closes temporary file
428  close $rc
429 
430  # Check the return status
431  if {([http::status $token] eq "ok") && ([http::ncode $token] == 200)} {
432  http::cleanup $token
433  return $fname
434  } else {
435  http::cleanup $token
436  file delete -force $fname
437  return ""
438  }
439 
440  }

§ egrep()

utils::egrep   pattern paths context opts  

Definition at line 871 of file utils.tcl.

871  proc egrep {pattern paths context opts} {
872 
873  set result ""
874 
875  foreach path $paths {
876  append result [egrep_file $pattern $path $context $opts]
877  }
878 
879  return $result
880 
881  }

§ egrep_file()

utils::egrep_file   pattern fname context opts  

Definition at line 824 of file utils.tcl.

824  proc egrep_file {pattern fname context opts} {
825 
826  set result ""
827 
828  # If the file cannot be read, skip the file grep
829  if {[catch { open $fname r} rc]} {
830  return ""
831  }
832 
833  # Grab the file contents
834  set lines [split [read $rc] \n]
835  close $rc
836 
837  # Initialize some variables
838  set i 0
839  set last_output -1
840  set last_match -1
841 
842  foreach line $lines {
843  if {[regexp {*}$opts -- $pattern $line]} {
844  if {($last_output != -1) && (($i - $last_output) < $context)} {
845  set j [expr $last_output + 1]
846  } else {
847  append result "--\n--\n"
848  set j [expr $i - $context]
849  }
850  foreach cline [lrange $lines $j [expr $i - 1]] {
851  append result "$fname-[expr $j + 1]-$cline\n"
852  incr j
853  }
854  append result "$fname:[expr $i + 1]:$line\n"
855  set last_match $i
856  set last_output $i
857  } elseif {($last_match != -1) && (($i - $last_match) <= $context)} {
858  append result "$fname-[expr $i + 1]-$line\n"
859  set last_output $i
860  }
861  incr i
862  }
863 
864  return $result
865 
866  }

§ export()

utils::export   str lang fname  

Definition at line 1110 of file utils.tcl.

1110  proc export {str lang fname} {
1111 
1112  # Perform any snippet substitutions
1113  set str [snippets::substitute $str $lang]
1114 
1115  if {$lang eq "Markdown"} {
1116  set md [file join $::tke_dir lib ptwidgets1.2 common Markdown_1.0.1 Markdown.pl]
1117  set opts [list]
1118  if {[file extension $fname] ne ".xhtml"} {
1119  lappend opts "--html4tags"
1120  }
1121  if {[catch { file tempfile tfile} rc]} {
1122  return -code error $rc
1123  }
1124  puts $rc $str
1125  close $rc
1126  if {[catch { exec perl $md {*}$opts $tfile} str]} {
1127  file delete -force $tfile
1128  return -code error $str
1129  }
1130  file delete -force $tfile
1131  }
1132 
1133  # Open the file for writing
1134  if {[catch { open $fname w} rc]} {
1135  return -code error $rc
1136  }
1137 
1138  # Write and the close the file
1139  puts $rc $str
1140  close $rc
1141 
1142  }

§ get_color_values()

utils::get_color_values   color  

Definition at line 712 of file utils.tcl.

712  proc get_color_values {color} {
713 
714  lassign [rgb_to_hsv {*}[set rgb [color_to_rgb $color]]] hue saturation value
715 
716  return [list $value {*}$rgb [format "#%02x%02x%02x" {*}$rgb]]
717 
718  }

§ get_complementary_mono_color()

utils::get_complementary_mono_color   color  

Definition at line 538 of file utils.tcl.

538  proc get_complementary_mono_color {color} {
539 
540  lassign [color_to_rgb $color] r g b
541 
542  # Calculate lightness (adjust the blue value to get a better result)
543  set sorted [lsort -real [list $r $g [expr $b & 0xfc]]]
544 
545  return [expr {((([lindex $sorted 0] + [lindex $sorted 2]) / 2) < 127) ? "white" : "black"}]
546 
547  }

§ get_current_lang()

utils::get_current_lang   txt  

Definition at line 951 of file utils.tcl.

951  proc get_current_lang {txt} {
952 
953  if {[set lang [ctext::getLang $txt insert]] eq ""} {
954  set lang [syntax::get_language $txt]
955  }
956 
957  return $lang
958 
959  }

§ get_default_background()

utils::get_default_background

Definition at line 518 of file utils.tcl.

518  proc get_default_background {} {
519 
520  return [ttk::style configure "." -background]
521 
522  }

§ get_default_foreground()

utils::get_default_foreground

Definition at line 510 of file utils.tcl.

510  proc get_default_foreground {} {
511 
512  return [ttk::style configure "." -foreground]
513 
514  }

§ get_eol_char()

utils::get_eol_char   fname  

Definition at line 910 of file utils.tcl.

910  proc get_eol_char {fname} {
911 
912  variable eol_rx
913 
914  if {[catch { open $fname r} rc]} {
915  return -code error "utils::get_eol_char: $rc"
916  }
917 
918  # Read the first 1024 bytes
919  fconfigure $rc -translation binary -buffersize 1024 -buffering full
920  set test [read $rc 1024]
921  close $rc
922 
923  return [string map {\{ {} \} {} \r\n crlf \n lf \r cr} [regexp -inline $eol_rx $test]]
924 
925  }

§ get_file_checksum()

utils::get_file_checksum   fname type  

Definition at line 1089 of file utils.tcl.

1089  proc get_file_checksum {fname type} {
1090 
1091  array set cmds {
1092  md5 ::md5::md5
1093  sha1 ::sha1::sha1
1094  sha224 ::sha2::sha224
1095  sha256 ::sha2::sha256
1096  }
1097 
1098  if {[file isfile $fname] && [info exists cmds($type)]} {
1099  if {![catch { $cmds($type) -hex -file $fname} rc]} {
1100  return $rc
1101  }
1102  }
1103 
1104  return ""
1105 
1106  }

§ get_file_count()

utils::get_file_count   fname type  

Definition at line 1055 of file utils.tcl.

1055  proc get_file_count {fname type} {
1056 
1057  if {[file isfile $fname] && ![is_binary $fname]} {
1058 
1059  # Open the file
1060  set rc [open $fname r]
1061  set contents [read $rc]
1062  close $rc
1063 
1064  switch $type {
1065  line {
1066  return [expr [string length $contents] - [string length [string map {\n {}} $contents]]]
1067  }
1068  word {
1069  return [llength [string map {\{ {} \} {} \" {} \[ {} \] {}} $contents]]
1070  }
1071  char {
1072  return [string length $contents]
1073  }
1074  }
1075 
1076  }
1077 
1078  return ""
1079 
1080  }

§ get_file_group()

utils::get_file_group   fname  

Definition at line 1041 of file utils.tcl.

1041  proc get_file_group {fname} {
1042 
1043  array set attrs [file attributes $fname]
1044 
1045  return [expr {[info exists attrs(-group)] ? $attrs(-group) : ""}]
1046 
1047  }

§ get_file_owner()

utils::get_file_owner   fname  

Definition at line 1031 of file utils.tcl.

1031  proc get_file_owner {fname} {
1032 
1033  array set attrs [file attributes $fname]
1034 
1035  return [expr {[info exists attrs(-owner)] ? $attrs(-owner) : ""}]
1036 
1037  }

§ get_file_permissions()

utils::get_file_permissions   fname  

Definition at line 1008 of file utils.tcl.

1008  proc get_file_permissions {fname} {
1009 
1010  if {$::tcl_platform(platform) eq "windows"} {
1011 
1012  append str [expr {[file readable $fname] ? "r" : "-"}]
1013  append str [expr {[file writable $fname] ? "w" : "-"}]
1014  append str [expr {[file executable $fname] ? "x" : "-"}]
1015  set str [string repeat $str 3]
1016 
1017  } else {
1018 
1019  array set perms [list 0 "---" 1 "--x" 2 "-w-" 3 "-wx" 4 "r--" 5 "r-x" 6 "rw-" 7 "rwx"]
1020  set perm [file attributes $fname -permissions]
1021  set str "$perms([string index $perm end-2])$perms([string index $perm end-1])$perms([string index $perm end])"
1022 
1023  }
1024 
1025  return [format "%s%s" [expr {[file isdirectory $fname] ? "d" : ""}] $str]
1026 
1027  }

§ get_file_size()

utils::get_file_size   fname  

Definition at line 990 of file utils.tcl.

990  proc get_file_size {fname} {
991 
992  set size [file size $fname]
993 
994  if {$size < 1024} {
995  return "$size bytes"
996  } elseif {$size < pow(1024, 2)} {
997  return [format {%0.1f KB} [expr $size.0 / 1024]]
998  } elseif {$size < pow(1024, 3)} {
999  return [format {%0.1f MB} [expr $size.0 / pow(1024, 2)]]
1000  } else {
1001  return [format {%0.1f GB} [expr $size.0 / pow(1024, 3)]]
1002  }
1003 
1004  }

§ glob_install()

utils::glob_install   path pattern ?tails?  

Definition at line 931 of file utils.tcl.

931  proc glob_install {path pattern {tails 0}} {
932 
933  if {[namespace exists ::freewrap]} {
934  if {$tails} {
935  return [lmap item [zvfs::list [file join $path $pattern]] { file tail $item }]
936  } else {
937  return [zvfs::list [file join $path $pattern]]
938  }
939  } else {
940  if {$tails} {
941  return [glob -nocomplain -directory $path -tails $pattern]
942  } else {
943  return [glob -nocomplain -directory $path $pattern]
944  }
945  }
946 
947  }

§ hsl_to_rgb()

utils::hsl_to_rgb   h s l  

Definition at line 684 of file utils.tcl.

684  proc hsl_to_rgb {h s l} {
685 
686  set s [expr $s / 100.0]
687  set l [expr $l / 100.0]
688  set c [expr (1 - abs( (2 * $l) - 1 )) * $s]
689  set m [expr ($l - ($c / 2)) * 255]
690  set x [expr $c * (1 - abs( fmod( ($h / 60.0), 2 ) - 1))]
691 
692  if {$h < 60} {
693  lassign [list [expr ($c * 255) + $m] [expr ($x * 255) + $m] $m] r g b
694  } elseif {$h < 120} {
695  lassign [list [expr ($x * 255) + $m] [expr ($c * 255) + $m] $m] r g b
696  } elseif {$h < 180} {
697  lassign [list $m [expr ($c * 255) + $m] [expr ($x * 255) + $m]] r g b
698  } elseif {$h < 240} {
699  lassign [list $m [expr ($x * 255) + $m] [expr ($c * 255) + $m]] r g b
700  } elseif {$h < 300} {
701  lassign [list [expr ($x * 255) + $m] $m [expr ($c * 255) + $m]] r g b
702  } else {
703  lassign [list [expr ($c * 255) + $m] $m [expr ($x * 255) + $m]] r g b
704  }
705 
706  return [list [expr round( $r )] [expr round( $g )] [expr round( $b )]]
707 
708  }

§ hsv_to_rgb()

utils::hsv_to_rgb   h s v  

Definition at line 592 of file utils.tcl.

592  proc hsv_to_rgb {h s v} {
593 
594  set hi [expr { int( double($h) / 60 ) % 6 }]
595  set f [expr { double($h) / 60 - $hi }]
596  set s [expr { double($s)/255 }]
597  set v [expr { double($v)/255 }]
598  set p [expr { double($v) * (1 - $s) }]
599  set q [expr { double($v) * (1 - $f * $s) }]
600  set t [expr { double($v) * (1 - (1 - $f) * $s) }]
601 
602  switch -- $hi {
603  0 {
604  set r $v
605  set g $t
606  set b $p
607  }
608  1 {
609  set r $q
610  set g $v
611  set b $p
612  }
613  2 {
614  set r $p
615  set g $v
616  set b $t
617  }
618  3 {
619  set r $p
620  set g $q
621  set b $v
622  }
623  4 {
624  set r $t
625  set g $p
626  set b $v
627  }
628  5 {
629  set r $v
630  set g $p
631  set b $q
632  }
633  default {
634  error "Wrong hi value in hsv_to_rgb procedure! This should never happen!"
635  }
636  }
637 
638  set r [expr {round($r*255)}]
639  set g [expr {round($g*255)}]
640  set b [expr {round($b*255)}]
641 
642  return [list $r $g $b]
643 
644  }

§ is_binary()

utils::is_binary   fname  

Definition at line 888 of file utils.tcl.

888  proc is_binary {fname} {
889 
890  variable bin_rx
891 
892  # Open the file for reading
893  if {[catch { open $fname r} rc]} {
894  return -code error "utils::is_binary: $rc"
895  }
896 
897  # Read the first 1024 bytes
898  fconfigure $rc -translation binary -buffersize 1024 -buffering full
899  set test [read $rc 1024]
900  close $rc
901 
902  # If the code segment contains any of the characters in bin_rx, indicate that it is a binary file
903  return [regexp $bin_rx $test]
904 
905  }

§ is_url()

utils::is_url   str  

Definition at line 373 of file utils.tcl.

373  proc is_url {str} {
374 
375  return [regexp {^(([a-zA-Z0-9]+://)?[a-z0-9\-]+\.[a-z0-9\-\.]+(?:/|(?:/[a-zA-Z0-9!#\$%&'\*\+,\-\.:;=\?@\[\]_~]+)*))$} $str]
376 
377  }

§ open_file_externally()

utils::open_file_externally   fname ?in_background?  

Definition at line 446 of file utils.tcl.

446  proc open_file_externally {fname {in_background 0}} {
447 
448  set opts ""
449 
450  # If the file to be viewed is located in the installation file system in freewrap,
451  # unpack the file so that we can act on it via exec.
452  if {[namespace exists ::freewrap] && [zvfs::exists $fname]} {
453  set fname [freewrap::unpack $fname]
454  }
455 
456  switch -glob $::tcl_platform(os) {
457  Darwin {
458  if {$in_background} {
459  set opts "-g"
460  }
461  return [catch { exec open {*}$opts $fname}]
462  }
463  Linux* {
464  if {$in_background} {
465  return [catch { exec -ignorestderr xdg-open $fname &}]
466  } else {
467  return [catch { exec -ignorestderr xdg-open $fname}]
468  }
469  }
470  *Win* {
471  if {[string range $fname 0 3] eq "http"} {
472  return [catch { exec {*}[auto_execok start] {} $fname}]
473  } else {
474  return [catch { exec {*}[auto_execok start] {} [file nativename $fname]}]
475  }
476  }
477  }
478 
479  }

§ perform_substitutions()

utils::perform_substitutions   str  

Definition at line 342 of file utils.tcl.

342  proc perform_substitutions {str} {
343 
344  variable vars
345 
346  return [subst [regsub -all {\$([a-zA-Z0-9_]+)} $str {[expr {[info exists vars(\1)] ? $vars(\1) : {&}}]}]]
347 
348  }

§ relative_to()

utils::relative_to   targetfile currentpath  

Definition at line 484 of file utils.tcl.

484  proc relative_to {targetfile currentpath} {
485  set cc [file split [file normalize $currentpath]]
486  set tt [file split [file normalize $targetfile]]
487  if {![string equal [lindex $cc 0] [lindex $tt 0]]} {
488  return $targetfile
489  }
490  while {[string equal [lindex $cc 0] [lindex $tt 0]] && ([llength $cc] > 0)} {
491  # discard matching components from the front
492  set cc [lreplace $cc 0 0]
493  set tt [lreplace $tt 0 0]
494  }
495  set prefix ""
496  if {[llength $cc] == 0} {
497  # just the file name, so targetfile is lower down (or in same place)
498  set prefix "."
499  }
500  # step up the tree
501  for {set i 0} {$i < [llength $cc]} {incr i} {
502  append prefix " .."
503  }
504  # stick it all together (the eval is to flatten the targetfile list)
505  return [eval file join $prefix $tt]
506  }

§ rgb_to_hsl()

utils::rgb_to_hsl   r g b  

Definition at line 648 of file utils.tcl.

648  proc rgb_to_hsl {r g b} {
649 
650  set r [expr double($r) / 255]
651  set g [expr double($g) / 255]
652  set b [expr double($b) / 255]
653 
654  lassign [lsort -real [list $r $g $b]] m unused M
655  set C [expr $M - $m]
656 
657  # Calculate hue
658  if {$C == 0.0} {
659  set h 0
660  } elseif {$M == $r} {
661  set h [expr round( fmod( (($g - $b) / $C), 6.0 ) * 60 )]
662  } elseif {$M == $g} {
663  set h [expr round( ((($b - $r) / $C) + 2.0) * 60 )]
664  } else {
665  set h [expr round( ((($r - $g) / $C) + 4.0) * 60 )]
666  }
667 
668  # Calculate light
669  set l [expr ($M + $m) / 2]
670 
671  # Calculate saturation
672  if {$C == 0.0} {
673  set s 0
674  } else {
675  set s [expr $C / (1.0 - abs( (2 * $l) - 1 ))]
676  }
677 
678  return [list $h $s $l]
679 
680  }

§ rgb_to_hsv()

utils::rgb_to_hsv   r g b  

Definition at line 551 of file utils.tcl.

551  proc rgb_to_hsv {r g b} {
552 
553  set sorted [lsort -real [list $r $g $b]]
554  set temp [lindex $sorted 0]
555  set v [lindex $sorted 2]
556 
557  set bottom [expr {$v-$temp}]
558  if {$bottom == 0} {
559  set h 0
560  set s 0
561  set v $v
562  } else {
563  if {$v == $r} {
564  set top [expr {$g-$b}]
565  if {$g >= $b} {
566  set angle 0
567  } else {
568  set angle 360
569  }
570  } elseif {$v == $g} {
571  set top [expr {$b-$r}]
572  set angle 120
573  } elseif {$v == $b} {
574  set top [expr {$r-$g}]
575  set angle 240
576  }
577  set h [expr { round( 60 * ( double($top) / $bottom ) + $angle ) }]
578  }
579 
580  if {$v == 0} {
581  set s 0
582  } else {
583  set s [expr { round( 255 - 255 * ( double($temp) / $v ) ) }]
584  }
585 
586  return [list $h $s $v]
587 
588  }

§ set_environment()

utils::set_environment   var_list  

Definition at line 352 of file utils.tcl.

352  proc set_environment {var_list} {
353 
354  variable vars
355 
356  array unset vars
357 
358  # Pre-load the vars with the environment variables
359  array set vars [array get ::env]
360 
361  # Load the var_list into vars
362  foreach var_pair $var_list {
363  set vars([string toupper [lindex $var_pair 0]]) [perform_substitutions [lindex $var_pair 1]]
364  }
365 
366  # Set the environment
367  array set ::env [array get vars]
368 
369  }

§ set_xignore()

utils::set_xignore   sb value auto  

Definition at line 309 of file utils.tcl.

309  proc set_xignore {sb value auto} {
310 
311  variable xignore
312  variable xignore_id
313 
314  # Clear the after (if it exists)
315  if {[info exists xignore_id($sb)]} {
316  after cancel $xignore_id($sb)
317  unset xignore_id($sb)
318  }
319 
320  # Set the xignore value to the specified value
321  set xignore($sb) $value
322 
323  }

§ set_xscrollbar()

utils::set_xscrollbar   sb first last  

Definition at line 288 of file utils.tcl.

288  proc set_xscrollbar {sb first last} {
289 
290  variable xignore
291  variable xignore_id
292 
293  if {($first == 0) && ($last == 1)} {
294  grid remove $sb
295  set_xignore $sb 1 0
296  set xignore_id($sb) [after 1000 [list utils::set_xignore $sb 0 1]]
297  } else {
298  if {![info exists xignore($sb)] || !$xignore($sb)} {
299  grid $sb
300  $sb set $first $last
301  }
302  set_xignore $sb 0 0
303  }
304 
305  }

§ set_yscrollbar()

utils::set_yscrollbar   sb first last  

Definition at line 274 of file utils.tcl.

274  proc set_yscrollbar {sb first last} {
275 
276  # If everything is displayed, hide the scrollbar
277  if {($first == 0) && (($last == 1) || ($last == 0))} {
278  grid remove $sb
279  } else {
280  grid $sb
281  $sb set $first $last
282  }
283 
284  }

§ stacktrace()

utils::stacktrace

Definition at line 215 of file utils.tcl.

215  proc stacktrace {} {
216 
217  set stack "Stack trace:\n"
218 
219  catch {
220  for {set i 1} {$i < [info level]} {incr i} {
221  set lvl [info level -$i]
222  set pname [lindex $lvl 0]
223  if {[namespace which -command $pname] eq ""} {
224  for {set j [expr $i + 1]} {$j < [info level]} {incr j} {
225  if {[namespace which -command [lindex [info level -$j] 0]] ne ""} {
226  set pname "[namespace qualifiers [lindex [info level -$j] 0]]::$pname"
227  break
228  }
229  }
230  }
231  append stack [string repeat " " $i]$pname
232  foreach value [lrange $lvl 1 end] arg [info args $pname] {
233  if {$value eq ""} {
234  info default $pname $arg value
235  }
236  append stack " $arg='$value'"
237  }
238  append stack \n
239  }
240  }
241 
242  return $stack
243 
244  }

§ str2titlecase()

utils::str2titlecase   str  

Definition at line 1160 of file utils.tcl.

1160  proc str2titlecase {str} {
1161 
1162  set start 0
1163  while {[regexp -indices -start $start -- {\S+} $str match]} {
1164  set str [string replace $str {*}$match [string totitle [string range $str {*}$match]]]
1165  set start [expr [lindex $match 1] + 1]
1166  }
1167 
1168  return $str
1169 
1170  }

§ string_to_keysym()

utils::string_to_keysym   str  

Definition at line 795 of file utils.tcl.

795  proc string_to_keysym {str} {
796 
797  variable c2k_map
798 
799  return [string map [array get c2k_map] $str]
800 
801  }

§ sym2char()

utils::sym2char   sym  

Definition at line 805 of file utils.tcl.

805  proc sym2char {sym} {
806 
807  variable c2k_map
808 
809  set map_list [array get c2k_map]
810 
811  if {[set index [lsearch -exact $map_list $sym]] != -1} {
812  return [lindex $map_list [expr $index - 1]]
813  } elseif {[string length $sym] == 1} {
814  return $sym
815  } else {
816  return ""
817  }
818 
819  }

§ sym2code()

utils::sym2code   sym  

Definition at line 248 of file utils.tcl.

248  proc sym2code {sym} {
249 
250  variable code2sym
251 
252  set code2sym_list [array get code2sym]
253 
254  if {[set index [lsearch -exact $code2sym_list $sym]] != -1} {
255  return [lindex $code2sym_list [expr $index - 1]]
256  }
257 
258  }

§ tablelist_configure()

utils::tablelist_configure   w  

Definition at line 262 of file utils.tcl.

262  proc tablelist_configure {w} {
263 
264  variable tablelistopts
265 
266  foreach {key value} [array get tablelistopts] {
267  $w configure -$key $value
268  }
269 
270  }

§ test_url()

utils::test_url   url  

Definition at line 382 of file utils.tcl.

382  proc test_url {url} {
383 
384  # Attempt to open the URL
385  if {[catch { http::geturl $url -validate 1} token]} {
386  return 0
387  }
388 
389  # Check the return status
390  set retval [expr {([http::status $token] eq "ok") && ([http::ncode $token] == 200)}]
391 
392  # Cleanup the token
393  http::cleanup $token
394 
395  return $retval
396 
397  }

§ text_anchor()

utils::text_anchor   w  

Definition at line 327 of file utils.tcl.

327  proc text_anchor {w} {
328 
329  if {[info procs ::tk::TextAnchor] ne ""} {
330  return [::tk::TextAnchor $w]
331  } else {
332  return tk::anchor$w
333  }
334 
335  }

§ update_permissions()

utils::update_permissions   path  

Definition at line 1176 of file utils.tcl.

1176  proc update_permissions {path} {
1177 
1178  if {[file isdirectory $path]} {
1179  catch { file attributes $path -permissions rwx------}
1180  foreach item [glob -directory $path *] {
1181  update_permissions $item
1182  }
1183  } else {
1184  catch { file attributes $path -permissions rw-------}
1185  }
1186 
1187  }