tdomselect

#!/usr/bin/tclsh
# -*- Tcl -*-
package require tdom
package require cmdline

# Ex. To list up reused passwords:
# tdomselect tmp/keepass.xml //entry list password username url title|sort|uniq

# tdomselect foo.docx
# tdomselect foo.docx //w:t
# tdomselect foo.docx //w:t toXPath
# tdomselect foo.docx //w:t 'n {list [$n toXPath] [$n asText]}'

proc usage {{rc 1}} {
    set prog [file tail $::argv0] 
    puts stderr "Usage: $prog -m asText xmlfile xpath ?sub-xpath...?"
    exit $rc
}

proc open_chan {fn args} {
    set fh [open $fn]
    if {[llength $args]} {
	fconfigure $fh {*}$args
    }
    set fh
}

proc read_enc {fn args} {
    set fh [open_chan $fn {*}$args]
    set data [read $fh]
    close $fh
    set data
}

#========================================
catch {
    package require Tclx
    signal trap SIGPIPE exit
}

set opts [cmdline::getoptions argv {
    {encoding.arg utf-8 "input file encoding"}
    {debug no "debug"}
    {parser.arg {} "parser options"}
}]

proc tdom_open {fn opts} {
    set ext [string tolower [file extension $fn]]
    set opener tdom_open$ext
    if {[llength [info commands $opener]]} {
	$opener $fn $opts
    } else {
	list -channel [open_chan $fn -encoding [dict get $opts encoding]]
    }
}

proc tdom_open.html {fn opts} {
    set data [read_enc $fn -encoding [dict get $opts encoding]]
    list $data
}

proc tdom_open.docx {fn opts} {
    list -channel [open_chan [list | unzip -qc $fn word/document.xml] \
                       -encoding utf-8]
}

proc tdom_open.odt {fn opts} {
    list -channel [open_chan [list | unzip -qc $fn content.xml] \
                       -encoding utf-8]
}

proc tdom_file_apply {opts fn method nodeVar cmdBody {emitCmd puts} args} {
    upvar 1 $nodeVar node

    set fd_opts [tdom_open $fn $opts]
    dom parse {*}$fd_opts doc
    close [if {[lindex $fd_opts 0] eq "-channel"} {
        lindex $fd_opts 1
    } else {
        lindex $fd_opts 0
    }]
    

    $doc documentElement root
    set rc [catch {$root {*}$method} found]
    if {$rc} {
	puts stderr "dom selection error for '$method'\n $found"
	exit 1
    }

    foreach node $found {
	set res [{*}$cmdBody $node]
	if {$emitCmd ne ""} {
	    {*}$emitCmd $res {*}$args
	}
    }

    set found
}

proc tdom_map.list {tags node} {
    set ls {}
    foreach c $tags {
	if {![regexp {^\./} $c]} {
	    set c "./$c"
	}
	foreach sub [$node selectNodes $c] {
	    lappend ls [regsub {\s+} [$sub asText] { }]
	}
    }
    join $ls \t
}

# returns [list $method $nodeVar $cmdBody $emitCmd ...]
proc tdom_auto_command argList {
    if {[llength $argList] == 1} {
	lassign $argList xpath
	list [list selectNodes $xpath] node \
	    [list apply [list node {$node asText}]]
    } else {
	set rest [lassign $argList xpath method]

	if {[llength $method] == 1} {
	    lassign $method method
	    set nodeVar node
	} else {
	    lassign $method nodeVar method
	}

	if {[llength [info commands [set cmdName tdom_map.$method]]]} {
	    list [list selectNodes $xpath] $nodeVar [list $cmdName $rest]
	} elseif {[regexp {\s} $method]} {
	    list [list selectNodes $xpath] $nodeVar \
		[list apply [list $nodeVar $method]]
	} else {
	    list [list selectNodes $xpath] node \
		[list apply [list node "\$node $method"]]
	}
    }
}

proc dict-default {dict key {default ""}} {
    if {[dict exists $dict $key]} {
        dict get $dict $key
    } else {
        set default
    }
}

if {![llength $argv]} {
    usage
}

set rest [lassign $argv fn]
if {![llength $rest]} {
    tdom_file_apply $opts $fn childNodes node [list apply {node {
	$node toXPath
    }}] puts
} else {
    set cmd [tdom_auto_command $rest]
    if {[dict get $opts debug]} {
	puts stderr cmd=$cmd
    }
    set found [tdom_file_apply $opts $fn {*}$cmd]
    exit [expr {[llength $found] == 0}]
}