Artifact Content

Not logged in

Artifact c9236f473fd11165799f4a1d1d6ae5e93be788a868630df2d3c3f740f4773030:


# -*- tcl -*- Copyright (c) 2012-2018 Andreas Kupries
# # ## ### ##### ######## ############# #####################
## Path utility commands.

namespace eval ::kettle::path {
    namespace export {[a-z]*}
    namespace ensemble create

    # unable to import kettle::option, circular dependency
    namespace import ::kettle::io
    namespace import ::kettle::status
}

# # ## ### ##### ######## ############# #####################
## API commands.

proc ::kettle::path::norm {path} {
    # full path normalization
    return [file dirname [file normalize $path/__]]
}

proc ::kettle::path::strip {path prefix} {
    return [file join \
		{*}[lrange \
			[file split [norm $path]] \
			[llength [file split [norm $prefix]]] \
			end]]
}

proc ::kettle::path::relativecwd {dst} {
    relative [pwd] $dst
}

proc ::kettle::path::relativesrc {dst} {
    relative [sourcedir] $dst
}

proc ::kettle::path::relative {base dst} {
    # Modified copy of ::fileutil::relative (tcllib)
    # Adapted to 8.5 ({*}).
    #
    #	Taking two _directory_ paths, a base and a destination, computes the path
    #	of the destination relative to the base.
    #
    # Arguments:
    #	base	The path to make the destination relative to.
    #	dst	The destination path
    #
    # Results:
    #	The path of the destination, relative to the base.

    # Ensure that the link to directory 'dst' is properly done relative to
    # the directory 'base'.

    if {[file pathtype $base] ne [file pathtype $dst]} {
	return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
    }

    set base [norm $base]
    set dst  [norm $dst]

    set save $dst
    set base [file split $base]
    set dst  [file split $dst]

    while {[lindex $dst 0] eq [lindex $base 0]} {
	set dst  [lrange $dst  1 end]
	set base [lrange $base 1 end]
	if {![llength $dst]} {break}
    }

    set dstlen  [llength $dst]
    set baselen [llength $base]

    if {($dstlen == 0) && ($baselen == 0)} {
	# Cases:
	# (a) base == dst

	set dst .
    } else {
	# Cases:
	# (b) base is: base/sub = sub
	#     dst  is: base     = {}

	# (c) base is: base     = {}
	#     dst  is: base/sub = sub

	while {$baselen > 0} {
	    set dst [linsert $dst 0 ..]
	    incr baselen -1
	}
	set dst [file join {*}$dst]
    }

    return $dst
}

proc ::kettle::path::sourcedir {{path {}}} {
    return [norm [file join [kettle option get @srcdir] $path]]
}

proc ::kettle::path::script {} {
    return [norm [kettle option get @srcscript]]
}

proc ::kettle::path::libdir {{path {}}} {
    return [norm [file join [kettle option get --lib-dir] $path]]
}

proc ::kettle::path::bindir {{path {}}} {
    return [norm [file join [kettle option get --bin-dir] $path]]
}

proc ::kettle::path::incdir {{path {}}} {
    return [norm [file join [kettle option get --include-dir] $path]]
}

proc ::kettle::path::mandir {{path {}}} {
    return [norm [file join [kettle option get --man-dir] $path]]
}

proc ::kettle::path::htmldir {{path {}}} {
    return [norm [file join [kettle option get --html-dir] $path]]
}

proc ::kettle::path::set-executable {path} {
    io trace {	!chmod ugo+x   $path}
    dry-barrier
    catch {
	file attributes $path -permissions ugo+x
    }
    return
}

proc ::kettle::path::grep {pattern data} {
    return [lsearch -all -inline -glob [split $data \n] $pattern]
}

proc ::kettle::path::rgrep {pattern data} {
    return [lsearch -all -inline -regexp [split $data \n] $pattern]
}

