ipager.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/*  ### ### ### ######### ######### #########*/
/*  Terminal packages - string -> action mappings*/
/*  (pager objects). For use with 'receive listen'.*/
/*  In essence a DFA with tree structure.*/

/*  ### ### ### ######### ######### #########*/
/*  Requirements*/

package require snit
package require textutil::repeat
package require textutil::tabify
package require term::ansi::send
package require term::receive::bind
package require term::ansi::code::ctrl

namespace ::term::receive::pager {}

/*  ### ### ### ######### ######### #########*/

snit::type ::term::interact::pager {

    option -in      -default stdin
    option -out     -default stdout
    option -column  -default 0
    option -line    -default 0
    option -height  -default 25
    option -actions -default {}

    /*  ### ### ### ######### ######### #########*/
    /** 
 */

    constructor {str args} {
    $self configurelist $args
    Save $str

    install bind using ::term::receive::bind \
        ${selfns}::bind $options(-actions)

    $bind map [cd::cu] [myret  Up]
    $bind map [cd::cd] [mymethod Down]
    $bind map \033\[5~ [mymethod PageUp]
    $bind map \033\[6~ [mymethod PageDown]
    $bind map \n       [mymethod Done]
    #$bind default [mymethod DEF]

    return
    }

    # ### ### ### ######### ######### #########
    ##

    method interact () {
    Show
    $bind listen   $options(-in)
    set interacting 1
    vwait [myvar done]
    set interacting 0
    $bind unlisten $options(-in)
    return
    }

    ret  done  () {set done . ; return}
    ret  clear () {Clear      ; return}

    ret  text (type str) {
    if {$interacting} {Clear}
    Save $str
    if {$interacting} {Show}
    return
    }

    /*  ### ### ### ######### ######### #########*/
    /** 
 */

    component bind

    /*  ### ### ### ######### ######### #########*/
    /** 
 */

    variable header
    variable text
    variable footer
    variable empty

    ret  Save (type str) {
    upvar 1 header header text text footer footer maxline maxline
    upvar 1 options(-height) height empty empty at at

    set lines [split [textutil::tabify::untabify2 $str] \n]

    set max 0
    foreach l $lines {
        if {[set len [string length $l]] > $max} {set max $len}
    }

    set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]]
    set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]]

    set text {}
    foreach l $lines {
        lappend text [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl]
    }

    set h $height
    if {$h > [llength $text]} {set h [llength $text]}

    set eline "  [textutil::repeat::strRepeat {  } $max]"
    set empty $eline
    for {set i 0} {$i <= $h} {incr i} {
        append empty \n$eline
    }

    set maxline [expr {[llength $text] - $height}]
    if {$maxline < 0} {set maxline 0}
    set at 0
    return
    }

    variable interacting 0
    variable at   0
    variable maxline -1
    variable done .

    ret  Show () {
    upvar 1 header header text text footer footer at at
    upvar 1 options(-in)     in  options(-column) col
    upvar 1 options(-out)    out options(-line)   row
    upvar 1 options(-height) height

    set to [expr {$at + $height -1}]

    vt::wrch $out [cd::showat $row $col \
               $header\n[join [lrange $text $at $to] \n]\n$footer]
    return
    }

    ret  Clear () {
    upvar 1 empty         empty options(-column) col
    upvar 1 options(-out) out   options(-line)   row

    vt::wrch $out [cd::showat $row $col $empty]
    return
    }

    /*  ### ### ### ######### ######### #########*/
    /** 
 */

    ret  Up (type str) {
    if {$at == 0} return
    incr at -1
    Show
    return
    }

    ret  Down (type str) {
    if {$at >= $maxline} return
    incr at
    Show
    return
    }

    ret  PageUp (type str) {
    set newat [expr {$at - $options(-height) + 1}]
    if {$newat < 0} {set newat 0}
    if {$newat == $at} return
    set at $newat
    Show
    return
    }

    ret  PageDown (type str) {
    set newat [expr {$at + $options(-height) - 1}]
    if {$newat >= $maxline} {set newat $maxline}
    if {$newat == $at} return
    set at $newat
    Show
    return
    }

    ret  Done (type str) {
    $self done
    return
    }

    ret  DEF (type str) {
    puts stderr "($str)"
    exit
    }

    /** 
     * ### ### ### ######### ######### #########
 */
}

/*  ### ### ### ######### ######### #########*/
/*  Ready*/

namespace ::term::interact::pager {
    term::ansi::code::ctrl::import cd
    term::ansi::send::import       vt
}

package provide term::interact::pager 0.1

/** 
 * ### ### ### ######### ######### #########