gpsman 6.4.4.2-2 / usr / lib / gpsman / datumell.tcl

#
# This file is part of:
#
#  gpsman --- GPS Manager: a manager for GPS receiver data
#
# Copyright (c) 1998-2013 Miguel Filgueiras migfilg@t-online.de
#
#    This program is free software; you can redistribute it and/or modify
#      it under the terms of the GNU General Public License as published by
#      the Free Software Foundation; either version 3 of the License, or
#      (at your option) any later version.
#
#      This program is distributed in the hope that it will be useful,
#      but WITHOUT ANY WARRANTY; without even the implied warranty of
#      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#      GNU General Public License for more details.
#
#      You should have received a copy of the GNU General Public License
#      along with this program.
#
#  File: datumell.tcl
#  Last change:  6 October 2013
#

## user-definitions: datums, ellipsoids, geo-reference files, renaming
##  methods, plug-ins

# each definition is represented by a list of data fields
#
# indices in table DefSpecs [more details in proc Definition]:
#
#   KIND,predef    name of global with menu description of predefined
#                  objects, or empty if only user-definitions
#   KIND,dfields   list of identifiers of data fields in definition
#         the first field is always for definition identifier, unique for
#         each kind of definition, and is never included here
#   KIND,fnames    list of tokens giving the format of field names
#   KIND,ftypes    list of tokens giving the widgets/constraints for
#         field values
#   KIND,fdtypes   list of types (string, atom or list) of field values
#         except the identifier, only for use with proc SaveUserDefined
#   KIND,datarr    name of global array for the definitions of this kind
#   KIND,ulist     name of global list for user definitions of this kind
#   KIND,baddef    name of proc that returns true if definition has errors;
#         called with kind, action, name and data list as arguments
#   KIND,savecomm  name of proc that saves user definitions of this kind
#         called with kind, action, name and data list as arguments; must
#         return 0 on error

array set DefSpecs {
    datum,predef    PREDEFDATUMDESCR
    datum,dfields  {ellpsd dx dy dz reserved nb ex ey ez nsat
	latS latN longW longE}
    datum,fnames  {|name |ellpsd =dx =dy =dz reserved |rmrk =ex =ey =ez
	"=# sat" |latS |latN |longW |longE}
    datum,ftypes  {entry ">FillDefsMenu ellpsd" float float float reserved text
	poss:float>-1 poss:float>-1 poss:float>-1 poss:float>-1
	poss:lat poss:lat poss:long poss:long}
    datum,datarr    GDATUM
    datum,ulist     UDatums
    datum,baddef    Ignore
    datum,savecomm  SaveUserDatumElls
    ellpsd,predef   PREDEFELLIPSOIDDESCR
    ellpsd,dfields  {a invf nb}
    ellpsd,fnames   {|name =a =1/f |rmrk}
    ellpsd,ftypes   {entry float>0 float>0 text}
    ellpsd,datarr   ELLPSDDEF
    ellpsd,ulist    UEllipsoids
    ellpsd,baddef   Ignore
    ellpsd,savecomm SaveUserDatumElls
    backgrnd,predef   ""
    backgrnd,dfields  {file nb}
    backgrnd,fnames   {|name |file |rmrk}
    backgrnd,ftypes   {entry file=MapBkInfo text}
    backgrnd,fdtypes  {string string}
    backgrnd,datarr   BACKGRNDS
    backgrnd,ulist    UBackgrnds
    backgrnd,baddef   Ignore
    backgrnd,savecomm SaveUserDefined
    renamethod,predef   ""
    renamethod,dfields  {nb method}
    renamethod,fnames   {|name |rmrk |operators}
    renamethod,ftypes   {entry text apply:RenameMethod}
    renamethod,fdtypes  {string list}
    renamethod,datarr   RENMETHS
    renamethod,ulist    URenMeths
    renamethod,baddef   Ignore
    renamethod,savecomm SaveUserDefined
    plugin,predef   PREDEFPLUGINDESCR
    plugin,dfields  {nb unavailif params code where}
    plugin,fnames   {|name |rmrk |unavailif |params |tclcode |where}
    plugin,ftypes   {entry text entry entry text text}
    plugin,fdtypes  {string list list list list}
    plugin,datarr   PLUGIN
    plugin,ulist    UPlugIns
    plugin,baddef   BadUserPlugIn
    plugin,savecomm SaveUserPlugIns
}

proc Define {dtype args} {
    # create a dialog for a new definition
    #  $dtype in {datum, ellpsd, backgrnd, renamethod, plugin}
    #  $args if defined is taken as the list of initial field values
    # return name of new definition or "" if operation is cancelled
    global DefSpecs

    return [Definition $dtype $DefSpecs($dtype,fnames) \
		$DefSpecs($dtype,ftypes) $args {create revert cancel}]
}

proc Inspect {dtype name args} {
    # create dialog for inspecting/editing a definition
    #  $dtype in {datum, ellpsd, backgrnd, renamethod, plugin}
    global DefSpecs

    set datarr $DefSpecs($dtype,datarr) ; set ulist $DefSpecs($dtype,ulist)
    global $datarr $ulist
    set as {change revert create forget cancel}
    if { $DefSpecs($dtype,predef) != "" } {
	# there are GPSMan definitions that cannot be changed
	if { [lsearch -exact [set $ulist] $name] == -1 } {
	    set as {create revert cancel}
	}
    }
    set d [linsert [set [set datarr]($name)] 0 $name]
    Definition $dtype $DefSpecs($dtype,fnames) $DefSpecs($dtype,ftypes) $d $as
    return
}

