Improved handling of case where child is killed by a signal

[tcl-tlc.git] / scripts / hconfig.itcl

# vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4

class tlc::Hconfig {
        inherit tlc::Baselog

        constructor {backend info args} {}

        public {
                variable exact          1

                method load {path {inherited {}} {datatypes {}} {inh_info {}}}
                method load_only {path}
                method exists {path}
                method listsub {path {immediate 0}}
                method save {path configlist {datatype_list ""}}
                method trash {path}
                method rename {frompath topath {allsub 0}}
        }

        private {
                variable sql_obj
                variable table

                method init_db {}
        }
}


body tlc::Hconfig::constructor {backend info args} { #<<<1
        log debug $this
        eval configure $args

        switch -- $backend {
                "pg_sql" {
                        foreach {sql_obj table} $info break
                        log debug "sql_obj: ($sql_obj) ($table)"
                }

                default {
                        error "Unsupported backend: ($backend)" "" \
                                        [list invalid_backend $backend]
                }
        }

        init_db
}


body tlc::Hconfig::init_db {} { #<<<1
        log debug
        if {![$sql_obj table_exists $table]} {
                $sql_obj getlist "
                        create table $table (
                                id                      serial,
                                path            text unique not null,
                                data            text,
                                leaf            int4 default 0,
                                datatypes       text default ''
                        )
                "
                $sql_obj getlist "
                        create index ${table}_path_idx on ${table}(path);
                "
        }
}


