PC World 1997 November/PCWorld_1997-11_cd.bin/software/programy/komix/DATA.Z/rwmethods.tcl

Text File | 1996-10-23 | 14.2 KB | 570 lines

#---------------------------------------------------------------------------
#
#    (c) Cadre Technologies Inc. 1995
#
#    File:        @(#)rwmethods.tcl    /main/hindenburg/1
#    Author:        Harm Leijendeckers
#    Description:    Implementation of methods of class Report
#
#---------------------------------------------------------------------------
# SccsId = @(#)rwmethods.tcl    /main/hindenburg/1    23 Oct 1996    Copyright 1995 Cadre Technologies Inc.


###########################################################################
#
#    Public methods.
#
###########################################################################


constructor Report {class this} {
    set this [GCObject::constructor $class $this]
    $this init
    return $this
}


# Initialize attributes. It's also called in the constructor.
method Report::init {this args} {
    set errormsg "wrong # args: should be \"Report::init ?-linelen num?\
        ?-pagelen num?\""

    # check arguments
    set ret [scan $args "%s%d%s%d" what1 val1 what2 val2]
    if { $ret != -1 && $ret != 2 && $ret != 4 } { error $errormsg }

    set oldLinelen [$this linelen]
    set oldPagelen [$this pagelen]
    $this linelen 0
    $this pagelen 0

    for { set i 0 } { $i < [expr $ret/2] } { incr i } {
    if { [Report::lchkfirst args -linelen] } {
        $this linelen [lvarpop args]
    }
    if { [Report::lchkfirst args -pagelen] } {
        $this pagelen [lvarpop args]
    }
    }

    if ![lempty $args] {
    $this linelen oldLinelen
    $this pagelen oldPagelen
    error $errormsg
    }

    # set linelen to parameter if used else use the m4 variable
    # and if that is not set use the default value
    if { [$this linelen] <= 0 } { $this linelen [m4_var get M4_a_printer_llen] }
    if { [$this linelen] <= 0 } { $this linelen 130 }

    # set pagelen to parameter if used else use the m4 variable
    # and if that is not set use the default value
    if { [$this pagelen] <= 0 } {
    $this pagelen [m4_var get M4_a_printer_plen]
    }
    if { [$this pagelen] <= 0 } { $this pagelen 61 }

    $this toPrint ""
    $this lineno 0
    $this pageno 0
    $this date [fmtclock [getclock] "%d %h %Y %X"]
    $this headerList ""
    $this footerList ""

    return
}


# Main print procedure.
method Report::print {this str args} {
    # substitute all tabs in str for one space
    regsub -all ((\r?\n)|\t) $str " " str

    # number
    set len [lindex $args 0]
    expr { [Report::isInt $len] ? [lvarpop args]
                : [set len [string length $str]] }

    # 'left', 'center', 'right' or 'fill'
    switch -exact [lindex $args 0] {
    left    { set align left; lvarpop args }
    center  { set align center; lvarpop args }
    right   { set align right; lvarpop args }
    fill    { set align fill; lvarpop args }
    default { set align left }
    }

    # 'break'
    set break [Report::lchkfirst args break]

    # format str according to len, align and break and add str to toPrint
    if { [string length $str] <= $len || $len == 0 } {
    # strlen(str) < len
    lappend new_s [Report::align $str $len $align]
    } else {
    # strlen(str) > len
    if { $break } {
        # truncate str
        lappend new_s [list [string range $str 0 [expr $len-1]]]
    } else {
        # break == off so divide str over more lines
        while { [string length $str] > $len } {
        set sub [string range $str 0 [expr $len-1]]
        set str [string range $str $len [string length $str]]
        lappend new_s [list $sub]
        }
        # strlen(str) <= len so add aligned str
        lappend new_s [Report::align $str $len $align]
    }
    }

    # add new_s to global toPrint
    set tmp [$this toPrint]
    lappend tmp [join $new_s]
    $this toPrint $tmp

    # look if the next argument is 'line'
    if { [Report::lchkfirst args line] } { $this line }

    # look if the next argument is 'page'
    if { [Report::lchkfirst args page] } { $this page }

    if ![lempty $args] {
    error [format "print command: unknown argument(s): %s" $args]
    }

    return
}


# Print all outstanding output and a newline.
method Report::line {this} {
    set tp [$this toPrint]
    $this toPrint ""

    # look if we need to print a header first
    $this doHeader
    $this doFooter

    if [lempty $tp] {
    puts ""
    $this lineno [expr [$this lineno]+1]
    return
    }

    for { set i 0 } { $i < [Report::maxelem $tp] } { incr i } {
    set s ""
    foreach j $tp {
        if { [Report::isSeparator $j] } {
            set elem [lindex $j 1]
        } else {
        if [lempty [lindex $j $i]] {
            set elem [join [Report::align " " \
            [string length [lindex $j 0]] fill]]
        } else { set elem [lindex $j $i] }
        }
        append s $elem
    }

    # delete trailing spaces
    set s [string trimright $s]

    $this doHeader

    # if s is longer than linelen, we only have to print
    # s again with length linelen
    if { [string length $s] > [$this linelen] } {
        $this print "$s" [$this linelen] line
    } else {
        puts $s
        $this lineno [expr [$this lineno]+1]
        $this doFooter
    }
    }

    return
}