proc GetDefFields {dtype name fs} {
    # return list of field values for definition of given type and name
    #  $fs is list of field names (as in DefSpecs array)
    # result is empty if definition does not exist; unknown fields are
    #  ignored silently
    global DefSpecs

    set datarr $DefSpecs($dtype,datarr)
    global $datarr
    if { [catch {set data [set [set datarr]($name)]}] } { return "" }
    set res "" ; set dflds $DefSpecs($dtype,dfields)
    foreach f $fs {
	if { [set ix [lsearch -exact $dflds $f]] != -1 } {
	    lappend res [lindex $data $ix]
	}
    }
    return $res
}

proc SaveUserDatumElls {args} {
    # save user-defined datums and ellipsoids
    # return 0 on error
    global UFile UDatums UEllipsoids GDATUM ELLPSDDEF MESS

    if { $UDatums == "" && $UEllipsoids == "" } {
	if { [file exists $UFile(datum,ell)] && \
		 [catch {file delete -- $UFile(datum,ell)}] } {
	    GMMessage $MESS(cantwrtdtel)
	}
	return 0
    }
    if { [catch {set f [open $UFile(datum,ell) w]}] } {
	GMMessage $MESS(cantwrtdtel)
	return 0
    }
    puts $f ""
    puts $f "# $MESS(written) GPSMan [NowTZ]"
    puts $f "# $MESS(editrisk)"
    puts $f ""
    puts -nonewline $f "set UDatums \{"
    WriteQuoteList $f $UDatums
    puts $f "\}"
    puts $f ""
    if { $UDatums != "" } {
	puts $f "array set GDATUM \{"
	foreach d $UDatums {
	    WriteQuote $f $d
	    set l $GDATUM($d)
	    puts -nonewline $f " \{"
	    WriteQuote $f [lindex $l 0]
	    puts $f ""
	    puts $f "    [lindex $l 1] [lindex $l 2] [lindex $l 3]"
	    puts -nonewline $f "    [lindex $l 4] "
	    WriteQuote $f [lindex $l 5]
	    puts $f "\}"
	    puts $f ""
	}
	puts $f "\}"
	puts $f ""
    }
    puts -nonewline $f "set UEllipsoids \{"
    WriteQuoteList $f $UEllipsoids
    puts $f "\}"
    puts $f ""
    if { $UEllipsoids != "" } {
	puts $f "array set ELLPSDDEF \{"
	foreach d $UEllipsoids {
	    WriteQuote $f $d
	    set l $ELLPSDDEF($d)
	    puts $f " \{[lindex $l 0] [lindex $l 1]"
	    WriteQuote $f [lindex $l 2]
	    puts $f "\}"
	    puts $f ""
	}
	puts $f "\}"
	puts $f ""
    }
    close $f
    return 1
}

proc SaveUserDefined {kind args} {
    # save user definition
    #  $kind in {backgrnd, renamethod, plugin}
    # return 0 on error
    global UFile DefSpecs MESS
    global $DefSpecs($kind,datarr) $DefSpecs($kind,ulist)

    set ulist [set $DefSpecs($kind,ulist)]
    if { $ulist == {} } {
	if { [file exists $UFile($kind)] && \
		 [catch {file delete -- $UFile($kind)}] } {
	    GMMessage $MESS(cantwrtdefs)
	    return 0
	}
	return 1
    }
    if { [catch {set f [open $UFile($kind) w]}] } {
	GMMessage $MESS(cantwrtdefs)
	return 0
    }
    set datarr $DefSpecs($kind,datarr)
    puts $f ""
    puts $f "# $MESS(written) GPSMan [NowTZ]"
    puts $f "# $MESS(editrisk)"
    puts $f ""
    puts -nonewline $f "set $DefSpecs($kind,ulist) \{"
    WriteQuoteList $f $ulist
    puts $f "\}"
    puts $f ""
    puts $f "array set $datarr \{"
    foreach d $ulist {
	WriteQuote $f $d
	puts -nonewline $f " \{"
	foreach v [set [set datarr]($d)] t $DefSpecs($kind,fdtypes) {
	    switch $t {
		atom {
		    puts $f $v
		}
		string {
		    WriteQuote $f $v ; puts $f ""
		}
		list {
		    puts $f [list $v]
		}
	    }
	}
	puts $f "\}"
	puts $f ""
    }
    puts $f "\}"
    puts $f ""
    close $f
    return 1
}

proc BadUserPlugIn {kind act name data} {
    # check plug-in definition
    #  $kind is plugin
    #  $act in {change, create, forget}  (depends on proc DefAction)
    #  $name is the plug-in unique name
    #  $data is list with all the values except short name (depends on
    #    proc DefAction)
    # return 1 on error
    global MESS

    if { $act == "forget" } { return 0 }
    # check the parameters and "where" lists
    if { [set where [lindex $data end]] == {} } {
	GMMessage $MESS(badpluginwhere)
	return 1
    }
    foreach t $where {
	foreach {patt type widget} $t { break }
	if { [llength $t] != 3 || $patt == "" || \
		 [lsearch -exact {button menu} $type] == -1 || \
		 $widget == "" } {
	    GMMessage $MESS(badpluginwhere)
	    return 1
	}
    }
    if { [llength [lindex $data 2]] & 1 == 1 } {
	GMMessage $MESS(badpluginparam)
	return 1
    }
    foreach {n p} [lindex $data 2] {
	if { [string index $n 0] != "_" } {
	    GMMessage $MESS(badpluginparam)
	    return 1
	}
    }
    return 0
}

proc SaveUserPlugIns {kind act name data} {
    # update data on available plug-ins and save definitions
    #  $kind is plugin
    #  $act in {change, create, forget}  (depends on proc DefAction)
    #  $name is the plug-in unique name
    #  $data is list with all the values except short name (depends on
    #    proc DefAction)
    # call proc SaveUserDefined for saving
    # return 0 on error
    global PLGSForWindow

    set where [lindex $data end]
    if { $act != "create" } {
	# change or forget
	# start by forgetting old references to this plugin
	foreach p [array names PLGSForWindow] {
	    set ts {}
	    foreach t $PLGSForWindow($p) {
		if { [lindex $t 0] != $name } {
		    lappend ts $t
		}
	    }
	    if { $ts == {} } {
		unset PLGSForWindow($p)
	    } else { set PLGSForWindow($p) $ts }
	}
    }
    if { $act != "forget" } {
	# create or change
	SetUpPlugIn $name $where
    }
    return [SaveUserDefined $kind]
}