body tlc::Hconfig::load {path {inherited {}} {datatypes {}} {inh_info {}}} { #<<<1
        log debug
        set path                [string trim $path "/ "]

        if {$inherited != {}} {
                upvar $inherited inh
        }
        if {$datatypes != {}} {
                upvar $datatypes dt
        }
        
        if {$inh_info != {}} {
                upvar $inh_info inh_inf
        }
        
        array set build {}

        set p           ""
        set sep         ""
        set leaf        0
        set real        0
        set last        {}
        # Initialize from root "" <<<
        set rows                [$sql_obj getlist "
                select
                        data,
                        leaf,
                        datatypes
                from
                        $table
                where
                        path = ''
        "]
        set real        [expr {[llength $rows] == 1}]
        set raw         [lindex $rows 0]
        set last        [lindex $raw 0]
        set leaf        [lindex $raw 1]
        set types       [lindex $raw 2]
        
        #log debug "path: ($p)  data: ($last)"
        array set build $last
        
        # look for this variable's data type in the (should be a list) types var
        #       the default type is text, so if the variable is not found in the types list
        #       then we set to that
        foreach {idx val} $last {
                set dt($idx) "text"
        }
        array set dt $types

        set inh_inf(parent)             [array get build]
        set inh_inf(this)               $last
        set inh_inf(parent_dt)  [array get dt]
        set inh_inf(this_dt)    $types
        # Initialize from root "" >>>

        foreach elem [split $path /] {
                append p        $sep $elem
                set rows                [$sql_obj getlist "
                        select
                                data,
                                leaf,
                                datatypes
                        from
                                $table
                        where
                                path = '[$sql_obj quote $p]'
                "]
                set real        [expr {[llength $rows] == 1}]
                set raw         [lindex $rows 0]
                set last        [lindex $raw 0]
                set leaf        [lindex $raw 1]
                set types       [lindex $raw 2]

                set inh_inf(parent)             [array get build]
                set inh_inf(this)               $last
                set inh_inf(parent_dt)  [array get dt]
                set inh_inf(this_dt)    $types

                array set dt $types
                foreach {key val} $last {
                        if {![info exists dt($key)]} {
                                set dt($key) "text"
                        }
                        switch -- $dt($key) {
                                "mergelist" { #<<<
                                        log debug "Compositing mergelist: $p, $key, $val"
                                        set chopitems   {}
                                        set newitems    {}

                                        if {![info exists build($key)]} {
                                                set build($key) {}
                                        }

                                        foreach item $val {
                                                switch -- [string index $item 0] {
                                                        "-" {
                                                                lappend chopitems       [string range $item 1 end]
                                                        }

                                                        "+" {
                                                                lappend newitems        [string range $item 1 end]
                                                        }

                                                        default {
                                                                lappend newitems        $item
                                                        }
                                                }
                                        }

                                        set chopped     \
                                                        [lindex [tlc::intersect3 $build($key) $chopitems] 0]
                                        set build($key) \
                                                        [lsort -unique [concat $chopped $newitems]]
                                        #>>>
                                }

                                "mergearray" { #<<<
                                        log debug "Compositing mergelist: $p, $key, $val"
                                        set chopitems   {}
                                        set newitems    {}

                                        catch {unset tmparr}
                                        if {![info exists build($key)]} {
                                                array set tmparr        {}
                                        } else {
                                                array set tmparr        $build($key)
                                        }

                                        foreach {skey sval} $val {
                                                switch -- [string index $skey 0] {
                                                        "-" {
                                                                lappend chopitems       [string range $skey 1 end]
                                                        }

                                                        "+" {
                                                                lappend newitems \
                                                                                [string range $skey 1 end] \
                                                                                $sval
                                                        }

                                                        default {
                                                                lappend newitems        $skey $sval
                                                        }
                                                }
                                        }

                                        foreach chopitem $chopitems {
                                                array unset tmparr $chopitem
                                        }
                                        foreach {skey sval} $newitems {
                                                set tmparr($skey)       $sval
                                        }
                                        set build($key) \
                                                        [array get tmparr]
                                        #>>>
                                }

                                default -
                                "text" { #<<<
                                        set build($key) $val
                                        #>>>
                                }
                        }
                }
                
                set sep         "/"
                if {$leaf == 1} break
        }
        if {$exact && (($p != $path) || !$real)} {
                error "path not found: ($path) exact: ($exact)" "" \
                                [list not_found $path]
        }

        foreach name [array names build] {
                set inh($name)  1
        }
        foreach {name value} $last {
                set inh($name)  0
        }

        return [array get build]
}


body tlc::Hconfig::load_only {path} { #<<<1
        log debug
        set path                [string trim $path "/ "]

        array set build {}

        set p           ""
        set sep         ""
        set leaf        0
        set real        0
        set last        {}
        foreach elem [split $path /] {
                append p        $sep $elem
                set rows                [$sql_obj getlist "
                        select
                                data,
                                leaf
                        from
                                $table
                        where
                                path = '[$sql_obj quote $p]'
                "]
                set real        [expr {[llength $rows] == 1}]
                set raw         [lindex $rows 0]
                set last        [lindex $raw 0]
                set leaf        [lindex $raw 1]
                set sep         "/"
                if {$leaf == 1} break
        }
        if {$exact && (($p != $path) || !$real)} {
                error "path not found: ($path) exact: ($exact)" "" \
                                [list path_not_found $path]
        }
        array set build $last

        return [array get build]
}


body tlc::Hconfig::exists {path} { #<<<1
        log debug
        set path        [string trim $path "/ "]
        
        set count       [lindex [lindex [$sql_obj getlist "
                select
                        count(*)
                from
                        $table
                where
                        path = '[$sql_obj quote $path]'
        "] 0] 0]

        return [expr {$count > 0}]
}


body tlc::Hconfig::save {path configlist {datatype_list ""}} { #<<<1
        log debug
        set path        [string trim $path "/ "]
        
        if {[catch {array set test      $configlist}]} {
                error "Badly formatted configlist.  Should be result of array get" "" \
                                [list bad_format]
        }

        set id  [lindex [lindex [$sql_obj getlist "
                select
                        count(*)
                from
                        $table
                where
                        path = '[$sql_obj quote $path]'
        "] 0] 0]

        if {$id == 0} {
                $sql_obj getlist "
                        insert into $table (
                                path,
                                data,
                                datatypes
                        ) values (
                                '[$sql_obj quote $path]',
                                '[$sql_obj quote $configlist]',
                                '[$sql_obj quote $datatype_list]'
                        )
                "
        } else {
                set row [lindex [$sql_obj getlist "
                        select
                                data,
                                datatypes
                        from
                                $table
                        where
                                path = '[$sql_obj quote $path]'
                "] 0]
                array set build         [lindex $row 0]
                array set datatypes     [lindex $row 1]
                array set build         $configlist
                array set datatypes     $datatype_list
                $sql_obj getlist "
                        update
                                $table
                        set
                                data = '[$sql_obj quote [array get build]]',
                                datatypes = '[$sql_obj quote [array get datatypes]]'
                        where
                                path = '[$sql_obj quote $path]'
                "
        }
}


body tlc::Hconfig::trash {path} { #<<<1
        log debug
        set path        [string trim $path "/ "]

        $sql_obj getlist "
                delete from
                        $table
                where
                        path = '[$sql_obj quote $path]'
        "
}


body tlc::Hconfig::rename {frompath topath {allsub 0}} { #<<<1
        log debug
        set frompath    [string trim $frompath "/ "]
        set topath              [string trim $topath "/ "]
        
        if {$allsub != 1} {
                $sql_obj getlist "
                        update
                                $table
                        set
                                path = '[$sql_obj quote $topath]'
                        where
                                path = '[$sql_obj quote $frompath]'
                "
        } else {
                set subs        [listsub $frompath 0]
                $sql_obj getlist "begin"
                foreach sub $subs {
                        set from        [join [list $frompath $sub] /]
                        set to          [join [list $topath $sub] /]
                        $sql_obj getlist "
                                update
                                        $table
                                set
                                        path = '[$sql_obj quote $to]'
                                where
                                        path = '[$sql_obj quote $from]'
                        "
                }

                $sql_obj getlist "
                        update
                                $table
                        set
                                path = '[$sql_obj quote $topath]'
                        where
                                path = '[$sql_obj quote $frompath]'
                "
                $sql_obj getlist "commit"
        }
}


body tlc::Hconfig::listsub {path {immediate 0}} { #<<<1
        log debug
        set path        [string trim $path "/ "]
        #log debug "listsub of ($path) ($immediate)"
        if {$path == ""} {
                set spec        ""
        } else {
                #set spec       "$path/"
                set spec        "$path/"
        }
        set speclen             [string length $spec]
        
        set build       {}
        set rows        [$sql_obj getlist "
                select
                        path
                from
                        $table
                where
                        path like '[$sql_obj quote ${spec}%]'
        "]

#       log debug "
#               select
#                       path
#               from
#                       $table
#               where
#                       path like '${spec}%'
#       "

        foreach row $rows {
                set subpath     [lindex $row 0]
                set subpath     [string range $subpath $speclen end]

                if {$subpath == ""} continue

                if {$immediate} {
                        set trimpoint   [string first "/" $subpath]
                        if {$trimpoint == -1} {
                                #log debug "($subpath): no \"/\" - appending as is"
                                lappend build   $subpath
                        } else {
                                incr trimpoint  -1
                                #log debug "($subpath): \"/\" at $trimpoint appending ([string range $subpath 0 $trimpoint])"
                                lappend build   [string range $subpath 0 $trimpoint]
                        }
                } else {
                        lappend build   $subpath
                }
        }

        if {$immediate} {
                set build       [lsort -unique $build]
        }

        return $build
}