tcllib 1.17-dfsg-1 / usr / share / tcltk / tcllib1.17 / page / pluginmgr.tcl

# -*- tcl -*-
# ### ### ### ######### ######### #########

## This package provides custom plugin management specific to PAGE. It
## is built on top of the generic plugin management framework (See
## ---> pluginmgr).

# ### ### ### ######### ######### #########
## Requisites

package require fileutil
package require pluginmgr           ; # Generic plugin management framework

namespace eval ::page::pluginmgr {}

# ### ### ### ######### ######### #########
## API (Public, exported)

proc ::page::pluginmgr::reportvia {cmd} {
    variable reportcmd $cmd
    return
}

proc ::page::pluginmgr::log {cmd} {
    variable reader
    variable writer
    variable transforms

    set     iplist {}
    lappend iplist [$reader interpreter]
    lappend iplist [$writer interpreter]
    foreach t $transforms {
	lappend iplist [$t interpreter]
    }

    if {$cmd eq ""} {
	# No logging. Disable with empty command,
	# to allow the system to completely remove
	# them from the bytecode (= No execution
	# overhead).

	foreach ip $iplist {
	    $ip eval [list proc page_log_error   args {}]
	    $ip eval [list proc page_log_warning args {}]
	    $ip eval [list proc page_log_info    args {}]
	}
    } else {
	# Activate logging. Make the commands in
	# the interpreters aliases to us.

	foreach ip $iplist {
	    interp alias $ip page_log_error   {} ${cmd}::error
	    interp alias $ip page_log_warning {} ${cmd}::warning
	    interp alias $ip page_log_info    {} ${cmd}::info
	}
    }
    return
}

proc ::page::pluginmgr::reader {name} {
    variable reader

    $reader load $name
    return [$reader do page_roptions]
}

proc ::page::pluginmgr::rconfigure {dict} {
    variable reader
    foreach {k v} $dict {
	$reader do page_rconfigure $k $v
    }
    return
}

proc ::page::pluginmgr::rtimeable {} {
    variable reader
    return [$reader do page_rfeature timeable]
}

proc ::page::pluginmgr::rtime {} {
    variable reader
    $reader do page_rtime
    return
}

proc ::page::pluginmgr::rgettime {} {
    variable reader
    return [$reader do page_rgettime]
}

proc ::page::pluginmgr::rhelp {} {
    variable reader
    return [$reader do page_rhelp]
}

proc ::page::pluginmgr::rlabel {} {
    variable reader
    return [$reader do page_rlabel]
}

proc ::page::pluginmgr::read {read eof {complete {}}} {
    variable reader

    #interp alias $ip page_read {} {*}$read
    #interp alias $ip page_eof  {} {*}$eof

    set ip [$reader interpreter]
    eval [linsert $read 0 interp alias $ip page_read {}]
    eval [linsert $eof  0 interp alias $ip page_eof  {}]

    if {![llength $complete]} {
	interp alias $ip page_read_done {} ::page::pluginmgr::Nop
    } else {
	eval [linsert $complete  0 interp alias $ip page_read_done  {}]
    }

    return [$reader do page_rrun]
}

proc ::page::pluginmgr::writer {name} {
    variable writer

    $writer load $name
    return [$writer do page_woptions]
}

proc ::page::pluginmgr::wconfigure {dict} {
    variable writer
    foreach {k v} $dict {
	$writer do page_wconfigure $k $v
    }
    return
}

proc ::page::pluginmgr::wtimeable {} {
    variable writer
    return [$writer do page_wfeature timeable]
}

proc ::page::pluginmgr::wtime {} {
    variable writer
    $writer do page_wtime
    return
}

proc ::page::pluginmgr::wgettime {} {
    variable writer
    return [$writer do page_wgettime]
}

proc ::page::pluginmgr::whelp {} {
    variable writer
    return [$writer do page_whelp]
}

proc ::page::pluginmgr::wlabel {} {
    variable writer
    return [$writer do page_wlabel]
}

proc ::page::pluginmgr::write {chan data} {
    variable writer

    $writer do page_wrun $chan $data
    return
}

proc ::page::pluginmgr::transform {name} {
    variable transform
    variable transforms

    $transform load $name

    set id [llength $transforms]
    set opt [$transform do page_toptions]
    lappend transforms [$transform clone]

    return [list $id $opt]
}

proc ::page::pluginmgr::tconfigure {id dict} {
    variable transforms

    set t [lindex $transforms $id]

    foreach {k v} $dict {
	$t do page_tconfigure $k $v
    }
    return
}

proc ::page::pluginmgr::ttimeable {id} {
    variable transforms
    set t [lindex $transforms $id]
    return [$t do page_tfeature timeable]
}

proc ::page::pluginmgr::ttime {id} {
    variable transforms
    set t [lindex $transforms $id]
    $t do page_ttime
    return
}

proc ::page::pluginmgr::tgettime {id} {
    variable transforms
    set t [lindex $transforms $id]
    return [$t do page_tgettime]
}

