home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / textutil / adjust.tcl next >
Encoding:
Text File  |  2001-08-17  |  6.2 KB  |  258 lines
  1. namespace eval ::textutil {
  2.  
  3.     namespace eval adjust {
  4.  
  5.     variable StrRepeat [ namespace parent ]::strRepeat
  6.     variable Justify  left
  7.     variable Length   72
  8.     variable FullLine 0
  9.     
  10.     namespace export adjust
  11.  
  12.     # This will be redefined later. We need it just to let
  13.     # a chance for the next import subcommand to work
  14.     #
  15.     proc adjust { text args } { }    
  16.  
  17.     }
  18.  
  19.     namespace import -force adjust::adjust
  20.     namespace export adjust
  21.  
  22. }
  23.  
  24. #########################################################################
  25.  
  26. proc ::textutil::adjust::adjust { text args } {
  27.         
  28.     if { [ string length [ string trim $text ] ] == 0 } then { 
  29.     return ""
  30.     }
  31.     
  32.     Configure $args
  33.     Adjust text newtext
  34.     
  35.     return $newtext
  36. }
  37.  
  38. proc ::textutil::adjust::Configure { args } {
  39.     variable Justify   left
  40.     variable Length    72
  41.     variable FullLine  0
  42.  
  43.     set args [ lindex $args 0 ]
  44.     foreach { option value } $args {
  45.     switch -exact -- $option {
  46.         -full {
  47.         if { ![ string is boolean -strict $value ] } then {
  48.             error "expected boolean but got \"$value\""
  49.         }
  50.         set FullLine [ string is true $value ]
  51.         }
  52.         -justify {
  53.         set lovalue [ string tolower $value ]
  54.         switch -exact -- $lovalue {
  55.             left -
  56.             right -
  57.             center -
  58.             plain {
  59.             set Justify $lovalue
  60.             }
  61.             default {
  62.             error "bad value \"$value\": should be center, left, plain or right"
  63.             }
  64.         }   
  65.         }
  66.         -length {
  67.         if { ![ string is integer $value ] } then {
  68.             error "expected positive integer but got \"$value\""
  69.         }
  70.         if { $value < 1 } then {
  71.             error "expected positive integer but got \"$value\""
  72.         }
  73.         set Length $value
  74.         }
  75.         default {
  76.         error "bad option \"$option\": must be -full, -justify or -length"
  77.         }
  78.     }
  79.     }
  80.  
  81.     return ""
  82. }
  83.  
  84. proc ::textutil::adjust::Adjust { varOrigName varNewName } {
  85.     variable Length
  86.  
  87.     upvar $varOrigName orig
  88.     upvar $varNewName  text
  89.  
  90.     regsub -all -- "(\n)|(\t)"     $orig  " "  text
  91.     regsub -all -- " +"            $text  " "  text
  92.     regsub -all -- "(^ *)|( *\$)"  $text  ""   text
  93.  
  94.     set ltext [ split $text ]
  95.     set line [ lindex $ltext 0 ]
  96.     set pos [ string length $line ]
  97.     set text ""
  98.     set numline 0
  99.     set numword 1
  100.     set words(0) 1
  101.     set words(1) [ list $pos $line ]
  102.  
  103.     foreach word [ lrange $ltext 1 end ] {
  104.         set size [ string length $word ]
  105.         if { ( $pos + $size ) < $Length } then {
  106.             append line " $word"
  107.         incr numword
  108.         incr words(0)
  109.         set words($numword) [ list $size $word ]
  110.             incr pos
  111.             incr pos $size
  112.         } else {
  113.             if { [ string length $text ] != 0 } then {
  114.                 append text "\n"
  115.             }
  116.             append text [ Justification $line [ incr numline ] words ]
  117.             set line "$word"
  118.             set pos $size
  119.         catch { unset words }
  120.         set numword 1
  121.         set words(0) 1
  122.         set words(1) [ list $size $word ]
  123.         }
  124.     }
  125.     if { [ string length $text ] != 0 } then {
  126.     append text "\n"
  127.     }
  128.     append text [ Justification $line end words ]
  129.     
  130.     return $text
  131. }
  132.  
  133. proc ::textutil::adjust::Justification { line index arrayName } {
  134.     variable Justify
  135.     variable Length
  136.     variable FullLine
  137.     variable StrRepeat
  138.  
  139.     upvar $arrayName words
  140.  
  141.     set len [ string length $line ]
  142.     if { $Length == $len } then {
  143.         return $line
  144.     }
  145.  
  146.     # Special case:
  147.     # for the last line, and if the justification is set to 'plain'
  148.     # the real justification is 'left' if the length of the line
  149.     # is less than 90% (rounded) of the max length allowed. This is
  150.     # to avoid expansion of this line when it is too small: without
  151.     # it, the added spaces will 'unbeautify' the result.
  152.     #
  153.  
  154.     set justify $Justify
  155.     if { ( "$index" == "end" ) && \
  156.          ( "$Justify" == "plain" ) && \
  157.          ( $len < round($Length * 0.90) ) } then {
  158.     set justify left
  159.     }
  160.  
  161.     # For a left justification, nothing to do, but to
  162.     # add some spaces at the end of the line if requested
  163.     #
  164.     
  165.     if { "$justify" == "left" } then {
  166.     set jus ""
  167.     if { $FullLine } then {
  168.         set jus [ $StrRepeat " " [ expr { $Length - $len } ] ]
  169.     }
  170.         return "${line}${jus}"
  171.     }
  172.  
  173.     # For a right justification, just add enough spaces
  174.     # at the beginning of the line
  175.     #
  176.  
  177.     if { "$justify" == "right" } then {
  178.     set jus [ $StrRepeat " " [ expr { $Length - $len } ] ]
  179.         return "${jus}${line}"
  180.     }
  181.  
  182.     # For a center justification, add half of the needed spaces
  183.     # at the beginning of the line, and the rest at the end
  184.     # only if needed.
  185.  
  186.     if { "$justify" == "center" } then {
  187.         set mr [ expr { ( $Length - $len ) / 2 } ]
  188.         set ml [ expr { $Length - $len - $mr } ]
  189.     set jusl [ $StrRepeat " " $ml ]
  190.     set jusr [ $StrRepeat " " $mr ]
  191.     if { $FullLine } then {
  192.         return "${jusl}${line}${jusr}"
  193.     } else {
  194.         return "${jusl}${line}"
  195.     }
  196.     }
  197.  
  198.     # For a plain justiciation, it's a little bit complex:
  199.     # if some spaces are missing, then
  200.     # sort the list of words in the current line by
  201.     # decreasing size
  202.     # foreach word, add one space before it, except if
  203.     # it's the first word, until enough spaces are added
  204.     # then rebuild the line
  205.     #
  206.  
  207.     if { "$justify" == "plain" } then {
  208.     set miss [ expr { $Length - [ string length $line ] } ]
  209.     if { $miss == 0 } then {
  210.         return "${line}"
  211.     }
  212.  
  213.     for { set i 1 } { $i < $words(0) } { incr i } {
  214.         lappend list [ eval list $i $words($i) 1 ]
  215.     }
  216.     lappend list [ eval list $i $words($words(0)) 0 ]
  217.     set list [ SortList $list decreasing 1 ]
  218.  
  219.     set i 0
  220.     while { $miss > 0 } {
  221.         set elem [ lindex $list $i ]
  222.         set nb [ lindex $elem 3 ]
  223.         incr nb
  224.         set elem [ lreplace $elem 3 3 $nb ]
  225.         set list [ lreplace $list $i $i $elem ]
  226.         incr miss -1
  227.         if { $i == $words(0) } then {
  228.         set i -1
  229.         }
  230.         incr i
  231.     }
  232.     set list [ SortList $list increasing 0 ]
  233.     set line ""
  234.     foreach elem $list {
  235.         set jus [ $StrRepeat " " [ lindex $elem 3 ] ]
  236.         set word [ lindex $elem 2 ]
  237.         if { [ lindex $elem 0 ] == $words(0) } then {
  238.         append line "${jus}${word}"
  239.         } else {
  240.         append line "${word}${jus}"
  241.         }
  242.     }
  243.  
  244.     return "${line}"
  245.     }
  246.  
  247.     error "Illegal justification key \"$justify\""
  248. }
  249.  
  250. proc ::textutil::adjust::SortList { list dir index } {
  251.  
  252.     if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then {
  253.     error "$sl"
  254.     }
  255.  
  256.     return $sl
  257. }
  258.