proc UserDefinitions {} {
    # set up user definitions as they may be needed when revising options
    global DefSpecs UProjs UFile USERDIR PLUGIN	

    foreach t {datum ellpsd backgrnd renamethod plugin} {
	# data array may be needed below
	global $DefSpecs($t,ulist) $DefSpecs($t,datarr)

	set $DefSpecs($t,ulist) {}
    }

    if { [file readable [set UFile(datum,ell) [file join $USERDIR datums]]] } {
	# assumed to be in system encoding
	source $UFile(datum,ell)
    }
    SetUpNZGrids
    set UProjs {}
    if { [file readable [set UFile(proj,grid) [file join $USERDIR projs]]] } {
	SetupUserProjs
    }
    foreach t {backgrnd renamethod plugin} f {mapbacks renamethod plugins} {
	if { [file readable [set UFile($t) [file join $USERDIR $f]]] } {
	    # assumed to be in system encoding
	    source $UFile($t)
	}
    }
    foreach plugin [set $DefSpecs(plugin,ulist)] {
	SetUpPlugIn $plugin [lindex $PLUGIN($plugin) end]
    }
    return
}

proc FillDefsMenu {kind menu commdargs args} {
    # fill menu of definitions both prefined or user-defined
    #  $kind in {datum, ellpsd, backgrnd, renamethod, plugin}
    #  $commdargs is callback and first arguments of menu entries to which
    #    are appended the entry and $menu by proc FillMenu
    # if $args is not empty it is a list of menu entries to be added to
    #  the beginning of the menu
    global DefSpecs TXT
    global $DefSpecs($kind,ulist)

    set ulist [set $DefSpecs($kind,ulist)]
    # avoid clashes with special denotations used by proc FillMenu
    if { [regexp {@|(---)} $ulist] } {
	set l {}
	foreach x $ulist {
	    if { [regexp {^(@|(---))} $x] } {
		lappend l " $x"
	    } else { lappend l $x }
	}
	set ulist $l
    }
    if { $DefSpecs($kind,predef) != "" } {
	global $DefSpecs($kind,predef)
	set descr [set $DefSpecs($kind,predef)]
	if { $ulist != {} } {
	    set ud [linsert $ulist 0 "$TXT(userdefs)..."]
	    set descr [linsert $descr 0 @ $ud ---]
	}
    } else { set descr $ulist }
    set descr [concat $args $descr]
    FillMenu $menu $commdargs $descr
    return
}