# Print all outstanding lines and fill the rest of the page with empty lines.
method Report::page {this} {
    # print outstanding lines
    if ![lempty [$this toPrint]] { $this line }

    # and fill the rest of the page with empty lines
    while { ![$this doFooter] } { $this line }

    return
}


# Print a separator. This can be any kind of string.
method Report::separator {this s args} {
    set tmp [$this toPrint]
    lappend tmp [list {} $s]
    $this toPrint $tmp

    # look if the next argument is 'line'
    if { [Report::lchkfirst args line] } { $this line }

    # look if the next argument is 'page'
    if { [Report::lchkfirst args page] } { $this page }

    if ![lempty $args] {
       error [format "separator command: unknown argument(s): %s" $args]
    }

    return
}


# Print a number of spaces, default is one.
method Report::space {this args} {
    if [lempty $args] { set args 1 }
    if { [llength $args] > 1 ||
    ( [llength $args] == 1 && ![Report::isInt $args] ) } {
    error [format "space command: unknown argument(s): %s" $args]
    return
    }

    $this print " " $args
}


method Report::file {this fileName {indent 0}} {
    set fp [open $fileName]
    set fstatus [gets $fp s]

    while { $fstatus != -1 } {
    $this print " " $indent fill
    set s [Report::expandTabs $s $indent 8]
    $this print $s [expr [$this linelen]-$indent] line
    set fstatus [gets $fp s]
    }
    close $fp

    return
}


# Add a header to the headerlist. A header is a set of Tcl commands.
method Report::header {this cmdstr} {
    lappend hl [expr [info level]-1]
    lappend hl $cmdstr

    # append to the end of headerList
    set tmp [$this headerList]
    lappend tmp $hl
    $this headerList $tmp

    return
}


# Add a footer to the footerlist. A footer is a set of Tcl commands.
method Report::footer {this cmdstr {len -1}} {
    if { $len < 1 } { set len [Report::countLines $cmdstr] }

    lappend fl [expr [info level]-1]
    lappend fl $len
    lappend fl $cmdstr

    # insert at the beginning of footerList
    $this footerList [linsert [$this footerList] 0 $fl]

    return
}


# Remove a header, footer or both on this level or on all levels.
method Report::remove {this what args} {
    set argerror "wrong # args: should be \"remove header|footer|hf <all>\""
    set all [lvarpop args]

    if { ![lempty $args] || ($all != "" && $all != "all") } {
    error $argerror
    }

    if { $what == "hf" } {
    $this remove header $all
    $this remove footer $all
    return
    }

    if { $all != "all" } {
    if { $what == "footer" } {
        $this footerList [lrange [$this footerList] 1 end]
        return
    }
    if { $what == "header" } {
        $this headerList [lrange [$this headerList] \
            0 [expr [llength [$this headerList]]-2]]
        return
    }
    error $argerror
    }

    # do a smart deletion of all the headers or footers on this
    # level
    if { $what == "header" || $what == "footer" } {
    # walk through list and delete headers on
    # current level and headers which should have
    # been deleted by the user after leaving a
    # level.

    if { $what == "header" } {
        set origList [$this headerList]
    } else {
        set origList [Report::lreverse [$this footerList]]
    }

    set callLevel [expr [info level]-2]
    set prevLevel -1
    set newL {}
    foreach i $origList {
        if { [lindex $i 0] >= $callLevel || [lindex $i 0] < $prevLevel } {
            break
        }
        lappend newL $i
        set prevLevel [lindex $i 0]
    }

    if { $what == "header" } {
        $this headerList $newL
    } else {
        $this footerList [Report::lreverse $newL]
    }

    return
    }

    error $argerror
}


# Return 1 if there is output to be printed, otherwise 0
method Report::queued {this} {
    if [lempty [$this toPrint]] {
    return 0
    }

    return 1
}


###########################################################################
#
#    Private methods. Don't call them outside a method.
#
###########################################################################


# Execute headerList if lineno == 0.
method Report::doHeader {this} {
    if { ([$this lineno] != 0 && [$this lineno] <= [$this pagelen])
        || [$this pagelen] == -1 } {
    return
    }

    $this pageno [expr [$this pageno]+1]

    # set the pagelen to unlimited so the header is always printed
    # as if it fits on one page
    set oldpagelen [$this pagelen]
    $this pagelen -1
    $this lineno 1

    foreach i [$this headerList] {
    if { [info level] < [lindex $i 0] } {
        # skip headers which were defined on a lower level
        # than the current level
        continue
    }
    # execute the header on the level it was defined
    uplevel #[lindex $i 0] [lindex $i 1]
    }

    $this pagelen $oldpagelen

    # if the header needed to be printed on more than one page
    # the current lineno is bigger then pagelen, so adjust it
    $this lineno [expr [$this lineno]%[$this pagelen]]
    if { ![$this lineno] } { $this lineno [$this pagelen] }

    return
}


