1# report.tcl -- 2# 3# Implementation of report objects for Tcl. 4# 5# Copyright (c) 2001 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: report.tcl,v 1.8 2004/01/15 06:36:13 andreas_kupries Exp $ 11 12package require Tcl 8.2 13package provide report 0.3.1 14 15namespace eval ::report { 16 # Data storage in the report module 17 # ------------------------------- 18 # 19 # One namespace per object, containing 20 # 1) An array mapping from template codes to templates 21 # 2) An array mapping from template codes and columns to horizontal template items 22 # 3) An array mapping from template codes and columns to vertical template items 23 # 4) ... deleted, local to formatting 24 # 5) An array mapping from columns to left padding 25 # 6) An array mapping from columns to right padding 26 # 7) An array mapping from columns to column size 27 # 8) An array mapping from columns to justification 28 # 9) A scalar containing the number of columns in the report. 29 # 10) An array mapping from template codes to enabledness 30 # 11) A scalar containing the size of the top caption 31 # 12) A scalar containing the size of the bottom caption 32 # 33 # 1 - template 5 - lpad 9 - columns 34 # 2 - hTemplate 6 - rpad 10 - enabled 35 # 3 - vTemplate 7 - csize 11 - tcaption 36 # 4 - fullHTemplate 8 - cjust 12 - bcaption 37 38 # commands is the list of subcommands recognized by the report 39 variable commands [list \ 40 "bcaption" \ 41 "botcapsep" \ 42 "botdata" \ 43 "botdatasep" \ 44 "bottom" \ 45 "columns" \ 46 "data" \ 47 "datasep" \ 48 "justify" \ 49 "pad" \ 50 "printmatrix" \ 51 "printmatrix2channel" \ 52 "size" \ 53 "sizes" \ 54 "tcaption" \ 55 "top" \ 56 "topcapsep" \ 57 "topdata" \ 58 "topdatasep" 59 ] 60 61 # Only export the toplevel commands 62 namespace export report defstyle rmstyle stylearguments stylebody 63 64 # Global data, style definitions 65 66 variable styles [list plain] 67 variable styleargs 68 variable stylebody 69 70 array set styleargs {plain {}} 71 array set stylebody {plain {}} 72 73 # Global data, template codes, for easy checking 74 75 variable tcode 76 array set tcode { 77 topdata 0 data 0 78 botdata 0 top 1 79 topdatasep 1 topcapsep 1 80 datasep 1 botcapsep 1 81 botdatasep 1 bottom 1 82 } 83} 84 85# ::report::report -- 86# 87# Create a new report with a given name 88# 89# Arguments: 90# name Optional name of the report; if null or not given, generate one. 91# 92# Results: 93# name Name of the report created 94 95proc ::report::report {name columns args} { 96 variable styleargs 97 98 if { [llength [info commands ::$name]] } { 99 error "command \"$name\" already exists, unable to create report" 100 } 101 if {![string is integer $columns]} { 102 return -code error "columns: expected integer greater than zero, got \"$columns\"" 103 } elseif {$columns <= 0} { 104 return -code error "columns: expected integer greater than zero, got \"$columns\"" 105 } 106 107 set styleName "" 108 switch -exact -- [llength $args] { 109 0 {# No style was specied. This is OK} 110 1 { 111 # We possibly got the "style" keyword, but everything behind is missing 112 return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??" 113 } 114 default { 115 # Break tail apart, check for correct keyword, ensure that style is known too. 116 # Don't forget to check the actual against the formal arguments. 117 118 foreach {dummy styleName} $args break 119 set args [lrange $args 2 end] 120 121 if {![string equal $dummy style]} { 122 return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??" 123 } 124 if {![info exists styleargs($styleName)]} { 125 return -code error "style \"$styleName\" is not known" 126 } 127 CheckStyleArguments $styleName $args 128 } 129 } 130 131 # The arguments seem to be ok, setup the namespace for the object 132 # and configure it to style "plain". 133 134 namespace eval ::report::report$name "variable columns $columns" 135 namespace eval ::report::report$name { 136 variable tcaption 0 137 variable bcaption 0 138 variable template 139 variable enabled 140 variable hTemplate 141 variable vTemplate 142 variable lpad 143 variable rpad 144 variable csize 145 variable cjust 146 147 variable t 148 variable i 149 variable dt [list] 150 variable st [list] 151 for {set i 0} {$i < $columns} {incr i} { 152 set lpad($i) "" 153 set rpad($i) "" 154 set csize($i) dyn 155 set cjust($i) left 156 lappend dt {} 157 lappend st {} {} 158 } 159 lappend dt {} 160 lappend st {} 161 162 foreach t { 163 topdata data botdata 164 } { 165 set enabled($t) 1 166 set template($t) $dt 167 for {set i 0} {$i <= $columns} {incr i} { 168 set vTemplate($t,$i) {} 169 } 170 } 171 foreach t { 172 top topdatasep topcapsep 173 datasep 174 botcapsep botdatasep bottom 175 } { 176 set enabled($t) 0 177 set template($t) $st 178 for {set i 0} {$i < $columns} {incr i} { 179 set hTemplate($t,$i) {} 180 } 181 for {set i 0} {$i <= $columns} {incr i} { 182 set vTemplate($t,$i) {} 183 } 184 } 185 186 unset t i dt st 187 } 188 189 # Create the command to manipulate the report 190 # $name -> ::report::ReportProc $name 191 interp alias {} ::$name {} ::report::ReportProc $name 192 193 # If a style was specified execute it now, before the oobject is 194 # handed back to the user. 195 196 if {$styleName != {}} { 197 ExecuteStyle $name $styleName $args 198 } 199 200 return $name 201} 202 203# ::report::defstyle -- 204# 205# Defines a new named style, with arguments and defining script. 206# 207# Arguments: 208# styleName Name of the new style. 209# arguments Formal arguments of the style, some format as for proc. 210# body The script actually defining the style. 211# 212# Results: 213# None. 214 215proc ::report::defstyle {styleName arguments body} { 216 variable styleargs 217 variable stylebody 218 variable styles 219 220 if {[info exists styleargs($styleName)]} { 221 return -code error "Cannot create style \"$styleName\", already exists" 222 } 223 224 # Check the formal arguments 225 # 1. Arguments without default may not follow an argument with a 226 # default. The special "args" is no exception! 227 # 2. Compute the minimal number of arguments required by the proc. 228 229 set min 0 230 set def 0 231 set ca 0 232 233 foreach v $arguments { 234 switch -- [llength $v] { 235 1 { 236 if {$def} { 237 return -code error \ 238 "Found argument without default after arguments having defaults" 239 } 240 incr min 241 } 242 2 { 243 set def 1 244 } 245 default { 246 error "Illegal length of value \"$v\"" 247 } 248 } 249 } 250 if {[string equal args [lindex $arguments end]]} { 251 # Correct requirements if we have a catch-all at the end. 252 incr min -1 253 set ca 1 254 } 255 256 # Now we are allowed to extend the internal database 257 258 set styleargs($styleName) [list $min $ca $arguments] 259 set stylebody($styleName) $body 260 lappend styles $styleName 261 return 262} 263 264# ::report::rmstyle -- 265# 266# Deletes the specified style. 267# 268# Arguments: 269# styleName Name of the style to destroy. 270# 271# Results: 272# None. 273 274proc ::report::rmstyle {styleName} { 275 variable styleargs 276 variable stylebody 277 variable styles 278 279 if {![info exists styleargs($styleName)]} { 280 return -code error "cannot delete unknown style \"$styleName\"" 281 } 282 if {[string equal $styleName plain]} { 283 return -code error {cannot delete builtin style "plain"} 284 } 285 286 unset styleargs($styleName) 287 unset stylebody($styleName) 288 289 set pos [lsearch -exact $styles $styleName] 290 set styles [lreplace $styles $pos $pos] 291 return 292} 293 294# ::report::_stylearguments -- 295# 296# Introspection, returns the list of formal arguments of the 297# specified style. 298# 299# Arguments: 300# styleName Name of the style to query. 301# 302# Results: 303# A list containing the formal argument of the style 304 305proc ::report::stylearguments {styleName} { 306 variable styleargs 307 if {![info exists styleargs($styleName)]} { 308 return -code error "style \"$styleName\" is not known" 309 } 310 return [lindex $styleargs($styleName) 2] 311} 312 313# ::report::_stylebody -- 314# 315# Introspection, returns the body/script of the 316# specified style. 317# 318# Arguments: 319# styleName Name of the style to query. 320# 321# Results: 322# A script, the body of the style. 323 324proc ::report::stylebody {styleName} { 325 variable stylebody 326 if {![info exists stylebody($styleName)]} { 327 return -code error "style \"$styleName\" is not known" 328 } 329 return $stylebody($styleName) 330} 331 332# ::report::_styles -- 333# 334# Returns alist containing the names of all known styles. 335# 336# Arguments: 337# None. 338# 339# Results: 340# A list containing the names of all known styles 341 342proc ::report::styles {} { 343 variable styles 344 return $styles 345} 346 347########################## 348# Private functions follow 349 350# ::report::CheckStyleArguments -- 351# 352# Internal helper. Used to check actual arguments of a style against the formal ones. 353# 354# Arguments: 355# styleName Name of the style in question 356# arguments Actual arguments for the style. 357# 358# Results: 359# None, or an error in case of problems. 360 361proc ::report::CheckStyleArguments {styleName arguments} { 362 variable styleargs 363 364 # Match formal and actual arguments, error out in case of problems. 365 foreach {min catchall formal} $styleargs($styleName) break 366 367 if {[llength $arguments] < $min} { 368 # Determine the name of the first formal parameter which did not get a value. 369 set firstmissing [lindex $formal [llength $arguments]] 370 return -code error "no value given for parameter \"$firstmissing\" to style \"$styleName\"" 371 } elseif {[llength $arguments] > $min} { 372 if {!$catchall && ([llength $arguments] > [llength $formal])} { 373 # More actual arguments than formals, without catch-all argument, error 374 return -code error "called style \"$styleName\" with too many arguments" 375 } 376 } 377} 378 379# ::report::ExecuteStyle -- 380# 381# Internal helper. Applies a named style to the specified report object. 382# 383# Arguments: 384# name Name of the report the style is applied to. 385# styleName Name of the style to apply 386# arguments Actual arguments for the style. 387# 388# Results: 389# None. 390 391proc ::report::ExecuteStyle {name styleName arguments} { 392 variable styleargs 393 variable stylebody 394 variable styles 395 variable commands 396 397 CheckStyleArguments $styleName $arguments 398 foreach {min catchall formal} $styleargs($styleName) break 399 400 array set a {} 401 402 if {([llength $arguments] > $min) && $catchall} { 403 # #min = number of formal arguments - 1 404 set a(args) [lrange $arguments $min end] 405 set formal [lrange $formal 0 end-1] 406 incr min -1 407 set arguments [lrange $arguments 0 $min] 408 409 # arguments and formal are now of equal length and we also 410 # know that there are no arguments having a default value. 411 foreach v $formal aval $arguments { 412 set a($v) $aval 413 } 414 } 415 416 # More arguments than minimally required, but no more than formal 417 # arguments! Proceed to standard matching: Go through the actual 418 # values and associate them with a formal argument. Then fill the 419 # remaining formal arguments with their default values. 420 421 foreach aval $arguments { 422 set v [lindex $formal 0] 423 set formal [lrange $formal 1 end] 424 if {[llength $v] > 1} {set v [lindex $v 0]} 425 set a($v) $aval 426 } 427 428 foreach vd $formal { 429 foreach {var default} $vd { 430 set a($var) $default 431 } 432 } 433 434 # Create and initialize a safe interpreter, execute the style and 435 # then break everything down again. 436 437 set ip [interp create -safe] 438 439 # -- Report methods -- 440 441 foreach m $commands { 442 # safe-ip method --> here report method 443 interp alias $ip $m {} $name $m 444 } 445 446 # -- Styles defined before this one -- 447 448 foreach s $styles { 449 if {[string equal $s $styleName]} {break} 450 interp alias $ip $s {} ::report::LinkExec $name $s 451 } 452 453 # -- Arguments as variables -- 454 455 foreach {var val} [array get a] { 456 $ip eval [list set $var $val] 457 } 458 459 # Finally execute / apply the style. 460 461 $ip eval $stylebody($styleName) 462 interp delete $ip 463 return 464} 465 466# ::report::_LinkExec -- 467# 468# Internal helper. Used for application of styles from within 469# another style script. Collects the formal arguments into the 470# one list which is expected by "ExecuteStyle". 471# 472# Arguments: 473# name Name of the report the style is applied to. 474# styleName Name of the style to apply 475# args Actual arguments for the style. 476# 477# Results: 478# None. 479 480proc ::report::LinkExec {name styleName args} { 481 ExecuteStyle $name $styleName $args 482} 483 484# ::report::ReportProc -- 485# 486# Command that processes all report object commands. 487# 488# Arguments: 489# name Name of the report object to manipulate. 490# cmd Subcommand to invoke. 491# args Arguments for subcommand. 492# 493# Results: 494# Varies based on command to perform 495 496proc ::report::ReportProc {name {cmd ""} args} { 497 variable tcode 498 499 # Do minimal args checks here 500 if { [llength [info level 0]] == 2 } { 501 error "wrong # args: should be \"$name option ?arg arg ...?\"" 502 } 503 504 # Split the args into command and args components 505 506 if {[info exists tcode($cmd)]} { 507 # Template codes are a bit special 508 eval [list ::report::_tAction $name $cmd] $args 509 } else { 510 if { [llength [info commands ::report::_$cmd]] == 0 } { 511 variable commands 512 set optlist [join $commands ", "] 513 set optlist [linsert $optlist "end-1" "or"] 514 error "bad option \"$cmd\": must be $optlist" 515 } 516 eval [list ::report::_$cmd $name] $args 517 } 518} 519 520# ::report::CheckColumn -- 521# 522# Helper to check and transform column indices. Returns the 523# absolute index number belonging to the specified 524# index. Rejects indices out of the valid range of columns. 525# 526# Arguments: 527# columns Number of columns 528# column The incoming index to check and transform 529# 530# Results: 531# The absolute index to the column 532 533proc ::report::CheckColumn {columns column} { 534 switch -regex -- $column { 535 {end-[0-9]+} { 536 regsub -- {end-} $column {} column 537 set cc [expr {$columns - 1 - $column}] 538 if {($cc < 0) || ($cc >= $columns)} { 539 return -code error "column: index \"end-$column\" out of range" 540 } 541 return $cc 542 } 543 end { 544 if {$columns <= 0} { 545 return -code error "column: index \"$column\" out of range" 546 } 547 return [expr {$columns - 1}] 548 } 549 {[0-9]+} { 550 if {($column < 0) || ($column >= $columns)} { 551 return -code error "column: index \"$column\" out of range" 552 } 553 return $column 554 } 555 default { 556 return -code error "column: syntax error in index \"$column\"" 557 } 558 } 559} 560 561# ::report::CheckVerticals -- 562# 563# Internal helper. Used to check the consistency of all active 564# templates with respect to the generated vertical separators 565# (Same length). 566# 567# Arguments: 568# name Name of the report object to check. 569# 570# Results: 571# None. 572 573proc ::report::CheckVerticals {name} { 574 upvar ::report::report${name}::vTemplate vTemplate 575 upvar ::report::report${name}::enabled enabled 576 upvar ::report::report${name}::columns columns 577 upvar ::report::report${name}::tcaption tcaption 578 upvar ::report::report${name}::bcaption bcaption 579 580 for {set c 0} {$c <= $columns} {incr c} { 581 # Collect all lengths for a column in a list, sort that and 582 # compare first against last element. If they are not equal we 583 # have found an inconsistent definition. 584 585 set res [list] 586 lappend res [string length $vTemplate(data,$c)] 587 588 if {$tcaption > 0} { 589 lappend res [string length $vTemplate(topdata,$c)] 590 if {($tcaption > 1) && $enabled(topdatasep)} { 591 lappend res [string length $vTemplate(topdatasep,$c)] 592 } 593 if {$enabled(topcapsep)} { 594 lappend res [string length $vTemplate(topcapsep,$c)] 595 } 596 } 597 if {$bcaption > 0} { 598 lappend res [string length $vTemplate(botdata,$c)] 599 if {($bcaption > 1) && $enabled(botdatasep)} { 600 lappend res [string length $vTemplate(botdatasep,$c)] 601 } 602 if {$enabled(botcapsep)} { 603 lappend res [string length $vTemplate(botcapsep,$c)] 604 } 605 } 606 foreach t {top datasep bottom} { 607 if {$enabled($t)} { 608 lappend res [string length $vTemplate($t,$c)] 609 } 610 } 611 612 set res [lsort $res] 613 614 if {[lindex $res 0] != [lindex $res end]} { 615 return -code error "inconsistent verticals in report" 616 } 617 } 618} 619 620# ::report::_tAction -- 621# 622# Implements the actions on templates (set, get, enable, disable, enabled) 623# 624# Arguments: 625# name Name of the report object. 626# template Name of the template to query or manipulate. 627# cmd The action applied to the template 628# args Additional arguments per action, see documentation. 629# 630# Results: 631# None. 632 633proc ::report::_tAction {name template cmd args} { 634 # When coming in here we know that $template contains a legal 635 # template code. No need to check again. We need 'tcode' 636 # nevertheless to distinguish between separator (1) and data 637 # templates (0). 638 639 variable tcode 640 641 switch -exact -- $cmd { 642 set { 643 if {[llength $args] != 1} { 644 return -code error "Wrong # args: $name $template $cmd template" 645 } 646 set templval [lindex $args 0] 647 648 upvar ::report::report${name}::columns columns 649 upvar ::report::report${name}::template tpl 650 upvar ::report::report${name}::hTemplate hTemplate 651 upvar ::report::report${name}::vTemplate vTemplate 652 upvar ::report::report${name}::enabled enabled 653 654 if {$tcode($template)} { 655 # Separator template, expected size = 2*colums+1 656 if {[llength $templval] > (2*$columns+1)} { 657 return -code error {template to long for number of columns in report} 658 } elseif {[llength $templval] < (2*$columns+1)} { 659 return -code error {template to short for number of columns in report} 660 } 661 662 set tpl($template) $templval 663 664 set even 1 665 set c1 0 666 set c2 0 667 foreach item $templval { 668 if {$even} { 669 set vTemplate($template,$c1) $item 670 incr c1 671 set even 0 672 } else { 673 set hTemplate($template,$c2) $item 674 incr c2 675 set even 1 676 } 677 } 678 } else { 679 # Data template, expected size = columns+1 680 if {[llength $templval] > ($columns+1)} { 681 return -code error {template to long for number of columns in report} 682 } elseif {[llength $templval] < ($columns+1)} { 683 return -code error {template to short for number of columns in report} 684 } 685 686 set tpl($template) $templval 687 688 set c 0 689 foreach item $templval { 690 set vTemplate($template,$c) $item 691 incr c 692 } 693 } 694 if {$enabled($template)} { 695 # Perform checks for active separator templates and 696 # all data templates. 697 CheckVerticals $name 698 } 699 } 700 get - 701 enable - 702 disable - 703 enabled { 704 if {[llength $args] > 0} { 705 return -code error "Wrong # args: $name $template $cmd" 706 } 707 switch -exact -- $cmd { 708 get { 709 upvar ::report::report${name}::template tpl 710 return $tpl($template) 711 } 712 enable { 713 if {!$tcode($template)} { 714 # Data template, can't be enabled. 715 return -code error "Cannot enable data template \"$template\"" 716 } 717 718 upvar ::report::report${name}::enabled enabled 719 720 if {!$enabled($template)} { 721 set enabled($template) 1 722 CheckVerticals $name 723 } 724 725 } 726 disable { 727 if {!$tcode($template)} { 728 # Data template, can't be disabled. 729 return -code error "Cannot disable data template \"$template\"" 730 } 731 732 upvar ::report::report${name}::enabled enabled 733 if {$enabled($template)} { 734 set enabled($template) 0 735 } 736 } 737 enabled { 738 if {!$tcode($template)} { 739 # Data template, can't be disabled. 740 return -code error "Cannot query state of data template \"$template\"" 741 } 742 743 upvar ::report::report${name}::enabled enabled 744 return $enabled($template) 745 } 746 default {error "Can't happen, panic, run, shout"} 747 } 748 } 749 default { 750 return -code error "Unknown template command \"$cmd\"" 751 } 752 } 753 return "" 754} 755 756# ::report::_tcaption -- 757# 758# Sets or queries the size of the top caption region of the report. 759# 760# Arguments: 761# name Name of the report object. 762# size The new size, if not empty. Emptiness indicates that a 763# query was requested 764# 765# Results: 766# None, or the current size of the top caption region 767 768proc ::report::_tcaption {name {size {}}} { 769 upvar ::report::report${name}::tcaption tcaption 770 771 if {$size == {}} { 772 return $tcaption 773 } 774 if {![string is integer $size]} { 775 return -code error "size: expected integer greater than or equal to zero, got \"$size\"" 776 } 777 if {$size < 0} { 778 return -code error "size: expected integer greater than or equal to zero, got \"$size\"" 779 } 780 if {$size == $tcaption} { 781 # No change, nothing to do 782 return "" 783 } 784 if {($size > 0) && ($tcaption == 0)} { 785 # Perform a consistency check after the assignment, the 786 # template might have been changed. 787 set tcaption $size 788 CheckVerticals $name 789 } else { 790 set tcaption $size 791 } 792 return "" 793} 794 795# ::report::_bcaption -- 796# 797# Sets or queries the size of the bottom caption region of the report. 798# 799# Arguments: 800# name Name of the report object. 801# size The new size, if not empty. Emptiness indicates that a 802# query was requested 803# 804# Results: 805# None, or the current size of the bottom caption region 806 807proc ::report::_bcaption {name {size {}}} { 808 upvar ::report::report${name}::bcaption bcaption 809 810 if {$size == {}} { 811 return $bcaption 812 } 813 if {![string is integer $size]} { 814 return -code error "size: expected integer greater than or equal to zero, got \"$size\"" 815 } 816 if {$size < 0} { 817 return -code error "size: expected integer greater than or equal to zero, got \"$size\"" 818 } 819 if {$size == $bcaption} { 820 # No change, nothing to do 821 return "" 822 } 823 if {($size > 0) && ($bcaption == 0)} { 824 # Perform a consistency check after the assignment, the 825 # template might have been changed. 826 set bcaption $size 827 CheckVerticals $name 828 } else { 829 set bcaption $size 830 } 831 return "" 832} 833 834# ::report::_size -- 835# 836# Sets or queries the size of the specified column. 837# 838# Arguments: 839# name Name of the report object. 840# column Index of the column to manipulate or query 841# size The new size, if not empty. Emptiness indicates that a 842# query was requested 843# 844# Results: 845# None, or the current size of the column 846 847proc ::report::_size {name column {size {}}} { 848 upvar ::report::report${name}::columns columns 849 upvar ::report::report${name}::csize csize 850 851 set column [CheckColumn $columns $column] 852 853 if {$size == {}} { 854 return $csize($column) 855 } 856 if {[string equal $size dyn]} { 857 set csize($column) $size 858 return "" 859 } 860 if {![string is integer $size]} { 861 return -code error "expected integer greater than zero, got \"$size\"" 862 } 863 if {$size <= 0} { 864 return -code error "expected integer greater than zero, got \"$size\"" 865 } 866 set csize($column) $size 867 return "" 868} 869 870# ::report::_sizes -- 871# 872# Sets or queries the sizes of all columns. 873# 874# Arguments: 875# name Name of the report object. 876# sizes The new sizes, if not empty. Emptiness indicates that a 877# query was requested 878# 879# Results: 880# None, or a list containing the sizes of all columns. 881 882proc ::report::_sizes {name {sizes {}}} { 883 upvar ::report::report${name}::columns columns 884 upvar ::report::report${name}::csize csize 885 886 if {$sizes == {}} { 887 set res [list] 888 foreach k [lsort -integer [array names csize]] { 889 lappend res $csize($k) 890 } 891 return $res 892 } 893 if {[llength $sizes] != $columns} { 894 return -code error "Wrong # number of column sizes" 895 } 896 foreach size $sizes { 897 if {[string equal $size dyn]} { 898 continue 899 } 900 if {![string is integer $size]} { 901 return -code error "expected integer greater than zero, got \"$size\"" 902 } 903 if {$size <= 0} { 904 return -code error "expected integer greater than zero, got \"$size\"" 905 } 906 } 907 908 set i 0 909 foreach s $sizes { 910 set csize($i) $s 911 incr i 912 } 913 return "" 914} 915 916# ::report::_pad -- 917# 918# Sets or queries the padding for the specified column. 919# 920# Arguments: 921# name Name of the report object. 922# column Index of the column to manipulate or query 923# where Where to place the padding. Emptiness indicates 924# that a query was requested. 925# 926# Results: 927# None, or the padding for the specified column. 928 929proc ::report::_pad {name column {where {}} {string { }}} { 930 upvar ::report::report${name}::columns columns 931 upvar ::report::report${name}::lpad lpad 932 upvar ::report::report${name}::rpad rpad 933 934 set column [CheckColumn $columns $column] 935 936 if {$where == {}} { 937 return [list $lpad($column) $rpad($column)] 938 } 939 940 switch -exact -- $where { 941 left { 942 set lpad($column) $string 943 } 944 right { 945 set rpad($column) $string 946 } 947 both { 948 set lpad($column) $string 949 set rpad($column) $string 950 } 951 default { 952 return -code error "where: expected left, right, or both, got \"$where\"" 953 } 954 } 955 return "" 956} 957 958# ::report::_justify -- 959# 960# Sets or queries the justification for the specified column. 961# 962# Arguments: 963# name Name of the report object. 964# column Index of the column to manipulate or query 965# jvalue Justification to set. Emptiness indicates 966# that a query was requested 967# 968# Results: 969# None, or the current justication for the specified column 970 971proc ::report::_justify {name column {jvalue {}}} { 972 upvar ::report::report${name}::columns columns 973 upvar ::report::report${name}::cjust cjust 974 975 set column [CheckColumn $columns $column] 976 977 if {$jvalue == {}} { 978 return $cjust($column) 979 } 980 switch -exact -- $jvalue { 981 left - right - center { 982 set cjust($column) $jvalue 983 return "" 984 } 985 default { 986 return -code error "justification: expected, left, right, or center, got \"$jvalue\"" 987 } 988 } 989} 990 991# ::report::_printmatrix -- 992# 993# Format the specified matrix according to the configuration of 994# the report. 995# 996# Arguments: 997# name Name of the report object. 998# matrix Name of the matrix object to format. 999# 1000# Results: 1001# A string containing the formatted matrix. 1002 1003proc ::report::_printmatrix {name matrix} { 1004 CheckMatrix $name $matrix 1005 ColumnSizes $name $matrix state 1006 1007 upvar ::report::report${name}::tcaption tcaption 1008 upvar ::report::report${name}::bcaption bcaption 1009 1010 set row 0 1011 set out "" 1012 append out [Separator top $name $matrix state] 1013 if {$tcaption > 0} { 1014 set n $tcaption 1015 while {$n > 0} { 1016 append out [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]] 1017 if {$n > 1} { 1018 append out [Separator topdatasep $name $matrix state] 1019 } 1020 incr n -1 1021 incr row 1022 } 1023 append out [Separator topcapsep $name $matrix state] 1024 } 1025 1026 set n [expr {[$matrix rows] - $bcaption}] 1027 1028 while {$row < $n} { 1029 append out [FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]] 1030 incr row 1031 if {$row < $n} { 1032 append out [Separator datasep $name $matrix state] 1033 } 1034 } 1035 1036 if {$bcaption > 0} { 1037 append out [Separator botcapsep $name $matrix state] 1038 set n $bcaption 1039 while {$n > 0} { 1040 append out [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]] 1041 if {$n > 1} { 1042 append out [Separator botdatasep $name $matrix state] 1043 } 1044 incr n -1 1045 incr row 1046 } 1047 } 1048 1049 append out [Separator bottom $name $matrix state] 1050 1051 #parray state 1052 return $out 1053} 1054 1055# ::report::_printmatrix2channel -- 1056# 1057# Format the specified matrix according to the configuration of 1058# the report. 1059# 1060# Arguments: 1061# name Name of the report. 1062# matrix Name of the matrix object to format. 1063# chan Handle of the channel to write the formatting result into. 1064# 1065# Results: 1066# None. 1067 1068proc ::report::_printmatrix2channel {name matrix chan} { 1069 CheckMatrix $name $matrix 1070 ColumnSizes $name $matrix state 1071 1072 upvar ::report::report${name}::tcaption tcaption 1073 upvar ::report::report${name}::bcaption bcaption 1074 1075 set row 0 1076 puts -nonewline $chan [Separator top $name $matrix state] 1077 if {$tcaption > 0} { 1078 set n $tcaption 1079 while {$n > 0} { 1080 puts -nonewline $chan \ 1081 [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]] 1082 if {$n > 1} { 1083 puts -nonewline $chan [Separator topdatasep $name $matrix state] 1084 } 1085 incr n -1 1086 incr row 1087 } 1088 puts -nonewline $chan [Separator topcapsep $name $matrix state] 1089 } 1090 1091 set n [expr {[$matrix rows] - $bcaption}] 1092 1093 while {$row < $n} { 1094 puts -nonewline $chan \ 1095 [FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]] 1096 incr row 1097 if {$row < $n} { 1098 puts -nonewline $chan [Separator datasep $name $matrix state] 1099 } 1100 } 1101 1102 if {$bcaption > 0} { 1103 puts -nonewline $chan [Separator botcapsep $name $matrix state] 1104 set n $bcaption 1105 while {$n > 0} { 1106 puts -nonewline $chan \ 1107 [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]] 1108 if {$n > 1} { 1109 puts -nonewline $chan [Separator botdatasep $name $matrix state] 1110 } 1111 incr n -1 1112 incr row 1113 } 1114 } 1115 1116 puts -nonewline $chan [Separator bottom $name $matrix state] 1117 return 1118} 1119 1120# ::report::_columns -- 1121# 1122# Retrieves the number of columns in the report. 1123# 1124# Arguments: 1125# name Name of the report queried 1126# 1127# Results: 1128# A number 1129 1130proc ::report::_columns {name} { 1131 upvar ::report::report${name}::columns columns 1132 return $columns 1133} 1134 1135# ::report::_destroy -- 1136# 1137# Destroy a report, including its associated command and data storage. 1138# 1139# Arguments: 1140# name Name of the report to destroy. 1141# 1142# Results: 1143# None. 1144 1145proc ::report::_destroy {name} { 1146 namespace delete ::report::report$name 1147 interp alias {} ::$name {} 1148 return 1149} 1150 1151# ::report::CheckMatrix -- 1152# 1153# Internal helper for the "print" methods. Checks that the 1154# supplied matrix can be formatted by the specified report. 1155# 1156# Arguments: 1157# name Name of the report to use for the formatting 1158# matrix Name of the matrix to format. 1159# 1160# Results: 1161# None, or an error in case of problems. 1162 1163proc ::report::CheckMatrix {name matrix} { 1164 upvar ::report::report${name}::columns columns 1165 upvar ::report::report${name}::tcaption tcaption 1166 upvar ::report::report${name}::bcaption bcaption 1167 1168 if {$columns != [$matrix columns]} { 1169 return -code error "report/matrix mismatch in number of columns" 1170 } 1171 if {($tcaption + $bcaption) > [$matrix rows]} { 1172 return -code error "matrix too small, top and bottom captions overlap" 1173 } 1174} 1175 1176# ::report::ColumnSizes -- 1177# 1178# Internal helper for the "print" methods. Computes the final 1179# column sizes (with and without padding) and stores them in 1180# the print-state 1181# 1182# Arguments: 1183# name Name of the report used for the formatting 1184# matrix Name of the matrix to format. 1185# statevar Name of the array variable holding the state 1186# of the formatter. 1187# 1188# Results: 1189# None. 1190 1191proc ::report::ColumnSizes {name matrix statevar} { 1192 # Calculate the final column sizes with and without padding and 1193 # store them in the local state. 1194 1195 upvar $statevar state 1196 1197 upvar ::report::report${name}::columns columns 1198 upvar ::report::report${name}::csize csize 1199 upvar ::report::report${name}::lpad lpad 1200 upvar ::report::report${name}::rpad rpad 1201 1202 for {set c 0} {$c < $columns} {incr c} { 1203 if {[string equal dyn $csize($c)]} { 1204 set size [$matrix columnwidth $c] 1205 } else { 1206 set size $csize($c) 1207 } 1208 1209 set state(s,$c) $size 1210 1211 incr size [string length $lpad($c)] 1212 incr size [string length $rpad($c)] 1213 1214 set state(s/pad,$c) $size 1215 } 1216 1217 return 1218} 1219 1220# ::report::Separator -- 1221# 1222# Internal helper for the "print" methods. Computes the final 1223# shape of the various separators using the column sizes with 1224# padding found in the print state. Uses also the print state as 1225# a cache to avoid costly recomputation for the separators which 1226# are used multiple times. 1227# 1228# Arguments: 1229# tcode Code of the separator to compute / template to use 1230# name Name of the report used for the formatting 1231# matrix Name of the matrix to format. 1232# statevar Name of the array variable holding the state 1233# of the formatter. 1234# 1235# Results: 1236# The final separator string. Empty for disabled separators. 1237 1238proc ::report::Separator {tcode name matrix statevar} { 1239 upvar ::report::report${name}::enabled e 1240 if {!$e($tcode)} {return ""} 1241 upvar $statevar state 1242 if {![info exists state($tcode)]} { 1243 upvar ::report::report${name}::vTemplate vt 1244 upvar ::report::report${name}::hTemplate ht 1245 upvar ::report::report${name}::columns cs 1246 set str "" 1247 for {set c 0} {$c < $cs} {incr c} { 1248 append str $vt($tcode,$c) 1249 set fill $ht($tcode,$c) 1250 set flen [string length $fill] 1251 set rep [expr {($state(s/pad,$c)/$flen)+1}] 1252 append str [string range [string repeat $fill $rep] 0 [expr {$state(s/pad,$c)-1}]] 1253 } 1254 append str $vt($tcode,$cs) 1255 set state($tcode) $str 1256 } 1257 return $state($tcode)\n 1258} 1259 1260# ::report::FormatData -- 1261# 1262# Internal helper for the "print" methods. Computes the output 1263# for one row in the matrix, given its values, the rowheight, 1264# padding and justification. 1265# 1266# Arguments: 1267# tcode Code of the data template to use 1268# name Name of the report used for the formatting 1269# statevar Name of the array variable holding the state 1270# of the formatter. 1271# line List containing the values to format 1272# rh Height of the row (line) in lines. 1273# 1274# Results: 1275# The formatted string for the supplied row. 1276 1277proc ::report::FormatData {tcode name statevar line rh} { 1278 upvar $statevar state 1279 upvar ::report::report${name}::vTemplate vt 1280 upvar ::report::report${name}::columns cs 1281 upvar ::report::report${name}::lpad lpad 1282 upvar ::report::report${name}::rpad rpad 1283 upvar ::report::report${name}::cjust cjust 1284 1285 if {$rh == 1} { 1286 set str "" 1287 set c 0 1288 foreach cell $line { 1289 # prefix, cell (pad-l, value, pad-r) 1290 append str $vt($tcode,$c)$lpad($c)[FormatCell $cell $state(s,$c) $cjust($c)]$rpad($c) 1291 incr c 1292 } 1293 append str $vt($tcode,$cs)\n 1294 return $str 1295 } else { 1296 array set str {} 1297 for {set l 1} {$l <= $rh} {incr l} {set str($l) ""} 1298 1299 # - Future - Vertical justification of cells less tall than rowheight 1300 # - Future - Vertical cutff aftert n lines, auto-repeat of captions 1301 # - Future - => Higher level, not here, use virtual matrices for this 1302 # - Future - and count the generated lines 1303 1304 set c 0 1305 foreach fcell $line { 1306 set fcell [split $fcell \n] 1307 for {set l 1; set lo 0} {$l <= $rh} {incr l; incr lo} { 1308 append str($l) $vt($tcode,$c)$lpad($c)[FormatCell \ 1309 [lindex $fcell $lo] $state(s,$c) $cjust($c)]$rpad($c) 1310 } 1311 incr c 1312 } 1313 set strout "" 1314 for {set l 1} {$l <= $rh} {incr l} { 1315 append strout $str($l)$vt($tcode,$cs)\n 1316 } 1317 return $strout 1318 } 1319} 1320 1321# ::report::FormatCell -- 1322# 1323# Internal helper for the "print" methods. Formats the value of 1324# a single cell according to column size and justification. 1325# 1326# Arguments: 1327# value The value to format 1328# size The size of the column, without padding 1329# just The justification for the current cell/column 1330# 1331# Results: 1332# The formatted string for the supplied cell. 1333 1334proc ::report::FormatCell {value size just} { 1335 set vlen [string length $value] 1336 1337 if {$vlen == $size} { 1338 # Value fits exactly, justification is irrelevant 1339 return $value 1340 } 1341 1342 # - Future - Other fill characters ... 1343 # - Future - Different fill characters per class of value => regex/glob pattern|functions 1344 # - Future - Wraparound - interacts with rowheight! 1345 1346 switch -exact -- $just { 1347 left { 1348 if {$vlen < $size} { 1349 return $value[string repeat " " [expr {$size - $vlen}]] 1350 } 1351 return [string range $value [expr {$vlen - $size}] end] 1352 } 1353 right { 1354 if {$vlen < $size} { 1355 return [string repeat " " [expr {$size - $vlen}]]$value 1356 } 1357 incr size -1 1358 return [string range $value 0 $size] 1359 } 1360 center { 1361 if {$vlen < $size} { 1362 set fill [expr {$size - $vlen}] 1363 set rfill [expr {$fill / 2}] 1364 set lfill [expr {$fill - $rfill}] 1365 return [string repeat " " $lfill]$value[string repeat " " $rfill] 1366 } 1367 1368 set cut [expr {$vlen - $size}] 1369 set lcut [expr {$cut / 2}] 1370 set rcut [expr {$cut - $lcut}] 1371 1372 return [string range $value $lcut end-$rcut] 1373 } 1374 default { 1375 error "Can't happen, panic, run, shout" 1376 } 1377 } 1378} 1379