proc Definition {kind fields types data acts} {
    # open a dialog for creating/inspecting/editing a definition of an
    #  object
    #  $kind  must be an index of TXT, and is used as an argument to
    #    proc DefAction that must be updated for each new kind
    # return name of new/changed definition or "" if operation is cancelled
    #  or definition is forgotten
    # the dialog will contain widgets for the name of the defined
    #  object and its parameters; in the next 3 lists the name corresponds
    #  always to the first element; these 3 lists are all aligned:
    #  $fields is a list with elements under the form:
    #       "reserved" field to be hidden and not saved
    #       =TEXT      field with label TEXT
    #       |TEXT      field with label $TXT(TEXT)
    #  $types is a list with elements that can be
    #       "reserved" field to be hidden and set to "_" when saving
    #       poss:EL field that can be either void or the description EL
    #       "entry" for an entry with any text (the name cannot be void)
    #       "text"  for any text (but the name cannot be void)
    #       "file=FTYPE"  for a file path (entry and select button) of type
    #           FTYPE (see $filetypes in proc GMStart, setup.tcl); can be
    #           void or refer to a non-existing file
    #       >PROC_AS   for a value in a menu filled in by a call to PROC_AS
    #           that is a string with a procedure name possibly followed
    #           by space separted initial arguments; two arguments will
    #           be appended: the menu and the command to be invoked by
    #           a selection; this command has two arguments: the selected
    #           value and the menu
    #       apply:PROC   for a text that cannot be directly changed by the
    #           user; clicking on it causes PROC to be called with the
    #           field as argument; PROC must return either an empty list
    #           for no-operation or a new value for the field; the field
    #           must be a pair with the text to be shown to the user and
    #           an internal representation of it; the field is kept in
    #           the global Datell($widget,value)
    #       any of the types accepted by proc BadParam (check.tcl)
    #  $data is a list (may be empty) of initial values for all entries;
    #    it is truncated to the length of $fields
    #  $acts are the possible actions allowed in the set:
    #    {cancel, create, change, revert, forget}
    # the dialog grabs the focus but cannot be kept raised because of menus
    global Datell EPOSX EPOSY COLOUR MESS TXT OBSWIDTH OBSHEIGHT LISTHEIGHT \
	DefCommand

    foreach x "kind types data" {
	set Datell($x) [set $x]
    }
    set Datell(grabs) [grab current]
    GMToplevel .datell $kind +$EPOSX+$EPOSY {} \
        {WM_DELETE_WINDOW {set DefCommand cancel}} {}

    frame .datell.fr -relief flat -borderwidth 5 -bg $COLOUR(selbg)
    label .datell.fr.title -text $TXT($kind) -relief sunken
    set frs .datell.fr.frsel
    frame $frs -relief flat -borderwidth 0
    set data [lrange $data 0 [expr [llength $fields]-1]]
    set n 0
    foreach f $fields t $types d $data {
	switch -glob $f {
	    reserved {
		incr n
		continue
	    }
	    |* {
		set lab $TXT([string range $f 1 end])
	    }
	    =* {
		set lab [string range $f 1 end]
	    }
	}
	label $frs.l$n -text $lab
	set vw $frs.v$n
	regsub {poss:} $t "" t
	switch -glob -- $t {
	    entry {
		entry $vw -width 30
		ShowTEdit $vw $d 1
	    }
	    text {
		frame $vw
		set txt $vw.txt
		text $txt -wrap word  -width 70 -height 5 \
		    -exportselection true -yscrollcommand [list $vw.sv set]
		$txt insert 1.0 $d
		TextBindings $txt
		scrollbar $vw.sv -command [list $txt yview]
		grid $txt -row 0 -column 0 -sticky nesw
		grid $vw.sv -row 0 -column 1 -sticky ns
	    }
	    file=* {
		regsub {file=} $t "" ftype
		frame $vw
		entry $vw.fn -width 50
		ShowTEdit $vw.fn $d 1
		button $vw.sel -text $TXT(select) \
		    -command "DefSelectFile $ftype $vw"
		grid $vw.fn -column 0 -row 0 -sticky nesw
		grid $vw.sel -column 1 -row 0 -sticky e
	    }
	    >* {
		set mn $vw.mn
		menubutton $vw -text $d -relief raised -direction below \
		    -menu $mn
		menu $mn -tearoff 0 \
		    -postcommand "[string range $t 1 end] $mn DefMenuSel"
	    }
	    apply:* {
		regsub {apply:} $t "" comm
		# keep field value in Datell array
		set Datell($vw,value) $d
		frame $vw
		set txt $vw.txt
		text $txt -wrap word -width 70 -height 5 \
		    -exportselection true -yscrollcommand [list $vw.sv set]
		bind $txt <Button-1> [list DefApply $comm $vw]
		BalloonBindings $txt clicktoedit
		scrollbar $vw.sv -command [list $txt yview]

		$txt insert 1.0 [lindex $d 0]
		$txt configure -state disabled
		grid $txt -row 0 -column 0 -sticky nesw
		grid $vw.sv -row 0 -column 1 -sticky ns
	    }
	    default {
		entry $vw -width 15
		$vw insert 0 $d
	    }
	}
	grid configure $frs.l$n -column 0 -row $n -sticky nesw
	grid configure $vw -column 1 -row $n -sticky nesw
	incr n
    }
    set frb .datell.fr.frb
    frame $frb -relief flat -borderwidth 0
    foreach e $acts {
	button $frb.b$e -text $TXT($e) \
		-command "$frb.b$e configure -state normal ; \
		          set DefCommand $e"
	pack $frb.b$e -side left
    }

    pack .datell.fr.title $frs $frb -side top -pady 5
    pack .datell.fr

    update idletasks
    # cannot use RaiseWindow because of menus
    grab .datell
    while 1 {
	tkwait variable DefCommand
	switch $DefCommand {
	    cancel {
		DestroyRGrabs .datell $Datell(grabs)
		return ""
	    }
	    revert {
		set n 0
		foreach t $Datell(types) d $Datell(data) {
		    set vw $frs.v$n
		    regsub {poss:} $t "" t
		    switch -glob $t {
			text {
			    $vw.txt delete 1.0 end ; $vw.txt insert 1.0 $d
			}
			>* {
			    $vw configure -text $d
			}
			reserved {
			}
			file=* {
			    $vw.fn delete 0 end ; $vw.fn insert 0 $d
			}
			apply:* {
			    set txt $vw.txt
			    $txt configure -state normal
			    $txt delete 1.0 end
			    $vw insert 1.0 [lindex $d 0]
			    $txt configure -state disabled
			    set Datell($vw,value) $d
			}
			entry -
			default {
			    $vw delete 0 end ; $vw insert 0 $d
			}
		    }
		    incr n
		}
	    }
	    create {
		set nd [DefData $Datell(kind) $frs $Datell(types)]
		if { [regexp {^[0-9]+$} $nd] } {
		    focus $frs.v$nd
		    continue
		}
		set name [lindex $nd 0]
		if { [DefAction create $Datell(kind) $name "" \
			  [lreplace $nd 0 0]] } {
		    DestroyRGrabs .datell $Datell(grabs)
		    return $name
		}
	    }
	    change {
		set nd [DefData $Datell(kind) $frs $Datell(types)]
		if { [regexp {^[0-9]+$} $nd] } {
		    focus $frs.v$nd
		    continue
		}
		set name [lindex $nd 0]
		set oldname [lindex $Datell(data) 0]
		if { [DefAction change $Datell(kind) $name $oldname \
			  [lreplace $nd 0 0]] } {
		    DestroyRGrabs .datell $Datell(grabs)
		    return $name
		}
	    }
	    forget {
		set d $Datell(data) ; set name [lindex $d  0]
		if { [DefAction forget $Datell(kind) $name $name \
			  [lreplace $d 0 0]] } {
		    DestroyRGrabs .datell $Datell(grabs)
		    return ""
		}
	    }
	}
    }
    # not used
    return
}

proc DefApply {comm frtext} {
    # call command $comm to let the user edit a field
    #  $comm is called with the current field value and must return either
    #   an empty list for no-operation or a new field value
    # the field value is a list whose head is a text description to be
    #  shown in $frtext.txt
    # the current field value is kept in global $Datell($frtext,value)
    global Datell

    if { [set nv [$comm $Datell($frtext,value)]] != {} } {
	set text $frtext.txt
	$text configure -state normal
	$text delete 1.0 end ; $text insert 1.0 [lindex $nv 0]
	$text configure -state disabled
	set Datell($frtext,value) $nv
    }
    return
}

proc DefSelectFile {ftype fr} {
    # get absolute file path and set appropriate entry in frame $fr
    global TXT File

    if { [set fn [GMGetFileName $TXT(select) $ftype r {} {}]] != ".." } {
	$fr.fn delete 0 end
	$fr.fn insert 0 $File($ftype)
    }
    return
}

