/usr/share/tcltk/iwidgets4.0.1/scripts/messagebox.itk

#
# Messagebox
# ----------------------------------------------------------------------
# Implements an information messages area widget with scrollbars.
# Message types can be user defined and configured.  Their options
# include foreground, background, font, bell, and their display
# mode of on or off.  This allows message types to defined as needed,
# removed when no longer so, and modified when necessary.  An export
# method is provided for file I/O.
#
# The number of lines that can be displayed may be limited with
# the default being 1000. When this limit is reached, the oldest line 
# is removed.  There is also support for saving the contents to a 
# file, using a file selection dialog.
# ----------------------------------------------------------------------
#
# History:
#   01/16/97 - Alfredo Jahn  Renamed from InfoMsgBox to MessageBox
#       Initial release...
#   01/20/97 - Alfredo Jahn  Add a popup window so that 3rd mouse
#       button can be used to configure/access the message area.
#       New methods added: _post and _toggleDebug.
#   01/30/97 - Alfredo Jahn  Add -filename option
#   05/11/97 - Mark Ulferts  Added the ability to define and configure 
#       new types.  Changed print method to be issue.  
#   09/05/97 - John Tucker Added export method. 
#
# ----------------------------------------------------------------------
#  AUTHOR: Alfredo Jahn V               EMAIL: ajahn@spd.dsccc.com
#          Mark L. Ulferts                     mulferts@austin.dsccc.com
#
#  @(#) $Id: messagebox.itk,v 1.6 2002/03/19 19:48:57 mgbacke Exp $
# ----------------------------------------------------------------------
#            Copyright (c) 1997 DSC Technologies Corporation
# ======================================================================
# Permission to use, copy, modify, distribute and license this software 
# and its documentation for any purpose, and without fee or written 
# agreement with DSC, is hereby granted, provided that the above copyright 
# notice appears in all copies and that both the copyright notice and 
# warranty disclaimer below appear in supporting documentation, and that 
# the names of DSC Technologies Corporation or DSC Communications 
# Corporation not be used in advertising or publicity pertaining to the 
# software without specific, written prior permission.
# 
# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING 
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON-
# INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE
# AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, 
# SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL 
# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR 
# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, 
# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION,
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 
# SOFTWARE.
# ======================================================================

#
# Usual options.
#
itk::usual Messagebox {
    keep -activebackground -activeforeground -background -borderwidth \
    -cursor -highlightcolor -highlightthickness \
    -jump -labelfont -textbackground -troughcolor 
}

# ------------------------------------------------------------------
#                              MSGTYPE
# ------------------------------------------------------------------

itcl::class iwidgets::MsgType {
    constructor {args} {eval configure $args}

    public variable background \#d9d9d9
    public variable bell 0
    public variable font -*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*
    public variable foreground Black
    public variable show 1
}

# ------------------------------------------------------------------
#                              MESSAGEBOX
# ------------------------------------------------------------------
itcl::class iwidgets::Messagebox {
    inherit itk::Widget

    constructor {args} {}
    destructor {}

    itk_option define -filename fileName FileName ""
    itk_option define -maxlines maxLines MaxLines 1000
    itk_option define -savedir saveDir SaveDir "[pwd]"

    public {
        method clear {}
        method export {filename} 
        method find {}
        method issue {string {type DEFAULT} args}
        method save {}
    method type {op tag args}
    }

    protected {
    variable _unique 0
    variable _types {}
    variable _interior {}

    method _post {x y}
    }
}

#
# Provide a lowercased access method for the Messagebox class.
# 
proc ::iwidgets::messagebox {pathName args} {
    uplevel ::iwidgets::Messagebox $pathName $args
}

#
# Use option database to override default resources of base classes.
#
option add *Messagebox.labelPos n widgetDefault
option add *Messagebox.cursor top_left_arrow widgetDefault
option add *Messagebox.height 0 widgetDefault
option add *Messagebox.width 0 widgetDefault
option add *Messagebox.visibleItems 80x24 widgetDefault

# ------------------------------------------------------------------
#                           CONSTRUCTOR
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::constructor {args} {
    set _interior $itk_interior

    # 
    # Create the text area.
    #
    itk_component add text {
    iwidgets::Scrolledtext $itk_interior.text -width 1 -height 1 \
        -state disabled -wrap none
    } {
    keep -borderwidth -cursor -exportselection -highlightcolor \
        -highlightthickness -padx -pady -relief -setgrid -spacing1 \
        -spacing2 -spacing3 

    keep -activerelief -elementborderwidth -jump -troughcolor

    keep -hscrollmode -height -sbwidth -scrollmargin -textbackground \
        -visibleitems -vscrollmode -width

    keep -labelbitmap -labelfont -labelimage -labelmargin \
        -labelpos -labeltext -labelvariable
    }
    grid $itk_component(text) -row 0 -column 0 -sticky nsew
    grid rowconfigure $_interior 0 -weight 1
    grid columnconfigure $_interior 0 -weight 1
    
    #
    # Setup right mouse button binding to post a user configurable
    # popup menu and diable the binding for left mouse clicks.
    #
    bind [$itk_component(text) component text] <ButtonPress-1> "break"
    bind [$itk_component(text) component text] \
    <ButtonPress-3> [itcl::code $this _post %x %y]
    
    #
    # Create the small popup menu that can be configurable by users.
    #
    itk_component add itemMenu {
    menu $itk_component(hull).itemmenu -tearoff 0 
    } {
    keep -background -font -foreground \
        -activebackground -activeforeground
    ignore -tearoff
    }

    #
    # Add clear and svae options to the popup menu.
    #
    $itk_component(itemMenu) add command -label "Find" \
    -command [itcl::code $this find]
    $itk_component(itemMenu) add command -label "Save" \
    -command [itcl::code $this save]
    $itk_component(itemMenu) add command -label "Clear" \
    -command [itcl::code $this clear]

    #
    # Create a standard type to be used if no others are specified.
    #
    type add DEFAULT

    eval itk_initialize $args
}