proc ::page::pluginmgr::thelp {id} {
    variable transforms
    set t [lindex $transforms $id]
    return [$t do page_thelp]
}

proc ::page::pluginmgr::tlabel {id} {
    variable transforms
    set t [lindex $transforms $id]
    return [$t do page_tlabel]
}

proc ::page::pluginmgr::transform_do {id data} {
    variable transforms
    variable reader

    set t [lindex $transforms $id]

    return [$t do page_trun $data]
}

proc ::page::pluginmgr::configuration {name} {
    variable config

    if {[file exists $name]} {
	# Try as plugin first. On failure read it as list of options,
	# separated by spaces and tabs, and possibly quoted with
	# quotes and double-quotes.

	if {[catch {$config load $name}]} {
	    set ch      [open $name r]
	    set options [::read $ch]
	    close $ch

	    set def {}
	    while {[string length $options]} {
		if {[regsub "^\[ \t\n\]+" $options {} options]} {
		    # Skip whitespace
		    continue
		}
		if {[regexp -indices {^'(([^']|(''))*)'} \
			$options -> word]} {
		    foreach {__ end} $word break
		    lappend def [string map {'' '} [string range $options 1 $end]]
		    set options [string range $options [incr end 2] end]
		} elseif {[regexp -indices {^"(([^"]|(""))*)"} \
			$options -> word]} {
		    foreach {__ end} $word break
		    lappend def [string map {{""} {"}} [string range $options 1 $end]]
		    set options [string range $options [incr end 2] end]
		} elseif {[regexp -indices "^(\[^ \t\n\]+)" \
			$options -> word]} {
		    foreach {__ end} $word break
		    lappend def [string range $options 0 $end]
		    set options [string range $options [incr end] end]
		}
	    }
	    return $def
	}
    } else {
	$config load $name
    }
    set def [$config do page_cdefinition]
    $config unload
    return $def
}

proc ::page::pluginmgr::report {level text {from {}} {to {}}} {
    variable replevel
    variable reportcmd
    uplevel #0 [linsert $reportcmd end $replevel($level) $text $from $to]
    return
}

# ### ### ### ######### ######### #########
## Internals

## Data structures
##
## - reader    | Instances of pluginmgr configured for input,
## - transform | transformational, and output plugins. The
## - writer    | manager for transforms is actually a template
##             | from which the actual instances are cloned.

## - reportcmd | Callback for reporting of input error and warnings.
## - replevel  | Mapping from chosen level to the right-padded text
##             | to use.

namespace eval ::page::pluginmgr {
    variable  replevel
    array set replevel {
	info    {info   }
	warning {warning}
	error   {error  }
    }
}

proc ::page::pluginmgr::Initialize {} {
    InitializeReporting
    InitializeConfig
    InitializeReader
    InitializeTransform
    InitializeWriter
    return
}

proc ::page::pluginmgr::InitializeReader {} {
    variable commands
    variable reader_api
    variable reader [pluginmgr RD \
	    -setup   ::page::pluginmgr::InitializeReaderIp \
	    -pattern page::reader::* \
	    -api     $reader_api \
	    -cmdip   {} \
	    -cmds    $commands]

    # The page_log_* commands are set later, when it is known if
    # logging is active or not, as their implementation depends on
    # this.

    pluginmgr::paths $reader page::reader
    return
}

proc ::page::pluginmgr::InitializeReaderIp {p ip} {
    interp eval $ip {
	# @sak notprovided page::plugin
	# @sak notprovided page::plugin::reader
	package provide page::plugin         1.0
	package provide page::plugin::reader 1.0
    }
    interp alias $ip puts  {} puts
    interp alias $ip open  {} ::page::pluginmgr::AliasOpen $ip
    interp alias $ip write {} ::page::pluginmgr::WriteFile $ip
    return
}

proc ::page::pluginmgr::InitializeWriter {} {
    variable commands
    variable writer_api
    variable writer [pluginmgr WR \
	    -setup   ::page::pluginmgr::InitializeWriterIp \
	    -pattern page::writer::* \
	    -api     $writer_api \
	    -cmdip   {} \
	    -cmds    $commands]

    # The page_log_* commands are set later, when it is known if
    # logging is active or not, as their implementation depends on
    # this.

    pluginmgr::paths $writer page::writer
    return
}

proc ::page::pluginmgr::InitializeWriterIp {p ip} {
    interp eval $ip {
	# @sak notprovided page::plugin
	# @sak notprovided page::plugin::writer
	package provide page::plugin         1.0
	package provide page::plugin::writer 1.0
    }
    interp alias $ip puts  {} puts
    interp alias $ip open  {} ::page::pluginmgr::AliasOpen $ip
    interp alias $ip write {} ::page::pluginmgr::WriteFile $ip
    return
}

proc ::page::pluginmgr::InitializeTransform {} {
    variable transforms {}
    variable commands
    variable transform_api
    variable transform [pluginmgr TR \
	    -setup   ::page::pluginmgr::InitializeTransformIp \
	    -pattern page::transform::* \
	    -api     $transform_api \
	    -cmdip   {} \
	    -cmds    $commands]

    # The page_log_* commands are set later, when it is known if
    # logging is active or not, as their implementation depends on
    # this.

    pluginmgr::paths $transform page::transform
    return
}

proc ::page::pluginmgr::InitializeTransformIp {p ip} {
    interp eval $ip {
	# @sak notprovided page::plugin
	# @sak notprovided page::plugin::transform
	package provide page::plugin            1.0
	package provide page::plugin::transform 1.0
    }
    interp alias $ip puts  {} puts
    interp alias $ip open  {} ::page::pluginmgr::AliasOpen $ip
    interp alias $ip write {} ::page::pluginmgr::WriteFile $ip
    return
}

proc ::page::pluginmgr::InitializeConfig {} {
    variable config [pluginmgr CO \
	    -pattern page::config::* \
	    -api {page_cdefinition}]

    pluginmgr::paths $config page::config
    return
}

proc ::page::pluginmgr::InitializeReporting {} {
    variable reportcmd ::page::pluginmgr::ReportStderr
    return
}

proc ::page::pluginmgr::ReportStderr {level text from to} {
    # from = epsilon | list (line col)
    # to   = epsilon | list (line col)
    # line = 5 digits, col = 3 digits

    if {
	($text eq "") &&
	![llength $from] &&
	![llength $to]
    } {
	puts stderr ""
	return
    }

    puts -nonewline stderr $level
    WriteLocation $from
    if {![llength $to]} {
	puts -nonewline stderr { }
    } else {
	puts -nonewline stderr {-}
    }
    WriteLocation $to
    puts -nonewline stderr " "
    puts -nonewline stderr $text
    puts stderr ""
    return
}

proc ::page::pluginmgr::WriteLocation {loc} {
    if {![llength $loc]} {
	set text {         }
    } else {
	set line [lindex $loc 0]
	set col  [lindex $loc 1]
	set text {}
	if {![string length $line]} {
	    append text _____
	} else {
	    append text [string map {{ } _} [format %5d $line]]
	}
	append text @
	if {![string length $col]} {
	    append text ___
	} else {
	    append text [string map {{ } _} [format %3d $col]]
	}
    }
    puts -nonewline stderr $text
    return
}

proc ::page::pluginmgr::AliasOpen {slave file {acc {}} {perm {}}} {

    if {$acc eq ""} {set acc r}

    ::safe::Log $slave =============================================
    ::safe::Log $slave "open $file $acc $perm"

    if {[regexp {[wa+]|(WRONLY)|(RDWR)|(APPEND)|(CREAT)|(TRUNC)} $acc]} {
	# Do not allow write acess.
	::safe::Log $slave "permission denied"
	::safe::Log $slave 0/============================================
	return -code error "permission denied"
    }

    if {[catch {set file [::safe::TranslatePath $slave $file]} msg]} {
	::safe::Log $slave $msg
	::safe::Log $slave "permission denied"
	::safe::Log $slave 1/============================================
	return -code error "permission denied"
    }
    
    # check that the path is in the access path of that slave

    if {[catch {::safe::FileInAccessPath $slave $file} msg]} {
	::safe::Log $slave $msg
	::safe::Log $slave "permission denied"
	::safe::Log $slave 2/============================================
	return -code error "permission denied"
    }

    # do the checks on the filename :

    if {[catch {::safe::CheckFileName $slave $file} msg]} {
	::safe::Log $slave "$file: $msg"
	::safe::Log $slave "$msg"
	::safe::Log $slave 3/============================================
	return -code error $msg
    }

    if {[catch {::interp invokehidden $slave open $file $acc} msg]} {
	::safe::Log $slave "Caught: $msg"
	::safe::Log $slave "script error"
	::safe::Log $slave 4/============================================
	return -code error "script error"
    }

    ::safe::Log $slave =/============================================
    return $msg

}

proc ::page::pluginmgr::Nop {args} {}

proc ::page::pluginmgr::WriteFile {slave file text} {
    if {[file pathtype $file] ne "relative"} {
	set file [file join [pwd] [file tail $fail]]
    }
    file mkdir [file dirname $file]
    fileutil::writeFile      $file $text
    return
}

# ### ### ### ######### ######### #########
## Initialization

namespace eval ::page::pluginmgr {

    # List of functions in the various plugin APIs

    variable reader_api {
	page_rhelp
	page_rlabel
	page_roptions
	page_rconfigure
	page_rrun
	page_rfeature
    }
    variable writer_api {
	page_whelp
	page_wlabel
	page_woptions
	page_wconfigure
	page_wrun
	page_wfeature
    }
    variable transform_api {
	page_thelp
	page_tlabel
	page_toptions
	page_tconfigure
	page_trun
	page_tfeature
    }
    variable commands {
	page_info    {::page::pluginmgr::report info}
	page_warning {::page::pluginmgr::report warning}
	page_error   {::page::pluginmgr::report error}
    }
}

::page::pluginmgr::Initialize

# ### ### ### ######### ######### #########
## Ready

package provide page::pluginmgr 0.2