home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / caynutil.tcl < prev    next >
Text File  |  1997-05-27  |  3KB  |  171 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1992-1997 by Cayenne Software, Inc.
  4. #
  5. # This software is furnished under a license and may be used only in
  6. # accordance with the terms of such license and with the inclusion of
  7. # the above copyright notice. This software or any other copies thereof
  8. # may not be provided or otherwise made available to any other person.
  9. # No title to and ownership of the software is hereby transferred.
  10. #
  11. # The information in this software is subject to change without notice
  12. # and should not be construed as a commitment by Cadre Technologies Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #    File        : @(#)caynutil.tcl    /main/hindenburg/2
  17. #    Original date    : Wed Aug  5 12:04:46 MET DST 1992
  18. #    Description    : Cayenne TCL utilities
  19. #              Basic utilities, should not use TCL procs defined
  20. #              in other files !!!
  21. #
  22. #---------------------------------------------------------------------------
  23. #
  24. # @(#)caynutil.tcl    /main/hindenburg/2    27 May 1997 Copyright 1992-1997 Cayenne Software, Inc.
  25. #
  26. #---------------------------------------------------------------------------
  27.  
  28. require cayn_msg.tcl
  29.  
  30. #
  31. # Procedure to reset the result to ""
  32. #
  33.  
  34. proc null {} {}
  35.  
  36. #
  37. # The Unix date command implemented in Tcl
  38. #
  39.  
  40. proc date {} {
  41.     return [fmtclock [getclock]]
  42. }
  43.  
  44. #
  45. # Return the name part of name.type
  46. #
  47.  
  48. proc nt_get_name {name} {
  49.     regsub {\.[^.]*$} $name "" name
  50.     return $name
  51. }
  52.  
  53. #
  54. # Return the type part of name.type
  55. #
  56.  
  57. proc nt_get_type {fullname} {
  58.     if {[regsub {.*\.} $fullname "" type]} {
  59.         return [get type]
  60.     }
  61.     return ""
  62. }
  63.  
  64. #
  65. # Print the contents of variable s on the standard output stream
  66. #
  67.  
  68. proc echo {s} {
  69.     puts stdout $s
  70. }
  71.  
  72. #
  73. # Print the contents of errorInfo on the standard output stream
  74. #
  75.  
  76. proc perror {} {
  77.     echo $errorInfo
  78. }
  79.  
  80. #
  81. # Read the contents from a file into a Tcl string
  82. #
  83.  
  84. proc read_file_into_text {path text} {
  85.     upvar $text txt
  86.  
  87.     if {![file exists $path]} {
  88.         m4_error $E_EXIST_FILE $path
  89.         return 0
  90.     }
  91.  
  92.     set fd [open $path "r"]
  93.     set txt [read $fd]
  94.     close $fd
  95.     return 1
  96. }
  97.  
  98. #
  99. # capitalize the first letter of a string
  100. #
  101.  
  102. proc cap {str} {
  103.     set ch [string toupper [string index $str 0]]
  104.     return "$ch[string range $str 1 end]"
  105. }
  106.  
  107. #
  108. # uncapitalize the first letter of a string
  109. #
  110.  
  111. proc uncap {str} {
  112.     set ch [string tolower [string index $str 0]]
  113.     return "$ch[string range $str 1 end]"
  114. }
  115.  
  116. #
  117. # Copy a file
  118. #
  119.  
  120. proc copy_text_file {from to} {
  121.     set max 8092
  122.     set in [open $from r]
  123.     set out [open $to w]
  124.  
  125.     while {[set result [read $in $max]] != ""} {
  126.         puts $out $result nonewline
  127.     }
  128.  
  129.     close $in
  130.     close $out
  131. }
  132.  
  133. #
  134. # Function to show proc invocations, activated using option "-trace"
  135. #
  136.  
  137. proc trace_call {call obj args} {
  138.     global tracing
  139.  
  140.     if {$tracing == 1} {
  141.         puts -nonewline "    >>> [$obj get_obj_type]::$call '"
  142.  
  143.         if [catch {puts -nonewline "[$obj getName]"}] {
  144.         puts -nonewline "<unnamed>"
  145.         }
  146.  
  147.         puts "' $args"
  148.     }
  149. }
  150.  
  151. #
  152. # Append one or more strings to the given list only if it was not
  153. # already present.  Has exactly the same calling interface as the builtin
  154. # 'lappend'.
  155. #
  156. # Returns the new list
  157. #
  158.  
  159. proc lappend_unique {l args} {
  160.     upvar $l list
  161.  
  162.     foreach s $args {
  163.         if {[lsearch -exact $list $s] == -1} {
  164.         lappend list $s
  165.         }
  166.     }
  167.  
  168.     return $list
  169. }
  170.  
  171.