# Execute footerList if lineno+footerlength == pagelen.
method Report::doFooter {this} {
    if { [$this pagelen] == -1 } { return 0 }

    # calculate current footerlength
    set len 0
    foreach i [$this footerList] { incr len [lindex $i 1] }

    # if we have got to print the footer
    if { [expr $len+[$this lineno]] > [$this pagelen] } {
    set oldpagelen [$this pagelen]
    $this pagelen -1

    foreach i [$this footerList] {
        # execute the footer on the level it was defined
        uplevel #[lindex $i 0] [lindex $i 2]
    }

    # if the user forgot a "print line" we do it
    if ![lempty [$this toPrint]] { $this line }

    $this pagelen $oldpagelen

    # if lineno < pagelen the footer was shorter than expected
    # so print some empty lines to cover it
    for { } \
        { [$this lineno] <= [$this pagelen] } \
        { $this lineno [expr [$this pageno]+1] } \
        { puts "" }

    $this lineno 0

    return 1
    }

    return 0
}


###########################################################################
#
#    Public methods, implemented as procedures.
#
###########################################################################


# Correct version of lrange, used as long as the bug in lrange is still there.
proc Report::lrange {list start end} {
    set result ""

    if { $end == "end" } { set end [expr [llength $list]-1] }

    for { set i $start } { $i <= $end } { incr i } {
    lappend result [lindex $list $i]
    }

    return $result
}


# Align string 's' according to 'len' and 'align' (== left|right|center|fill).
proc Report::align {s len align} {
    set retval ""

    if { $len <= [string length $s] } {
    set retval [string range $s 0 [expr $len-1] ]
    } else {
    switch -exact $align {
    right   { set retval [format [format "%%%ds" $len] $s] }
    center  { set tmp [format [format "%%%ds" [expr ($len+\
            [string length $s])/2] ] $s]
          set retval [format [format "%%-%ds" $len] $tmp] }
    fill    { set tmp $s
          while { [string length $tmp] < $len } {
            append tmp $s
          }
          set retval [string range $tmp 0 [expr $len-1] ] }
    default { set retval [format [format "%%-%ds" $len] $s] }
    }
    }

    return [list $retval]
}


# Return 1 if parameter is an integer, else 0.
proc Report::isInt {int} {
    return [expr { [scan $int "%d%s" int rest] == 1 }]
}


# Return 1 if the first element of 'list' == 'first' and delete that first
# element, else return 0.
proc Report::lchkfirst {list first} {
    upvar 1 $list l

    if { [lindex $l 0] == $first } {
    lvarpop l
    return 1
    }

    return 0
}


# Return 1 if parameter is a separater, else 0.
proc Report::isSeparator {args} {
    set args [join $args]
    return [expr {[llength $args] == 2 &&
          [string length [lindex $args 0]] == 0 &&
          [string length [lindex $args 1]] != 0}]
}


# Return the number of elements of the biggest subtree in 'args'.
proc Report::maxelem {args} {
    set args [join $args]
    set retval 0
    foreach i $args {
    if { [Report::isSeparator $i] } { continue }
    if { [llength $i] > $retval } { set retval [llength $i] }
    }
    return $retval
}


# Count the number of times that word "line" occurs in string 's'.
proc Report::countLines {s} {
    set num 0
    while { [regsub "line" $s "" s] } { incr num }
    return $num
}


# Expand tabs to spaces in string 's', tablength is variable, default = 8.
proc Report::expandTabs {s indent {tablen 8}} {
    if { $tablen < 0 } { set tablen 0 }

    # add indent spaces
    set s [format [format "%%%ds%%s" $indent] "" $s]

    set pos [string first \t $s]
    while { $pos != -1 } {
    if { $tablen != 0 } {
        set numspaces [expr $tablen-$pos%$tablen]
    } else {
        set numspaces 0
    }

    set spaces [Report::align " " $numspaces fill]

    # join is needed otherwise spaces are enclosed in braces
    regsub \t $s [join $spaces] s

    set pos [string first \t $s]
    }

    # remove the indented spaces
    set s [string range $s $indent end]

    return $s
}


# Return the reverse of list 'l'.
proc Report::lreverse {l} {
    if [lempty $l] { return {} }
    set len [llength $l]
    return [concat [list [lindex $l [incr len -1]] \
           [Report::lreverse [Report::lrange $l 0 [incr len -1]]]]]
}