Tk Library Source Code

#
# Populates a given plainnotebook widget with panes that display the contents
# of the files of the specified suffix within the current working directory
#
proc populateNotebook {nb sfx} {
    set currentTheme [styleutil::getCurrentTheme]
    set panePadding [expr {$currentTheme eq "aqua" ? 0 : "7p"}]
    ##nagelfar ignore
    foreach fileName [lsort -dictionary [glob *.$sfx]] {
	set baseName [string range $fileName 0 end-4]
	set sa [scrollutil::scrollarea $nb.sa_$baseName]
	if {$sfx eq "gif"} {
	    set canv [canvas $sa.canv -background #c0c0c0]
	    set img [image create photo -file $fileName -format gif]
	    $canv create image 15p 15p -anchor nw -image $img

#
set f  [ttk::frame .f]
set nb [scrollutil::plainnotebook $f.nb -closabletabs 1 \
	-forgetcommand condCopySel -leavecommand saveSel]
set currentTheme [styleutil::getCurrentTheme]
set panePadding [expr {$currentTheme eq "aqua" ? 0 : "7p"}]
cd [expr {[info exists ttk::library] ? $ttk::library : $tile::library}]
##nagelfar ignore
foreach fileName [lsort [glob *.tcl]] {
    set baseName [string range $fileName 0 end-4]
    set sa [scrollutil::scrollarea $nb.sa_$baseName -lockinterval 10]
    if {$currentTheme eq "vista"} {
	$sa configure -relief solid
    }
    set txt [text $sa.txt -font TkFixedFont -height 30 -takefocus 1 -wrap none]

#
set f  [ttk::frame .f]
set nb [scrollutil::scrollednotebook $f.nb -style My.TNotebook \
	-forgetcommand condCopySel -leavecommand saveSel]
set currentTheme [styleutil::getCurrentTheme]
set panePadding [expr {$currentTheme eq "aqua" ? 0 : "7p"}]
cd [expr {[info exists ttk::library] ? $ttk::library : $tile::library}]
##nagelfar ignore
foreach fileName [lsort [glob *.tcl]] {
    set baseName [string range $fileName 0 end-4]
    set sa [scrollutil::scrollarea $nb.sa_$baseName -lockinterval 10]
    if {$currentTheme eq "vista"} {
	$sa configure -relief solid
    }
    set txt [text $sa.txt -font TkFixedFont -takefocus 1 -wrap none]

# widgets displaying the contents of the Ttk library files
#
set f  [ttk::frame .f]
set nb [ttk::notebook $f.nb -style My.TNotebook]
set currentTheme [styleutil::getCurrentTheme]
set panePadding [expr {$currentTheme eq "aqua" ? 0 : "7p"}]
cd [expr {[info exists ttk::library] ? $ttk::library : $tile::library}]
##nagelfar ignore
foreach fileName [lsort [glob *.tcl]] {
    set baseName [string range $fileName 0 end-4]
    set sa [scrollutil::scrollarea $nb.sa_$baseName -lockinterval 10]
    if {$currentTheme eq "vista"} {
	$sa configure -relief solid
    }
    set txt [text $sa.txt -font TkFixedFont -takefocus 1 -wrap none]

What is new in Scrollutil 2.3.2?
--------------------------------

1. Made sure that the Migration Tool for Tcl 9 won't output any
   warnings or notes.

What was new in Scrollutil 2.3.1?
---------------------------------

1. Reverted the implementation of the "scrollutil::getscrollarea"
   command to its version contained in Scrollutil 2.2, thus eliminating
   two potentially critical bugs introduced in Scrollutil 2.3 (thanks to
   Nicolas Bats and Paul Obermeier for their bug reports).

What was new in Scrollutil 2.3?

Scrolling utilities package Scrollutil 2.3.2
Copyright (c) 2019-2024  Csaba Nemethi (E-mail: [email protected])

This library is free software; you can use, modify, and redistribute it
for any purpose, provided that existing copyright notices are retained
in all copies and that this notice is included verbatim in any
distributions.

How to Get It?
--------------

Scrollutil is available for free download from the Web page

    https://www.nemethi.de

The distribution file is "scrollutil2.3.2.tar.gz" for UNIX and
"scrollutil2_3_2.zip" for Windows.  These files contain the same
information, except for the additional carriage return character
preceding the linefeed at the end of each line in the text files for
Windows.

Scrollutil is also included in tklib, which has the address

    https://core.tcl.tk/tklib

How to Install It?
------------------

Install the package as a subdirectory of one of the directories given
by the "auto_path" variable.  For example, you can install it as a
directory at the same level as the Tcl and Tk script libraries.  The
locations of these library directories are given by the "tcl_library"
and "tk_library" variables, respectively.

To install Scrollutil on UNIX, "cd" to the desired directory and unpack
the distribution file "scrollutil2.3.2.tar.gz":

    gunzip -c scrollutil2.3.2.tar.gz | tar -xf -

On most UNIX systems this can be replaced with

    tar -zxf scrollutil2.3.2.tar.gz

Both commands will create a directory named "scrollutil2.3.2", with the
subdirectories "demos", "doc", and "scripts".

On Windows, use WinZip or some other program capable of unpacking the
distribution file "scrollutil2_3_2.zip" into the directory
"scrollutil2.3.2", with the subdirectories "demos", "doc", and
"scripts".

How to Use It?
--------------

The Scrollutil distribution provides two packages, called Scrollutil and
Scrollutil_tile.  The main difference between the two is that

  <blockquote>
    <address>
      <a href="https://www.nemethi.de">https://www.nemethi.de</a>
    </address>
  </blockquote>

  <p>The distribution file is <code>scrollutil2.3.2.tar.gz</code> for UNIX and
  <code>scrollutil2_3_2.zip</code> for Windows.&nbsp; These files contain the
  same information, except for the additional carriage return character
  preceding the linefeed at the end of each line in the text files for
  Windows.</p>

  <p>Scrollutil is also included in tklib, which has the address</p>

  <blockquote>

  a directory at the same level as the Tcl and Tk script libraries.  The
  locations of these library directories are given by the
  <code>tcl_library</code> and <code>tk_library</code> variables,
  respectively.</p>

  <p>To install Scrollutil <i>on UNIX</i>, <code>cd</code> to the desired
  directory and unpack the distribution file
  <code>scrollutil2.3.2.tar.gz</code>:</p>

  <blockquote>
    <pre>
gunzip -c scrollutil2.3.2.tar.gz | tar -xf -
</pre>
  </blockquote>

  <p>On most UNIX systems this can be replaced with</p>

  <blockquote>
    <pre>
tar -zxf scrollutil2.3.2.tar.gz
</pre>
  </blockquote>

  <p>Both commands will create a directory named <code>scrollutil2.3.2</code>,
  with the subdirectories <code>demos</code>, <code>doc</code>, and
  <code>scripts</code>.</p>

  <p><i>On Windows</i>, use WinZip or some other program capable of unpacking
  the distribution file <code>scrollutil2_3_2.zip</code> into the directory
  <code>scrollutil2.3.2</code>, with the subdirectories <code>demos</code>,
  <code>doc</code>, and <code>scripts</code>.</p>

  <p>Notice that in tklib the Scrollutil <code>demos</code> directory is
  replaced with the subdirectory <code>scrollutil</code> of the
  <code>examples</code> directory.&nbsp; Please take this into account when
  reading the <a href="#examples">examples</a> below.</p>

#==============================================================================
# Scrollutil and Scrollutil_tile package index file.
#
# Copyright (c) 2019-2024  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

#
# Regular packages:
#
package ifneeded scrollutil         2.3.2 \
	[list source [file join $dir scrollutil.tcl]]
package ifneeded scrollutil_tile    2.3.2 \
	[list source [file join $dir scrollutil_tile.tcl]]

#
# Aliases:
#
package ifneeded Scrollutil         2.3.2 \
	[list package require -exact scrollutil      2.3.2]
package ifneeded Scrollutil_tile    2.3.2 \
	[list package require -exact scrollutil_tile 2.3.2]

#
# Code common to all packages:
#
package ifneeded scrollutil::common 2.3.2 \
	[list source [file join $dir scrollutilCommon.tcl]]

	forget {
	    if {$argCount != 2} {
		mwutil::wrongNumArgs "$win $cmd pageIndex"
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg
	    if {$pageIdx < 0 || $pageIdx >= $data(pageCount)} {
		return -code error "page index $pageIdx out of bounds"
	    }

	    set widget [lindex $data(pageList) $pageIdx]
	    if {[set forgetCmd $data(-forgetcommand)] ne "" &&

	haspageattrib -
	unsetpageattrib {
	    if {$argCount != 3} {
		mwutil::wrongNumArgs "$win $cmd pageIndex name"
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg
	    if {$pageIdx < 0 || $pageIdx >= $data(pageCount)} {
		return -code error "page index $pageIdx out of bounds"
	    }

	    set first [string first "page" $cmd]
	    set last [expr {$first + 3}]

	insert {
	    if {$argCount < 3} {
		mwutil::wrongNumArgs \
		    "$win $cmd pageIndex window ?option value option value ...?"
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg

	    set widget [lindex $args 2]
	    if {![winfo exists $widget]} {
		return -code error "bad window path name \"$widget\""
	    }

	pageattrib {
	    if {$argCount < 2} {
		mwutil::wrongNumArgs \
		    "$win $cmd pageIndex ?name ?value name value ...??"
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg
	    if {$pageIdx < 0 || $pageIdx >= $data(pageCount)} {
		return -code error "page index $pageIdx out of bounds"
	    }

	    set widget [lindex $data(pageList) $pageIdx]
	    return [::scrollutil::attribSubCmd $win $widget \
		    [lrange $args 2 end]]
	}

	pagecget {
	    if {$argCount != 3} {
		mwutil::wrongNumArgs "$win $cmd pageIndex option"
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg
	    if {$pageIdx < 0 || $pageIdx >= $data(pageCount)} {
		return -code error "page index $pageIdx out of bounds"
	    }

	    variable pageConfigSpecs
	    set opt [mwutil::fullConfigOpt [lindex $args 2] pageConfigSpecs]
	    return [doPageCget $pageIdx $win $opt]
	}

	pageconfigure {
	    if {$argCount < 2} {
		mwutil::wrongNumArgs \
		    "$win $cmd pageIndex ?option ?value option value ...??"
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg
	    if {$pageIdx < 0 || $pageIdx >= $data(pageCount)} {
		return -code error "page index $pageIdx out of bounds"
	    }

	    variable pageConfigSpecs
	    return [mwutil::configureSubCmd $win pageConfigSpecs \

	    }

	    if {$argCount == 1} {
		return $data(currentPage)
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg
	    if {$pageIdx < 0 || $pageIdx >= $data(pageCount)} {
		return -code error "page index $pageIdx out of bounds"
	    }

	    set widget [lindex $data(pageList) $pageIdx]
	    if {[lsearch -exact $data(pageList) $data(currentPage)] >= 0} {

	window {
	    if {$argCount != 2} {
		mwutil::wrongNumArgs "$win $cmd pageIndex"
	    }

	    set pageIdx [lindex $args 1]
	    ##nagelfar ignore
	    set pageIdx [format "%d" $pageIdx]	;# integer check with error msg
	    if {$pageIdx < 0 || $pageIdx >= $data(pageCount)} {
		return -code error "page index $pageIdx out of bounds"
	    }

	    return [lindex $data(pageList) $pageIdx]
	}

	    $win.nb configure $opt $val
	    set data($opt) [$win.nb cget $opt]
	}

	w {
	    switch -- $opt {
		-caller {
		    ##nagelfar ignore
		    if {![string is integer -strict $val]} {
			return -code error "bad page index $val"
		    }
		    if {$val >= 0} {
			set pm [winfo parent $win]
			if {[winfo class $pm] ne "Pagesman"} {
			    return -code error \

	    }

	    set pm [winfo parent $win]
	    if {[winfo class $pm] ne "Pagesman"} {
		return -code error "\"$pm\" is not a pagesman widget"
	    }
	    foreach {pageIdx text img} $argList {}
	    ##nagelfar ignore
	    if {![string is integer -strict $pageIdx] || $pageIdx < 0} {
		return -code error "bad page index $pageIdx"
	    }
	    if {$img ne "" && [lsearch -exact [image names] $img] < 0} {
		return -code error "image \"$img\" doesn't exist"
	    }

	index {
	    if {$argCount != 2} {
		mwutil::wrongNumArgs "$win $cmd tab"
	    }

	    set tabId [lindex $args 1]
	    ##nagelfar ignore
	    if {[scan $tabId "@%d,%d%n" x y count] == 3 &&
		$count == [string length $tabId]} {
		set cf $data(cf)
		incr x [expr {[winfo rootx $win] - [winfo rootx $cf]}]
		incr y [expr {[winfo rooty $win] - [winfo rooty $cf]}]
		if {$x < 0 || $x >= [winfo width  $cf] ||
		    $y < 0 || $y >= [winfo height $cf]} {

		return -code error "tab index $pos out of bounds"
	    }
	    set pm [winfo parent $win]
	    if {[winfo class $pm] ne "Pagesman"} {
		return -code error "\"$pm\" is not a pagesman widget"
	    }
	    foreach {pageIdx text img} [lrange $args 2 end] {}
	    ##nagelfar ignore
	    if {![string is integer -strict $pageIdx] || $pageIdx < 0} {
		return -code error "bad page index $pageIdx"
	    }
	    if {$img ne "" && [lsearch -exact [image names] $img] < 0} {
		return -code error "image \"$img\" doesn't exist"
	    }

    set argCount [llength $argList]
    if {$argCount < 3} {
	mwutil::wrongNumArgs "$win scan mark|dragto x y ?dragGain?"
    }

    variable scanOpts
    set opt [mwutil::fullOpt "option" [lindex $argList 0] $scanOpts]
    ##nagelfar ignore
    set x [format "%d" [lindex $argList 1]]
    ##nagelfar ignore
    set y [format "%d" [lindex $argList 2]]

    upvar ::scrollutil::ns${win}::data data
    if {$opt eq "mark"} {
	if {$argCount != 3} {
	    mwutil::wrongNumArgs "$win scan mark x y"
	}

	set data(scanX) $x
	set data(scanY) $y
	set data(scanXOffset) $data(xOffset)
	set data(scanYOffset) $data(yOffset)
    } else {
	if {$argCount == 3} {
	    set gain 10
	} elseif {$argCount == 4} {
	    ##nagelfar ignore
	    set gain [format "%d" [lindex $argList 3]]
	} else {
	    mwutil::wrongNumArgs "$win scan dragto x y ?gain?"
	}

	set xOffset [expr {$data(scanXOffset) - $gain * ($x - $data(scanX))}]
	applyOffset $win x $xOffset 0

#------------------------------------------------------------------------------
proc scrollutil::sf::seerectSubCmd {win argList} {
    set argCount [llength $argList]
    if {$argCount < 4 || $argCount > 5} {
	mwutil::wrongNumArgs "$win seerect x1 y1 x2 y2 ?nw|ne|sw|se?"
    }

    ##nagelfar ignore
    set x1 [format "%d" [lindex $argList 0]]
    ##nagelfar ignore
    set y1 [format "%d" [lindex $argList 1]]
    ##nagelfar ignore
    set x2 [format "%d" [lindex $argList 2]]
    ##nagelfar ignore
    set y2 [format "%d" [lindex $argList 3]]
    if {$x1 > $x2} {
	set tmp $x1; set x1 $x2; set x2 $temp
    }
    if {$y1 > $y2} {
	set tmp $y1; set y1 $y2; set y2 $temp
    }

	    return [list $first $last]
	}

	1 {
	    #
	    # Command: $win xview <units>
	    #
	    ##nagelfar ignore
	    set units [format "%d" [lindex $argList 0]]
	    set xScrlIncr $data(-xscrollincrement)
	    if {$xScrlIncr > 0} {
		set xOffset [expr {$units * $xScrlIncr}]
	    } else {
		set xOffset [expr {int($units * 0.1 * $mfWidth)}]
	    }

	    return [list $first $last]
	}

	1 {
	    #
	    # Command: $win yview <units>
	    #
	    ##nagelfar ignore
	    set units [format "%d" [lindex $argList 0]]
	    set yScrlIncr $data(-yscrollincrement)
	    if {$yScrlIncr > 0} {
		set yOffset [expr {$units * $yScrlIncr}]
	    } else {
		set yOffset [expr {int($units * 0.1 * $mfWidth)}]
	    }

			    obscureScrollbars $win
			}
		    } else {
			unobscureScrollbars $win
		    }
		}
		-lockinterval {
		    ##nagelfar ignore
		    set val [format "%d" $val]	;# integer check with error msg
		    if {$val < 0} {
			set val 0
		    }
		    set data($opt) $val
		}
		-respectheader {

# If the scrollednotebook tab identifier tabId is of the form “@x,y” then
# returns a tab identifier of the same form, in which x is relative to the
# internal ttk::notebook widget; otherwise returns tabId unchanged.
#------------------------------------------------------------------------------
proc scrollutil::snb::snbTabIdToNbTabId {win tabId} {
    upvar ::scrollutil::ns${win}::data data

    ##nagelfar ignore
    if {[scan $tabId "@%d,%d%n" x y count] == 3 &&
	$count == [string length $tabId]} {
	foreach {first last} [$data(sf) xview] {}
	set cfWidth [winfo width $data(cf)]
	incr x [expr {int($first * $cfWidth + 0.5)}]
	return "@$x,$y"
    } else {

#==============================================================================
# mwutil, scaleutil, and themepatch package index file.
#
# Copyright (c) 2020-2024  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

package ifneeded mwutil     2.23   [list source [file join $dir mwutil.tcl]]
package ifneeded scaleutil  1.14.1 [list source [file join $dir scaleutil.tcl]]
package ifneeded themepatch 1.7    [list source [file join $dir themepatch.tcl]]

# ========================
#

namespace eval scaleutil {
    #
    # Public variables:
    #
    variable version	1.14.1
    variable library	[file dirname [file normalize [info script]]]

    #
    # Public procedures:
    #
    namespace export	scalingPercentage scale

	    #
	} elseif {[catch {exec ps -e | grep gnome-session}] == 0 &&
		  [catch {exec gsettings get \
		   org.gnome.settings-daemon.plugins.xsettings overrides} \
		   result] == 0 &&
		  [set idx \
		   [string first "'Gdk/WindowScalingFactor'" $result]] >= 0} {
	    ##nagelfar ignore
	    scan [string range $result $idx end] "%*s <%d>" winScalingFactor
	}

	#
	# Get the scaling percentage
	#
	if {$winScalingFactor >= 2} {

    set str [read $chan]
    close $chan

    set idx [string first "courier" $str]
    set str [string range $str $idx end]

    set idx [string first "size" $str]
    ##nagelfar ignore
    scan [string range $str $idx end] "%*s %d" size
    set points [expr {$size < 0 ? 9 : $size}]		;# -12 -> 9, else 10
    foreach font {TkDefaultFont TkTextFont TkHeadingFont
		  TkIconFont TkMenuFont} {
	font configure $font -size [expr {$factor * $points}]
    }

    set idx [string first "ttsize" $str]
    ##nagelfar ignore
    scan [string range $str $idx end] "%*s %d" size
    set points [expr {$size < 0 ? 8 : $size}]		;# -10 -> 8, else 9
    foreach font {TkTooltipFont TkSmallCaptionFont} {
	font configure $font -size [expr {$factor * $points}]
    }

    set idx [string first "capsize" $str]
    ##nagelfar ignore
    scan [string range $str $idx end] "%*s %d" size
    set points [expr {$size < 0 ? 11 : $size}]		;# -14 -> 11, else 12
    font configure TkCaptionFont -size [expr {$factor * $points}]

    set idx [string first "fixedsize" $str]
    ##nagelfar ignore
    scan [string range $str $idx end] "%*s %d" size
    set points [expr {$size < 0 ? 9 : $size}]		;# -12 -> 9, else 10
    font configure TkFixedFont -size [expr {$factor * $points}]
}

#------------------------------------------------------------------------------
# scaleutil::scaleStyles_alt

    #
    # The rest is for scrollable widget containers.
    #

    foreach event $eventList {
	if {[string match <*Button-?> $event]} {
	    ##nagelfar ignore
	    bind WheeleventRedir $event [format {
		if {![scrollutil::hasFocus %%W] ||
		    ![scrollutil::isCompatible %s %%W]} {
		    event generate [winfo toplevel %%W] %s \
			-rootx %%X -rooty %%Y
		    break
		}
	    } $event $event]
	} else {
	    ##nagelfar ignore
	    bind WheeleventRedir $event [format {
		if {![scrollutil::hasFocus %%W] ||
		    ![scrollutil::isCompatible %s %%W]} {
		    event generate [winfo toplevel %%W] %s \
			-rootx %%X -rooty %%Y -delta %%D
		    break
		}

#==============================================================================
# Main Scrollutil package module.
#
# Copyright (c) 2019-2024  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

package require -exact scrollutil::common 2.3.2

package provide scrollutil $::scrollutil::version
package provide Scrollutil $::scrollutil::version

::scrollutil::useTile 0

::scrollutil::sa::createBindings

    proc - {} { return [expr {$::tcl_version >= 8.5 ? "-" : ""}] }

    package require Tk 8.4[-]

    #
    # Public variables:
    #
    variable version	2.3.2
    variable library	[file dirname [file normalize [info script]]]

    #
    # Creates a new scrollarea/scrollsync/scrollableframe/pagesman widget:
    #
    namespace export	scrollarea scrollsync scrollableframe pagesman

    if {[catch {package present mwutil} version] == 0 &&
	[package vcompare $version 2.23] < 0} {
	package forget mwutil
    }
    package require mwutil 2.23[-]

    if {[catch {package present scaleutil} version] == 0 &&
	[package vcompare $version 1.14.1] < 0} {
	package forget scaleutil
    }
    package require scaleutil 1.14.1[-]
}
::scrollutil::loadUtils

#==============================================================================
# Main Scrollutil_tile package module.
#
# Copyright (c) 2019-2024  Csaba Nemethi (E-mail: [email protected])
#==============================================================================

package require -exact scrollutil::common 2.3.2

if {$::tk_version < 8.5 || [regexp {^8\.5a[1-5]$} $::tk_patchLevel]} {
    package require tile 0.6[::scrollutil::-]
}

package provide scrollutil_tile $::scrollutil::version
package provide Scrollutil_tile $::scrollutil::version