pluginmgr/pluginmgr.tcl

Go to the documentation of this file.

/*  plugin.tcl --*/
/* */
/*  Generic plugin management.*/
/* */
/*  Copyright (c) 2005 Andreas Kupries <andreas_kupries@sourceforge.net>*/
/* */
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  */
/*  RCS: @(#) $Id: pluginmgr.tcl,v 1.6 2007/06/23 03:39:34 andreas_kupries Exp $*/

/*  ### ### ### ######### ######### #########*/
/*  Description*/

/*  Each instance of the plugin manager can be configured with data*/
/*  which specifies where to find plugins, and how to validate*/
/*  them. With that it can then be configured to load and provide access*/
/*  to a specific plugin, doing all required checks and*/
/*  initialization. Users for specific plugin types simply have to*/
/*  encapsulate the generic class, providing all the specifics, leaving*/
/*  their users only the task of naming the requested actual plugin.*/

/*  ### ### ### ######### ######### #########*/
/*  Requisites*/

package require Tcl 8.4
package require snit

/*  ### ### ### ######### ######### #########*/
/*  Implementation*/

snit::type ::pluginmgr {

    /*  ### ### ### ######### ######### #########*/
    /*  Public API - Options*/

    /*  - Pattern to match package name. Exactly one '*'. No default.*/
    /*  - List of commands the plugin has to provide. Empty list default.*/
    /*  - Callback for additional checking after the API presence has*/
    /*    been verified. Empty list default.*/
    /*  - Dictionary of commands to put into the plugin interpreter.*/
    /*    Key: cmds for plugin, value is cmds to invoke for them.*/
    /*  - Interpreter to use for the -cmds (invoked commands). Default*/
    /*    is current interp.*/

    option -pattern {}
    option -api     {}
    option -check   {}
    option -cmds    {}
    option -cmdip   {}
    option -up =    {}

    /*  ### ### ### ######### ######### #########*/
    /*  Public API - Methods*/

    ret  do (type args) {
    if {$plugin eq ""} {
        return -code error "No plugin defined"
    }
    return [$sip eval $args]
    }

    ret  interpreter () {
    return $sip
    }

    ret  plugin () {
    return $plugin
    }

    ret  load (type name) {
    if {$name eq $plugin} return

    if {$options(-pattern) eq ""} {
        return -code error "Translation pattern is not configured"
    }

    set save $sip

    $self SetupIp
    if {![$self LoadPlugin $name]} {
        set sip $save
        return -code error "Unable to locate plugin \"$name\""
    }

    if {![$self CheckAPI missing]} {
        set sip $save
        return -code error \
            "Cannot use plugin \"$name\", API incomplete: \"$missing\" missing"
    }

    set savedname $plugin
    set plugin    $name
    if {![$self CheckExternal]} {
        set sip    $save
        set plugin $savedname
        return -code error \
            "Cannot use plugin \"$name\", API bad"
    }
    $self SetupExternalCmds

    if {$save ne ""} {interp delete $save}
    return
    }

    ret  unload () {
    if {$sip eq ""} return
    interp delete $sip
    set sip    ""
    set plugin ""
    return
    }

    ret  list () {
    if {$options(-pattern) eq ""} {
        return -code error "Translation pattern is not configured"
    }

    set save $sip
    $self SetupIp

    set result {}
    set pattern [string map [list \
        +  \\+  ?  \\?    \
        \[ \\\[ \] \\\]   \
        (  \\(  )  \\)    \
        . \\. \ *  {(.*)} \
        ] $options(-pattern)]

    # @mdgen NODEP: bogus-package
    $sip eval {catch {package require bogus-package}}
    foreach p [$sip eval {package names}] {
        if {![regexp $pattern $p -> plugin]} continue
        lappend result $plugin
    }

    interp delete $sip
    set sip $save
    return $result
    }

    ret  path (type path) {
    set path [file join [pwd] $path]
    if {[lsearch -exact $paths $path] < 0} {
        lappend paths $path
    }
    return
    }

    ret  paths () {
    return $paths
    }

    ret  clone () {
    set o [$type create %AUTO% \
        -pattern $options(-pattern) \
        -api     $options(-api)    \
        -check   $options(-check) \
        -cmds    $options(-cmds) \
        -cmdip   $options(-cmdip) \
        -setup   $options(-setup)]

    $o __clone__ $paths $sip $plugin

    # Clone has become owner of the interp.
    set sip    {}
    set plugin {}

    return $o
    }

    ret  __clone__ (_type paths _, type sip _, type plugin) {
    set paths  $_paths
    set sip    $_sip
    set plugin $_plugin
    return
    }

    /*  ### ### ### ######### ######### #########*/
    /*  Internal - Configuration and state*/

    variable paths  {} ; /*  List of paths to provide the sip with.*/
    variable sip    {} ; /*  Safe interp used for plugin execution.*/
    variable plugin {} ; /*  Name of currently loaded plugin.*/

    /*  ### ### ### ######### ######### #########*/
    /*  Internal - Object construction and descruction.*/

    constructor {args} {
    $self configurelist $args
    return
    }

    destructor {
    if {$sip ne ""} {interp delete $sip}
    return
    }

    /*  ### ### ### ######### ######### #########*/
    /*  Internal - Option management*/

    onconfigure -pattern {newvalue} {
     current =  $options(-pattern)
    if {$newvalue eq $current} return

     n =  [regexp -all "\\*" $newvalue]
    if {$n < 1} {
        return -code error "Invalid pattern, * missing"
    } elseif {$n > 1} {
        return -code error "Invalid pattern, too many *'s"
    }

     options = (-pattern) $newvalue
    return
    }

    onconfigure -api {newvalue} {
     current =  $options(-api)
    if {$newvalue eq $current} return
     options = (-api) $newvalue
    return
    }

    onconfigure -cmds {newvalue} {
     current =  $options(-cmds)
    if {$newvalue eq $current} return
     options = (-cmds) $newvalue
    return
    }

    onconfigure -cmdip {newvalue} {
     current =  $options(-cmdip)
    if {$newvalue eq $current} return
     options = (-cmdip) $newvalue
    return
    }


    /*  ### ### ### ######### ######### #########*/
    /*  Internal - Helper commands*/

    ret  SetupIp () {
    set sip [::safe::interpCreate]
    foreach p $paths {
        ::safe::interpAddToAccessPath $sip $p
    }

    if {![llength $options(-setup)]} return
    uplevel \#0 [linsert $options(-setup) end $self $sip]
    return
    }

    ret  LoadPlugin (type name) {
    if {[file exists $name]} {
        # Plugin files are loaded directly.

        $sip invokehidden source $name
        return 1
    }

    # Otherwise the name is transformed into a package name
    # and loaded thorugh the package management.

    set pluginpackage [string map \
        [list * $name] $options(-pattern)]
    if {[catch {
        $sip eval [list package require $pluginpackage]
    } res]} {
        return 0
    }
    return 1
    }

    ret  CheckAPI (type mv) {
    upvar 1 $mv missing
    if {![llength $options(-api)]} {return 1}

    # Check the plugin for useability.

    foreach p $options(-api) {
        if {[llength [$sip eval [list info commands $p]]] == 1} continue
        interp delete $sip
        set missing $p
        return 0
    }
    return 1
    }

    ret  CheckExternal () {
    if {![llength $options(-check)]} {return 1}
    return [uplevel \#0 [linsert $options(-check) end $self]]
    }


    ret  SetupExternalCmds () {
    if {![llength $options(-cmds)]} return

    set cip $options(-cmdip)
    foreach {pcmd ecmd} $options(-cmds) {
        eval [linsert $ecmd 0 interp alias $sip $pcmd $cip]
        #interp alias $sip $pcmd $cip {*}$ecmd
    }
    return
    }

    /*  ### ### ### ######### ######### #########*/

    ret  paths (type pmgr , type args) {
    if {[llength $args] == 0} {
        return -code error "wrong#args: Expect \"[info level 0] object name...\""
    }
    foreach name $args {
        AddPaths $pmgr $name
    }
    return
    }

    ret  AddPaths (type pmgr , type name) {
    global env tcl_platform

    if {$tcl_platform(platform) eq "windows"} {
        set sep \;
    } else {
        set sep :
    }

    #puts "$pmgr += ($name) $sep"

    regsub -all {::+} $name \000 name
    set name [split $name \000]

    # Environment variables

    set prefix {}
    foreach part $name {
        lappend prefix $part
        set ev [string toupper [join $prefix _]]_PLUGINS

        #puts "+? env($ev)"

        if {[info exists env($ev)]} {
        foreach path [split $env($ev) $sep] {
            $pmgr path $path
        }
        }
    }

    # Windows registry

    if {
        ($tcl_platform(platform) eq "windows") &&
        ![catch {package require registry}]
    } {
        foreach root {
        HKEY_LOCAL_MACHINE
        HKEY_CURRENT_USER
        } {
        set prefix {}
        foreach part $name {
            lappend prefix $part
            set rk $root\\SOFTWARE\\[join $prefix \\]PLUGINS

            #puts "+? registry($rk)"

            if {![catch {set data [registry get $rk {}]}]} {
            foreach path [split $data $sep] {
                $pmgr path $path
            }
            }
        }
        }
    }

    # Home directory dot path

    set prefix {}
    foreach part $name {
        lappend prefix $part
        set pd [file join ~ .[join $prefix /] plugin]

        #puts "+? path($pd)"

        if {[file exists $pd]} {
        $pmgr path $pd
        }
    }
    return
    }
}

/*  ### ### ### ######### ######### #########*/
/*  Ready*/

package provide pluginmgr 0.1