proc DefMenuSel {value menu} {
    # a $value was selected in $menu

    [winfo parent $menu] configure -text $value
    return
}

proc DefData {kind frs types} {
    # collect and check data in the definition dialog
    #  $kind gives the kind of object being defined (used in error messages)
    #  $frs is the frame with the widgets containing the data
    #  $types as in proc Definition
    # return list with values or an integer on error giving the number of the
    #  widget (from 0) with bad value
    global TXT MESS Datell

    set nd "" ; set n 0
    foreach t $types {
	set vw $frs.v$n
	set poss [regsub {poss:} $t "" t]	    
	switch -glob $t {
	    entry {
		set d [string trim [$vw get]]
		if { $n == 0 && $d == "" } {
		    GMMessage $MESS(namevoid)
		    return 0
		}
	    }
	    text {
		set d [string trim [$vw.txt get 1.0 end] " \n"]
	    }
	    file=* {
		set d [string trim [$vw.fn get]]
	    }
	    >* {
		set d [$vw cget -text]
	    }
	    apply:* {
		set d $Datell($vw,value)
	    }
	    reserved {
		set d "_"
	    }
	    default {
		set d [$vw get]
		if { ! $poss && $d != "" && [BadParam $TXT($kind) $t $d] } {
		    return $n
		}
	    }
	}
	lappend nd $d
	incr n
    }
    return $nd
}

proc DefAction {act kind name oldname data} {
    # try to act on definition of object under $name (was $oldname)
    #  $act in {change, create, forget}
    #  $kind in {datum, ellpsd, backgrnd, renamethod, plugin}
    #  $data is list with all the values except name (not used if $act==forget)
    # it is assumed that for each kind there a list of names of user-defined
    #  objects, data array indexed by the object name and a proc that is to
    #  be called upon a successful action
    # this proc does NOT check whether definitions are in use when
    #  changing/forgetting
    # changes here may affect the procedure called for each kind of definition
    # return 0 if action fails, and 1 otherwise
    global MESS TXT DefSpecs

    foreach v "datarr ulist baddef savecomm" {
	set $v $DefSpecs($kind,$v)
    }
    global $datarr $ulist
    if { [$baddef $kind $act $name $data] } { return 0 }
    switch $act {
	create {
	    if { [lsearch -exact [array names $datarr] $name] != -1 } {
		GMMessage $MESS(idinuse)
		return 0
	    }
	    set $ulist [lsort -dictionary [linsert [set $ulist] 0 $name]]
	    set [set datarr]($name) $data
	}
	change {
	    if { $name != $oldname } {
		if { [lsearch -exact [array names $datarr] $name] != -1 } {
		    GMMessage $MESS(idinuse)
		    return 0
		}
		set $ulist [lsort -dictionary \
		       [linsert [Delete [set $ulist] $oldname] 0 $name]]
		unset [set datarr]($oldname)
	    }
	    set [set datarr]($name) $data
	}
	forget {
	    if { ! [GMConfirm [format $MESS(askforget) $TXT($kind)]] } {
		return 0
	    }
	    set $ulist [Delete [set $ulist] $oldname]
	    unset [set datarr]($oldname)
	}
    }
    return [$savecomm $kind $act $name $data]
}