proc ::kettle::path::fixhashbang {file shell} {
    dry-barrier

    set in [open $file r]
    gets $in line
    if {![string match "#!*tclsh*" $line]} {
	return -code error "No tclsh #! in $file"
    }

    io trace {	!fix hash-bang $shell}

    set   out [open ${file}.[pid] w]
    io puts $out "#!/usr/bin/env [norm $shell]"

    fconfigure $in  -translation binary -encoding binary
    fconfigure $out -translation binary -encoding binary
    fcopy $in $out
    close $in
    close $out

    file rename -force ${file}.[pid] $file
    return
}

proc ::kettle::path::add-top-comment {comment contents} {
    set r {}
    set done no
    foreach line [split $contents \n] {
	if {$done || [regexp "^\\s*\#.*$" $line]} {
	    lappend r $line
	    continue
	}
	lappend r $comment
	lappend r $line
	set done yes
    }
    join $r \n
}

proc ::kettle::path::tcl-package-file {file} {
    set contents   [c/z [cat $file]]
    set provisions [grep {*package provide *} $contents]
    if {![llength $provisions]} {
	return 0
    }

    io trace {    Testing: [relativesrc $file]}

    foreach line $provisions {
	io trace {        Candidate |$line|}
	if {[catch {
	    lassign $line cmd method pn pv
	}]} {
	    io trace {        * Not a list}
	    continue
	}
	if {$cmd ne "package"} {
	    io trace {        * $cmd: Not a 'package' command}
	    continue
	}
	if {$method ne "provide"} {
	    io trace {        * $method: Not a 'package provide' command}
	    continue
	}
	if {[catch {package vcompare $pv 0}]} {
	    io trace {        * $pkgver: Not a version number}
	    continue
	}
	if {[llength [rgrep {^\s*package\s+require\s+critcl} $contents]]} {
	    io trace {        * critcl required: Not pure Tcl}
	    continue
	}

	io trace {    Accepted: $pn $pv @ [relativesrc $file]}

	lappend files [relativesrc $file]
	set here [file dirname $file]

	# Look for referenced dependent files.
	foreach line [grep {* @owns: *} $contents] {
	    if {![regexp {#\s+@owns:\s+(.*)$} $line -> path]} continue
		lappend files \
		    [relativesrc \
			 [file normalize \
			      [file join $here [string trim $path]]]]
	}

	# For 'scan'.
	kettle option set @predicate [list $files $pn $pv]
	return 1
    }

    # No candidate satisfactory.
    return 0
}

proc ::kettle::path::critcl3-package-file {file} {
    set contents   [c/z [cat $file]]
    set provisions [grep {*package provide *} $contents]
    if {![llength $provisions]} {
	return 0
    }

    io trace {    Testing: [relativesrc $file]}

    foreach line $provisions {
	io trace {        Candidate |$line|}
	if {[catch {
	    lassign $line cmd method pn pv
	}]} {
	    io trace {        * Not a list}
	    continue
	}
	if {$cmd ne "package"} {
	    io trace {        * $cmd: Not a 'package' command}
	    continue
	}
	if {$method ne "provide"} {
	    io trace {        * $method: Not a 'package provide' command}
	    continue
	}
	if {[catch {package vcompare $pv 0}]} {
	    io trace {        * $pkgver: Not a version number}
	    continue
	}

	# Nearly accepted. Now check if this file asks for critcl.

	if {![llength [rgrep {package\s+require\s+critcl\s+3} $contents]]} {
	    io trace {        * critcl 3: Not required}
	    continue
	}

	io trace {    Accepted: $pn $pv @ [relativesrc $file]}

	# For 'scan'.
	kettle option set @predicate [list $file $pn $pv]
	return 1
    }

    # No candidate satisfactory.
    return 0
}

proc ::kettle::path::doctools-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # anti marker
    if {[regexp -- {--- !doctools ---}            $test]} { return 0 }
    if {[regexp -- "!tcl\.tk//DSL doctools//EN//" $test]} { return 0 }
    # marker
    if {[regexp "\\\[manpage_begin "             $test]} { return 1 }
    if {[regexp -- {--- doctools ---}            $test]} { return 1 }
    if {[regexp -- "tcl\.tk//DSL doctools//EN//" $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::diagram-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL diagram//EN//1.0} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::tcltest-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL tcltest//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::teapot-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL teapot//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::bench-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL tclbench//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::kettle-build-file {path} {
    set test [c/z [cathead $path 100 -translation binary]]
    # marker (no anti-markers)
    if {[regexp {kettle -f} $test]} { return 1 }
    return 0
}

proc ::kettle::path::foreach-file {path pv script} {
    upvar 1 $pv thepath

    set ex [kettle option get --ignore-glob]

    set known {}
    lappend waiting $path
    while {[llength $waiting]} {
	set pending $waiting
	set waiting {}
	set at 0
	while {$at < [llength $pending]} {
	    set current [lindex $pending $at]
	    incr at

	    # Do not follow into parent.
	    if {[string match *.. $current]} continue

	    # Ignore what we have visited already.
	    set c [file dirname [file normalize $current/___]]
	    if {[dict exists $known $c]} continue
	    dict set known $c .

	    # Ignore non-development files.
	    if {[Ignore $ex $c]} continue

	    # Expand directories.
	    if {[file isdirectory $c]} {
		lappend waiting {*}[lsort -unique [glob -directory $c * .*]]
		continue
	    }

	    # Handle files as per the user's will.
	    set thepath $current
	    switch -exact -- [catch { uplevel 1 $script } result] {
		0 - 4 {
		    # ok, continue - nothing
		}
		2 {
		    # return, abort, rethrow
		    return -code return
		}
		3 {
		    # break, abort
		    return
		}
		1 - default {
		    # error, any thing else - rethrow
		    return -code error $result
		}
	    }
	}
    }
    return
}

proc ::kettle::path::scan {label root predicate} {
    set nroot [sourcedir $root]

    io trace {}
    io trace {SCAN $label @ [relativesrc $nroot]}

    if {![file exists $nroot]} {
	io trace {  NOT FOUND}
	return -code return
    }

    set result {}
    foreach-file $nroot path {
	set spath [strip $path $nroot]

	# General checking, outside of the custom predicates.
	# Skip core files: core, and core.\d+

	set n [file tail $spath]
	if {$n eq "core" || [regexp {^core\.\d+$} $n]} {
	    io trace {    SKIP core dump: $spath}
	    continue
	}

	try {
	    kettle option unset @predicate
	    if {![uplevel 1 [list {*}$predicate $path]]} continue

	    io trace {    Accepted: $spath}

	    if {[kettle option exists @predicate]} {
		lappend result {*}[kettle option get @predicate]
	    } else {
		lappend result $spath
	    }
	} on error {e o} {
	    io err { io puts "    Skipped: [relativesrc $path] @ $e" }
	} finally {
	    kettle option unset @predicate
	}
    }

    if {![llength $result]} { return -code return }

    return [list $nroot $result]
}

proc ::kettle::path::tmpfile {{prefix tmp_}} {
    global tcl_platform
    return .kettle_$prefix[pid]_[clock seconds]_[clock milliseconds]_[info hostname]_$tcl_platform(user)
}

proc ::kettle::path::tmpdir {} {
    # Taken from tcllib fileutil.
    global tcl_platform env

    set attempdirs [list]
    set problems   {}

    foreach tmp {TMPDIR TEMP TMP} {
	if { [info exists env($tmp)] } {
	    lappend attempdirs $env($tmp)
	} else {
	    lappend problems "No environment variable $tmp"
	}
    }

    switch $tcl_platform(platform) {
	windows {
	    lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
	}
	macintosh {
	    lappend attempdirs $env(TRASH_FOLDER)  ;# a better place?
	}
	default {
	    lappend attempdirs \
		[file join / tmp] \
		[file join / var tmp] \
		[file join / usr tmp]
	}
    }

    lappend attempdirs [pwd]

    foreach tmp $attempdirs {
	if { [file isdirectory $tmp] &&
	     [file writable $tmp] } {
	    return [file normalize $tmp]
	} elseif { ![file isdirectory $tmp] } {
	    lappend problems "Not a directory: $tmp"
	} else {
	    lappend problems "Not writable: $tmp"
	}
    }

    # Fail if nothing worked.
    return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]"
}

proc ::kettle::path::ensure-cleanup {path} {
    ::atexit [lambda {path} {
	file delete -force $path
    } [norm $path]]
}

proc ::kettle::path::c/z {content} {
    return [lindex [split $content \x1A] 0]
}

proc ::kettle::path::cat {path args} {
    set c [open $path r]
    if {[llength $args]} { fconfigure $c {*}$args }
    set contents [read $c]
    close $c
    return $contents
}

proc ::kettle::path::cathead {path n args} {
    set c [open $path r]
    if {[llength $args]} { fconfigure $c {*}$args }
    set contents [read $c $n]
    close $c
    return $contents
}

proc ::kettle::path::write {path contents args} {
    set c [open $path w]
    if {[llength $args]} { fconfigure $c {*}$args }
    ::puts -nonewline $c $contents
    close $c
    return
}

proc ::kettle::path::write-append {path contents args} {
    set c [open $path a]
    if {[llength $args]} { fconfigure $c {*}$args }
    ::puts -nonewline $c $contents
    close $c
    return
}

proc ::kettle::path::write-prepend {path contents args} {
    set new [tmpfile tmp_prepend_]
    write-append $new $contents            {*}$args
    write-append $new [cat $path {*}$args] {*}$args

    file rename -force $new $path
    return
}

proc ::kettle::path::write-modify {path cmdprefix args} {
    set new [tmpfile tmp_modify_]
    write $new [{*}$cmdprefix [cat $path {*}$args]] {*}$args

    file rename -force $new $path
    return
}

proc ::kettle::path::copy-file {src dstdir} {
    # Copy single file into destination _directory_
    # Fails goal on an existing file.

    io puts -nonewline "\tInstalling file \"[file tail $src]\": "

    dry-barrier

    if {[catch {
	file mkdir $dstdir
	file copy $src $dstdir/[file tail $src]
    } msg]} {
	io err { io puts "FAIL ($msg)" }
	status fail "FAIL ($msg)"
    } else {
	io ok { io puts OK }
    }
}

proc ::kettle::path::copy-files {dstdir args} {
    # Copy multiple files into a destination _directory_
    # Fails goal on an existing file.
    foreach src $args {
	copy-file $src $dstdir
    }
    return
}

proc ::kettle::path::remove-path {base path} {
    # General uninstallation of a file or directory.

    io puts -nonewline "\tUninstalling \"[relative $base ${path}]\": "

    dry-barrier

    if {[catch {
	file delete -force $path
    } msg]} {
	io err { io puts "FAIL ($msg)" }
	status fail
    } else {
	io ok { io puts OK }
    }
}

proc ::kettle::path::remove-paths {base args} {
    # General uninstallation of multiple files.
    foreach path $args {
	remove-path $base $path
    }
    return
}

proc ::kettle::path::install-application {src dstdir} {
    # Install single-file application into destination _directory_.
    # a previously existing file is moved out of the way.

    set fname [file tail $src]
    io puts "Installing application \"$fname\""
    io puts "    Into [relativesrc $dstdir]"

    dry-barrier {
	# Simulated run, has its own dry-barrier.
	copy-file $src $dstdir
    }

    # Save existing file, if any.
    file delete -force $dstdir/${fname}.old
    catch {
	file rename $dstdir/${fname} $dstdir/${fname}.old
    }

    try {
	copy-file $src $dstdir
    } trap {KETTLE STATUS FAIL} {e o} {
	# Failed, restore previous, if any.
	catch {
	    file rename $dstdir/${fname}.old $dstdir/${fname}
	}
	return {*}$o $e
    }

    set-executable $dstdir/$fname
    return
}

proc ::kettle::path::install-script {src dstdir shell {cmd {}}} {
    # Install single-file script application into destination _directory_.
    # a previously existing file is moved out of the way.

    set fname [file tail $src]

    io puts "Installing script \"$fname\""
    io puts "    Into [relativesrc $dstdir]"

    dry-barrier {
	# Simulated run, has its own dry-barrier.
	copy-file $src $dstdir
    }

    # Save existing file, if any.
    file mkdir $dstdir
    file delete -force $dstdir/${fname}.old
    catch {
	file rename $dstdir/${fname} $dstdir/${fname}.old
    }

    try {
	copy-file $src $dstdir
    } trap {KETTLE STATUS FAIL} {e o} {
	# Failed, restore previous, if any.
	catch {
	    file rename $dstdir/${fname}.old $dstdir/${fname}
	}

	return {*}$o $e
    }

    if {[llength $cmd]} {
	{*}$cmd $dstdir/$fname
    }

    fixhashbang    $dstdir/$fname $shell
    set-executable $dstdir/$fname
    return
}

proc ::kettle::path::install-file-group {label dstdir args} {
    # Install multiple files into a destination directory.
    # The destination is created to hold the files. The files
    # are strongly coupled, i.e. belong together.

    io puts "Installing $label"
    io puts "    Into [relativesrc $dstdir]"

    dry-barrier {
	# Simulated installation (has its own dry-barrier).
	copy-files $dstdir {*}$args
    }

    set new ${dstdir}-new
    set old ${dstdir}-old

    # Clean temporary destination. Remove left-overs from previous runs.
    file delete -force $new
    file mkdir         $new

    try {
	copy-files $new {*}$args
    } trap {KETTLE STATUS FAIL} {e o} {
	file delete -force $new
	return {*}$o $e
    }

    # Now shuffle old and new things around to put the new into place.
    io puts -nonewline {    Commmit: }
    if {[catch {
	file delete -force $old
	catch { file rename $dstdir $old }
	file rename -force $new $dstdir
	file delete -force $old
    } msg]} {
	io err { io puts "FAIL ($msg)" }
	status fail
    } else {
	io ok { io puts OK }
    }
    return
}

proc ::kettle::path::install-file-set {label dstdir args} {
    # Install multiple files into a destination directory.
    # The destination has to exist. The files in the set
    # are only loosely coupled. Example: manpages.

    io puts "Installing $label"
    io puts "    Into [relativesrc $dstdir]"

    ## Consider removal of existing files ...
    ## Except, for manpages we want to be informed of clashes.
    ## for others it might make sense ...

    copy-files $dstdir {*}$args
    return
}

proc ::kettle::path::uninstall-application {src dstdir} {
    set fname [file tail $src]

    io puts "Uninstall application \"$fname\""
    io puts "    From [relativesrc $dstdir]"

    remove-path $dstdir $dstdir/$fname
    return
}

proc ::kettle::path::uninstall-file-group {label dstdir} {
    io puts "Uninstalling $label"
    io puts "    From [relativesrc [file dirname $dstdir]]"

    remove-path [file dirname $dstdir] $dstdir
    return
}

proc ::kettle::path::uninstall-file-set {label dstdir args} {
    # Install multiple files into a destination directory.
    # The destination has to exist. The files in the set
    # are only loosely coupled. Example: manpages.

    io puts "Uninstalling $label"
    io puts "    From [relativesrc $dstdir]"

    ## Consider removal of existing files ...
    ## Except, for manpages we want to be informed of clashes.
    ## for others it might make sense ...

    foreach f $args {
	remove-path $dstdir $dstdir/$f
    }
    return
}

proc ::kettle::path::exec {args} {
    pipe line {
	# line ends in \n, except possibly at eof.
	io puts -nonewline $line
    } {*}$args
    return
}

proc ::kettle::path::pipe {lv script args} {
    upvar 1 $lv line
    set stderr [tmpfile pipe_stderr_]
    ensure-cleanup $stderr

    io trace {  PIPE: [T $args]}

    if {[kettle option get --dry]} return

    set err {}
    set pipe [open "|$args 2> $stderr" r]
    fconfigure $pipe -translation lf

    try {
	while {![eof $pipe]} {
	    if {[gets $pipe line] < 0} continue
	    if {![eof $pipe]} {
		append line \n
	    }
	    try {
		uplevel 1 $script
	    } trap {KETTLE} {e o} {
		# Rethrow internal signals.
		# No report, not a true error.
		return {*}$o $e
	    } on error {e o} {
		io err { io puts $e }
		break
	    }
	}
    } finally {
	try {
	    close $pipe
	} on error {e o} {
	    io err { io puts $e }
	}

	set err [cat $stderr]
	file delete $stderr
    }

    if {$err eq {}} return
    io err { io puts $err }
    return
}

proc ::kettle::path::in {path script} {
    set here [pwd]
    try {
	cd $path
	uplevel 1 $script
    } finally {
	cd $here
    }
}

proc ::kettle::path::scanup {path cmd} {
    io trace {scan up $path ($cmd)}

    set path [file normalize $path]
    while {1} {
	io trace {    testing $path}

	# Found the proper directory, per the predicate.
	if {[{*}$cmd $path]} { return $path }

	# Not found, walk to parent
	set new [file dirname $path]

	# Stop when reaching the root.
	if {$new eq $path} { return {} }
	if {$new eq {}} { return {} }

	# Ok, truly walk up.
	set path $new
    }
    return {}
}

# # ## ### ##### ######## ############# #####################
## Repository type detection, extraction of current revision, ...

proc ::kettle::path::find.git {path} {
    scanup $path ::kettle::path::is.git
}

proc ::kettle::path::find.fossil {path} {
    scanup $path ::kettle::path::is.fossil
}

proc ::kettle::path::revision.git {path} {
    in $path {
	try {
	    set v [::exec {*}[auto_execok git] describe]
	} on error {e o} {
	    set v [lindex [split [dict get $o -errorinfo] \n] 0]
	}
    }
    return [string trim $v]
}

proc ::kettle::path::revision.fossil {path} {
    set fossilcmd [auto_execok fossil]
    if {[llength $fossilcmd]} {
	in $path {
	    set info [::exec {*}$fossilcmd info]
	}
	return [lindex [grep {checkout:*} $info] 0 1]
    } else {
	return Unknown
    }
}

proc ::kettle::path::is.git {path} {
    set control $path/.git
    expr {[file exists $control] && [file isdirectory $control]}
}

proc ::kettle::path::is.fossil {path} {
    foreach control {
	_FOSSIL_
	.fslckout
	.fos
    } {
	set control $path/$control
	if {[file exists $control] && [file isfile $control]} {return 1}
    }
    return 0
}

# # ## ### ##### ######## ############# #####################
## Internal

proc ::kettle::path::dry-barrier {{dryscript {}}} {
    if {![kettle option get --dry]} return
    # dry run: notify, ... 
    if {$dryscript eq {}} {
	io cyan { io puts {!dry run!} }
    } else {
	uplevel 1 $dryscript
    }
    # ... and abort caller.
    return -code return
}

proc ::kettle::path::T {words} {
    set r {}
    foreach w $words {
	if {[file exists $w]} {
	    set w [relativecwd [norm $w]]
	}
	lappend r $w
    }
    return $r
}

proc ::kettle::path::Ignore {patterns path} {
    set path [file tail $path]
    foreach p $patterns {
	if {[string match $p $path]} { return 1 }
    }
    return 0
}

# # ## ### ##### ######## ############# #####################
return