Version 6 of Read-Only Text Megawidget with TclOO

Updated 2012-11-24 03:28:25 by RLE

Bryan Oakley 02 Dec 2008 - This page gives an example of a megawidget written with the new OO features of tcl/tk 8.6. The megawidget in question looks and behaves almost identically to the standard text widget, but prevents insertion into or deletion of text that is tagged with a "readonly" tag. I know people have asked for such a thing in the past and I thought it would make for a good programming exercise.

When I first started down this path I looked at Megawidgets with TclOO. My first thought was "wow, that's a lot of code to do just a little example". Of course, Donal's example is a little fancier than mine in that he has a widget factory that pumps out megawidgets. That seemed too complicated for my needs,and besides, I like doing things like this by hand so I better understand what is happening under the covers.

The following is what I ended up with. I'm sure there are some optimizations that can be made and I've only lightly tested it on one platform, but my day of experimentation has come to an end so I'm posting what I have for others to tinker with. I think it shows that even straight out of the box, the new OO facilities make it pretty easy to extend existing widgets without the need for a lot of overhead.

In case it's not obvious, copy this into an interpreter and type "rotext::example"


package require TclOO

namespace eval rotext {

    # this is a tk-like wrapper around the ReadOnlyText class so
    # that object creation works like other Tk widgets. 
    proc rotext {path args} {
        set obj [ReadOnlyText create tmp $path {*}$args]
        rename $obj ::$path
        return $path
    }

    proc example {} {
        rotext::rotext .t -yscrollcommand [list .vsb set] -wrap word
        scrollbar .vsb -command [list .t yview]
        pack .vsb -side right -fill y -expand false
        pack .t -side left -fill both -expand true
        .t insert end [join [lsort [info commands]] \n]
        .t tag configure readonly -foreground red
        .t insert 2.0 "You can't delete me or change me!\n" readonly
    }

    oo::class create ReadOnlyText {
        variable widget
        constructor {path args} {
            text $path {*}$args
            # we must rename the widget command since it clashes with
            # the object being created
            set widget ${path}_
            rename $path $widget

            # manually forward all the text subcommands except the few that are
            # implemented in this class
            foreach subcommand {
                bbox cget compare configure count debug delete dlineinfo
                dump edit get image index insert mark peer replace scan
                search see tag window xview yview
            } {
                if {$subcommand ni [info class methods [self class]]} {
                    oo::objdefine [self] forward $subcommand [namespace current]::$widget $subcommand
                }
            }
        }

        method isreadonly {index1 index2} {
            set result false
            if {$index2 eq ""} {set index2 "end"}
            for {set index $index1} \
                {[$widget compare $index < $index2]} \
                {set index [$widget index "$index+1c"]} {
                    if {"readonly" in [$widget tag names $index]} {
                        set result true
                        break
                    }
                }
            return $result
        }

        method delete {args} {
            foreach {index1 index2} $args {
                if {[my isreadonly $index1 $index2]} {
                    bell
                    return
                }
            }
            $widget delete {*}$args
        }

        method replace {index1 index2 chars args} {
            if {[my isreadonly $index1 $index2]} {
                bell
                return
            }
            $widget replace $index1 $index2 $chars {*}$args
        }

        method insert {index args} {
            if {[my isreadonly $index "$index +1c"]} {
                bell
                return
            }
            $widget insert $index {*}$args
        }

    }
}

JOB Nov.2012 - In the constructor section I'd like to adopt the code slightly, to make it even more generic:

       constructor {path args} {
            text $path {*}$args
            # we must rename the widget command since it clashes with
            # the object being created
            set widget ${path}_
            rename $path $widget

            # manually forward all the text subcommands except the few that are
            # implemented in this class
            foreach subcommand [::rotext::getwidgetcommands "text"] {

              if {$subcommand ni [info class methods [self class]]} {
                    oo::objdefine [self] forward $subcommand [namespace current]::$widget $subcommand
                }
            }
        }

And one more helper function (within the rotext namespace) to eliminate the need of hard coded command arguments:

proc getwidgetcommands {w} {

  # retrieve command list from widget object
  set tmp [eval $w ".___wtmp___[clock clicks]"]
  catch {$tmp "__force_cmd_output__"} msg
  catch {destroy $tmp}

  set cmdlist {}
  foreach item [split $msg ","] {
  set cmdlist [lappend cmdlist [lindex [split $item " "] end]]
  }
  # foreach item $cmdlist { puts "--- $item ---" }
  return $cmdlist
}