proc RenameMethod {descmeth} {
    # create dialog to edit a WP renaming method
    #  $descmeth is either empty or a pair with a textual description
    #   and a list for the internal representation of the method:
    #    keep1st   -- keep 1st char, further changes act on remaining chars
    #    reset     -- restart with initial name undoing any previous changes
    #    case:X    -- change case, X in {tolower, toupper}
    #    maxlgth:N -- cut to a maximum of N chars
    #    inslt:S   -- insert S at left 
    #    insrt:S   -- insert S at right
    #    replc:XY  -- replace chars by mapping head of XY to its tail
    #              element; both must be strings of same length
    #    delany:S  -- delete all chars that also appear in string S
    #    rsub:RS   -- apply regsub -all taking head of RS as regular
    #              expression and its tail element as substitution
    #              specification
    #    accifnew  -- accept if result is a new name
    #    guntilnew:P -- generate names using the head of P as prefix
    #                followed by a number; the tail element of P is
    #                the number of digits to be used; numbers start
    #                from 1 and all possible values are tried until
    #                a new name is found; if none there is no side-effect
    # return an empty list if no change was made, or a pair as $descmeth
    global Datell COLOUR TXT MESS EPOSX EPOSY TYPES

    if { [winfo exists .renameth] } { raise .renameth ; bell ; return }

    set Datell(renameth,orgtxt) [lindex $descmeth 0]
    set Datell(renameth,orglst) [lindex $descmeth 1]
    set Datell(renameth,test) ""
    set Datell(renameth,testchk) ""

    toplevel .renameth
    wm protocol .renameth WM_DELETE_WINDOW \
	{ set Datell(renameth,act) cancel }

    wm title .renameth "$TXT(renamethod)/GPS Manager"
    wm transient .renameth
    wm geometry .renameth +$EPOSX+$EPOSY

    frame .renameth.fr -relief flat -borderwidth 5 -bg $COLOUR(selbg)
    label .renameth.fr.title -text $TXT(renamethod) -relief sunken

    frame .renameth.fr.frm

    # sequence of operations
    set frt .renameth.fr.frm.frt
    frame $frt
    set txt $frt.txt
    text $txt -wrap none -width 50 -height 25 -exportselection true \
	-yscrollcommand "$frt.yscr set" -xscrollcommand "$frt.xscr set" \
	-cursor arrow
    $txt tag configure msel -background $COLOUR(selbg)
    foreach ev {Button-3 ButtonRelease-3} a {move stop} {
	bind $txt <$ev> "RenameMText $a %x %y"
    }
    bind $txt <Button-1> "RenameMText sel %x %y ; break"
    bind $txt <B1-Motion> break
    bind $txt <B3-Enter> "RenameMText enter-down %X %Y ; break"
    foreach ev {B3-Motion Any-Enter B3-Leave} a {go enter leave} {
	bind $txt <$ev> "RenameMText $a %X %Y"
    }
    scrollbar $frt.xscr -orient horizontal -command "$txt xview"
    scrollbar $frt.yscr -command "$txt yview"

    frame $frt.ftb
    foreach x {del clearall} {
	button $frt.ftb.$x -text $TXT($x) -command "RenameMText $x"
    }
    BalloonButton $frt.ftb.hlp renmove_hlp

    # widgets in this frame are used in other procs
    set fra .renameth.fr.frm.fra
    frame $fra
    label $fra.add -text $TXT(add)
    grid $fra.add -row 0 -column 0 -sticky w -ipadx 50
    set row 1
    set acts [list keep1st reset case maxlgth inslt insrt replc \
		  delany rsub accifnew guntilnew]
    foreach act $acts {
	set fargs $fra.fargs$act
	frame $fargs
	set col -1
	# these widgets are used in proc RenameMAdd
	button $fargs.addop -text $TXT($act) -width 20 \
	    -command "RenameMAdd $act $fargs"
	grid $fargs.addop -row 0 -column 0
	grid [BalloonButton $fargs.h$act ${act}_hlp] -row 0 -column 1
	set acol 2
	switch $act {
	    case {
		foreach v {toupper tolower} {
		    radiobutton $fargs.$v -text $TXT($v) \
			-variable Datell(renameth,argcase) \
			-value $v -anchor w -selectcolor $COLOUR(check)
		    grid $fargs.$v -row 0 -column $acol -sticky ew -padx 5
		    incr acol
		}
		$fargs.toupper select
	    }
	    maxlgth {
		entry $fargs.arg -width 5 -justify right
		grid $fargs.arg -row 0 -column $acol -padx 5
	    }
	    inslt - insrt - delany {
		entry $fargs.arg -width 20
		TextBindings $fargs.arg
		grid $fargs.arg -row 0 -column $acol -padx 5
	    }
	    replc - rsub {
		foreach x {1 2} {
		    entry $fargs.arg$x -width 20
		    TextBindings $fargs.arg$x
		    grid $fargs.arg$x -row 0 -column $acol -padx 5
		    incr acol
		}
	    }
	    keep1st - accifnew - reset {}
	    guntilnew {
		label $fargs.atit -text $TXT(ndigits) -width 23 \
		    -anchor e
		entry $fargs.arg -width 5 -justify right
		grid $fargs.atit -row 0 -column $acol -padx 5 -sticky e
		grid $fargs.arg -row 0 -column [incr acol] -sticky w
	    }
	}
	grid $fargs -row $row -column [incr col] -sticky w
	incr row
    }

    # test area
    set frtr .renameth.fr.frtr
    frame $frtr
    button $frtr.try -text $TXT(applyto) -command RenameMTest
    entry $frtr.name -width 25
    TextBindings $frtr.name
    bind $frtr.name <Leave> \
	{ set Datell(renameth,test) "" ; set Datell(renameth,testchk) "" }
    label $frtr.res -width 25 -textvariable Datell(renameth,test) \
	-relief raised
    set hlp [BalloonButton $frtr.hlp rentest_hlp]
    label $frtr.chk -text $TXT(check): -width 6
    label $frtr.chkr -textvariable Datell(renameth,testchk) -width 6
    pack $frtr.try $frtr.name $frtr.res $hlp -side left -padx 3
    pack $frtr.chk -side left -padx 5
    pack $frtr.chkr -side left

    # control buttons
    set frb .renameth.fr.frb
    frame $frb
    foreach c {ok revert cancel} {
	button $frb.$c -text $TXT($c) \
	    -command "set Datell(renameth,act) $c"
	pack $frb.$c -side left
    }

    RenameMFill

    # in $frt
    grid $txt -row 0 -column 0 -sticky nesw
    grid $frt.yscr -row 0 -column 1 -sticky ns
    grid $frt.xscr -row 1 -column 0 -sticky ew
    grid $frt.ftb.del $frt.ftb.clearall $frt.ftb.hlp
    grid $frt.ftb -row 2 -column 0 -columnspan 2

    # in .renameth.fr.frm
    grid $frt -row 0 -column 0 -sticky nesw -pady 15
    grid $fra -row 0 -column 1 -sticky w -padx 3

    grid rowconfigure $frt 0 -weight 1
    grid columnconfigure $frt 0 -weight 1
    grid rowconfigure .renameth.fr.frm 0 -weight 1
    grid columnconfigure .renameth.fr.frm 0 -weight 1

    pack .renameth.fr.title
    pack $frb -side bottom -pady 5
    pack $frtr -side bottom -pady 5
    # must be the last one
    pack .renameth.fr.frm -fill both -expand 1 -pady 5
    pack .renameth.fr -fill both -expand 1

    grid rowconfigure .renameth.fr 1 -weight 1
    grid columnconfigure .renameth.fr 1 -weight 1
    grid rowconfigure .renameth 0 -weight 1
    grid columnconfigure .renameth 1 -weight 1

    update idletasks
    # cannot use RaiseWindow because of menus
    set grabs [grab current]
    grab .renameth
    while 1 {
	tkwait variable Datell(renameth,act)
	switch $Datell(renameth,act) {
	    cancel {
		set res {}
		break
	    }
	    revert {
		if { [GMConfirm $MESS(askrevert)] } {
		    RenameMFill
		}
	    }
	    ok {
		if { [set res $Datell(renameth,lst)] == {} } {
		    GMMessage $MESS(emptyrmeth) ; continue
		}
		set descr [string trim [$txt get 1.0 end] "\n"]
		append descr "\n"
		set res [list $descr $res]
		break
	    }
	}
    }
    DestroyRGrabs .renameth $grabs
    destroy .renameth
    return $res
}

