diff options
Diffstat (limited to 'tcllib/modules/report/report.tcl')
| -rw-r--r-- | tcllib/modules/report/report.tcl | 1386 |
1 files changed, 1386 insertions, 0 deletions
diff --git a/tcllib/modules/report/report.tcl b/tcllib/modules/report/report.tcl new file mode 100644 index 0000000..87a8f49 --- /dev/null +++ b/tcllib/modules/report/report.tcl @@ -0,0 +1,1386 @@ +# report.tcl -- +# +# Implementation of report objects for Tcl. +# +# Copyright (c) 2001-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: report.tcl,v 1.8 2004/01/15 06:36:13 andreas_kupries Exp $ + +package require Tcl 8.2 +package provide report 0.3.2 + +namespace eval ::report { + # Data storage in the report module + # ------------------------------- + # + # One namespace per object, containing + # 1) An array mapping from template codes to templates + # 2) An array mapping from template codes and columns to horizontal template items + # 3) An array mapping from template codes and columns to vertical template items + # 4) ... deleted, local to formatting + # 5) An array mapping from columns to left padding + # 6) An array mapping from columns to right padding + # 7) An array mapping from columns to column size + # 8) An array mapping from columns to justification + # 9) A scalar containing the number of columns in the report. + # 10) An array mapping from template codes to enabledness + # 11) A scalar containing the size of the top caption + # 12) A scalar containing the size of the bottom caption + # + # 1 - template 5 - lpad 9 - columns + # 2 - hTemplate 6 - rpad 10 - enabled + # 3 - vTemplate 7 - csize 11 - tcaption + # 4 - fullHTemplate 8 - cjust 12 - bcaption + + # commands is the list of subcommands recognized by the report + variable commands [list \ + "bcaption" \ + "botcapsep" \ + "botdata" \ + "botdatasep" \ + "bottom" \ + "columns" \ + "data" \ + "datasep" \ + "justify" \ + "pad" \ + "printmatrix" \ + "printmatrix2channel" \ + "size" \ + "sizes" \ + "tcaption" \ + "top" \ + "topcapsep" \ + "topdata" \ + "topdatasep" + ] + + # Only export the toplevel commands + namespace export report defstyle rmstyle stylearguments stylebody + + # Global data, style definitions + + variable styles [list plain] + variable styleargs + variable stylebody + + array set styleargs {plain {}} + array set stylebody {plain {}} + + # Global data, template codes, for easy checking + + variable tcode + array set tcode { + topdata 0 data 0 + botdata 0 top 1 + topdatasep 1 topcapsep 1 + datasep 1 botcapsep 1 + botdatasep 1 bottom 1 + } +} + +# ::report::report -- +# +# Create a new report with a given name +# +# Arguments: +# name Optional name of the report; if null or not given, generate one. +# +# Results: +# name Name of the report created + +proc ::report::report {name columns args} { + variable styleargs + + if { [llength [info commands ::$name]] } { + error "command \"$name\" already exists, unable to create report" + } + if {![string is integer $columns]} { + return -code error "columns: expected integer greater than zero, got \"$columns\"" + } elseif {$columns <= 0} { + return -code error "columns: expected integer greater than zero, got \"$columns\"" + } + + set styleName "" + switch -exact -- [llength $args] { + 0 {# No style was specied. This is OK} + 1 { + # We possibly got the "style" keyword, but everything behind is missing + return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??" + } + default { + # Break tail apart, check for correct keyword, ensure that style is known too. + # Don't forget to check the actual against the formal arguments. + + foreach {dummy styleName} $args break + set args [lrange $args 2 end] + + if {![string equal $dummy style]} { + return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??" + } + if {![info exists styleargs($styleName)]} { + return -code error "style \"$styleName\" is not known" + } + CheckStyleArguments $styleName $args + } + } + + # The arguments seem to be ok, setup the namespace for the object + # and configure it to style "plain". + + namespace eval ::report::report$name "variable columns $columns" + namespace eval ::report::report$name { + variable tcaption 0 + variable bcaption 0 + variable template + variable enabled + variable hTemplate + variable vTemplate + variable lpad + variable rpad + variable csize + variable cjust + + variable t + variable i + variable dt [list] + variable st [list] + for {set i 0} {$i < $columns} {incr i} { + set lpad($i) "" + set rpad($i) "" + set csize($i) dyn + set cjust($i) left + lappend dt {} + lappend st {} {} + } + lappend dt {} + lappend st {} + + foreach t { + topdata data botdata + } { + set enabled($t) 1 + set template($t) $dt + for {set i 0} {$i <= $columns} {incr i} { + set vTemplate($t,$i) {} + } + } + foreach t { + top topdatasep topcapsep + datasep + botcapsep botdatasep bottom + } { + set enabled($t) 0 + set template($t) $st + for {set i 0} {$i < $columns} {incr i} { + set hTemplate($t,$i) {} + } + for {set i 0} {$i <= $columns} {incr i} { + set vTemplate($t,$i) {} + } + } + + unset t i dt st + } + + # Create the command to manipulate the report + # $name -> ::report::ReportProc $name + interp alias {} ::$name {} ::report::ReportProc $name + + # If a style was specified execute it now, before the oobject is + # handed back to the user. + + if {$styleName != {}} { + ExecuteStyle $name $styleName $args + } + + return $name +} + +# ::report::defstyle -- +# +# Defines a new named style, with arguments and defining script. +# +# Arguments: +# styleName Name of the new style. +# arguments Formal arguments of the style, some format as for proc. +# body The script actually defining the style. +# +# Results: +# None. + +proc ::report::defstyle {styleName arguments body} { + variable styleargs + variable stylebody + variable styles + + if {[info exists styleargs($styleName)]} { + return -code error "Cannot create style \"$styleName\", already exists" + } + + # Check the formal arguments + # 1. Arguments without default may not follow an argument with a + # default. The special "args" is no exception! + # 2. Compute the minimal number of arguments required by the proc. + + set min 0 + set def 0 + set ca 0 + + foreach v $arguments { + switch -- [llength $v] { + 1 { + if {$def} { + return -code error \ + "Found argument without default after arguments having defaults" + } + incr min + } + 2 { + set def 1 + } + default { + error "Illegal length of value \"$v\"" + } + } + } + if {[string equal args [lindex $arguments end]]} { + # Correct requirements if we have a catch-all at the end. + incr min -1 + set ca 1 + } + + # Now we are allowed to extend the internal database + + set styleargs($styleName) [list $min $ca $arguments] + set stylebody($styleName) $body + lappend styles $styleName + return +} + +# ::report::rmstyle -- +# +# Deletes the specified style. +# +# Arguments: +# styleName Name of the style to destroy. +# +# Results: +# None. + +proc ::report::rmstyle {styleName} { + variable styleargs + variable stylebody + variable styles + + if {![info exists styleargs($styleName)]} { + return -code error "cannot delete unknown style \"$styleName\"" + } + if {[string equal $styleName plain]} { + return -code error {cannot delete builtin style "plain"} + } + + unset styleargs($styleName) + unset stylebody($styleName) + + set pos [lsearch -exact $styles $styleName] + set styles [lreplace $styles $pos $pos] + return +} + +# ::report::_stylearguments -- +# +# Introspection, returns the list of formal arguments of the +# specified style. +# +# Arguments: +# styleName Name of the style to query. +# +# Results: +# A list containing the formal argument of the style + +proc ::report::stylearguments {styleName} { + variable styleargs + if {![info exists styleargs($styleName)]} { + return -code error "style \"$styleName\" is not known" + } + return [lindex $styleargs($styleName) 2] +} + +# ::report::_stylebody -- +# +# Introspection, returns the body/script of the +# specified style. +# +# Arguments: +# styleName Name of the style to query. +# +# Results: +# A script, the body of the style. + +proc ::report::stylebody {styleName} { + variable stylebody + if {![info exists stylebody($styleName)]} { + return -code error "style \"$styleName\" is not known" + } + return $stylebody($styleName) +} + +# ::report::_styles -- +# +# Returns alist containing the names of all known styles. +# +# Arguments: +# None. +# +# Results: +# A list containing the names of all known styles + +proc ::report::styles {} { + variable styles + return $styles +} + +########################## +# Private functions follow + +# ::report::CheckStyleArguments -- +# +# Internal helper. Used to check actual arguments of a style against the formal ones. +# +# Arguments: +# styleName Name of the style in question +# arguments Actual arguments for the style. +# +# Results: +# None, or an error in case of problems. + +proc ::report::CheckStyleArguments {styleName arguments} { + variable styleargs + + # Match formal and actual arguments, error out in case of problems. + foreach {min catchall formal} $styleargs($styleName) break + + if {[llength $arguments] < $min} { + # Determine the name of the first formal parameter which did not get a value. + set firstmissing [lindex $formal [llength $arguments]] + return -code error "no value given for parameter \"$firstmissing\" to style \"$styleName\"" + } elseif {[llength $arguments] > $min} { + if {!$catchall && ([llength $arguments] > [llength $formal])} { + # More actual arguments than formals, without catch-all argument, error + return -code error "called style \"$styleName\" with too many arguments" + } + } +} + +# ::report::ExecuteStyle -- +# +# Internal helper. Applies a named style to the specified report object. +# +# Arguments: +# name Name of the report the style is applied to. +# styleName Name of the style to apply +# arguments Actual arguments for the style. +# +# Results: +# None. + +proc ::report::ExecuteStyle {name styleName arguments} { + variable styleargs + variable stylebody + variable styles + variable commands + + CheckStyleArguments $styleName $arguments + foreach {min catchall formal} $styleargs($styleName) break + + array set a {} + + if {([llength $arguments] > $min) && $catchall} { + # #min = number of formal arguments - 1 + set a(args) [lrange $arguments $min end] + set formal [lrange $formal 0 end-1] + incr min -1 + set arguments [lrange $arguments 0 $min] + + # arguments and formal are now of equal length and we also + # know that there are no arguments having a default value. + foreach v $formal aval $arguments { + set a($v) $aval + } + } + + # More arguments than minimally required, but no more than formal + # arguments! Proceed to standard matching: Go through the actual + # values and associate them with a formal argument. Then fill the + # remaining formal arguments with their default values. + + foreach aval $arguments { + set v [lindex $formal 0] + set formal [lrange $formal 1 end] + if {[llength $v] > 1} {set v [lindex $v 0]} + set a($v) $aval + } + + foreach vd $formal { + foreach {var default} $vd { + set a($var) $default + } + } + + # Create and initialize a safe interpreter, execute the style and + # then break everything down again. + + set ip [interp create -safe] + + # -- Report methods -- + + foreach m $commands { + # safe-ip method --> here report method + interp alias $ip $m {} $name $m + } + + # -- Styles defined before this one -- + + foreach s $styles { + if {[string equal $s $styleName]} {break} + interp alias $ip $s {} ::report::LinkExec $name $s + } + + # -- Arguments as variables -- + + foreach {var val} [array get a] { + $ip eval [list set $var $val] + } + + # Finally execute / apply the style. + + $ip eval $stylebody($styleName) + interp delete $ip + return +} + +# ::report::_LinkExec -- +# +# Internal helper. Used for application of styles from within +# another style script. Collects the formal arguments into the +# one list which is expected by "ExecuteStyle". +# +# Arguments: +# name Name of the report the style is applied to. +# styleName Name of the style to apply +# args Actual arguments for the style. +# +# Results: +# None. + +proc ::report::LinkExec {name styleName args} { + ExecuteStyle $name $styleName $args +} + +# ::report::ReportProc -- +# +# Command that processes all report object commands. +# +# Arguments: +# name Name of the report object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::report::ReportProc {name {cmd ""} args} { + variable tcode + + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + + if {[info exists tcode($cmd)]} { + # Template codes are a bit special + eval [list ::report::_tAction $name $cmd] $args + } else { + if { [llength [info commands ::report::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + eval [list ::report::_$cmd $name] $args + } +} + +# ::report::CheckColumn -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns. +# +# Arguments: +# columns Number of columns +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::report::CheckColumn {columns column} { + switch -regex -- $column { + {end-[0-9]+} { + regsub -- {end-} $column {} column + set cc [expr {$columns - 1 - $column}] + if {($cc < 0) || ($cc >= $columns)} { + return -code error "column: index \"end-$column\" out of range" + } + return $cc + } + end { + if {$columns <= 0} { + return -code error "column: index \"$column\" out of range" + } + return [expr {$columns - 1}] + } + {[0-9]+} { + if {($column < 0) || ($column >= $columns)} { + return -code error "column: index \"$column\" out of range" + } + return $column + } + default { + return -code error "column: syntax error in index \"$column\"" + } + } +} + +# ::report::CheckVerticals -- +# +# Internal helper. Used to check the consistency of all active +# templates with respect to the generated vertical separators +# (Same length). +# +# Arguments: +# name Name of the report object to check. +# +# Results: +# None. + +proc ::report::CheckVerticals {name} { + upvar ::report::report${name}::vTemplate vTemplate + upvar ::report::report${name}::enabled enabled + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::tcaption tcaption + upvar ::report::report${name}::bcaption bcaption + + for {set c 0} {$c <= $columns} {incr c} { + # Collect all lengths for a column in a list, sort that and + # compare first against last element. If they are not equal we + # have found an inconsistent definition. + + set res [list] + lappend res [string length $vTemplate(data,$c)] + + if {$tcaption > 0} { + lappend res [string length $vTemplate(topdata,$c)] + if {($tcaption > 1) && $enabled(topdatasep)} { + lappend res [string length $vTemplate(topdatasep,$c)] + } + if {$enabled(topcapsep)} { + lappend res [string length $vTemplate(topcapsep,$c)] + } + } + if {$bcaption > 0} { + lappend res [string length $vTemplate(botdata,$c)] + if {($bcaption > 1) && $enabled(botdatasep)} { + lappend res [string length $vTemplate(botdatasep,$c)] + } + if {$enabled(botcapsep)} { + lappend res [string length $vTemplate(botcapsep,$c)] + } + } + foreach t {top datasep bottom} { + if {$enabled($t)} { + lappend res [string length $vTemplate($t,$c)] + } + } + + set res [lsort $res] + + if {[lindex $res 0] != [lindex $res end]} { + return -code error "inconsistent verticals in report" + } + } +} + +# ::report::_tAction -- +# +# Implements the actions on templates (set, get, enable, disable, enabled) +# +# Arguments: +# name Name of the report object. +# template Name of the template to query or manipulate. +# cmd The action applied to the template +# args Additional arguments per action, see documentation. +# +# Results: +# None. + +proc ::report::_tAction {name template cmd args} { + # When coming in here we know that $template contains a legal + # template code. No need to check again. We need 'tcode' + # nevertheless to distinguish between separator (1) and data + # templates (0). + + variable tcode + + switch -exact -- $cmd { + set { + if {[llength $args] != 1} { + return -code error "Wrong # args: $name $template $cmd template" + } + set templval [lindex $args 0] + + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::template tpl + upvar ::report::report${name}::hTemplate hTemplate + upvar ::report::report${name}::vTemplate vTemplate + upvar ::report::report${name}::enabled enabled + + if {$tcode($template)} { + # Separator template, expected size = 2*colums+1 + if {[llength $templval] > (2*$columns+1)} { + return -code error {template to long for number of columns in report} + } elseif {[llength $templval] < (2*$columns+1)} { + return -code error {template to short for number of columns in report} + } + + set tpl($template) $templval + + set even 1 + set c1 0 + set c2 0 + foreach item $templval { + if {$even} { + set vTemplate($template,$c1) $item + incr c1 + set even 0 + } else { + set hTemplate($template,$c2) $item + incr c2 + set even 1 + } + } + } else { + # Data template, expected size = columns+1 + if {[llength $templval] > ($columns+1)} { + return -code error {template to long for number of columns in report} + } elseif {[llength $templval] < ($columns+1)} { + return -code error {template to short for number of columns in report} + } + + set tpl($template) $templval + + set c 0 + foreach item $templval { + set vTemplate($template,$c) $item + incr c + } + } + if {$enabled($template)} { + # Perform checks for active separator templates and + # all data templates. + CheckVerticals $name + } + } + get - + enable - + disable - + enabled { + if {[llength $args] > 0} { + return -code error "Wrong # args: $name $template $cmd" + } + switch -exact -- $cmd { + get { + upvar ::report::report${name}::template tpl + return $tpl($template) + } + enable { + if {!$tcode($template)} { + # Data template, can't be enabled. + return -code error "Cannot enable data template \"$template\"" + } + + upvar ::report::report${name}::enabled enabled + + if {!$enabled($template)} { + set enabled($template) 1 + CheckVerticals $name + } + + } + disable { + if {!$tcode($template)} { + # Data template, can't be disabled. + return -code error "Cannot disable data template \"$template\"" + } + + upvar ::report::report${name}::enabled enabled + if {$enabled($template)} { + set enabled($template) 0 + } + } + enabled { + if {!$tcode($template)} { + # Data template, can't be disabled. + return -code error "Cannot query state of data template \"$template\"" + } + + upvar ::report::report${name}::enabled enabled + return $enabled($template) + } + default {error "Can't happen, panic, run, shout"} + } + } + default { + return -code error "Unknown template command \"$cmd\"" + } + } + return "" +} + +# ::report::_tcaption -- +# +# Sets or queries the size of the top caption region of the report. +# +# Arguments: +# name Name of the report object. +# size The new size, if not empty. Emptiness indicates that a +# query was requested +# +# Results: +# None, or the current size of the top caption region + +proc ::report::_tcaption {name {size {}}} { + upvar ::report::report${name}::tcaption tcaption + + if {$size == {}} { + return $tcaption + } + if {![string is integer $size]} { + return -code error "size: expected integer greater than or equal to zero, got \"$size\"" + } + if {$size < 0} { + return -code error "size: expected integer greater than or equal to zero, got \"$size\"" + } + if {$size == $tcaption} { + # No change, nothing to do + return "" + } + if {($size > 0) && ($tcaption == 0)} { + # Perform a consistency check after the assignment, the + # template might have been changed. + set tcaption $size + CheckVerticals $name + } else { + set tcaption $size + } + return "" +} + +# ::report::_bcaption -- +# +# Sets or queries the size of the bottom caption region of the report. +# +# Arguments: +# name Name of the report object. +# size The new size, if not empty. Emptiness indicates that a +# query was requested +# +# Results: +# None, or the current size of the bottom caption region + +proc ::report::_bcaption {name {size {}}} { + upvar ::report::report${name}::bcaption bcaption + + if {$size == {}} { + return $bcaption + } + if {![string is integer $size]} { + return -code error "size: expected integer greater than or equal to zero, got \"$size\"" + } + if {$size < 0} { + return -code error "size: expected integer greater than or equal to zero, got \"$size\"" + } + if {$size == $bcaption} { + # No change, nothing to do + return "" + } + if {($size > 0) && ($bcaption == 0)} { + # Perform a consistency check after the assignment, the + # template might have been changed. + set bcaption $size + CheckVerticals $name + } else { + set bcaption $size + } + return "" +} + +# ::report::_size -- +# +# Sets or queries the size of the specified column. +# +# Arguments: +# name Name of the report object. +# column Index of the column to manipulate or query +# size The new size, if not empty. Emptiness indicates that a +# query was requested +# +# Results: +# None, or the current size of the column + +proc ::report::_size {name column {size {}}} { + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::csize csize + + set column [CheckColumn $columns $column] + + if {$size == {}} { + return $csize($column) + } + if {[string equal $size dyn]} { + set csize($column) $size + return "" + } + if {![string is integer $size]} { + return -code error "expected integer greater than zero, got \"$size\"" + } + if {$size <= 0} { + return -code error "expected integer greater than zero, got \"$size\"" + } + set csize($column) $size + return "" +} + +# ::report::_sizes -- +# +# Sets or queries the sizes of all columns. +# +# Arguments: +# name Name of the report object. +# sizes The new sizes, if not empty. Emptiness indicates that a +# query was requested +# +# Results: +# None, or a list containing the sizes of all columns. + +proc ::report::_sizes {name {sizes {}}} { + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::csize csize + + if {$sizes == {}} { + set res [list] + foreach k [lsort -integer [array names csize]] { + lappend res $csize($k) + } + return $res + } + if {[llength $sizes] != $columns} { + return -code error "Wrong # number of column sizes" + } + foreach size $sizes { + if {[string equal $size dyn]} { + continue + } + if {![string is integer $size]} { + return -code error "expected integer greater than zero, got \"$size\"" + } + if {$size <= 0} { + return -code error "expected integer greater than zero, got \"$size\"" + } + } + + set i 0 + foreach s $sizes { + set csize($i) $s + incr i + } + return "" +} + +# ::report::_pad -- +# +# Sets or queries the padding for the specified column. +# +# Arguments: +# name Name of the report object. +# column Index of the column to manipulate or query +# where Where to place the padding. Emptiness indicates +# that a query was requested. +# +# Results: +# None, or the padding for the specified column. + +proc ::report::_pad {name column {where {}} {string { }}} { + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::lpad lpad + upvar ::report::report${name}::rpad rpad + + set column [CheckColumn $columns $column] + + if {$where == {}} { + return [list $lpad($column) $rpad($column)] + } + + switch -exact -- $where { + left { + set lpad($column) $string + } + right { + set rpad($column) $string + } + both { + set lpad($column) $string + set rpad($column) $string + } + default { + return -code error "where: expected left, right, or both, got \"$where\"" + } + } + return "" +} + +# ::report::_justify -- +# +# Sets or queries the justification for the specified column. +# +# Arguments: +# name Name of the report object. +# column Index of the column to manipulate or query +# jvalue Justification to set. Emptiness indicates +# that a query was requested +# +# Results: +# None, or the current justication for the specified column + +proc ::report::_justify {name column {jvalue {}}} { + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::cjust cjust + + set column [CheckColumn $columns $column] + + if {$jvalue == {}} { + return $cjust($column) + } + switch -exact -- $jvalue { + left - right - center { + set cjust($column) $jvalue + return "" + } + default { + return -code error "justification: expected, left, right, or center, got \"$jvalue\"" + } + } +} + +# ::report::_printmatrix -- +# +# Format the specified matrix according to the configuration of +# the report. +# +# Arguments: +# name Name of the report object. +# matrix Name of the matrix object to format. +# +# Results: +# A string containing the formatted matrix. + +proc ::report::_printmatrix {name matrix} { + CheckMatrix $name $matrix + ColumnSizes $name $matrix state + + upvar ::report::report${name}::tcaption tcaption + upvar ::report::report${name}::bcaption bcaption + + set row 0 + set out "" + append out [Separator top $name $matrix state] + if {$tcaption > 0} { + set n $tcaption + while {$n > 0} { + append out [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]] + if {$n > 1} { + append out [Separator topdatasep $name $matrix state] + } + incr n -1 + incr row + } + append out [Separator topcapsep $name $matrix state] + } + + set n [expr {[$matrix rows] - $bcaption}] + + while {$row < $n} { + append out [FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]] + incr row + if {$row < $n} { + append out [Separator datasep $name $matrix state] + } + } + + if {$bcaption > 0} { + append out [Separator botcapsep $name $matrix state] + set n $bcaption + while {$n > 0} { + append out [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]] + if {$n > 1} { + append out [Separator botdatasep $name $matrix state] + } + incr n -1 + incr row + } + } + + append out [Separator bottom $name $matrix state] + + #parray state + return $out +} + +# ::report::_printmatrix2channel -- +# +# Format the specified matrix according to the configuration of +# the report. +# +# Arguments: +# name Name of the report. +# matrix Name of the matrix object to format. +# chan Handle of the channel to write the formatting result into. +# +# Results: +# None. + +proc ::report::_printmatrix2channel {name matrix chan} { + CheckMatrix $name $matrix + ColumnSizes $name $matrix state + + upvar ::report::report${name}::tcaption tcaption + upvar ::report::report${name}::bcaption bcaption + + set row 0 + puts -nonewline $chan [Separator top $name $matrix state] + if {$tcaption > 0} { + set n $tcaption + while {$n > 0} { + puts -nonewline $chan \ + [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]] + if {$n > 1} { + puts -nonewline $chan [Separator topdatasep $name $matrix state] + } + incr n -1 + incr row + } + puts -nonewline $chan [Separator topcapsep $name $matrix state] + } + + set n [expr {[$matrix rows] - $bcaption}] + + while {$row < $n} { + puts -nonewline $chan \ + [FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]] + incr row + if {$row < $n} { + puts -nonewline $chan [Separator datasep $name $matrix state] + } + } + + if {$bcaption > 0} { + puts -nonewline $chan [Separator botcapsep $name $matrix state] + set n $bcaption + while {$n > 0} { + puts -nonewline $chan \ + [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]] + if {$n > 1} { + puts -nonewline $chan [Separator botdatasep $name $matrix state] + } + incr n -1 + incr row + } + } + + puts -nonewline $chan [Separator bottom $name $matrix state] + return +} + +# ::report::_columns -- +# +# Retrieves the number of columns in the report. +# +# Arguments: +# name Name of the report queried +# +# Results: +# A number + +proc ::report::_columns {name} { + upvar ::report::report${name}::columns columns + return $columns +} + +# ::report::_destroy -- +# +# Destroy a report, including its associated command and data storage. +# +# Arguments: +# name Name of the report to destroy. +# +# Results: +# None. + +proc ::report::_destroy {name} { + namespace delete ::report::report$name + interp alias {} ::$name {} + return +} + +# ::report::CheckMatrix -- +# +# Internal helper for the "print" methods. Checks that the +# supplied matrix can be formatted by the specified report. +# +# Arguments: +# name Name of the report to use for the formatting +# matrix Name of the matrix to format. +# +# Results: +# None, or an error in case of problems. + +proc ::report::CheckMatrix {name matrix} { + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::tcaption tcaption + upvar ::report::report${name}::bcaption bcaption + + if {$columns != [$matrix columns]} { + return -code error "report/matrix mismatch in number of columns" + } + if {($tcaption + $bcaption) > [$matrix rows]} { + return -code error "matrix too small, top and bottom captions overlap" + } +} + +# ::report::ColumnSizes -- +# +# Internal helper for the "print" methods. Computes the final +# column sizes (with and without padding) and stores them in +# the print-state +# +# Arguments: +# name Name of the report used for the formatting +# matrix Name of the matrix to format. +# statevar Name of the array variable holding the state +# of the formatter. +# +# Results: +# None. + +proc ::report::ColumnSizes {name matrix statevar} { + # Calculate the final column sizes with and without padding and + # store them in the local state. + + upvar $statevar state + + upvar ::report::report${name}::columns columns + upvar ::report::report${name}::csize csize + upvar ::report::report${name}::lpad lpad + upvar ::report::report${name}::rpad rpad + + for {set c 0} {$c < $columns} {incr c} { + if {[string equal dyn $csize($c)]} { + set size [$matrix columnwidth $c] + } else { + set size $csize($c) + } + + set state(s,$c) $size + + incr size [string length $lpad($c)] + incr size [string length $rpad($c)] + + set state(s/pad,$c) $size + } + + return +} + +# ::report::Separator -- +# +# Internal helper for the "print" methods. Computes the final +# shape of the various separators using the column sizes with +# padding found in the print state. Uses also the print state as +# a cache to avoid costly recomputation for the separators which +# are used multiple times. +# +# Arguments: +# tcode Code of the separator to compute / template to use +# name Name of the report used for the formatting +# matrix Name of the matrix to format. +# statevar Name of the array variable holding the state +# of the formatter. +# +# Results: +# The final separator string. Empty for disabled separators. + +proc ::report::Separator {tcode name matrix statevar} { + upvar ::report::report${name}::enabled e + if {!$e($tcode)} {return ""} + upvar $statevar state + if {![info exists state($tcode)]} { + upvar ::report::report${name}::vTemplate vt + upvar ::report::report${name}::hTemplate ht + upvar ::report::report${name}::columns cs + set str "" + for {set c 0} {$c < $cs} {incr c} { + append str $vt($tcode,$c) + set fill $ht($tcode,$c) + set flen [string length $fill] + set rep [expr {($state(s/pad,$c)/$flen)+1}] + append str [string range [string repeat $fill $rep] 0 [expr {$state(s/pad,$c)-1}]] + } + append str $vt($tcode,$cs) + set state($tcode) $str + } + return $state($tcode)\n +} + +# ::report::FormatData -- +# +# Internal helper for the "print" methods. Computes the output +# for one row in the matrix, given its values, the rowheight, +# padding and justification. +# +# Arguments: +# tcode Code of the data template to use +# name Name of the report used for the formatting +# statevar Name of the array variable holding the state +# of the formatter. +# line List containing the values to format +# rh Height of the row (line) in lines. +# +# Results: +# The formatted string for the supplied row. + +proc ::report::FormatData {tcode name statevar line rh} { + upvar $statevar state + upvar ::report::report${name}::vTemplate vt + upvar ::report::report${name}::columns cs + upvar ::report::report${name}::lpad lpad + upvar ::report::report${name}::rpad rpad + upvar ::report::report${name}::cjust cjust + + if {$rh == 1} { + set str "" + set c 0 + foreach cell $line { + # prefix, cell (pad-l, value, pad-r) + append str $vt($tcode,$c)$lpad($c)[FormatCell $cell $state(s,$c) $cjust($c)]$rpad($c) + incr c + } + append str $vt($tcode,$cs)\n + return $str + } else { + array set str {} + for {set l 1} {$l <= $rh} {incr l} {set str($l) ""} + + # - Future - Vertical justification of cells less tall than rowheight + # - Future - Vertical cutff aftert n lines, auto-repeat of captions + # - Future - => Higher level, not here, use virtual matrices for this + # - Future - and count the generated lines + + set c 0 + foreach fcell $line { + set fcell [split $fcell \n] + for {set l 1; set lo 0} {$l <= $rh} {incr l; incr lo} { + append str($l) $vt($tcode,$c)$lpad($c)[FormatCell \ + [lindex $fcell $lo] $state(s,$c) $cjust($c)]$rpad($c) + } + incr c + } + set strout "" + for {set l 1} {$l <= $rh} {incr l} { + append strout $str($l)$vt($tcode,$cs)\n + } + return $strout + } +} + +# ::report::FormatCell -- +# +# Internal helper for the "print" methods. Formats the value of +# a single cell according to column size and justification. +# +# Arguments: +# value The value to format +# size The size of the column, without padding +# just The justification for the current cell/column +# +# Results: +# The formatted string for the supplied cell. + +proc ::report::FormatCell {value size just} { + set vlen [string length [StripAnsiColor $value]] + + if {$vlen == $size} { + # Value fits exactly, justification is irrelevant + return $value + } + + # - Future - Other fill characters ... + # - Future - Different fill characters per class of value => regex/glob pattern|functions + # - Future - Wraparound - interacts with rowheight! + + switch -exact -- $just { + left { + if {$vlen < $size} { + return $value[string repeat " " [expr {$size - $vlen}]] + } + return [string range $value [expr {$vlen - $size}] end] + } + right { + if {$vlen < $size} { + return [string repeat " " [expr {$size - $vlen}]]$value + } + incr size -1 + return [string range $value 0 $size] + } + center { + if {$vlen < $size} { + set fill [expr {$size - $vlen}] + set rfill [expr {$fill / 2}] + set lfill [expr {$fill - $rfill}] + return [string repeat " " $lfill]$value[string repeat " " $rfill] + } + + set cut [expr {$vlen - $size}] + set lcut [expr {$cut / 2}] + set rcut [expr {$cut - $lcut}] + + return [string range $value $lcut end-$rcut] + } + default { + error "Can't happen, panic, run, shout" + } + } +} + +proc ::report::StripAnsiColor {string} { + # Look for ANSI color control sequences and remove them. Avoid + # counting their characters as such sequences as a whole represent + # a state change, and are logically of zero/no width. + regsub -all "\033\\\[\[0-9;\]*m" $string {} string + return $string +}
\ No newline at end of file |