~q3cpma/haggle

35a536c144b2eb77377851282210f8d58d489b1a — q3cpma 4 months ago 5515fce master 1.0.0
Sync util.tcl and use it (exec_require, atexit, is_dict, dict lappendn)
2 files changed, 159 insertions(+), 92 deletions(-)

M haggle.tcl
M util.tcl
M haggle.tcl => haggle.tcl +27 -24
@@ 3,10 3,7 @@ package require tdom
set scriptdir [file dirname [file dirname \
								 [file normalize [file join [info script] dummy]]]]
source [file join $scriptdir atom.tcl]

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


set USER_AGENT {Mozilla/5.0 (Windows NT 6.1; WOW64; rv:54.0) Gecko/20100101 Firefox/54.0}


@@ 14,6 11,7 @@ set USER_AGENT {Mozilla/5.0 (Windows NT 6.1; WOW64; rv:54.0) Gecko/20100101 Fire
# Wrapper to set common curl options
proc curl {args} {
	global USER_AGENT

	exec -ignorestderr curl \
		--compressed \
		--connect-timeout 5 \


@@ 33,7 31,7 @@ proc remove_comments str {
# Try to get the price at url, produce an error if curl does or the
# extraction doesn't return a singular floating point number
proc get_price {url noproxy method arg} {
	puts "Downloading $url..."
	puts stderr "Downloading $url..."
	set html [curl --no-progress-meter {*}[util::? $noproxy {-x ""}] $url]
	switch $method {
		regexp {


@@ 57,7 55,7 @@ proc get_price {url noproxy method arg} {

# Option and argument handling
set optres [util::autocli \
	{proxy  {param {}   PROXY_URL {Set the curl HTTP/HTTPS proxy.}}} \
	{proxy  {param {} PROXY_URL {Set the curl HTTP/HTTPS proxy.}}} \
	[file tail [info script]] \
	{monitor online prices} \
	CATALOG \


@@ 93,21 91,29 @@ if {$proxy ne ""} {

set catalog [remove_comments [util::read_wrap $catalog_path]]
if {![string is list $catalog]} {
    die "$catalog_path: does not contain a Tcl list"
    util::die "$catalog_path: does not contain a Tcl list"
}
set datadir_path [file normalize [file dirname $catalog_path]]
set datadir_path [file dirname $catalog_path]
set feed_path [file join $datadir_path haggle.xml]
set feed [atom read_or_create $feed_path "Haggle - price monitoring"]
util::atexit add {
	global feed
	atom write $feed
}

set pricesdb_path [file join $datadir_path pricesdb.tcldict]
if {[file exists $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"
set pricedb_path [file join $datadir_path pricedb.tcldict]
if {[file exists $pricedb_path]} {
	set pricedb [util::read_wrap $pricedb_path]
	if {![util::is_dict $pricedb]} {
		util::die "$pricedb_path: does not contain a Tcl dict"
	}

} else {
	set pricesdb [dict create]
	set pricedb [dict create]
}
util::atexit add {
	global pricedb_path pricedb
	util::write_wrap $pricedb_path $pricedb
}

# Gather the minimum price per product across shops


@@ 152,14 158,14 @@ foreach shop_list $catalog {
# Atom entries have the URL of the current lowest price as link value
dict for {product val} $prices {
	lassign $val min shop url
	if {[dict get? $pricesdb data $product]} {
	if {[dict get? $pricedb data $product]} {
		dict assign $data
		set prev_min [lindex [lindex $min_hist end] 0]
		if {$min != $prev_min} {
			if {$min < $prev_min} {
				if {$min < $all_time_low} {
					set all_time_low $min
					dict set pricesdb $product all_time_low $all_time_low
					dict set pricedb $product all_time_low $all_time_low
				}
				atom add_entry feed "$product: price decrease" \
					content \


@@ 172,7 178,7 @@ dict for {product val} $prices {
			} else {
				if {$min > $all_time_high} {
					set all_time_high $min
					dict set pricesdb $product all_time_high $all_time_high
					dict set pricedb $product all_time_high $all_time_high
				}
				atom add_entry feed "$product: price increase" \
					content \


@@ 183,16 189,13 @@ dict for {product val} $prices {
						 <br>] \
					link $url
			}
			dict appendn pricesdb $product min_hist \
			dict lappendn pricedb $product min_hist \
				[list $min [clock seconds] $shop]
		}
	} else {
		dict set pricesdb $product all_time_low $min
		dict set pricesdb $product all_time_high $min
		dict appendn pricesdb $product min_hist \
		dict set pricedb $product all_time_low $min
		dict set pricedb $product all_time_high $min
		dict lappendn pricedb $product min_hist \
			[list $min [clock seconds] $shop]
	}
}

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

M util.tcl => util.tcl +132 -68
@@ 1,6 1,7 @@
namespace path {::tcl::mathop ::tcl::mathfunc}

namespace eval util {
	source [file join [info library] init.tcl]
	catch {package require Tclx}
	namespace path {::tcl::mathop ::tcl::mathfunc}
	namespace export *



@@ 8,16 9,52 @@ namespace eval util {
                               # 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 {}
	# Detect if a channel is a tty
	proc ::tcl::chan::isatty {chan} {
		::tcl::mathop::! [::catch {chan configure $chan -mode}]
	}

	namespace ensemble configure chan -map \
		[linsert [namespace ensemble configure chan -map] end \
			 isatty ::tcl::chan::isatty]

	# Add/delete scripts to run when exiting (incl. calls to exit and error)
	# Syntax is `atexit add|del script`, scripts are run in the global namespace
	#
	# Example:
	#     util::atexit add {puts "hello world"}
	#     util::atexit add {puts [clock format [clock seconds]]}
	#     util::atexit add {global env; puts "env: $env(HOME)"}
	#     util::atexit del {puts "hello world"}
	#
	# will print
	#     Wed Jul 14 14:27:58 CEST 2021
	#     env: /home/user
	#
	# when reaching the end
	variable atexit_scripts {}
	proc atexit {action script} {
		variable atexit_scripts

		switch $action {
			add {
				lappend atexit_scripts $script
			}
			del {
				set idx [lsearch -exact $atexit_scripts $script]
				set atexit_scripts [lreplace $atexit_scripts $idx $idx]
			}
			default {
				error "$action: must be \"add\" or \"del\""
			}
		}
		return
	}
	trace add execution exit enter [list apply \
		[list args \
			 "foreach script \$util::atexit_scripts {eval \$script}" \
			] \
		]

	# Identity
	proc id {x} {


@@ 237,7 274,7 @@ namespace eval util {
			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] \
						  dumb  [! [chan isatty stdout]] \
						 ]
			append msg [format_paragraph **NAME** {*}$opts]\n
			append msg [format_paragraph "$name - $short_descr" indent $tabw {*}$opts]\n


@@ 262,7 299,7 @@ namespace eval util {
						append msg \n
						continue
					}
					set indent [+ [string length {*}[regexp -inline { +} $par]] $tabw]
					set indent [+ [string length [regexp -inline {^ +} $par]] $tabw]
					append msg [format_paragraph $par indent $indent {*}$opts]\n
				}
			}


@@ 290,6 327,7 @@ namespace eval util {
			}
			return [string range $msg 0 end-1]; # Remove extraneous newline
		}
		# Create a usage proc instead of generating the usage string to reduce startup latency
		proc usage {} $body

		set result [dict create]


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


@@ 355,9 393,11 @@ namespace eval util {
                          # Path and file utilities #
                          ###########################

	# Check if name is available to be called via exec
	proc exec_check {name} {
		eq [auto_execok curl] {}
	# Die if executable `name` isn't available
	proc exec_require {name} {
		if {[auto_execok $name] eq ""} {
			die "$name: executable not found"
		}
	}

	# Useful open/read/close wrapper


@@ 386,7 426,7 @@ namespace eval util {
		if {![file isdirectory $path]} {
			error "$path: not a directory"
		}
		= [llength [glob -nocomplain -tails -directory $path * .*]] 2
		== [llength [glob -nocomplain -tails -directory $path * .*]] 2
	}

	# glob wrapper sorting by mtime


@@ 416,6 456,17 @@ namespace eval util {
		tailcall lmap $var $lst [list if $test [list set $var] else continue]
	}

	# Traditional FP foldl, args contains the command to run on accumulator and element
	# Examples:
	#     lfoldl {1 2 3} 0 +            => 6
	#     lfoldl {1 2 3} "" string cat  => 123
	proc lfoldl {lst init args} {
		foreach elem $lst {
			set init [uplevel 1 $args [list $init $elem]]
		}
		return $init
	}

	# Opposite of lappend
	proc lprepend {_lst args} {
		upvar $_lst lst


@@ 465,10 516,15 @@ namespace eval util {
                               # Dict utilities #
                               ##################

	# Check if str is a valid dict
	proc is_dict {str} {
		expr {[string is list $str] && [llength $str] % 2 == 0}
	}

	# 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
		upvar $_var var
		if {[exists $dict {*}$args]} {
			::set var [get $dict {*}$args]
			return 1


@@ 479,52 535,66 @@ namespace eval util {
	# Assign the dict values to key-named variables (with s/[ -]/_/g applied to
	# them).
	proc ::tcl::dict::assign {dict} {
		uplevel [list lassign [dict values $dict]] \
			[lmap s [dict keys $dict] {string map {- _ " " _} $s}]
		uplevel [list lassign [values $dict]] \
			[lmap s [keys $dict] {string map {- _ " " _} $s}]
	}

	# dict lappend with support for nested dictionaries while lappending
	# only one element
	proc ::tcl::dict::lappendn {_dict args} {
		upvar 1 $_dict d
		::set keys [::lrange $args 0 end-1]
		::set arg [::lindex $args end]
		try {
			set d {*}$keys [list {*}[get $d {*}$keys] $arg]
		} on error {} {
			set d {*}$keys [list $arg]
		}
	}

	# dict append with support for nested dictionaries while appending
	# only one element
	proc ::tcl::dict::appendn {dict args} {
		upvar 1 $dict d
	proc ::tcl::dict::appendn {_dict args} {
		upvar 1 $_dict d
		::set keys [::lrange $args 0 end-1]
		::set appdarg [::lindex $args end]
		::set arg [::lindex $args end]
		try {
			set d {*}$keys [list {*}[get $d {*}$keys] $appdarg]
			set d {*}$keys [string cat [get $d {*}$keys] $arg]
		} on error {} {
			set d {*}$keys [list $appdarg]
			set d {*}$keys $arg
		}
	}

	# dict incr with support for nested dictionaries that only incr by 1
	proc ::tcl::dict::incrn {dict args} {
		upvar 1 $dict d
	proc ::tcl::dict::incrn {_dict args} {
		upvar 1 $_dict d
		try {
			set d {*}$args [+ [get $d {*}$args] 1]
			set d {*}$args [::tcl::mathop::+ [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
	proc ::tcl::dict::add {_dict args} {
		upvar 1 $_dict d
		::set keys [::lrange $args 0 end-1]
		::set addarg [::lindex $args end]
		::set arg [::lindex $args end]
		try {
			set d {*}$keys [+ [get $d {*}$keys] $addarg]
			set d {*}$keys [::tcl::mathop::+ [get $d {*}$keys] $arg]
		} on error {} {
			set d {*}$keys $addarg
			set d {*}$keys $arg
		}
	}

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

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


@@ 599,8 669,8 @@ namespace eval util {
		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
			upvar [lindex $args end] cursor
			util::lreplaceip args end end
		}
		if {$rd} {
			set fmt @$cursor[string range $fmt 1 end]


@@ 616,39 686,33 @@ namespace eval util {
                             # Terminal utilities #
                             ######################

	if {[package present Tclx]} {
		variable tput_cache [dict create]
	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
	# tput wrapper with memoization
	proc tput {args} {
		variable tput_cache
		if {$args in {lines cols}} {
			set res [::util::read_wrap "|tput $args" rb]
		} elseif {![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
	# Like above, but allows for multiple arguments
	proc tputm {args} {
		variable tput_cache
		set res {}
		foreach arg $args {
			if {$arg in {lines cols}} {
				set val [::util::read_wrap "|tput $arg" rb]
			} elseif {![dict get? $tput_cache val $arg]} {
				set val [::util::read_wrap "|tput $arg" rb]
				dict set tput_cache $arg $val
			}
			return $res
			append res $val
		}
		return $res
	}
}