proc RenameMFill {} {
    # use original method as described in the Datell array to fill in
    #  the edit window and (re-)initialise other Datell elements
    global Datell

    set Datell(renameth,lst) $Datell(renameth,orglst)
    set Datell(renameth,move) {}
    set Datell(renameth,test) "" ; set Datell(renameth,testchk) ""
    set frt .renameth.fr.frm.frt
    set txt $frt.txt
    $txt configure -state normal
    $txt delete 1.0 end
    $txt insert 1.0 $Datell(renameth,orgtxt)
    $txt configure -state disabled
    return
}

proc RenameMAdd {act fr} {
    # add a new operation to renaming method being edited
    #  $act   see proc RenameMethod
    #  $fr    is frame containing widgets with title and arguments, the
    #          first one being the title
    global Datell TXT MESS

    # get arguments if any from widgets
    set descr $TXT($act)
    set op $act
    switch $act {
	keep1st - accifnew - reset {}
	case {
	    append descr " " $TXT($Datell(renameth,argcase))
	    append op ":" $Datell(renameth,argcase)
	}
	maxlgth - guntilnew {
	    set v [string trim [$fr.arg get]]
	    if { ! [CheckNumber GMMessage $v] } { return }
	    if { $v < 1 && $op == "guntilnew" } {
		GMMessage [format $MESS(xcantbey) $TXT(ndigits) 0]
		return
	    }
	    append descr " " $v
	    append op ":" $v
	}
	inslt - insrt - delany - guntilnew {
	    if { [set str [$fr.arg get]] == "" } {
		GMMessage $MESS(strgvoid)
		return
	    }
	    append descr " " $str
	    append op ":" [list $str]
	}
	replc {
	    set str1 [$fr.arg1 get] ; set str2 [$fr.arg2 get]
	    if { [string length $str1] != [string length $str2] } {
		GMMessage $MESS(samelgth)
		return
	    }
	    append descr " " $str1 " --> " $str2
	    append op ":" [list $str1 $str2]
	}
	rsub {
	    set s1 [$fr.arg1 get] ; set s2 [$fr.arg2 get]
	    if { [catch {regsub -all -- "{$s1}" aaa "{$s2}" x} s] } {
		GMMessage $MESS(rschkargs)
		return
	    }
	    append descr " " $s1 "  ;  "  $s2
	    append op ":" [list $s1 $s2]
	}
    }

    set txt .renameth.fr.frm.frt.txt
    $txt configure -state normal
    $txt insert end "- $descr\n"
    $txt configure -state disabled
    lappend Datell(renameth,lst) $op
    return
}

proc RenameMArgs {op} {
    # the description of an operation was selected: show its arguments
    #  $op    internal representation of the operation
    global Datell

    set fra .renameth.fr.frm.fra
    regexp {^([^:]+)} $op x opn
    set fr $fra.fargs$opn
    regsub "$opn:" $op "" val
    switch $opn {
	keep1st - accifnew - reset {}
	case {
	    set Datell(renameth,argcase) $val
	}
	maxlgth - guntilnew {
	    $fr.arg delete 0 end
	    $fr.arg insert 0 $val
	}
	inslt - insrt - delany - guntilnew {
	    $fr.arg delete 0 end
	    $fr.arg insert 0 [lindex $val 0]
	}
	replc - rsub {
	    foreach s $val k {1 2} {
		$fr.arg$k delete 0 end
		$fr.arg$k insert 0 $s
	    }
	}
    }
    return
}

proc RenameMTest {} {
    # test method being defined with string given by user
    global Datell MESS TXT

    set fr .renameth.fr.frtr
    set Datell(renameth,test) "" ; set Datell(renameth,testchk) ""
    if { [set str [$fr.name get]] == "" } {
	GMMessage $MESS(namevoid)
	return
    }
    if { [set meth $Datell(renameth,lst)] == 0 } { return }
    set Datell(renameth,test) [RenameMethApply $meth $str {} GMMessage]
    if { [CheckName Ignore $Datell(renameth,test)] } {
	set Datell(renameth,testchk) $TXT(ok)
    } else { set Datell(renameth,testchk) $TXT(failed) }
    return
}

