~q3cpma/haggle

5515fcedd5b81090381bd974e8830f25ae9c7693 — q3cpma 6 months ago c83e51a
Massive util.tcl update and subsequent adaption
6 files changed, 564 insertions(+), 128 deletions(-)

M README
M atom.tcl
M haggle.tcl
M test_regexp.tcl
M test_xpath.tcl
M util.tcl -rwxr-xr-x => -rw-r--r--
M README => README +1 -2
@@ 84,8 84,7 @@ $ cat catalog.tcllist
	{Shure SHR1540} https://www.woodbrass.com/casques-studio-fermes-shure-srh1540-p340698.html
}

# Tried with XPath, but tdom can't parse the HTML
{Amazon.fr regexp {^<span id="priceblock_ourprice" class="a-size-medium a-color-price priceBlockBuyingPriceString">([0-9]+)(,[0-9]+).€</span>$}
{Amazon.fr regexp {^<span id="price_inside_buybox" class="a-size-medium a-color-price">\s*([0-9]+),[0-9]+.€\s*</span>$}
	{Shure SHR1540} https://www.amazon.fr/Shure-SRH1540-construction-daluminium-oreillettes/dp/B00FR8DMR8
}
$ haggle.tcl catalog.tcllist

M atom.tcl => atom.tcl +8 -6
@@ 7,8 7,13 @@ source [file join $scriptdir util.tcl]


namespace eval atom {
	namespace import ::util::?
	namespace export create read read_or_create add_entry write
	namespace ensemble create

	variable xmlns http://www.w3.org/2005/Atom


	proc timestamp {} {
		clock format [clock seconds] -format %Y-%m-%dT%XZ -timezone :UTC
	}


@@ 51,14 56,14 @@ namespace eval atom {
		dict set atom xml $doc
		set root [$doc documentElement]
		add $doc $root title $title
		add $doc $root id [util::? {$id ne ""} $id file://$path]
		add $doc $root id [? {$id ne ""} {$id} {file://$path}]
		add $doc $root updated [timestamp]
		return $atom
	}

	proc read {path} {
		set atom [dict create path [file normalize $path] modified 0]
		set doc [dom parse [util::read_file $path]]
		set doc [dom parse [util::read_wrap $path]]
		dict set atom xml $doc
		dict set atom entry_count [llength [select_nodes $doc //atom:entry]]
		return $atom


@@ 76,7 81,7 @@ namespace eval atom {

	proc write {atom} {
		if {[dict get $atom modified]} {
			write_file [dict get $atom path] [[dict get $atom xml] asXML -indent 2]
			util::write_wrap [dict get $atom path] [[dict get $atom xml] asXML -indent 2]
		}
	}



@@ 109,7 114,4 @@ namespace eval atom {
		dict set atom modified 1
		[select_nodes $doc //atom:feed/atom:updated/text()] nodeValue $timestamp
	}

	namespace export create read read_or_create add_entry write
	namespace ensemble create
}

M haggle.tcl => haggle.tcl +32 -36
@@ 3,11 3,9 @@ package require tdom
set scriptdir [file dirname [file dirname \
								 [file normalize [file join [info script] dummy]]]]
source [file join $scriptdir atom.tcl]
source [file join $scriptdir util.tcl]
namespace path {::tcl::mathop ::tcl::mathfunc}

if {![util::executable_check curl]} {
	die "curl executable not found"
if {[util::exec_check curl]} {
	util::die "curl executable not found"
}




@@ 39,6 37,7 @@ proc get_price {url noproxy method arg} {
	set html [curl --no-progress-meter {*}[util::? $noproxy {-x ""}] $url]
	switch $method {
		regexp {
			set result {}
			regexp -line $arg $html -> result
		}
		xpath {


@@ 49,7 48,7 @@ proc get_price {url noproxy method arg} {
	if {[string is list $result] && [llength $result] > 1} {
		error "Extraction returned more than one element (result: $result)"
	}
	if {![string is double $result]} {
	if {![string is double -strict $result]} {
		error "Extraction didn't return a number (result: $result)"
	}
	return [double $result]


@@ 57,45 56,42 @@ proc get_price {url noproxy method arg} {


# Option and argument handling
util::autocli usage opts \
    [file tail [info script]] \
    "monitor online prices" \
    "\[OPTIONS\] CATALOG" \
    {
        "Read product data from CATALOG, a file containing a Tcl list using"
		"the following syntax:"
		"   {SHOP ?noproxy? METHOD METHOD_ARG ?PRODUCT URL ...?} ..."
		"Everything between a # and a newline is ignored."
		""
		"For each PRODUCT, the corresponding URL is downloaded and the"
		"extraction method applied with its argument on the body to produce"
		"the price."
		""
		"Thus the lowest price for PRODUCT is found across the whole CATALOG"
		"and if a change is detected compared to the last run, an Atom entry"
		"is written into a designated feed."
		""
        "The files for the Atom feed and database holding the price stats are"
		" created next to the given CATALOG."
		""
		"Available methods are:"
		" * xpath:  XPath query"
		" * regexp: Tcl regexp's first capturing group of the first match"
    } \
    {proxy {param "" PROXY_URL "Set the curl HTTP/HTTPS proxy."}}
set optres [util::autocli \
	{proxy  {param {}   PROXY_URL {Set the curl HTTP/HTTPS proxy.}}} \
	[file tail [info script]] \
	{monitor online prices} \
	CATALOG \
	{
		{Read product data from CATALOG, a file containing a Tcl list using the following syntax:}
		{    {SHOP ?noproxy? METHOD METHOD_ARG ?PRODUCT URL ...?} ...}
		{    # Comment}
		{}
		{For each PRODUCT, the corresponding URL is downloaded and the extraction method applied
		 with its argument on the body to produce the price.}
		{}
		{Thus the lowest price for PRODUCT is found across the whole CATALOG and if a change is
		 detected compared to the last run, an Atom entry is written into a designated feed.}
		{}
        {The files for the Atom feed and database holding the price stats are created next to the
		 given CATALOG.}
		{}
		{Available methods are:}
		{    xpath:\xa0 XPath query}
		{    regexp: regexp first capturing group of the first match}
	}]

if {![util::shift catalog_path]} {
    die $usage
    util::die [util::usage]
}

dict assign $opts
dict assign $optres
if {$proxy ne ""} {
	set ::env(http_proxy)  $proxy
	set ::env(https_proxy) $proxy
}


set catalog [remove_comments [util::read_file $catalog_path]]
set catalog [remove_comments [util::read_wrap $catalog_path]]
if {![string is list $catalog]} {
    die "$catalog_path: does not contain a Tcl list"
}


@@ 105,7 101,7 @@ set feed [atom read_or_create $feed_path "Haggle - price monitoring"]

set pricesdb_path [file join $datadir_path pricesdb.tcldict]
if {[file exists $pricesdb_path]} {
	set pricesdb [util::read_file $pricesdb_path]
	set pricesdb [util::read_wrap $pricesdb_path]
	if {![string is list $pricesdb] || [llength $pricesdb] % 2} {
		die "$pricesdb_path: does not contain a Tcl dict"
	}


@@ 198,5 194,5 @@ dict for {product val} $prices {
	}
}

util::write_file $pricesdb_path $pricesdb
util::write_wrap $pricesdb_path $pricesdb
atom write $feed

M test_regexp.tcl => test_regexp.tcl +3 -3
@@ 4,11 4,11 @@ set scriptdir [file dirname [file dirname \
source [file join $scriptdir util.tcl]

if {$argc != 2} {
	die "Usage: [file tail [info script]] HTML_PATH XPATH_QUERY"
	util::die "Usage: [file tail [info script]] HTML_PATH XPATH_QUERY"
}
shift path regexp
util::shift path regexp

regexp -line $regexp [read_file $path] -> result
regexp -line $regexp [util::read_wrap $path] -> result
if {[info exists result]} {
	puts "\"$result\""
} else {

M test_xpath.tcl => test_xpath.tcl +3 -3
@@ 5,9 5,9 @@ set scriptdir [file dirname [file dirname \
source [file join $scriptdir util.tcl]

if {$argc != 2} {
	die "Usage: [file tail [info script]] HTML_PATH XPATH_QUERY"
	util::die "Usage: [file tail [info script]] HTML_PATH XPATH_QUERY"
}
shift path xpath
util::shift path xpath

dom parse -html [read_file $path] doc
dom parse -html [util::read_wrap $path] doc
puts "\"[[$doc documentElement] selectNodes $xpath]\""

M util.tcl => util.tcl +517 -78
@@ 1,18 1,62 @@
                               ##################
							   # Misc utilities #
							   ##################
namespace eval util {
	source [file join [info library] init.tcl]
	catch {package require Tclx}
	namespace path {::tcl::mathop ::tcl::mathfunc}
	namespace export *

                               ##################
                               # Misc utilities #
                               ##################

	# Source that that only applies once for each file
	variable sourced [dict create]
	proc source_once {path} {
		variable sourced
		set normpath [file normalize $path]
		if {![dict exists $sourced $normpath]} {
			uplevel 1 [list ::source $path]
			dict set sourced $normpath {}
		}
	}

	# Identity
	proc id {x} {string cat $x}
	proc id {x} {
		string cat $x
	}

	# Explicit
	proc decr {_x {decrement 1}} {upvar $_x x; incr x -$decrement}
	proc decr {_x {decrement 1}} {
		upvar $_x x
		incr x -$decrement
	}

	proc until {test body} {
		uplevel 1 [list while !($test) $body]
	}

	# Random integer in range [0, max[
	proc irand {max} {
		int [* [rand] $max]
	}

	proc do {body keyword test} {
		if {$keyword eq "while"} {
			set test "!($test)"
		} elseif {$keyword ne "until"} {
			return -code error "unknown keyword \"$keyword\": must be until or while"
		}
		set cond [list expr $test]
		while 1 {
			uplevel 1 $body
			if {[uplevel 1 $cond]} {
				break
			}
		}
		return
	}

	# Ternary; caution, evals both a and b regardless of the return value
	proc ? {expr a {b ""}} {
		tailcall if $expr [list string cat $a] else [list string cat $b]
	# Ternary; properly quote variables/command substs to avoid surprises
	proc ? {test a {b {}}} {
		tailcall if $test [list subst $a] [list subst $b]
	}

	# Like shift(1) but assign the shift values to args


@@ 34,69 78,236 @@ namespace eval util {
		exit $code
	}

	# All-in-one CLI creation. Sets a pretty help notice and parses argv
	# Execute body every ms milliseconds or cancel an existing every
	proc every {ms body} {
		global every tcl_interactive
		if {$ms eq "cancel"} {
			after cancel [dict get $every $body]
			dict unset every $body
			return
		}
		eval $body
		dict set every $body [namespace code [info level 0]]
		tailcall after $ms [namespace code [info level 0]]
	}

	# Like textutil::adjust followed by textutil::indent with the following
	# differences :
	# * Add terminal markup and handles it properly (don't count the ECMA sequences in text width).
	# * Use textutil::wcswidth is text isn't ASCII.
	#
	# args is a dict with the following optional key/values (otherwise, defaults are used):
	# * markup  Dict with the keys: {bold dim underline blink reverse strike}
	#           and the markup string delimiter, or list of two strings for
	#           different start/end delimiters as value.
	# * indent  How many spaces of indentation.
	# * width   Desired printing width.
	# * dumb    Strip markup without translating it (mostly for when stdout
	#           isn't a tty).
	#
	# ToDo: add color?
	proc format_paragraph {text args} {
		time {set opts [dict merge \
					  [dict create \
						   markup {
							   bold      **
							   dim       {}
							   underline __
							   blink     {}
							   reverse   !!
							   strike    --} \
						   indent 0 \
						   width 80 \
						   dumb 0] \
					  $args]
			dict assign $opts} 1
		if {![string is ascii text] && ![catch {package require textutil}] &&
			![catch {package present textutil::wcswidth}]} {
			interp alias {} textwidth {} ::textutil::wcswidth
		} else {
			interp alias {} textwidth {} ::tcl::string::length
		}

		if {!$dumb} {
			# cf ECMA-48 SGR
			set codes [dict create \
						   bold      [dict create 1 \x1b\[1m 0 \x1b\[22m] \
						   dim       [dict create 1 \x1b\[2m 0 \x1b\[22m] \
						   underline [dict create 1 \x1b\[4m 0 \x1b\[24m] \
						   blink     [dict create 1 \x1b\[5m 0 \x1b\[25m] \
						   reverse   [dict create 1 \x1b\[7m 0 \x1b\[27m] \
						   strike    [dict create 1 \x1b\[9m 0 \x1b\[29m]]
			# Escape subst sensitive characters
			set map {[ \\[ $ \\$}
			# Create a map to modify state and emit corresponsing sequence for each symbol
			set state [dict map {key val} $markup {id 0}]
			dict for {attr sym} $markup {
				switch [llength $sym] {
					0 {}
					1 {
						lappend map $sym
						lappend map "\[if {\[dict get \$state $attr\]} {
										   dict set state $attr 0
										   dict get \$codes $attr 0
									   } else {
										   dict set state $attr 1
										   dict get \$codes $attr 1
									   }\]"
					}
					2 {
						lappend map [lindex $sym 0]
						lappend map "\[dict set state $attr 1
									   dict get \$codes $attr 1\]"
						lappend map [lindex $sym 1]
						lappend map "\[dict set state $attr 0
									   dict get \$codes $attr 0\]"
					}
					default {error "$sym: invalid markup item"}
				}
			}
			set text [subst [string map $map $text]]
			dict for {key val} $state {
				if {$val == 1} {
					error "Unclosed $key attr sequence"
				}
			}
		} else {
			dict for {attr sym} $markup {
				switch [llength $sym] {
					0 {}
					1 {lappend map $sym {}}
					2 {lappend map [lindex $sym 0] {} [lindex $sym 1] {}}
					default {error "$sym: invalid markup item"}
				}
			}
			set text [string map $map $text]
		}

		set ret {}
		set line {}
		set linelen $width; # Force line break case in first loop iter
		foreach word [regexp -all -inline {[^\t\n ]+} $text] {
			set wordlen [textwidth [regsub -all {\x1b\[\d{1,2}m} $word {}]]
			if {$linelen + $wordlen > $width} {
				if {$line ne ""} { # Not first line
					append ret $line\n
				}
				set line [string repeat " " $indent]$word
				set linelen [+ $indent $wordlen]
			} else {
				append line " $word"
				incr linelen [+ $wordlen 1]
			}
		}
		append ret $line
		interp alias {} textwidth {}
		return $ret
	}

	# All-in-one CLI creation. Sets a pretty usage proc and parses argv
	# according to flag/parametric options of the form "-opt ?param?".
	#
	# _help: variable to store the help.
	# _optres: variable to store the option parsing result. Same form as
	#          optspec but with values filled by the passed or default
	#          value. Flag value is 1 if found, 0 otherwise.
	# name: executable name.
	# short_descr: description in a few words.
	# synopsis: what comes after the executable name in the usual man(1) format.
	# long_descr: optional long description in the form of list of lines.
	# optspec: dict of the form {key val} with
	#     key: option name without starting dash
	#     val: either {"flag" ?optdescr_line ...?}
	#                   or
	#                 {"param" default_value ?val_name optdescr_line ...?}
	# optspec      Dict with:
	#                  key  Option name without starting dash.
	#                  val  {"flag" ?optdescr_par ...?}
	#                           or
	#                       {"param" default_value ?val_name optdescr_par ...?}
	# name         Progam name.
	# short_descr  Description in a few words.
	# synargslist  Synopsis arguments lists (for multiple synopsis). Must use
	#              the traditional [] and ... notation for optional and
	#              multiple arguments to get automatic markup.
	# long_descr   Optional long description as a list of (possibly indented) paragraphs.
	#
	# Modify argv and argc to only leave the arguments. Returns nothing.
	proc autocli {_help _optres name short_descr synopsis {long_descr ""} optspec} {
		upvar $_help help $_optres result
	# Modify argv and argc to only leave the arguments.
	# Create a usage proc in this namespace to get the help message as a string.
	# Returns the parsed options in the same form as optspec but with values filled with
	# the parsed value or specified default. Flag value is 1 if found, 0 otherwise.
	proc autocli {optspec name short_descr synargslist {long_descr ""}} {
		global argv argc

		set help "NAME\n    $name - $short_descr\n"
		append help "\nSYNOPSIS\n    $name $synopsis\n"
		if {$long_descr ne ""} {
			append help "\nDESCRIPTION\n"
			append help [join [lmap x $long_descr {id "    $x"}] \n]
			append help \n
		set body [join [list [list set optspec $optspec] \
					  [list set name $name] \
					  [list set short_descr $short_descr] \
					  [list set synargslist $synargslist] \
					  [list set long_descr $long_descr]] \
				 \n]
		append body {
			set tabw 4
			set printw [min [array unset ::env COLUMNS; ::util::read_wrap "|tput cols" rb] 80]
			set opts [dict create \
						  width $printw \
						  dumb [? {[package present Tclx]} {[! [fstat stdout tty]]} 0] \
						 ]
			append msg [format_paragraph **NAME** {*}$opts]\n
			append msg [format_paragraph "$name - $short_descr" indent $tabw {*}$opts]\n
			append msg \n
			append msg [format_paragraph **SYNOPSIS** {*}$opts]\n
			set synindent [+ [string length $name] $tabw 1]
			set synopts {}
			foreach synargs $synargslist {
				append msg "[format_paragraph "**$name**" indent $tabw {*}$opts] "
				if {$optspec ne ""} {
					set synargs "\[OPTION\]... $synargs"
				}
				regsub -all {\w+}  $synargs {__&__} synargs
				regsub -all {[][]} $synargs {**&**} synargs
				append msg [string trimleft [format_paragraph $synargs indent $synindent {*}$opts]]\n
			}
			append msg \n
			if {$long_descr ne ""} {
				append msg [format_paragraph **DESCRIPTION** {*}$opts]\n
				foreach par $long_descr {
					if {$par eq ""} {
						append msg \n
						continue
					}
					set indent [+ [string length {*}[regexp -inline { +} $par]] $tabw]
					append msg [format_paragraph $par indent $indent {*}$opts]\n
				}
			}
			append msg \n
			append msg [format_paragraph **OPTIONS** {*}$opts]\n
			dict set optspec help {flag "Print this help message and exit."}
			dict for {key val} $optspec {
				if {[lindex $val 0] eq "flag"} {
					append msg [format_paragraph "**-$key**" indent $tabw {*}$opts]\n
					foreach par [lrange $val 1 end] {
						append msg [format_paragraph $par indent [* $tabw 2] {*}$opts]\n
					}
				} else {
					set par "**-$key**[? {[llength $val] >= 4} { __[lindex $val 2]__}]"
					append msg [format_paragraph $par indent $tabw {*}$opts]\n
					foreach par [lrange $val 3 end] {
						append msg [format_paragraph $par indent [* $tabw 2] {*}$opts]\n
					}
					if {[lindex $val 1] ne ""} {
						append msg [format_paragraph "Defaults to \"[lindex $val 1]\"." \
										indent [* $tabw 2] {*}$opts]\n
					}
				}
				append msg \n
			}
			return [string range $msg 0 end-1]; # Remove extraneous newline
		}
		append help "\nOPTIONS\n"
		append help "    -help\n"
		append help "        Print this help message and exit.\n"
		proc usage {} $body

		set result [dict create]
		# Validate and fill defaut values for result
		dict for {key val} $optspec {
			if {![string is list $val]} {
				error "$val: invalid optspec value for key $key; not a valid list"
			}
			set type [lindex $val 0]
			set vallen [llength $val]
			if {$type eq "flag"} {
				dict set result $key 0
				append help "\n    -$key\n"
				foreach line [lrange $val 1 end] {
					append help "        $line\n"
				}
			} elseif {$type eq "param"} {
				set vallen [llength $val]
				if {$vallen < 2} {
					error "$val: invalid optspec value for key $key; missing default value"
				}
				set default [lindex $val 1]
				dict set result $key $default
				append help "\n    -$key"
				if {$vallen >= 4} {
					append help " [lindex $val 2]"
				}
				append help \n
				foreach line [lrange $val 3 end] {
					append help "        $line\n"
				}
				if {$default ne ""} {
					append help "        Defaults to \"$default\".\n"
				}
			} else {
				error "$val: invalid optspec value for key $key; invalid opt type"
			}


@@ 105,7 316,7 @@ namespace eval util {
		while {[shift arg]} {
			switch -glob -nocase -- $arg {
				-- {break}
				-help {die $help 0}
				-help {die [usage] 0}
				-?* {
					set key [string range $arg 1 end]
					if {[dict get? $optspec val $key]} {


@@ 114,13 325,13 @@ namespace eval util {
							flag {dict set result $key 1}
							param {
								if {![shift param]} {
									die "option $arg requires a parameter\n\n$help"
									die "option $arg requires a parameter\n\n[usage]"
								}
								dict set result $key $param
							}
						}
					} else {
						die "$arg: unknown option\n\n$help"
						die "$arg: unknown option\n\n[usage]"
					}
				}
				default {


@@ 133,37 344,77 @@ namespace eval util {
		return $result
	}

						  ###########################
						  # Path and file utilities #
						  ###########################
                              ####################
                              # String utilities #
                              ####################

	# Split a string into block of size chars (last block can be of inferior size)
	proc block_split {str size} {regexp -inline -all ".{1,$size}" $str}

                          ###########################
                          # Path and file utilities #
                          ###########################

	# Check if name is available to be called via exec
	proc exec_check {name} {
		eq [auto_execok curl] {}
	}

	# Useful open/read/close wrapper
	proc read_file {path args} {
		if {[catch {open $path {*}$args} chan]} {
			die "$path: $chan"
		}
	proc read_wrap {path args} {
		set chan [open $path {*}$args]
		set result [read $chan]
		close $chan
		return $result
	}

	# Useful open/puts/close wrapper.
	proc write_file {path data args} {
		if {[catch {open $path {*}[? {$args eq ""} w $args]} chan]} {
			die "$path: $chan"
		}
	# Useful open/puts/close wrapper
	proc write_wrap {path data args} {
		set chan [open $path {*}[? {$args eq ""} w {$args}]]
		puts $chan $data
		close $chan
	}

	# Check if a binary can be found by the sh(1)/exec[lv]p(3).
	proc executable_check {exename} {
		! [catch [list exec sh -c [list command -v $exename] >/dev/null]]
	# Remove some forbidden/annoying characters from str when used as POSIX
	# path component
	proc path_sanitize {str {repl _}} {
		regsub -all {[\x0-\x1f/]} $str $repl
	}

	# Explicit
	proc is_dir_empty {path} {
		if {![file isdirectory $path]} {
			error "$path: not a directory"
		}
		= [llength [glob -nocomplain -tails -directory $path * .*]] 2
	}

							   ##################
							   # List utilities #
							   ##################
	# glob wrapper sorting by mtime
	proc glob_mtime {args} {
		lmap x [lsort -integer -index 0 \
					[lmap x [glob {*}$args] {list [file mtime $x] $x}]] \
			{lindex $x 1}
	}

	# Rename all the files in dir according to their mtime
	proc rename_mtime {{dir .}} {
		set paths [glob_mtime -directory $dir *]
		set fmt %0[string length [llength $paths]]u
		foreach path $paths {
			incr count
			set target [file join $dir [format $fmt $count][file extension $path]]
			file rename -force -- $path $target
		}
	}

                               ##################
                               # List utilities #
                               ##################

	# Like lmap, but expr is used as an if argument to filter values
	proc lfilter {var lst test} {
		tailcall lmap $var $lst [list if $test [list set $var] else continue]
	}

	# Opposite of lappend
	proc lprepend {_lst args} {


@@ 172,16 423,54 @@ namespace eval util {
		set lst [linsert $lst [set lst 0] {*}$args]
	}

							   ##################
							   # Dict utilities #
							   ##################
	# Create a sequence of num elements, starting from start and with step
	# as difference between an element and its predecessor
	proc iota {num {start 0} {step 1}} {
		set res {}
		set end [+ $start [* $num $step]]
		for {set n $start} {$n != $end} {incr n $step} {
			lappend res $n
		}
		return $res
	}

	# incr on a list item
	proc lincr {_lst index {increment 1}} {
		upvar $_lst lst
		lset lst $index [+ [lindex $lst $index] $increment]
	}

	# lassign _lst and set it to the result immediately; returns nothing
	proc lshift {_lst args} {
		uplevel "set [list $_lst] \[lassign \$[list $_lst] $args\]"
	}

	# Append suffix to all the elements of list and return the resulting list
	proc lsuffix {lst suffix} {
		lmap x $lst {id $x$suffix}
	}

	# Prepend prefix to all the elements of list and return the resulting list
	proc lprefix {lst prefix} {
		lmap x $lst {id $prefix$x}
	}

	# Fast inplace lreplace
	proc lreplaceip {_list args} {
		upvar 1 $_list list
		set list [lreplace $list[set list {}] {*}$args]
	}

                               ##################
                               # Dict utilities #
                               ##################

	# Conditional dict get, sets _var only if the key is to be found in dict.
	# Returns 1 if it was found, 0 otherwise.
	proc ::tcl::dict::get? {dict _var args} {
		::upvar $_var var
		if {[dict exists $dict {*}$args]} {
			::set var [dict get $dict {*}$args]
		if {[exists $dict {*}$args]} {
			::set var [get $dict {*}$args]
			return 1
		}
		return 0


@@ 207,9 496,159 @@ namespace eval util {
		}
	}

	# dict incr with support for nested dictionaries that only incr by 1
	proc ::tcl::dict::incrn {dict args} {
		upvar 1 $dict d
		try {
			set d {*}$args [+ [get $d {*}$args] 1]
		} on error {} {
			set d {*}$args 1
		}
	}

	# Like dict::incrn but with a specified increment instead of 1
	proc ::tcl::dict::add {dict args} {
		upvar 1 $dict d
		::set keys [::lrange $args 0 end-1]
		::set addarg [::lindex $args end]
		try {
			set d {*}$keys [+ [get $d {*}$keys] $addarg]
		} on error {} {
			set d {*}$keys $addarg
		}
	}

	namespace ensemble configure dict -map \
		[linsert [namespace ensemble configure dict -map] end \
			 get?    ::tcl::dict::get? \
			 assign  ::tcl::dict::assign \
			 appendn ::tcl::dict::appendn]
			 appendn ::tcl::dict::appendn \
			 incrn   ::tcl::dict::incrn \
			 add     ::tcl::dict::add]

                              ####################
                              # Binary utilities #
                              ####################

	# Print byte range as space separated hex values
	proc hex_bytes {bytes {offset 0} {count *}} {
		binary scan $bytes @${offset}cu$count hex
		join [lmap x $hex {format %02x $x}]
	}

	# Compute and store in _cursor the new cursor position according to fmt
	# end is the binary string length (for counts '*')
	proc ::tcl::binary::update_cursor {fmt _cursor end} {
		namespace path ::tcl::mathop
		upvar $_cursor cursor

		set atom_re {[aAbBHhcsStiInwWmfrRdqQxX@]u?(?:[0-9]+)?(?= *)}
		foreach atom [regexp -all -inline $atom_re $fmt] {
			set 1 [string index $atom 0]
			set 2 [string index $atom 1]
			switch [string length $atom] {
				1 {set count 1}
				2 {set count [util::? {$2 eq "u"} 1 $2]}
				default {set count [string range $atom [util::? {$2 eq "u"} 2 1] end]}
			}
			if {$count eq "*"} {
				set cursor $end
				continue
			}
			switch $1 {
				a -
				A -
				h -
				H -
				c -
				C {incr cursor $count}
				s -
				S -
				t {incr cursor [* $count 2]}
				i -
				I -
				n -
				f -
				r -
				R {incr cursor [* $count 4]}
				w -
				W -
				m -
				d -
				q -
				Q {incr cursor [* $count 8]}
				b -
				B {incr cursor [/ [+ $count 7] 8]}
				x {incr cursor $count}
				X {incr cursor -$count}
				@ {set cursor $count}
			}
		}
	}

	if {[info commands ::tcl::binary::_scan] eq ""} {
		rename ::tcl::binary::scan ::tcl::binary::_scan
	}

	# New binary scan with the following features:
	# * if fmt starts with ">", read the last argument as an offset variable and
	#   use it as starting cursor value
	# * if fmt ends with ">", read the last argument as an offset variable and
	#   write the last cursor position in it
	proc ::tcl::binary::scan {str fmt args} {
		set rd [string equal [string index $fmt 0] >]
		set wr [string equal [string index $fmt end] >]
		if {$rd || $wr} {
			::upvar [lindex $args end] cursor
			::util::lreplaceip args end end
		}
		if {$rd} {
			set fmt @$cursor[string range $fmt 1 end]
		}
		if {$wr} {
			set fmt [string range $fmt 0 end-1]
			update_cursor $fmt cursor [string length $str]
		}
		tailcall _scan $str $fmt {*}$args
	}

                             ######################
                             # Terminal utilities #
                             ######################

	if {[package present Tclx]} {
		variable tput_cache [dict create]

		signal trap SIGWINCH {
			# stty -f on some BSDs
			lassign [exec stty -F /dev/tty size] lines cols
			dict set ::util::tput_cache lines $lines
			dict set ::util::tput_cache cols $cols
		}
		kill SIGWINCH [pid]

		# tput wrapper with memoization
		proc tput {args} {
			variable tput_cache
			if {![dict get? $tput_cache res $args]} {
				set res [::util::read_wrap "|tput $args" rb]
				dict set tput_cache $args $res
			}
			return $res
		}

		# Like above, but allows for multiple arguments
		proc tputm {args} {
			variable tput_cache
			set res {}
			foreach arg $args {
				if {![dict get? $tput_cache val $arg]} {
					set val [::util::read_wrap "|tput $arg" rb]
					dict set tput_cache $arg $val
				}
				append res $val
			}
			return $res
		}
	}
}