Fix too many ]s in try

[tcl-tlc-base.git] / scripts / hconfig_ext.itcl

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

class tlc::Hconfig_ext {
        inherit tlc::Baselog

        constructor {args} {}

        public {
                variable exact          1

                method register_backend {obj args}

                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}
        }

        private {
                variable backends
                variable backend_pathlist       {}

                method find_handler {path}
                method normalize {path}
        }
}


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

        array set backends      {}

        eval configure $args
}


body tlc::Hconfig_ext::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 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_ext::load_only {path} { #<<<1
        set path        [normalize $path]
        return [[find_handler $path] retrieve $path]
}


body tlc::Hconfig_ext::exists {path} { #<<<1
        set path        [normalize $path]
        return [[find_handler $path] exists $path]
}


body tlc::Hconfig_ext::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 quote $path]'
        "] 0] 0]

        if {$id == 0} {
                $sql_obj getlist "
                        insert into $table (
                                path,
                                data,
                                datatypes
                        ) values (
                                '[sql quote $path]',
                                '[sql quote $configlist]',
                                '[sql quote $datatype_list]'
                        )
                "
        } else {
                set row [lindex [$sql_obj getlist "
                        select
                                data,
                                datatypes
                        from
                                $table
                        where
                                path = '[sql 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 quote [array get build]]',
                                datatypes = '[sql quote [array get datatypes]]'
                        where
                                path = '[sql quote $path]'
                "
        }
}


body tlc::Hconfig_ext::trash {path} { #<<<1
        set path        [normalize $path]
        return [[find_handler $path] trash $path]
}


body tlc::Hconfig_ext::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 quote $topath]'
                        where
                                path = '[sql 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 quote $to]'
                                where
                                        path = '[sql quote $from]'
                        "
                }

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


body tlc::Hconfig_ext::listsub {path {immediate 0}} { #<<<1
        log debug
        #log debug "listsub of ($path) ($immediate)"
        set path        [normalize $path]
        return [[find_handler $path] listsub $path $immediate]
}


body Hconfig_ext::register_backend {obj args} { #<<<1
        set paths       $args

        if {![itcl::is object $obj] || [$obj isa tlc::Hconfig_backend]} {
                error "obj must implement tlc::Hconfig_backend" "" [list invalid_type]
        }

        if {[llength $paths] == 0} {
                error "Must provide at least one path" "" [list invalid_paths]
        }

        foreach path $paths {
                set path        [string trim $path /]
                if {[info exists backends($path)]} {
                        error "Path \"$path\" is already handled by \"$backends($path)\"" \
                                        "" [list duplicate_path $path $backends($path)]
                }
        }

        foreach path $paths {
                set backends($path)     $obj
        }

        # Get a list of paths sorted longest to shortest
        set backend_pathlist \
                        [lsort -command [code $this pathsort] [array names backends]]
}


body Hconfig_ext::pathsort {p1 p2} { #<<<1
        return [expr {[string length $p2] - [string length $p1]}]
}


body Hconfig_ext::find_handler {path} { #<<<1
        foreach rootpath $backend_pathlist {
                if {[string match "${rootpath}*" $path]} {
                        return $backends($path)
                }
        }
        error "No backends" "" [list no_backends]
}


body Hconfig_ext::normalize {path} { #<<<1
        return [string trim $path "/ "]
}