report.tcl

Go to the documentation of this file.

/*  report.tcl --*/
/* */
/*  Implementation of report objects for Tcl.*/
/* */
/*  Copyright (c) 2001 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.1

namespace ::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  styleargs =  {plain {}}
    array  stylebody =  {plain {}}

    /*  Global data, template codes, for easy checking*/

    variable  tcode
    array  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*/

ret  ::report::report (type name , type columns , type 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.*/

ret  ::report::defstyle (type styleName , type arguments , type 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.*/

ret  ::report::rmstyle (type 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*/

ret  ::report::stylearguments (type 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.*/

ret  ::report::stylebody (type 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*/

ret  ::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.*/

ret  ::report::CheckStyleArguments (type styleName , type 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.*/

ret  ::report::ExecuteStyle (type name , type styleName , type 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.*/

ret  ::report::LinkExec (type name , type styleName , type 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*/

ret  ::report::ReportProc (type name , optional cmd ="" , type 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*/

ret  ::report::CheckColumn (type columns , type 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.*/

ret  ::report::CheckVerticals (type 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.*/

ret  ::report::_tAction (type name , type template , type cmd , type 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*/

ret  ::report::_tcaption (type name , optional 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.*/
     tcaption =  $size
    CheckVerticals $name
    } else {
     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*/

ret  ::report::_bcaption (type name , optional 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.*/
     bcaption =  $size
    CheckVerticals $name
    } else {
     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*/

ret  ::report::_size (type name , type column , optional size ={)} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::csize   csize

     column =  [CheckColumn $columns $column]

    if {$size == {}} {
    return $csize($column)
    }
    if {[string equal $size dyn]} {
     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\""
    }
     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.*/

ret  ::report::_sizes (type name , optional sizes ={)} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::csize   csize

    if {$sizes == {}} {
     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\""
    }
    }

     i =  0
    foreach s $sizes {
     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.*/

ret  ::report::_pad (type name , type column , optional where ={) {string { }}} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::lpad   lpad
    upvar ::report::report${name}::rpad   rpad

     column =  [CheckColumn $columns $column]

    if {$where == {}} {
    return [list $lpad($column) $rpad($column)]
    }

    switch -exact -- $where {
    left {
         lpad = ($column) $string
    }
    right {
         rpad = ($column) $string
    }
    both {
         lpad = ($column) $string
         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*/

ret  ::report::_justify (type name , type column , optional jvalue ={)} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::cjust   cjust

     column =  [CheckColumn $columns $column]

    if {$jvalue == {}} {
    return $cjust($column)
    }
    switch -exact -- $jvalue {
    left - right - center {
         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.*/

ret  ::report::_printmatrix (type name , type 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.*/

ret  ::report::_printmatrix2channel (type name , type matrix , type 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*/

ret  ::report::_columns (type 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.*/

ret  ::report::_destroy (type 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.*/

ret  ::report::CheckMatrix (type name , type 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.*/

ret  ::report::ColumnSizes (type name , type matrix , type 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.*/

ret  ::report::Separator (type tcode , type name , type matrix , type 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.*/

ret  ::report::FormatData (type tcode , type name , type statevar , type line , type 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.*/

ret  ::report::FormatCell (type value , type size , type just) {
    set vlen [string length $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"
    }
    }
}