proc RenameMText {op args} {
    # attend to events on method description widget
    #  $op in 
    #      {sel, del, clearall, move, go, stop, enter, enter-down, leave}
    #  $args is empty for del and either %x,%y for sel, move, stop or %X,%Y
    global Datell

    set txt .renameth.fr.frm.frt.txt
    set tb .renamethmv
    switch $op {
	sel {
	    # select/deselect a line
	    foreach {x y} $args {}
	    if { [set ix [$txt index @$x,$y]] == -1 } { return }
	    regexp {^([^.]+)} $ix xx line
	    if { [$txt get $line.0 $line.end] == "" } { return }
	    if { ! [catch {set ix [$txt index msel.first]}] } {
		$txt tag remove msel msel.first msel.last
		if { $ix == "$line.0" } { return }
	    }
	    $txt tag add msel $line.0 $line.end
	    RenameMArgs [lindex $Datell(renameth,lst) [expr $line-1]]
	}
	del {
	    if { [catch {set ix [$txt index msel.first]}] } {
		bell ; return
	    }
	    regexp {^([^.]+)} $ix xx line
	    $txt configure -state normal
	    $txt delete $line.0 "$line.end + 1c"
	    $txt configure -state disabled
	    # text indices start from 1
	    incr line -1
	    set Datell(renameth,lst) [lreplace $Datell(renameth,lst) \
					  $line $line]
	}
	clearall {
	    $txt configure -state normal
	    $txt delete 1.0 end
	    $txt configure -state disabled
	    set Datell(renameth,lst) {}
	}
	move {
	    # start moving a line
	    foreach {x y} $args {}
	    if { [set ix [$txt index @$x,$y]] == -1 } { return }
	    regexp {^([^.]+)} $ix xx line
	    if { [set chs [$txt get  $line.0 $line.end]] == "" } { return }
	    if { $Datell(renameth,move) == {} } {
		set Datell(renameth,move) in
	    }
	    NewBalloon $tb $chs \
	     +[expr $x+[winfo rootx $txt]+9]+[expr \
						  $y+[winfo rooty $txt]+9]
	    set Datell(renameth,move,txt) $chs
	    set Datell(renameth,move,line) $line
	}
	enter-down {
	    if { $Datell(renameth,move) == "out" } {
		if { [winfo exists $tb] } {
		    set Datell(renameth,move) in
		    foreach {X Y} $args {}
		    wm geometry $tb +[expr $X+9]+[expr $Y+9]
		} else {
		    set Datell(renameth,move) {}
		}
	    }
	}
	enter {
	    if { $Datell(renameth,move) != {} } {
		destroy $tb ; set Datell(renameth,move) {}
	    }
	}
	go {
	    if { $Datell(renameth,move) == "in" && [winfo exists $tb] } {
		foreach {X Y} $args {}
		wm geometry $tb +[expr $X+9]+[expr $Y+9]
	    }
	}
	stop {
	    if { $Datell(renameth,move) == "in" && [winfo exists $tb] } {
		destroy $tb ; set Datell(renameth,move) {}
		foreach {x y} $args {}
		if { [set ix [$txt index @$x,$y]] == -1 } { return }
		regexp {^([^.]+)} $ix xx line
		set old $Datell(renameth,move,line)
		if { $line == $old } { return }
		$txt configure -state normal
		$txt delete $old.0 "$old.end + 1c"
		$txt insert $line.0 "$Datell(renameth,move,txt)\n"
		$txt configure -state disabled
		# text indices start from 1
		incr old -1 ; incr line -1
		set op [lindex $Datell(renameth,lst) $old]
		set lst [lreplace $Datell(renameth,lst) $old $old]
		set Datell(renameth,lst) [linsert $lst $line $op]
	    }
	}
	leave {
	    if { $Datell(renameth,move) == "in" } {
		set Datell(renameth,move) out
	    }
	}
    }
    return
}

proc RenameMethApply {method str unames errproc} {
    # apply a WP renaming method to a string
    #  $method is a list described in proc RenameMethod
    #  $unames is a list of names not to be used
    # return an empty string when there is an error or the result is in
    #  $unames or is in use in the data-base, in both cases calling
    #  $errproc with message
    global MESS TXT

    # apply operators (if any)
    set old $str
    set res ""
    foreach op $method {
	switch -glob -- $op {
	    keep1st {
		# keep 1st char, further changes act on remaining chars
		append res [string index $str 0]
		set str [string replace $str 0 0]
	    }
	    reset {
		# restart with given name undoing any previous changes
		set str $old
		set res ""
	    }
	    case:* {
		# tolower / toupper
		regsub "case:" $op "" op
		set str [string $op $str]
	    }
	    maxlgth:* {
		# trim to length
		regsub "maxlgth:" $op "" n
		set str [string range $str 0 [expr $n-1]]
	    }
	    inslt:* {
		# insert left
		regsub "inslt:" $op "" s
		set s [lindex $s 0]
		append s $str
		set str $s
	    }
	    insrt:* {
		# insert right
		regsub "insrt:" $op "" s
		append str [lindex $s 0]
	    }
	    replc:* {
		# map chars according to the given two strings
		#  that have the same length
		regsub "replc:" $op "" p
		foreach {s1 s2} $p {}
		set s1 [split $s1 ""]
		set s2 [split $s2 ""]
		foreach c1 $s1 c2 $s2 {
		    set str [string map [list $c1 $c2] $str]
		}
	    }
	    delany:* {
		# delete all chars that also appear in given string
		regsub "delany:" $op "" s
		foreach c [split [lindex $s 0] ""] {
		    set str [string map [list $c {}] $str]
		}
	    }
	    rsub:* {
		# apply "regsub -all" to given regular expression
		#  and substitution specification
		regsub "rsub:" $op "" p
		foreach {re ssp} $p {}
		if { [catch {regsub -all -- $re $str $ssp str}] } {
		    $errproc $MESS(rschkargs)
		    return ""
		}
	    }
	    accifnew {
		# accept result if it is a new name
		set r $res
		append r $str
		if { [lsearch -exact $unames $r] == -1 && \
			 [IndexNamed WP $r] == -1 } { return $r }
	    }
	    guntilnew:* {
		# generate names using current result as prefix
		#  followed by a number with given number of digits
		#  until either a new name is found and returned,
		#  or all values were tried in which case nothing happens
		regsub "guntilnew:" $op "" nd
		set n 1 ; set lim1 [expr int(pow(10,$nd))]
		set fmt "%0${nd}d"
		set pre $res
		append pre $str
		# this may be too slow...
		set sid [SlowOpWindow $TXT(gennames)]
		for { set n 1 } { $n < $lim1 } { incr n } {
		    set name "$pre[format $fmt $n]"
		    if { [lsearch -exact $unames $name] == -1 && \
			     [IndexNamed WP $name] == -1 } {
			SlowOpFinish $sid ""
			return $name
		    }
		    if { $n%50 == 0 && [SlowOpAborted] } { break }
		}
		SlowOpFinish $sid ""
	    }
	}
    }
    append res $str
    if { [lsearch -exact $unames $res] != -1 || \
	     [IndexNamed WP $res] != -1 } {
	$errproc "$MESS(nameinuse): $res"
	return ""
    }
    return $res
}