944 lines
31 KiB
Tcl
Executable File
944 lines
31 KiB
Tcl
Executable File
#!/bin/sh
|
|
# this line restarts using wish \
|
|
exec wish "$0" "$@"
|
|
|
|
###############################################################
|
|
# Description: pickconfig.tcl
|
|
# This file validates a LinuxCNC configuration
|
|
# passed to it, or prompts the user to choose
|
|
# one.
|
|
#
|
|
# Author: John Kasunich
|
|
# License: GPL Version 2
|
|
#
|
|
# Copyright (c) 2005-2009 All rights reserved.
|
|
###############################################################
|
|
#
|
|
# usage:
|
|
# pickconfig <config-path>
|
|
#
|
|
# <config-path> is one or more directories (separated with
|
|
# colons) in which pickconfig should search for configs.
|
|
# pickconfig will open a GUI window displaying all configs
|
|
# that it finds and ask the user to choose one, then print
|
|
# the path to the chosen config and exit.
|
|
#
|
|
###############################################################
|
|
|
|
# Load the linuxcnc.tcl file, which defines variables for various useful paths
|
|
source [file join [file dirname [info script]] .. linuxcnc.tcl]
|
|
|
|
set logo [linuxcnc::image_search linuxcnc-wizard]
|
|
image create photo machinelogo
|
|
|
|
option add *font [linuxcnc::standard_font]
|
|
option add *Text.font [linuxcnc::standard_fixed_font]
|
|
option add *Entry*background white
|
|
option add *Listbox*background white
|
|
option add *Tree*background white
|
|
|
|
|
|
################### MAINTENANCE ITEMS #####################
|
|
|
|
# flat structure:
|
|
# Ini files should always refer to ../../nc_files so
|
|
# that hey will work in run-in-place and deb-installed
|
|
# systems.
|
|
# Config subdirs can be moved with little impact when
|
|
# ../../nc_files relative link is used.
|
|
#
|
|
# hierarchical structure:
|
|
# Ini files must refer to appropriate nc_files by
|
|
# relative links so that they will work in run-in-place
|
|
# and deb-installed systems.
|
|
# Ini files must be edited if config subdirs are moved to
|
|
# a different depth in the tree to update the relative
|
|
# links
|
|
#
|
|
set ::make_flat_user_dirs 1 ;# 0 ==> hierarchical
|
|
|
|
# start on this node if no ~/.linuxcncrc:
|
|
set ::default_start_node sim/axis/axis.ini
|
|
|
|
# exclude directories that should never be offered
|
|
set ::exclude_list [list common]
|
|
|
|
# exclude files with special names
|
|
set ::exclude_file_list _panelui.ini
|
|
|
|
# support filenames that are never copied to user:
|
|
set ::never_copy_list [list maintainer.txt nodemocopy]
|
|
|
|
# emphasize sim ini configs that have the most support by reordering
|
|
# reorder: priority low to high:
|
|
set ::preferred_names [list \
|
|
low_graphics \
|
|
gmoccapy \
|
|
gscreen \
|
|
touchy \
|
|
ngcgui \
|
|
axis \
|
|
by_machine \
|
|
by_interface \
|
|
sim \
|
|
]
|
|
|
|
# support creation of links for newly added _lib dirs in nc_files
|
|
set ::always_update_nc_files 1
|
|
|
|
################### PROCEDURE DEFINITIONS #####################
|
|
|
|
set desktopdir [exec bash -c {test -f ${XDG_CONFIG_HOME:-~/.config}/user-dirs.dirs && . ${XDG_CONFIG_HOME:-~/.config}/user-dirs.dirs; echo ${XDG_DESKTOP_DIR:-$HOME/Desktop}}]
|
|
|
|
# use initialize_config for bwidget and .linuxcncrc
|
|
proc initialize_config {} {
|
|
# need bwidget
|
|
set result [catch {package require BWidget 1.7}]
|
|
if {$result != 0} {
|
|
puts stderr $result
|
|
tk_messageBox -icon error -type ok -message [msgcat::mc "Can't find the bwidget 1.7 package. There is a debian bwidget package; install \nit with sudo apt-get install bwidget."]
|
|
exit
|
|
destroy .
|
|
} else {
|
|
if {[catch {open $::env(HOME)/.linuxcncrc} programin]} {
|
|
return
|
|
} else {
|
|
set rcstring [read $programin]
|
|
catch {close $programin}
|
|
set ret [getVal $rcstring PICKCONFIG LAST_CONFIG ]
|
|
set ::openmode 1
|
|
return $ret
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# FIXME add trap for comment on the first of a line.
|
|
proc getVal {stringa sect var} {
|
|
set varval ""
|
|
set x [regexp -indices -- "$sect.*$var *= *" $stringa indexes]
|
|
if {$x } {
|
|
set startindex [lindex $indexes 1]
|
|
set x [regexp -start $startindex -linestop -- ".*" \
|
|
$stringa varval ]
|
|
set varval [string trim $varval]
|
|
}
|
|
return $varval
|
|
}
|
|
|
|
proc setVal {stringb sect var newval} {
|
|
set x [regexp -indices -- "$sect.*$var *= *" $stringb start ]
|
|
if {$x } {
|
|
set startindex [expr [lindex $start 1] +1]
|
|
set x [regexp -indices -start $startindex -linestop -- ".*" $stringb end ]
|
|
set endindex [lindex $end 1]
|
|
set newstring [string replace $stringb $startindex $endindex $newval]
|
|
return $newstring
|
|
}
|
|
}
|
|
|
|
# main button callback, it assigns the button name to '::choice'
|
|
|
|
proc button_pushed { button_name } {
|
|
|
|
set ::choice $button_name
|
|
}
|
|
|
|
# slider process is used for several widgets
|
|
proc sSlide {f a b} {
|
|
$f.sc set $a $b
|
|
}
|
|
|
|
proc title {node} {
|
|
if [file isfile $node] {
|
|
set txt "CURRENT: [file tail $::selected_node]"
|
|
} else {
|
|
set txt ""
|
|
}
|
|
wm title . "[msgcat::mc "LinuxCNC Configuration Selector"] $txt"
|
|
}
|
|
|
|
proc find_usable_nodes {startdir} {
|
|
return [exec find -L $startdir -type f \
|
|
-name "*.ini" -o -name "*.demo" ]
|
|
} ;# find_usable_nodes
|
|
|
|
proc name_is_usable_nodename {node} {
|
|
if { [ regexp {.*\.ini$} $node ] == 1 \
|
|
|| [ regexp {.*\.demo$} $node ] == 1 \
|
|
} {
|
|
if {[lsearch $::exclude_file_list [file tail $node]] >= 0} {
|
|
return 0
|
|
}
|
|
return 1 ;# ok
|
|
}
|
|
return 0 ;# fail
|
|
} ;# name_is_usable_nodename {node}
|
|
|
|
proc ok_to_copy_config {filename} {
|
|
# The following tests determines when to copy files to a user directory:
|
|
# 1) If the directory for the selected file is not writable,
|
|
# then it is presumed to be a system dir running from an install (by
|
|
# a deb install typically) so copy the configuration to user directory.
|
|
#
|
|
# 2) For non-RIP builds, if the file is not under the user's
|
|
# myconfigs_node, force copy regardless of filesystem writability.
|
|
# This catches distros where installed sample-configs happen to be
|
|
# writable by the running user (e.g. Gentoo system-wide installs to
|
|
# a group-writable path).
|
|
#
|
|
# 3) if the directory is included in ::user_aux_dirs (as
|
|
# specified by the environmental variable LINUXCNC_AUX_EXAMPLES),
|
|
# then the config is copied to user directory to avoid overwriting
|
|
# a developmental source directory.
|
|
#
|
|
# Otherwise, it is presumed to be a Run-In-Place directory and
|
|
# copying to another directory is not wanted.
|
|
#
|
|
# For convenience in testing pickconfig by itself in rip builds:
|
|
# export debug_pickconfig=1
|
|
# This forces copying to the user directory so that the copied
|
|
# configs can be tested.
|
|
|
|
set forcecopy 0
|
|
if { [info exists ::env(debug_pickconfig)] \
|
|
&& [string first $::myconfigs_node $filename]} {
|
|
set forcecopy 1
|
|
}
|
|
|
|
set is_rip [expr {[info exists ::linuxcnc::RUN_IN_PLACE]
|
|
&& $::linuxcnc::RUN_IN_PLACE eq "yes"}]
|
|
if {!$is_rip && [string first $::myconfigs_node $filename] != 0} {
|
|
set forcecopy 1
|
|
}
|
|
|
|
if { [info exists ::user_aux_dirs] } {
|
|
foreach dir $::user_aux_dirs {
|
|
if {[file dirname $filename] == "$dir" } {
|
|
set forcecopy 1
|
|
}
|
|
}
|
|
}
|
|
|
|
if { ![file writable [file dirname $filename]]
|
|
|| $forcecopy
|
|
} {
|
|
set filetype [file extension $filename]
|
|
if {$filetype == ".ini"} { return 1 ;# ok }
|
|
if {$filetype == ".demo"} {
|
|
set nocopyfile [file join [file dirname $filename] nodemocopy]
|
|
if {![file exists $nocopyfile]} { return 1 ;# ok }
|
|
}
|
|
}
|
|
return 0 ;# not ok
|
|
} ;# ok_to_copy
|
|
|
|
# Notes on text displayed in detail_box widget:
|
|
# if node is usable (an ini file named xxx.ini or xxx.demo), then:
|
|
# show xxx.txt if it exists
|
|
# else
|
|
# show README if it exists in the directory for node
|
|
# else
|
|
# show "No Details available"
|
|
#
|
|
# if node is a directory, then:
|
|
# show README if it exists in the directory for node
|
|
|
|
# called when user clicks tree node
|
|
proc node_clicked {} {
|
|
|
|
set node [$::tree selection get]
|
|
set ::selected_node $node
|
|
title $node
|
|
if {$node == ""} return
|
|
set node [lindex $node 0]
|
|
|
|
$::tree selection set $node
|
|
$::tree see $node
|
|
|
|
set readme ""
|
|
if [name_is_usable_nodename $node] {
|
|
# acceptable name
|
|
# enable changes to the details widget
|
|
set node [format %s $node]
|
|
set dir [ file dirname $node]
|
|
set name [ file rootname [file tail $node ] ]
|
|
set readme [file join $dir $name.txt]
|
|
if { ![ file exists $readme ] } {
|
|
set readme [file join [ file dirname $node ] README ]
|
|
}
|
|
set image [file join $dir $name.gif]
|
|
if { ![ file exists $image ] } {
|
|
set image [ file join [ file dirname $node ] logo.gif ]
|
|
}
|
|
if { [ file readable $image ] } {
|
|
machinelogo blank
|
|
machinelogo read $image
|
|
puts stderr "using image $image"
|
|
$::detail_box image create end -image machinelogo
|
|
$::detail_box insert end "\n"
|
|
$::detail_box tag configure centered -justify center
|
|
$::detail_box tag add centered 0.0 0.end
|
|
}
|
|
# save selection
|
|
set ::inifile $node
|
|
|
|
# enable the OK button
|
|
$::button_ok configure -state normal
|
|
bind . <Return> {button_pushed OK}
|
|
bind . <KP_Enter> {button_pushed OK}
|
|
} else {
|
|
if {[file isdirectory $node]} {
|
|
set readme [file join $node README]
|
|
# clear selection
|
|
set ::inifile ""
|
|
# disable the OK button
|
|
$::button_ok configure -state disabled
|
|
bind . <Return> ""
|
|
bind . <KP_Enter> ""
|
|
}
|
|
}
|
|
|
|
# remove old text
|
|
$::detail_box configure -state normal
|
|
$::detail_box delete 1.0 end
|
|
if { [ file readable $readme ] } {
|
|
# description found, read it
|
|
set descr [ read -nonewline [ open $readme ]]
|
|
# expect file with unbroken paragraphs
|
|
$::detail_box insert end $descr
|
|
} else {
|
|
if [file isdirectory $node] {
|
|
if {"$node" == "$::myconfigs_node"} {
|
|
$::detail_box insert end "Your existing configs"
|
|
} elseif { "$node" == "$::sampleconfigs_node"} {
|
|
$::detail_box insert end "Available configs"
|
|
}
|
|
# else leave detail_box empty
|
|
} else {
|
|
# no description, gotta tell the user something
|
|
$::detail_box insert end [msgcat::mc "No details available."]
|
|
}
|
|
}
|
|
# lock it again
|
|
$::detail_box configure -state disabled
|
|
}
|
|
|
|
################ MAIN PROGRAM STARTS HERE ####################
|
|
set ::configs_dir_list $linuxcnc::CONFIG_DIR
|
|
set ::myconfigs_node $linuxcnc::USER_CONFIG_DIR
|
|
# order convention for items in the linuxcnc::USER_CONFIG_DIR list:
|
|
set ::sampleconfigs [lindex $::configs_dir_list end] ;# last item
|
|
|
|
# check for auxiliary applications example configs installed in
|
|
# known directory defined by: linuxcnc::LINUXCNC_AUX_ExAMPLES
|
|
set aux_examples $linuxcnc::LINUXCNC_AUX_EXAMPLES
|
|
set ::aux_dir_list {}
|
|
if [file isdirectory $aux_examples] {
|
|
foreach auxdir [glob $aux_examples/*] {
|
|
puts stderr "pickconfig: installed aux examples: $auxdir"
|
|
lappend ::configs_dir_list $auxdir
|
|
lappend ::aux_dir_list $auxdir
|
|
}
|
|
}
|
|
# user may specify auxiliary config directories using the environmental
|
|
# variable LINUXCNC_AUX_CONFIGS (a colon (:) separated path)
|
|
# This is useful for testing auxiliary apps without using a deb install
|
|
if [info exists ::env(LINUXCNC_AUX_CONFIGS)] {
|
|
foreach auxdir [split $::env(LINUXCNC_AUX_CONFIGS) :] {
|
|
if { [file isdirectory $auxdir] \
|
|
&& [file readable $auxdir] } {
|
|
set normauxdir [file normalize $auxdir]
|
|
puts stderr "pickconfig: user aux examples: $normauxdir"
|
|
lappend ::configs_dir_list $normauxdir
|
|
lappend ::user_aux_dirs $normauxdir ;# forcecopy
|
|
} else {
|
|
puts stderr "pickconfig: LINUXCNC_AUX_CONFIGS invalid directory:"
|
|
puts stderr " $auxdir"
|
|
puts stderr "continuing"
|
|
}
|
|
}
|
|
}
|
|
|
|
set ::last_ini "none"
|
|
set ::last_ini [initialize_config]
|
|
|
|
set ::openmode 0
|
|
if { [file exists [file join $::sampleconfigs $::default_start_node]]
|
|
|| "$::last_ini" != ""
|
|
} {
|
|
set ::openmode 1
|
|
}
|
|
|
|
# set options that are common to all widgets
|
|
foreach class { Button Entry Label Listbox Scale Text } {
|
|
option add *$class.borderWidth 1 100
|
|
}
|
|
|
|
# make a toplevel and a master frame.
|
|
title ""
|
|
set logo [label .logo -image $logo]
|
|
set top [frame .main -borderwidth 0 -relief flat ]
|
|
pack $logo -side left -anchor nw
|
|
pack $top -side left -expand yes -fill both
|
|
|
|
wm geo . 780x480
|
|
wm minsize . 780 480
|
|
|
|
proc SW { args } {
|
|
set res [eval ScrolledWindow $args]
|
|
$res.vscroll configure -relief flat
|
|
::${res}:cmd configure -highlightthickness 1
|
|
return $res
|
|
}
|
|
# a frame for packing the top window
|
|
set f1 [ frame $top.f1 ]
|
|
|
|
set message [msgcat::mc "Welcome to LinuxCNC.\n\nSelect a machine configuration from the list on the left.\nDetails about the selected configuration will appear in the display on the right.\nClick 'OK' to run the selected configuration"]
|
|
|
|
set lbl [ label $f1.lbl -text $message -justify left -padx 15 -pady 10 -wraplength 600 ]
|
|
pack $lbl -anchor w
|
|
|
|
# a subframe for the tree/detail box
|
|
set f2 [ frame $f1.f2 -borderwidth 0 -relief flat -padx 15 ]
|
|
|
|
# Let the tree scroll
|
|
set s1 [ SW $f2.f3 -auto both]
|
|
$s1 configure -relief sunken -borderwidth 2
|
|
# get the font height to scale the height of the tree rows
|
|
set font_linespace [font metrics [linuxcnc::standard_font] -linespace]
|
|
# the tree
|
|
set ::tree [Tree $s1.tree -highlightthickness 0 \
|
|
-width [expr {int($font_linespace * 1.33)}] -relief flat -padx 4 \
|
|
-deltay $font_linespace\
|
|
]
|
|
$s1 setwidget $::tree
|
|
pack $s1 -fill y -expand n -side left
|
|
|
|
# pack the tree into its subframe
|
|
bind $::tree <<TreeSelect>> { node_clicked }
|
|
$::tree bindText <Double-1> { $f5.ok invoke ;# }
|
|
|
|
# bwidget 1.7.0 does not generate <<TreeSelect>> events for keyboard navigation.
|
|
# These bindings fix that.
|
|
bind $::tree.c <KeyPress-Up> [list +event generate $::tree <<TreeSelect>>]
|
|
bind $::tree.c <KeyPress-Down> [list +event generate $::tree <<TreeSelect>>]
|
|
|
|
# Let the text scroll
|
|
set f4 [ SW $f2.f4 -scrollbar vertical]
|
|
$s1 configure
|
|
# a text box to display the details
|
|
set tb [ text $f4.tb -width 30 -wrap word -padx 6 -pady 6 \
|
|
-takefocus 0 -state disabled \
|
|
-relief flat -borderwidth 0 -height 12]
|
|
$f4.vscroll configure -takefocus 1
|
|
$f4 setwidget $tb
|
|
set ::detail_box $tb
|
|
# pack the subframe into the main frame
|
|
pack $f2 -side top -fill both -expand y
|
|
pack $f4 -side left -padx 3 -fill both -expand y
|
|
|
|
|
|
# a subframe for the buttons
|
|
set f5 [ frame $f1.f5 ]
|
|
button $f5.ok -text [msgcat::mc "OK"] -command "button_pushed OK" -width 8 -default active
|
|
set ::button_ok $f5.ok
|
|
$::button_ok configure -state disabled
|
|
button $f5.cancel -text [msgcat::mc "Cancel"] -command "button_pushed Cancel" -width 8 -default normal
|
|
pack $f5.cancel -side right -padx 4 -pady 4
|
|
pack $f5.ok -side right -padx 4 -pady 4
|
|
pack $f5 -side bottom -anchor e -fill x -expand n -padx 15
|
|
|
|
pack $f1 -fill both -expand y
|
|
|
|
set ::config_count 0
|
|
|
|
proc describe {dir} {
|
|
if {"$dir" == "$::myconfigs_node"} {
|
|
return [msgcat::mc "My Configurations"]
|
|
}
|
|
if {"$dir" == "$::sampleconfigs"} {
|
|
set ::sampleconfigs_node $dir
|
|
return [msgcat::mc "Sample Configurations"]
|
|
}
|
|
if {[lsearch $::aux_dir_list $dir] >= 0} {
|
|
return [file tail $dir]
|
|
} else {
|
|
return $dir
|
|
}
|
|
}
|
|
|
|
proc treeopen {args} {
|
|
set beforevisible [$::tree visible $::selected_node]
|
|
update
|
|
set visible [$::tree visible $::selected_node]
|
|
if {!$beforevisible && $visible && [info exists ::restorebox] } {
|
|
set state [$::detail_box cget -state]
|
|
$::detail_box configure -state normal
|
|
$::detail_box insert end $::restorebox
|
|
$::detail_box configure -state $state
|
|
unset ::restorebox
|
|
}
|
|
} ;# treeopen
|
|
|
|
proc treeclose {args} {
|
|
set visible [$::tree visible $::selected_node]
|
|
if {!$visible && ![info exists ::restorebox] } {
|
|
set ::restorebox [$::detail_box get 1.0 end]
|
|
set state [$::detail_box cget -state]
|
|
$::detail_box configure -state normal
|
|
$::detail_box delete 1.0 end
|
|
$::detail_box configure -state $state
|
|
}
|
|
} ;# treeclose
|
|
|
|
proc walktree {dir} {
|
|
if ![info exists ::openmode] {set ::openmode 0}
|
|
if ![$::tree exists $dir] {
|
|
set ::lvl $dir
|
|
$::tree insert end root $dir -text [describe $dir] -open $::openmode
|
|
}
|
|
set bothlist [lsort [glob -nocomplain $dir/*]]
|
|
if { [info exists ::sampleconfigs_node]
|
|
&& "$dir" == "$::sampleconfigs_node"} {
|
|
set bothlist [rearrange $bothlist]
|
|
}
|
|
set sortedlist {}
|
|
set filelist {}
|
|
set dirlist {}
|
|
# display files before directories
|
|
foreach item $bothlist {
|
|
if [file isdirectory $item] {
|
|
lappend dirlist $item
|
|
} else {
|
|
lappend sortedlist $item
|
|
}
|
|
}
|
|
foreach f $dirlist { lappend sortedlist $f }
|
|
|
|
foreach f $sortedlist {
|
|
if [file isdirectory $f] {
|
|
if {[lsearch $::exclude_list [file tail $f]] == 0} continue
|
|
set foundini [find_usable_nodes $f]
|
|
if {"$foundini" == ""} {
|
|
verbose "no usable files, skipping directory: $f"
|
|
continue
|
|
}
|
|
|
|
set text [file tail $f]
|
|
$::tree insert end $::lvl $f -text $text -open $::openmode
|
|
set restore $::lvl
|
|
set ::lvl $f
|
|
walktree $f ;# recursion
|
|
set ::lvl $restore
|
|
} else {
|
|
if [name_is_usable_nodename $f] {
|
|
set text [file rootname [file tail $f]]
|
|
$::tree insert end $::lvl $f -text $text -open $::openmode
|
|
incr ::config_count
|
|
continue
|
|
} else {
|
|
verbose "skipping non-start_node file: $f"
|
|
}
|
|
}
|
|
}
|
|
} ;# walktree
|
|
|
|
proc rearrange l {
|
|
set taillist {}
|
|
foreach item $l {
|
|
lappend taillist [file tail $item]
|
|
}
|
|
foreach name $::preferred_names {
|
|
set idx [lsearch $taillist $name]
|
|
if {$idx < 0} continue
|
|
set found [lindex $l $idx]
|
|
set taillist [lreplace $taillist $idx $idx]
|
|
set taillist [linsert $taillist 0 $name]
|
|
set l [lreplace $l $idx $idx]
|
|
set l [linsert $l 0 $found]
|
|
}
|
|
return $l
|
|
} ;# rearrange
|
|
|
|
proc verbose {msg} {
|
|
if ![info exists ::env(verbose_pickconfig)] return
|
|
puts stderr "pickconfig:$msg"
|
|
}
|
|
|
|
proc minimal_tree {node} {
|
|
if {"$node" == "root"} return
|
|
set p [$::tree parent $node]
|
|
foreach c [$::tree nodes $p] {
|
|
if {"$c" == "$node"} continue
|
|
$::tree closetree $c 1 ;# 1 ==> recurse
|
|
}
|
|
minimal_tree $p ;#recursion
|
|
} ;# minimal_tree
|
|
|
|
foreach dir $::configs_dir_list {
|
|
if {[info exists visited($dir)]} continue
|
|
if {![file isdirectory $dir]} {
|
|
verbose "pickconfig: skipping <$dir>, not a directory"
|
|
continue
|
|
}
|
|
set visited($dir) {}
|
|
walktree $dir
|
|
}
|
|
|
|
if { $::config_count == 0 } {
|
|
puts stderr [msgcat::mc "ERROR: no configurations found in path '%s'" $configs_dir_list]
|
|
exit 1
|
|
}
|
|
|
|
bind . <Escape> {button_pushed Cancel}
|
|
bind . <Return> ""
|
|
bind . <KP_Enter> ""
|
|
|
|
wm protocol . WM_DELETE_WINDOW {button_pushed Cancel}
|
|
|
|
proc wait_and_see {node {wait 10}} {
|
|
set yv [$::tree yview]
|
|
if {![winfo viewable $::tree] || [lindex $yv 0] == [lindex $yv 1]} {
|
|
after $wait [list wait_and_see $node [expr $wait*2]]
|
|
} else {
|
|
$::tree see $node
|
|
$::tree xview moveto 0.0
|
|
minimal_tree $node
|
|
node_clicked
|
|
}
|
|
}
|
|
|
|
proc get_file_contents {f} {
|
|
set fd [open $f]
|
|
set contents [read $fd]
|
|
close $fd
|
|
return $contents
|
|
}
|
|
|
|
proc put_file_contents {f c} {
|
|
set fd [open $f w]
|
|
puts -nonewline $fd $c
|
|
close $fd
|
|
}
|
|
|
|
proc fail_if_linkname_exists {linkname} {
|
|
if { [file exists $linkname] \
|
|
&& [file type $linkname] != "link"} {
|
|
set type [file type $linkname]
|
|
tk_messageBox -title "Make link fail" \
|
|
-icon error -type ok \
|
|
-message "Cannot create link for\n$linkname\n\
|
|
because of existing $type with same name\n\n\
|
|
Remove (or rename) $linkname"
|
|
exit 1
|
|
}
|
|
}
|
|
|
|
proc prompt_copy configname {
|
|
|
|
set res [tk_dialog .d [msgcat::mc "Copy Configuration?"] [msgcat::mc "Would you like to copy the %s configuration to your home directory so you can customize it?" $configname] warning 0 [msgcat::mc "Yes"] [msgcat::mc "Cancel"]]
|
|
|
|
if {$res == -1 || $res == 1} { return "" }
|
|
set chosendir [format %s [file dirname $configname]]
|
|
foreach d $::configs_dir_list {
|
|
if {"$d" == "$chosendir"} {
|
|
# found chosendir at level 0 of a directory in the ::configs_dir_list
|
|
set copytodir [format %s [file join $::myconfigs_node [file tail $chosendir]]]
|
|
break
|
|
}
|
|
# if chosendir not found at level 0, try subdirs
|
|
# note: expect $d ($::configs_dir_list) in normalized form
|
|
if {0 != [string first "$d/" $configname]} {
|
|
continue
|
|
} else {
|
|
# found chosendir as a subdir
|
|
set idx [expr 1 + [string length $d]] ;#
|
|
set hiername [string range $chosendir $idx end]
|
|
if $::make_flat_user_dirs {
|
|
# Flat dir structure for copied configs
|
|
# create copytodir at one level below ::myconfigs_node
|
|
set flatname [string map {/ .} $hiername]
|
|
set copytodir [format %s [file join $::myconfigs_node $flatname]]
|
|
} else {
|
|
# Hierarchical dir structure for copied configs
|
|
# create copytodir following hierarchy
|
|
set copytodir [format %s [file join $::myconfigs_node $hiername]]
|
|
}
|
|
break
|
|
}
|
|
}
|
|
set copybase $copytodir
|
|
|
|
set i 0
|
|
# distribution config ini files expect nc_files at same level as configs dir
|
|
set ncfiles [file normalize [file join $::myconfigs_node ../nc_files]]
|
|
file mkdir [file join $::myconfigs_node]
|
|
|
|
set obsoletedir [file normalize [file join $::env(HOME) emc2]]
|
|
if [file isdir $obsoletedir] {
|
|
tk_messageBox -title "Copy Configuration Notice" \
|
|
-message "A directory named:\n \
|
|
$obsoletedir\n \
|
|
exists \n\n \
|
|
You may want to copy items to the new directory:\n \
|
|
[file normalize [file join $::myconfigs_node ..]]" \
|
|
-type ok
|
|
}
|
|
|
|
if {$::always_update_nc_files || ![file exists $ncfiles]} {
|
|
file mkdir $ncfiles ;# tcl: ok if it exists
|
|
set refname $linuxcnc::NCFILES_DIR
|
|
set linkname [file join $ncfiles examples]
|
|
fail_if_linkname_exists $linkname
|
|
|
|
# tcl wont overwrite any existing link, so remove
|
|
catch {file delete $linkname}
|
|
file link -symbolic $linkname $refname
|
|
|
|
# liblist: libs used in inifiles for [RS274NGC]SUBROUTINE_PATH
|
|
# example: ngcgui uses lib named ngcgui_lib
|
|
|
|
set _libs [glob [file join $linuxcnc::NCFILES_DIR *_lib]]
|
|
foreach lib $_libs {
|
|
if ![file isdir $lib] continue
|
|
lappend liblist $lib
|
|
}
|
|
foreach lib $liblist {
|
|
set refname [file join $linuxcnc::NCFILES_DIR $lib]
|
|
set linkname [file join $ncfiles [file tail $lib]]
|
|
fail_if_linkname_exists $linkname
|
|
|
|
if {[file exists $linkname]} {
|
|
# tcl wont overwrite any existing link, so remove
|
|
file delete $linkname
|
|
}
|
|
# avoid error if no target
|
|
if [file exists $refname] {
|
|
file link -symbolic $linkname $refname
|
|
}
|
|
}
|
|
set dir [file tail $ncfiles]
|
|
set date [clock format [clock seconds] -format "%d%b%Y %T"]
|
|
set fd [open [file join $ncfiles readme.ngc] w]
|
|
puts $fd "(info: readme.ngc)"
|
|
set msg "(debug, readme.ngc autogenerated by:)\n"
|
|
set msg "${msg}(debug, $::argv0)\n"
|
|
set msg "${msg}(debug, $date)\n"
|
|
set msg "${msg}(debug, LinuxCNC vmajor=#<_vmajor> vminor=#<_vminor>)\n"
|
|
set msg "${msg}(debug, User writable directory: $dir)\n"
|
|
set msg "${msg}(debug, Example files: $dir/examples)\n"
|
|
foreach lib $liblist {
|
|
set msg "${msg}(debug, $lib subroutines: $dir/${lib}_lib)\n"
|
|
}
|
|
puts $fd $msg
|
|
# make readme.ngc compatible with ngcgui:
|
|
# (repeat the debug prints within the subroutine)
|
|
puts $fd "o<readme> sub"
|
|
puts $fd $msg
|
|
puts $fd " #<parm1> = #1 (=123 pvalue)"
|
|
puts $fd " (debug, readme.ngc: pvalue = #<parm1>)"
|
|
puts $fd "o<readme> endsub"
|
|
# include m2 to preclude message:
|
|
# "File ended with no percent sign or program end"
|
|
puts $fd "m2"
|
|
close $fd
|
|
}
|
|
while {1} {
|
|
if [file exists $copytodir] {
|
|
incr i
|
|
set copytodir "$copybase-$i" ;# user may have protected directory, so bump name
|
|
# limit attempts to avoid infinite loop for hard error
|
|
if {$i > 1000} {
|
|
puts stderr "$::argv0:$msg"
|
|
tk_messageBox -icon error -type ok \
|
|
-message [msgcat::mc "Failed to mkdir for $copytodir\n<$msg>"]
|
|
destroy .
|
|
exit
|
|
}
|
|
continue ;# try again
|
|
} else {
|
|
# note: file mkdir will make parents as required
|
|
if [catch { file mkdir $copytodir } msg] {
|
|
continue ;# try again
|
|
}
|
|
}
|
|
# A hierarchy of directories is allowed.
|
|
# User selects an offered ini file.
|
|
# All files in same directory are copied.
|
|
# The target of a linked file is copied
|
|
foreach f [glob -directory $chosendir *] {
|
|
# nc_files (as a symlink) may be present for rip testing
|
|
# nc_files (as a symlink) not copied here (handled elsewhere)
|
|
if { [file tail $f] == "nc_files"
|
|
&& [file type $f] == "link" } {
|
|
verbose "pickconfig: not copying link: $f"
|
|
continue
|
|
}
|
|
if {[lsearch $::never_copy_list [file tail $f]] >= 0} continue
|
|
# is_special: subdir is to be copied
|
|
set is_special 0
|
|
if { "" == [find_usable_nodes $f] } {
|
|
# ok: no usable child files so the directory can be copied
|
|
set is_special 1
|
|
}
|
|
|
|
switch [file type $f] {
|
|
link {
|
|
if {$is_special} {
|
|
# since is link, require:
|
|
# -r recursive, -L dereference
|
|
exec cp -rL [file join $chosendir $f] $copytodir
|
|
} else {
|
|
# to follow sym links correctly, use system cp:
|
|
exec cp [file join $chosendir $f] $copytodir
|
|
}
|
|
}
|
|
file {file copy "$f" $copytodir}
|
|
directory { # recursive copy of subdirs
|
|
if {$is_special } {
|
|
# -r recursive
|
|
exec cp -r [file join $chosendir $f] $copytodir
|
|
}
|
|
}
|
|
default {puts stderr \
|
|
"prompt_copy:unsupported type=[file type $f] for $f"}
|
|
}
|
|
}
|
|
foreach f [glob -directory $copytodir *] {
|
|
file attributes $f -permissions u+w
|
|
if {[file extension $f] == ".ini"} {
|
|
set c [get_file_contents $f]
|
|
# note: the following regsub _typically_ forces:
|
|
# PROGRAM_PREFIX=/home/username/linuxcnc/nc_files
|
|
regsub {(?n)^(PROGRAM_PREFIX\s*=\s*).*$} $c "\\1$ncfiles" c
|
|
put_file_contents $f $c
|
|
}
|
|
if {$::tcl_platform(platform) == "unix"} {
|
|
file attributes $f -permissions u+w
|
|
}
|
|
}
|
|
|
|
# make convenience link to HALLIB_DIR:
|
|
file link -symbolic [file join $copytodir hallib] $::env(HALLIB_DIR)
|
|
|
|
break
|
|
}
|
|
|
|
tk_dialog .d [msgcat::mc "Configuration Copied"] [msgcat::mc "The configuration file has been copied to %s. Next time, choose this location when starting LinuxCNC." $copytodir] info 0 [msgcat::mc "OK"]
|
|
|
|
return $copytodir/[file tail $configname]
|
|
}
|
|
|
|
|
|
# add the selection set if a ::last_ini has been found in ~/.linuxcncrc
|
|
|
|
if { $::last_ini != -1
|
|
&& [file exists $::last_ini]
|
|
&& ![catch {$::tree index $::last_ini}]} {
|
|
set start_node $::last_ini
|
|
} else {
|
|
set start_node ${::sampleconfigs}/$::default_start_node
|
|
}
|
|
if [catch {
|
|
$::tree selection set $start_node
|
|
wait_and_see $start_node
|
|
}] {
|
|
set ::openmode 0
|
|
puts stderr "pickconfig: cannot find expected start_node <$start_node>, continuing"
|
|
}
|
|
# update and enable commands after initial setup of tree
|
|
update
|
|
set ::selected_node [$::tree selection get]
|
|
title $::selected_node
|
|
$::tree configure \
|
|
-closecmd {after cancel treeclose; after idle treeclose} \
|
|
-opencmd {after cancel treeopen; after idle treeopen}
|
|
|
|
|
|
proc make_shortcut {inifile} {
|
|
if {[catch {open $inifile} inifd]} { return }
|
|
set inistring [read $inifd]
|
|
close $inifd
|
|
switch [file extension $inifile] {
|
|
".ini" {set name [getVal $inistring EMC MACHINE]}
|
|
".demo" {set name [lindex [split [file tail $inifile] "."] 0]
|
|
}
|
|
default {set name linuxcnc-other}
|
|
}
|
|
if {"$name" == ""} {set name LinuxCNC-other}
|
|
set filename0 [file join $::desktopdir [file rootname [file tail $inifile]]]
|
|
set filename ${filename0}.desktop
|
|
set i 0
|
|
while {[file exists $filename]} {
|
|
incr i
|
|
set filename $filename0${i}.desktop
|
|
}
|
|
exec linuxcncmkdesktop $inifile $name > $filename
|
|
file attributes $filename -permissions +x
|
|
tk_dialog .d [msgcat::mc "Shortcut Created"] [msgcat::mc "A shortcut to this configuration file has been created on your desktop. You can use it to automatically launch this configuration."] info 0 [msgcat::mc "OK"]
|
|
}
|
|
|
|
set make_shortcut 0
|
|
if {[file isdir $::desktopdir]} {
|
|
checkbutton $f5.c -variable make_shortcut \
|
|
-text [msgcat::mc "Create Desktop Shortcut"] \
|
|
-state normal
|
|
pack $f5.c -side left -expand 1 -anchor w
|
|
}
|
|
|
|
while {1} {
|
|
focus $::tree
|
|
vwait ::choice
|
|
|
|
if { $::choice == "OK" } {
|
|
if [ok_to_copy_config $::inifile] {
|
|
set copied_inifile [prompt_copy $::inifile]
|
|
if {$copied_inifile == ""} {
|
|
continue ;# user canceled
|
|
} else {
|
|
set ::inifile $copied_inifile
|
|
}
|
|
}
|
|
if {$make_shortcut} { make_shortcut $::inifile }
|
|
puts $::inifile ;# this is the result for this script (to stdout)
|
|
|
|
# test for ~/.linuxcncrc file and modify if needed.
|
|
# or make this file and add the var.
|
|
|
|
if {[file exists $::env(HOME)/.linuxcncrc]} {
|
|
if {$::inifile == $::last_ini} {
|
|
exit
|
|
} else {
|
|
if {[catch {open $::env(HOME)/.linuxcncrc} programin]} {
|
|
return
|
|
} else {
|
|
set rcstring [read $programin]
|
|
catch {close $programin}
|
|
}
|
|
set ret [setVal $rcstring PICKCONFIG LAST_CONFIG $::inifile ]
|
|
catch {file copy -force $name $name.bak}
|
|
if {[catch {open $::env(HOME)/.linuxcncrc w} fileout]} {
|
|
puts stdout [msgcat::mc "can't save %s" $::env(HOME)/.linuxcncrc ]
|
|
exit
|
|
}
|
|
puts $fileout $ret
|
|
catch {close $fileout}
|
|
exit
|
|
}
|
|
}
|
|
set newfilestring "# .linuxcncrc is a startup configuration file for LinuxCNC. \n# format is INI like. \n# \[SECTION_NAME\] \n# VARNAME = varvalue \n# where section name is the name of the system writing to this file \n\n# written by pickconfig.tcl \n\[PICKCONFIG\]\nLAST_CONFIG = $::inifile\n"
|
|
|
|
if {[catch {open $::env(HOME)/.linuxcncrc w+} fileout]} {
|
|
puts stderr [msgcat::mc "can't save %s" $::env(HOME)/.linuxcncrc ]
|
|
exit
|
|
}
|
|
|
|
puts $fileout $newfilestring
|
|
catch {close $fileout}
|
|
}
|
|
break
|
|
}
|
|
|
|
exit
|