Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
vecs
FIJI Public
Commits
8f8c23fd
Commit
8f8c23fd
authored
Feb 25, 2015
by
Stefan Tauner
Browse files
fiji_scripts: add preliminary fiji_setup.pl
parent
81d32b4f
Changes
7
Hide whitespace changes
Inline
Side-by-side
FIJI.pm
View file @
8f8c23fd
...
...
@@ -11,9 +11,12 @@ use warnings;
# Architecture from http://www.perlmonks.org/?node_id=1072731
# Fields:
# ini_name = key name in FIJI Settings file
# is_numeric = (optional) enables conversion of oct, hex, binary
# strings and checking that the value is really a number.
# - ini_name = key name in FIJI Settings file
# - unit = (optional) physical unit
# - not_supplied = (optional) not to be set by the user (but generated e.g. by fiji_instrument)
# - type = (optional) enables type-specific conversions and tests:
# numeric: values must be oct, hex, binary strings looking like a real number.
# boolean: will be convert to a truth value by Perl semantics
# values = (optional) an array reference listing all valid values (emulates an enum)
# default = (optional) default value if not given in file and not determinable otherwise
my
%designmap
;
...
...
@@ -21,35 +24,47 @@ BEGIN {
%designmap
=
(
ID
=>
{
ini_name
=>
"
ID
",
is_numeric
=>
1
,
type
=>
'
numeric
',
not_supplied
=>
1
,
},
FIU_NUM
=>
{
ini_name
=>
"
FIU_NUM
",
default
=>
undef
,
# optional in .ini, is set to
num
b
er
of FIU blocks
is_numeric
=>
1
,
type
=>
'
numer
ic
',
not_supplied
=>
1
,
# auto-generated
},
BAUDRATE
=>
{
ini_name
=>
"
BAUDRATE
",
default
=>
115200
,
is_numeric
=>
1
,
type
=>
'
numeric
',
unit
=>
'
bps
',
},
FREQUENCY
=>
{
ini_name
=>
"
FREQUENCY
",
default
=>
50e8
,
type
=>
'
numeric
',
unit
=>
'
Hz
',
},
FIU_CFG_BITS
=>
{
ini_name
=>
"
FIU_CFG_BITS
",
default
=>
3
,
is_numeric
=>
1
,
type
=>
'
numeric
',
not_supplied
=>
1
,
# currently not user-configurable
},
TIMER_WIDTH
=>
{
ini_name
=>
"
TIMER_WIDTH
",
default
=>
32
,
is_numeric
=>
1
,
type
=>
'
numeric
',
unit
=>
'
bits
',
},
ARM_DURATION_WIDTH
=>
{
ini_name
=>
"
ARM_DUR_WIDTH
",
is_numeric
=>
1
,
type
=>
'
numeric
',
not_supplied
=>
1
,
# derived from TIMER_WIDTH if need be
},
INJECT_DURATION_WIDTH
=>
{
ini_name
=>
"
INJECT_DUR_WIDTH
",
is_numeric
=>
1
,
type
=>
'
numeric
',
not_supplied
=>
1
,
# derived from TIMER_WIDTH if need be
},
);
}
...
...
@@ -66,21 +81,22 @@ BEGIN {
FIU_MODEL
=>
{
ini_name
=>
"
FAULT_MODEL
",
default
=>
"
RUNTIME
",
values
=>
[
qw(RUNTIME STUCK_AT_0 STUCK_AT_1
DELAY SEU
STUCK_OPEN
PASS_THR
U)
],
values
=>
[
qw(RUNTIME
PASS_THRU
STUCK_AT_0 STUCK_AT_1 STUCK_OPEN
DELAY SE
U)
],
},
FIU_LFSR_EN
=>
{
ini_name
=>
"
ENABLED_BY_LFSR
",
default
=>
0
,
type
=>
'
boolean
',
},
FIU_LFSR_MASK
=>
{
ini_name
=>
"
LFSR_MASK
",
default
=>
0
,
is_
numeric
=>
1
,
type
=>
'
numeric
'
,
},
FIU_LFSR_STUCK_OPEN_BIT
=>
{
ini_name
=>
"
LFSR_BIT_FOR_STUCK_OPEN
",
default
=>
0
,
is_
numeric
=>
1
,
type
=>
'
numeric
'
,
},
);
}
...
...
FIJI/Settings.pm
View file @
8f8c23fd
...
...
@@ -14,7 +14,87 @@ use Config::Simple;
use
FIJI
qw(:all)
;
## @function read_configfile ($fiji_ini_file)
sub
new
($;$$) {
my
$logger
=
get_logger
();
my
(
$class
,
$fiji_ini_file
,
$existing_settings
)
=
@_
;
my
$settings_ref
;
if
(
defined
(
$fiji_ini_file
))
{
$settings_ref
=
read_settingsfile
(
$fiji_ini_file
,
$existing_settings
);
if
(
!
defined
(
$settings_ref
))
{
return
undef
;
}
if
(
defined
(
$existing_settings
))
{
return
$existing_settings
;
}
}
else
{
# Without any config file as input, simply create an empty settings
# hash with default design constants.
my
$consts_ref
=
{};
my
$ret
=
_set_defaults
(
DESIGNMAP
,
$consts_ref
);
if
(
!
defined
(
$ret
))
{
$logger
->
error
("
Could not set defaults for design constants.
");
return
undef
;
}
$settings_ref
=
{
'
design
'
=>
$consts_ref
};
}
my
$r
=
bless
(
$settings_ref
,
$class
);
if
(
!
ref
(
$r
)
||
!
UNIVERSAL::
can
(
$r
,'
can
'))
{
$logger
->
error
("
Could not bless FIJI::Settings class from
\"
$fiji_ini_file
\"
.
");
return
undef
;
}
return
$r
;
}
## @method save ($fiji_ini_file)
# @brief Store contained FIJI Settings to file.
#
# @ATTENTION Will happily overwrite existing files!
#
# \param fiji_ini_file The file name to write the FIJI Settings to.
sub
save
($$)
{
my
$logger
=
get_logger
();
my
(
$self
,
$fiji_ini_file
)
=
@_
;
return
"
No file name given
"
if
!
defined
(
$fiji_ini_file
);
my
$fiji_ini
=
new
Config::
Simple
(
syntax
=>
'
ini
');
foreach
my
$key
(
keys
%
{
$self
})
{
my
$val
=
$self
->
{
$key
};
$logger
->
debug
(
sprintf
("
Key: %s, type: %s, value: %s
",
$key
,
ref
(
\
$val
),
$val
));
if
(
ref
(
\
$val
)
eq
"
REF
")
{
if
(
ref
(
$val
)
eq
"
HASH
")
{
if
(
$key
eq
"
design
")
{
$fiji_ini
->
set_block
("
CONSTS
",
$val
);
next
;
}
}
elsif
(
ref
(
$val
)
eq
"
ARRAY
")
{
if
(
$key
eq
"
FIUs
")
{
my
$fiu_cnt
=
0
;
foreach
my
$fiu
(
@
{
$val
})
{
my
$ini_fiu
;
foreach
my
$k
(
keys
$fiu
)
{
$ini_fiu
->
{
FIUMAP
->
{
$k
}
->
{'
ini_name
'}}
=
$fiu
->
{
$k
};
}
$fiji_ini
->
set_block
("
FIU
"
.
$fiu_cnt
++
,
$ini_fiu
);
}
next
;
}
}
}
my
$err
=
"
Unknown element found in FIJI Settings:
\"
$val
\"
";
$logger
->
error
(
$err
);
return
$err
;
}
if
(
!
defined
(
$fiji_ini
->
write
(
$fiji_ini_file
)))
{
my
$err
=
Config::
Simple
->
error
();
$logger
->
error
(
$err
);
return
$err
;
}
return
undef
;
}
## @function read_settingsfile ($fiji_ini_file)
# @brief Load the FIJI Settings file containing design and FIU constants.
#
# \param fiji_ini_file The name of an .ini file with FIJI Settings:
...
...
@@ -25,26 +105,28 @@ use FIJI qw(:all);
# the constants for the respective FIU, see \ref _sanitize_fiu
#
# \returns a reference to the hash containing the read constants.
sub
read_
config
file
{
sub
read_
settings
file
{
my
$logger
=
get_logger
();
my
(
$fiji_ini_file
)
=
@_
;
my
(
$fiji_ini_file
,
$existing_settings
)
=
@_
;
my
$fiji_ini
;
eval
{
$fiji_ini
=
new
Config::
Simple
(
$fiji_ini_file
)
};
# pesky library tries to die on syntax errors
if
(
!
defined
(
$fiji_ini
))
{
$logger
->
fatal
("
Could not read config file
\"
$fiji_ini_file
\"
:
"
.
(
defined
(
$@
)
?
$@
:
Config::
Simple
->
error
()));
$logger
->
error
("
Could not read config file
\"
$fiji_ini_file
\"
:
"
.
(
defined
(
$@
)
?
$@
:
Config::
Simple
->
error
()));
return
undef
;
}
my
$fiji_settings
=
(
defined
(
$existing_settings
))
?
$existing_settings
:
{};
my
$fiji_consts
=
$fiji_ini
->
get_block
("
CONSTS
");
if
(
!
(
%$fiji_consts
))
{
$logger
->
fatal
("
Could not fetch CONSTS block from config file
\"
$fiji_ini_file
\"
");
$logger
->
error
("
Could not fetch CONSTS block from config file
\"
$fiji_ini_file
\"
");
return
undef
;
}
$fiji_consts
=
_sanitize_consts
(
$fiji_consts
);
if
(
!
defined
(
$fiji_consts
))
{
$logger
->
fatal
("
Design constants in FIJI Settings invalid
");
$logger
->
error
("
Design constants in FIJI Settings invalid
");
return
undef
;
}
$fiji_settings
->
{'
design
'}
=
$fiji_consts
;
my
$fiu_num
=
0
;
while
(
1
)
{
...
...
@@ -55,33 +137,32 @@ sub read_configfile {
}
my
$fiji_fiu
=
_sanitize_fiu
(
$fiji_fiu_cfg
);
if
(
!
defined
(
$fiji_fiu
))
{
$logger
->
fatal
("
Constants for
$fiu_name
in FIJI Settings are invalid
");
$logger
->
error
("
Constants for
$fiu_name
in FIJI Settings are invalid
");
return
undef
;
}
push
(
@
{
$fiji_
const
s
->
{'
FIUs
'}},
$fiji_fiu
);
push
(
@
{
$fiji_
setting
s
->
{'
FIUs
'}},
$fiji_fiu
);
$fiu_num
++
;
$logger
->
trace
("
Read in
$fiu_name
from FIJI Settings file successfully.
");
}
if
(
$fiu_num
==
0
)
{
$logger
->
fatal
("
Could not fetch any FIU block from config file
\"
$fiji_ini_file
\"
");
$logger
->
error
("
Could not fetch any FIU block from config file
\"
$fiji_ini_file
\"
");
return
undef
;
}
# FIU_NUM is optional in the Settings file... if it was set check that
# it corresponds to the number of FIU<number> blocks.
if
(
defined
(
$fiji_consts
->
{'
FIU_NUM
'})
&&
$fiji_consts
->
{'
FIU_NUM
'}
!=
$fiu_num
)
{
$logger
->
fatal
(
FIU_NUM
->
{'
ini_name
'}
.
"
does not match the numbers of FIU blocks found.
");
$logger
->
error
(
FIU_NUM
->
{'
ini_name
'}
.
"
does not match the numbers of FIU blocks found.
");
return
undef
;
}
else
{
$fiji_consts
->
{'
FIU_NUM
'}
=
$fiu_num
;
# assume the best if FIU_NUM constant is not given
}
$logger
->
info
("
Successfully read in design constants and
$fiu_num
FIU definitions from FIJI Settings file.
");
return
$fiji_
const
s
;
return
$fiji_
setting
s
;
}
## @function _set_defaults (%$map_ref, %$consts_ref)
# @brief Set defaults according to FIJI.pm.
#
...
...
@@ -90,46 +171,69 @@ sub read_configfile {
sub
_set_defaults
{
my
$logger
=
get_logger
();
my
(
$map_ref
,
$consts_ref
)
=
@_
;
my
$new_hash
=
{};
#
my $new_hash = {};
# Iterating over respective hash from FIJI.pm and set defaults if need be
foreach
my
$k
(
keys
(
$map_ref
))
{
my
$ini_name
=
$map_ref
->
{
$k
}
->
{'
ini_name
'};
if
(
exists
(
$consts_ref
->
{
$ini_name
}))
{
$new_hash
->
{
$k
}
=
$consts_ref
->
{
$ini_name
};
$logger
->
trace
(
sprintf
("
Copying setting %s (%s) = %s.
",
$k
,
$ini_name
,
$consts_ref
->
{
$ini_name
}));
if
(
$ini_name
ne
$k
)
{
$consts_ref
->
{
$k
}
=
$consts_ref
->
{
$ini_name
};
$logger
->
trace
(
sprintf
("
Copying setting %s (%s) = %s.
",
$k
,
$ini_name
,
defined
(
$consts_ref
->
{
$ini_name
})
?
$consts_ref
->
{
$ini_name
}
:
"
undef
"));
delete
$consts_ref
->
{
$ini_name
};
}
}
else
{
if
(
exists
(
$map_ref
->
{
$k
}
->
{
default
}))
{
$new_hash
->
{
$k
}
=
$map_ref
->
{
$k
}
->
{
default
};
$logger
->
trace
(
sprintf
("
Adding default constant: %s (%s) = %s.
",
$k
,
$ini_name
,
$map_ref
->
{
$k
}
->
{
default
}));
if
(
exists
(
$map_ref
->
{
$k
}
->
{'
default
'}))
{
$consts_ref
->
{
$k
}
=
$map_ref
->
{
$k
}
->
{
default
};
# If the default key is there but its value is undef then
# the value will be set somewhere else later (used for FIU_NUM)
if
(
!
defined
(
$
new_hash
->
{
$k
}))
{
if
(
!
defined
(
$
consts_ref
->
{
$k
}))
{
next
;
}
$logger
->
trace
(
sprintf
("
Adding default constant: %s (%s) = %s.
",
$k
,
$ini_name
,
$map_ref
->
{
$k
}
->
{
default
}));
}
elsif
(
$map_ref
->
{
$k
}
->
{'
not_supplied
'})
{
next
;
}
else
{
$logger
->
error
(
sprintf
("
%s is missing from FIJI Settings.
",
$ini_name
));
return
undef
;
}
}
# convert non-decimal (hexadecimal, binary, octal) values to decimal
if
(
$map_ref
->
{
$k
}
->
{'
is_numeric
'})
{
my
$orig
=
$new_hash
->
{
$k
};
$new_hash
->
{
$k
}
=
oct
(
$orig
)
if
$orig
=~
/^0/
;
$logger
->
trace
("
Converted value of
$k
(
\"
$orig
\"
) to
\"
$new_hash
->{
$k
}
\"
.
")
if
(
$orig
ne
$new_hash
->
{
$k
});
if
(
!
looks_like_number
(
$new_hash
->
{
$k
}))
{
$logger
->
error
("
$orig
does not look like a number.
");
return
undef
;
if
(
defined
(
$map_ref
->
{
$k
}
->
{'
type
'}))
{
my
$orig
=
$consts_ref
->
{
$k
};
if
(
$map_ref
->
{
$k
}
->
{'
type
'}
eq
'
numeric
')
{
# convert non-decimal (hexadecimal, binary, octal) values to decimal
$consts_ref
->
{
$k
}
=
oct
(
$orig
)
if
$orig
=~
/^0/
;
if
(
!
looks_like_number
(
$consts_ref
->
{
$k
}))
{
$logger
->
error
("
$orig
does not look like a number.
");
return
undef
;
}
}
elsif
(
$map_ref
->
{
$k
}
->
{'
type
'}
eq
'
boolean
')
{
# convert strings to binary if need be
if
(
!
defined
(
$orig
))
{
$logger
->
error
("
\"
undef
\"
is not a boolean value.
");
return
undef
;
}
elsif
(
lc
(
$orig
)
eq
'
true
')
{
$orig
=
1
;
}
elsif
(
lc
(
$orig
)
eq
'
false
')
{
$orig
=
0
;
}
if
((
$orig
ne
'
0
')
&&
(
$orig
ne
'
1
'))
{
$logger
->
error
("
\"
$orig
\"
does not look like a boolean value.
");
return
undef
;
}
# ensure proper boolean value, i.e. 0 or 1
$consts_ref
->
{
$k
}
=
(
!!
$orig
)
?
1
:
0
;
}
$logger
->
trace
("
Converted value of
$k
(
\"
$orig
\"
) to
\"
$consts_ref
->{
$k
}
\"
.
")
if
(
$orig
ne
$consts_ref
->
{
$k
});
}
elsif
(
defined
(
$map_ref
->
{
$k
}
->
{'
values
'}))
{
if
(
!
grep
{
$_
eq
$
new_hash
->
{
$k
}}
@
{
$map_ref
->
{
$k
}
->
{'
values
'}})
{
$logger
->
error
("
$
new_hash
->{
$k
} is not allowed. Allowed values are:
"
.
join
("
,
",
@
{
$map_ref
->
{
$k
}
->
{'
values
'}}));
if
(
!
grep
{
$_
eq
$
consts_ref
->
{
$k
}}
@
{
$map_ref
->
{
$k
}
->
{'
values
'}})
{
$logger
->
error
("
$
consts_ref
->{
$k
} is not allowed. Allowed values are:
"
.
join
("
,
",
@
{
$map_ref
->
{
$k
}
->
{'
values
'}}));
return
undef
;
}
}
}
return
$
new_hash
;
return
$
consts_ref
;
}
## @function _sanitize_fiu (%$fiu_ref)
...
...
@@ -148,9 +252,9 @@ sub _sanitize_fiu {
return
undef
;
}
my
$
new_consts
=
_set_defaults
(
FIUMAP
,
$fiu_ref
);
if
(
!
defined
(
$
new_consts
))
{
$logger
->
fatal
("
Could not set defaults for design constants.
");
my
$
ret
=
_set_defaults
(
FIUMAP
,
$fiu_ref
);
if
(
!
defined
(
$
ret
))
{
$logger
->
error
("
Could not set defaults for design constants.
");
return
undef
;
}
...
...
@@ -220,34 +324,34 @@ sub _sanitize_consts {
}
}
my
$
new_consts
=
_set_defaults
(
DESIGNMAP
,
$consts_ref
);
if
(
!
defined
(
$
new_consts
))
{
$logger
->
fatal
("
Could not set defaults for design constants.
");
my
$
ret
=
_set_defaults
(
DESIGNMAP
,
$consts_ref
);
if
(
!
defined
(
$
ret
))
{
$logger
->
error
("
Could not set defaults for design constants.
");
return
undef
;
}
# check for sane values
if
((
$
new_
consts
->
{
FIU_CFG_BITS
}
<=
0
))
{
if
((
$consts
_ref
->
{
FIU_CFG_BITS
}
<=
0
))
{
$logger
->
error
("
FIU_CFG_BITS is <= 0.
");
return
undef
;
}
if
((
$
new_
consts
->
{
ARM_DURATION_WIDTH
}
<=
0
)
||
(
$
new_
consts
->
{
ARM_DURATION_WIDTH
}
%
8
!=
0
))
{
$logger
->
error
("
ARM_DURATION_WIDTH is invalid (
$
new_
consts
->{ARM_DURATION_WIDTH}).
");
if
((
$consts
_ref
->
{
ARM_DURATION_WIDTH
}
<=
0
)
||
(
$consts
_ref
->
{
ARM_DURATION_WIDTH
}
%
8
!=
0
))
{
$logger
->
error
("
ARM_DURATION_WIDTH is invalid (
$consts
_ref
->{ARM_DURATION_WIDTH}).
");
return
undef
;
}
if
((
$
new_
consts
->
{
INJECT_DURATION_WIDTH
}
<=
0
)
||
((
$
new_
consts
->
{
INJECT_DURATION_WIDTH
}
%
8
)
!=
0
))
{
$logger
->
error
("
INJECT_DURATION_WIDTH is invalid (
$
new_
consts
->{INJECT_DURATION_WIDTH}).
");
if
((
$consts
_ref
->
{
INJECT_DURATION_WIDTH
}
<=
0
)
||
((
$consts
_ref
->
{
INJECT_DURATION_WIDTH
}
%
8
)
!=
0
))
{
$logger
->
error
("
INJECT_DURATION_WIDTH is invalid (
$consts
_ref
->{INJECT_DURATION_WIDTH}).
");
return
undef
;
}
if
(
(
$new_
consts
->
{
ID
}
<=
0
)
||
(
$new_
consts
->
{
ID
}
>
(
2
**
15
-
1
)))
{
$logger
->
error
("
ID is invalid (
$
new_
consts
->{ID}).
");
if
(
defined
(
$consts_ref
->
{
ID
})
&&
(
$
consts
_ref
->
{
ID
}
<=
0
||
$
consts
_ref
->
{
ID
}
>
(
2
**
15
-
1
)))
{
$logger
->
error
("
ID is invalid (
$consts
_ref
->{ID}).
");
return
undef
;
}
if
((
$
new_
consts
->
{
BAUDRATE
}
<=
0
))
{
if
((
$consts
_ref
->
{
BAUDRATE
}
<=
0
))
{
$logger
->
error
("
BAUDRATE missing is <= 0.
");
return
undef
;
}
return
$
new_
consts
;
return
$consts
_ref
;
}
1
;
Tk/DynaMouseWheelBind.pm
0 → 100644
View file @
8f8c23fd
# https://rt.cpan.org/Public/Bug/Display.html?id=33655
require
Tk::
Widget
;
package
Tk::
Widget
;
use
strict
;
use
warnings
;
use
constant
SCROLL_FACTOR
=>
2
;
# keep Tk::Widgets namespace clean
my
(
$motion
,
$do_scroll
,
$mousewheel_event
,
$setup
,
);
sub
DynaMouseWheelBind
{
my
$w
=
shift
;
my
@classes
=
@_
;
my
$mw
=
$w
->
MainWindow
;
$setup
->
(
$mw
);
for
my
$class
(
@classes
)
{
eval
"
require
$class
"
or
die
$@
;
# initialize class bindings so the following changes
# won't get overridden
$class
->
InitClass
(
$mw
);
# replace MouseWheel bindings - these should be processed
# through the $mw binding only
my
@mw_events
=
('
<MouseWheel>
',
'
<4>
',
'
<5>
',
);
$mw
->
bind
(
$class
,
$_
,'')
for
(
@mw_events
);
$mw
->
bind
(
$class
,'
<<DynaMouseWheel>>
',
$do_scroll
);
}
}
# setup two bindings to track the window under the cursor
# and globally receive <MouseWheel>
$setup
=
sub
{
my
$mw
=
shift
;
$mw
->
bind
('
all
','
<Enter>
',
$motion
);
$mw
->
bind
('
all
','
<MouseWheel>
',[
$mousewheel_event
,
Tk::
Ev
('
D
')]);
$mw
->
bind
('
all
','
<4>
',[
$mousewheel_event
,
120
]);
$mw
->
bind
('
all
','
<5>
',[
$mousewheel_event
,
-
120
]);
};
{
my
$under_cursor
;
my
$scrollable
;
my
$delta
;
$motion
=
sub
{
$under_cursor
=
$_
[
0
]
->
XEvent
->
Info
('
W
');
};
$do_scroll
=
sub
{
$scrollable
->
yview
('
scroll
',
-
(
$delta
/
120
)
*
SCROLL_FACTOR
,
'
units
');
};
$mousewheel_event
=
sub
{
my
$widget
=
shift
;
$delta
=
shift
;
# just in case, the mouse has not been moved yet:
my
$w
=
$under_cursor
||=
$widget
;
# print "under_cursor:[$under_cursor]\n";
my
@tags
=
$w
->
bindtags
;
my
$has_binding
;
until
(
$has_binding
||
$w
->
isa
('
Tk::Toplevel
')){
if
(
$w
->
Tk::
bind
(
ref
(
$w
),'
<<DynaMouseWheel>>
')){
$has_binding
=
1
;
}
else
{
$w
=
$w
->
parent
;
}
}
if
(
$has_binding
)
{
$scrollable
=
$w
;
$w
->
eventGenerate
('
<<DynaMouseWheel>>
');
}
};
}
# end of scope for $under_cursor, $scrollable, $delta
1
;
Tk/FIJISettingsViewer.pm
0 → 100644
View file @
8f8c23fd
## @file
## @class Tk::FIJISettingsViewer
#
#
package
Tk::
FIJISettingsViewer
;
use
strict
;
use
warnings
;
use
Log::
Log4perl
qw(get_logger)
;
use
Scalar::
Util
'
blessed
';
use
Tk
;
use
Tk::
widgets
qw(LabFrame Label Entry Pane Button Dialog Checkbutton)
;
use
Tk::
DynaMouseWheelBind
;
use
base
qw(Tk::Frame)
;
use
FIJI
qw(:all)
;
Construct
Tk::
Widget
'
FIJISettingsViewer
';
my
$fr_design
;
# labled frame surrounding widgets representing design constant
my
$fr_fius
;
# labled frame surrounding widgets representing design constant
sub
ClassInit
{
my
(
$class
,
$mw
)
=
@_
;
$class
->
SUPER::
ClassInit
(
$mw
);
my
$self
=
bless
{},
$class
;
return
$self
;
}
sub
Populate
{
my
$logger
=
get_logger
();
my
(
$self
,
$args
)
=
@_
;
my
$settings
=
delete
$args
->
{'
-settings
'};
if
(
!
blessed
(
$
{
$settings
})
||
!
$
{
$settings
}
->
isa
("
FIJI::Settings
"))
{
$logger
->
error
("
Given settings are not of type FIJI::Settings. No way to report this back from the constructor...
");
}
else
{
$self
->
{'
settings
'}
=
$settings
;
if
(
ref
(
$
{
$self
->
{'
settings
'}}
->
{'
FIUs
'})
ne
'
ARRAY
')
{
$logger
->
debug
("
Adding empty FIUs array to settings reference.
");
$
{
$self
->
{'
settings
'}}
->
{'
FIUs
'}
=
[]
;
}
}
$self
->
SUPER::
Populate
(
$args
);
$self
->
_populate_widget
(
$self
);
$self
->
update
();
}
## @method _populate_widget()
# Creates, aranges and binds all widgets
#
sub
_populate_widget
{
my
$logger
=
get_logger
();
my
(
$self
,
$fr
)
=
@_
;
my
$i
;
$fr
->
DynaMouseWheelBind
('
Tk::Pane
');
################
# design panel #
################
$fr_design
=
$fr
->
LabFrame
(
-
label
=>
"
Design Constants
",
-
labelside
=>
"
acrosstop
"
)
->
pack
(
'
-side
'
=>
'
top
',
'
-anchor
'
=>
'
nw
',
'
-fill
'
=>
'
x
'
);
$fr_design
->
gridColumnconfigure
(
2
,
-
weight
=>
1
);
$i
=
0
;
foreach
my
$hdr
(
qw(Name Unit Value)
)
{
$fr_design
->
Label
(
-
text
=>
$hdr
,
)
->
grid
(
'
-row
'
=>
0
,
'
-column
'
=>
$i
++
,
);
}
$fr_design
->
Label
(
-
text
=>
"
Control
",
)
->
grid
(
'
-row
'
=>
0
,
'
-column
'
=>
$i
++
,
'
-columnspan
'
=>
2
,
);
my
$designmap
=
DESIGNMAP
;
foreach
my
$k
(
qw(FREQUENCY BAUDRATE TIMER_WIDTH)
)
{
Tk::
grid
(
$fr_design
->
Label
(
'
-text
'
=>
DESIGNMAP
->
{
$k
}
->
{'
ini_name
'},
),
$fr_design
->
Label
(
'
-text
'
=>
DESIGNMAP
->
{
$k
}
->
{'
unit
'},
),
$fr_design
->
Entry
(
'
-textvariable
'
=>
\
$
{
$self
->
{'
settings
'}}
->
{'
design
'}
->
{
$k
},
'
-width
'
=>
-
1
,
),
$fr_design
->
Button
(
-
text
=>
'
Defaults
',
# -command => [\&_save, $self],
# sub {
# my $state = defined($filename) ? 'normal' : 'disabled';
# $btn_open->configure(-state => $state);
# $btn_save->configure(-state => $state);
# },
),
'
-sticky
'
=>
'
ew
'
);
}
##############
# FIUs panel #
##############
my
$fr_fius_main
=
$fr
->
LabFrame
(