# ------------------------------------------------------------------
#                            DESTURCTOR
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::destructor {} {
    foreach type $_types {
        type remove $type
    }
}

# ------------------------------------------------------------------
#                            METHODS
# ------------------------------------------------------------------

# ------------------------------------------------------------------
# METHOD clear 
#
# Clear the text area.
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::clear {} {
    $itk_component(text) configure -state normal

    $itk_component(text) delete 1.0 end

    $itk_component(text) configure -state disabled
}

# ------------------------------------------------------------------
# PUBLIC METHOD: type <op> <tag> <args>
#
# The type method supports several subcommands.  Types can be added
# removed and configured.  All the subcommands use the MsgType class
# to implement the functionaility.
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::type {op tag args} {
    switch $op {
        add {
            eval iwidgets::MsgType $this$tag $args
        
            lappend _types $tag

            $itk_component(text) tag configure $tag \
            -font [$this$tag cget -font] \
            -background [$this$tag cget -background] \
            -foreground [$this$tag cget -foreground]

            return $tag
        }

        remove {
            if {[set index [lsearch $_types $tag]] != -1} {
                itcl::delete object $this$tag
                set _types [lreplace $_types $index $index]

                return
            } else {
                error "bad message type: \"$tag\", does not exist"
            }
        }

        configure {
            if {[set index [lsearch $_types $tag]] != -1} {
                set retVal [eval $this$tag configure $args]
    
                $itk_component(text) tag configure $tag \
                    -font [$this$tag cget -font] \
                    -background [$this$tag cget -background] \
                    -foreground [$this$tag cget -foreground]
    
                return $retVal
    
            } else {
                error "bad message type: \"$tag\", does not exist"
            }
        }

        cget {
            if {[set index [lsearch $_types $tag]] != -1} {
                return [eval $this$tag cget $args]
            } else {
                error "bad message type: \"$tag\", does not exist"
            }
        }

        default {
            error "bad type operation: \"$op\", should be add,\
                    remove, configure or cget"
        }
    }
}

# ------------------------------------------------------------------
# PUBLIC METHOD: issue string ?type? args
#
# Print the string out to the Messagebox. Check the options of the
# message type to see if it should be displayed or if the bell 
# should be wrong.
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::issue {string {type DEFAULT} args} {
    if {[lsearch $_types $type] == -1} {
        error "bad message type: \"$type\", use the type\
               command to create a new types"
    }

    #
    # If the type is currently configured to be displayed, then insert
    # it in the text widget, add the tag to the line and move the 
    # vertical scroll bar to the bottom.
    #
    set tag $this$type

    if {[$tag cget -show]} {
        $itk_component(text) configure -state normal

        #
        # Find end of last message.
        #
        set prevend [$itk_component(text) index "end - 1 chars"]
     
        $itk_component(text) insert end "$string\n" $args

        $itk_component(text) tag add $type $prevend "end - 1 chars"
        $itk_component(text) yview end

        #
        # Sound a beep if the message type is configured such.
        #
        if {[$tag cget -bell]} {
            bell
        }

        #
        # If we reached our max lines limit, then remove enough lines to
        # get it back under.
        #
        set lineCount [lindex [split [$itk_component(text) index end] "."] 0]

        if { $lineCount > $itk_option(-maxlines) } {
            set numLines [expr {$lineCount - $itk_option(-maxlines) -1}]
        
            $itk_component(text) delete 1.0 $numLines.0
        }

        $itk_component(text) configure -state disabled
    }
}

# ------------------------------------------------------------------
# PUBLIC METHOD: save
#
# Save contents of messages area to a file using a fileselectionbox. 
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::save {} {
    set saveFile ""
    set filter   ""

    set saveFile [tk_getSaveFile -title "Save Messages" \
              -initialdir $itk_option(-savedir) \
              -parent $itk_interior \
              -initialfile $itk_option(-filename)]

    if { $saveFile != "" } {
        $itk_component(text) export $saveFile
    }
}

# ------------------------------------------------------------------
# PUBLIC METHOD: find
#
# Search the contents of messages area for a specific string.
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::find {} {
    if {! [info exists itk_component(findd)]} {
        itk_component add findd {
            iwidgets::Finddialog $itk_interior.findd \
            -textwidget $itk_component(text)
        } 
    }

    $itk_component(findd) center $itk_component(text)
    $itk_component(findd) activate
}

# ------------------------------------------------------------------
# PRIVATE METHOD: _post
#
# Used internally to post the popup menu at the coordinate (x,y)
# relative to the widget.
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::_post {x y} {
    set rx [expr {[winfo rootx $itk_component(text)]+$x}]
    set ry [expr {[winfo rooty $itk_component(text)]+$y}]

    tk_popup $itk_component(itemMenu) $rx $ry
}


# ------------------------------------------------------------------
# METHOD export filename
#
# write text to a file (export filename)
# ------------------------------------------------------------------
itcl::body iwidgets::Messagebox::export {filename} {

    $itk_component(text) export $filename

}
iwidgets4 4.0.1-6 / usr / share / tcltk / iwidgets4.0.1 / scripts / messagebox.itk
