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
ce037e9e
Commit
ce037e9e
authored
Sep 17, 2015
by
Christian Fibich
Committed by
Stefan Tauner
Aug 29, 2016
Browse files
Changed all get_logger() calls to get root logger
Added logging to Tk::Text widget
parent
44ad9f47
Changes
18
Hide whitespace changes
Inline
Side-by-side
FIJI.pm
View file @
ce037e9e
...
...
@@ -108,6 +108,16 @@ BEGIN {
phases_opt
=>
[
qw(setup)
],
order
=>
5
,
},
INSTRUMENTATION_LOG
=>
{
description
=>
"
Instrumentation log file
",
help
=>
"
Log file for FIJI Instrumentation tool
",
ini_name
=>
"
INSTRUMENTATION_LOG
",
default
=>
"
fiji_instrument.log
",
type
=>
'
file
',
group
=>
'
general_control
',
phases_opt
=>
[
qw(setup)
],
order
=>
6
,
},
BAUDRATE
=>
{
description
=>
"
Baud rate
",
help
=>
"
Enter the Baud rate for communication between Host and FIJI logic.
",
...
...
FIJI/Connection.pm
View file @
ce037e9e
...
...
@@ -50,7 +50,7 @@ use FIJI::AnySerialPort;
#
# \returns a FIJI::Connection object, or undef if non could be obtained.
sub
init
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$class
,
$portname
,
$baudrate
)
=
@_
;
if
(
defined
(
$baudrate
)
)
{
...
...
@@ -126,7 +126,7 @@ sub init {
#
# \returns 0 if configuration seems sane.
sub
sanitize_config
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$config_ref
)
=
@_
;
my
$consts_ref
=
$config_ref
->
{'
consts
'};
...
...
@@ -197,7 +197,7 @@ sub sanitize_config {
#
# \returns 0 on success
sub
send_config
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$config_ref
,
$timeout
,
$block_till_ready
,
$wait_for_ready
)
=
@_
;
my
$port
=
$self
->
{'
port
'};
...
...
@@ -388,7 +388,7 @@ sub send_config {
#
# \returns the number of bytes actually transmitted
sub
_send_bitstream
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$port
,
$str_ref
,
$timeout
)
=
@_
;
if
(
!
defined
(
$port
)
)
{
...
...
@@ -441,7 +441,7 @@ sub _send_bitstream {
#
# \returns 0 on success
sub
_rcv_bitstream
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$port
,
$todo
,
$timeout
,
$buf_ref
)
=
@_
;
my
@bytes
;
...
...
@@ -492,7 +492,7 @@ sub _rcv_bitstream {
# \returns The type of the return message, or undef in the case of errors.
# Possible types are: 'CONF_DONE', 'UNDERRUN', 'READY'
sub
_parse_return_message
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$message_byte
,
$error_ref
,
$fd_ref
)
=
@_
;
if
(
defined
(
$error_ref
)
&&
ref
(
$error_ref
)
ne
'
HASH
'
)
{
$logger
->
error
("
Second parameter is not a reference to a hash.
");
...
...
FIJI/Downloader.pm
View file @
ce037e9e
...
...
@@ -22,7 +22,7 @@ package FIJI::Downloader;
use
strict
;
use
warnings
;
use
Log::
Log4perl
qw(get_logger
:easy
)
;
use
Log::
Log4perl
qw(get_logger)
;
use
FIJI::
Tests
;
use
FIJI::
Settings
;
use
FIJI::
Connection
;
...
...
@@ -33,7 +33,7 @@ use threads;
use
threads::
shared
;
sub
new
(;$$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$class
,
$testsname
,
$existing_tests
,
$cfgname
,
$existing_cfg
)
=
@_
;
my
$self
=
{};
my
$rv
=
"
Constructor has no means of obtaining a FIJI::Tests/Settings object
"
.
bless
$self
,
$class
;
...
...
@@ -102,7 +102,7 @@ sub existing_tests {
# Generates a configuration hash from discrete parameters
#
sub
_test_fi_uart
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$port
,
$payload_ref
,
$t1_duration
,
$t2_duration
,
$trigger_en
,
$trigger_ext
,
$reset
,
$fiji_consts
)
=
@_
;
# my @payload = map hex($_), $cfg_str =~ /(..)/g; # TODO: how to do this with unpack?
...
...
@@ -133,7 +133,7 @@ sub _test_fi_uart {
# portname Optional serial port to use
sub
download_auto
($)
{
my
$msg
;
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$testref
,
$portname
,
$intermediate_cb
)
=
@_
;
my
$fiji_tests
=
$self
->
{'
fiji_tests
'};
...
...
@@ -225,7 +225,7 @@ sub download_auto ($) {
# after the test execution
# portname Optional serial port to use
sub
download_random
($$$;$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$testref
,
$portname
,
$intermediate_cb
)
=
@_
;
my
$fiji_design_consts
=
$self
->
{'
fiji_settings
'}
->
{'
design
'};
...
...
@@ -277,7 +277,7 @@ sub download_random ($$$;$) {
# portname Optional serial port to use
sub
download_manual
($;$) {
my
$msg
;
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$portname
)
=
@_
;
...
...
@@ -321,7 +321,7 @@ sub download_manual ($;$) {
# Params
#
sub
_get_test_from_stdin
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
)
=
@_
;
my
$fiji_design_consts
=
$self
->
{'
fiji_settings
'}
->
{'
design
'};
...
...
@@ -408,7 +408,7 @@ sub _get_test_from_stdin {
}
sub
download_test
($$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$test
,
$portname
)
=
@_
;
my
$port
=
FIJI::
Connection
->
init
(
$portname
,
$self
->
{'
fiji_settings
'}
->
{'
design
'}
->
{'
BAUDRATE
'}
)
...
...
@@ -440,7 +440,7 @@ sub update_rnd($) {
# test->{'TRIGGER'}
# port serial port to use
sub
_download_test
($$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$test
,
$port
)
=
@_
;
my
$fiji_tests
=
$self
->
{'
fiji_tests
'};
...
...
@@ -492,7 +492,7 @@ sub _download_test ($$) {
# Returns 1 if execution shall be halted and 0 otherwise
sub
_check_halt
($)
{
my
$halt
=
0
;
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$recv_msg
)
=
@_
;
my
$fiji_tests
=
$self
->
{'
fiji_tests
'};
...
...
FIJI/Netlist.pm
View file @
ce037e9e
...
...
@@ -86,7 +86,7 @@ sub new ($) {
}
sub
read_file
($)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$filename
)
=
@_
;
## Netlist synthesized from VHDL could contain SV keywords at this point.
...
...
@@ -137,7 +137,7 @@ sub get_nets ($) {
}
sub
_get_subnets
($$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$nets_ref
,
$mod
,
$hier
)
=
@_
;
my
$thishier
=
$hier
;
...
...
@@ -164,7 +164,7 @@ sub _get_subnets ($$) {
# name the name to check against
#
sub
_check_name_in_hierarchy
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$startmod
,
$name
)
=
@_
;
my
$nl
=
$startmod
->
netlist
;
...
...
@@ -215,7 +215,7 @@ sub _check_name_in_hierarchy {
# index for ORIGINAL,MODIFIED and FAULT_DETECT: the index of this net
# (indent just for formatting output)
sub
_add_port_to_hierarchy
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$startmod
,
$name
,
$function
,
$index
,
$indent
)
=
@_
;
my
$nl
=
$startmod
->
netlist
;
my
$direction
=
"
undef
";
...
...
@@ -292,7 +292,7 @@ sub _add_port_to_hierarchy {
# port_name how the port shall be named (will be prefixed with "fiji_")
# index for some FIJI_PORTTYPEs, an index is needed (FIU and Fault Detect)
sub
net_add_function
($$$;$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$net
,
$function
,
$port_name
,
$index
)
=
@_
;
$logger
->
debug
(
"
Adding function to
"
.
$net
->
module
->
name
.
"
, net
"
.
$net
->
name
);
...
...
@@ -337,7 +337,7 @@ sub net_add_function ($$$;$) {
sub
instrument_net
($$;$) {
#FIXME only works with single-bit pins/ports/nets
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$net
,
$fiu_idx
,
$driver
)
=
@_
;
my
$msg
;
...
...
@@ -479,7 +479,7 @@ sub instrument_net ($$;$) {
# Check if the driver specified by $driver_type and $driver_path
# is actually connected to the net specified by $net_path
sub
_validate_driver
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$net_path
,
$driver_path
,
$driver_type
)
=
@_
;
my
$connection_object
=
$self
->
get_connection_object
(
$driver_path
,
$driver_type
);
...
...
@@ -561,7 +561,7 @@ sub _connection_tostr($;$) {
}
sub
get_connection_object
($$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$connection_path
,
$connection_type
)
=
@_
;
my
$rv
;
...
...
@@ -618,7 +618,7 @@ sub get_connection_object($$) {
# -> connection_hashref->{'connected'} contains a list cells connected to the
# net but driver/driven cannot be decided
sub
_get_net_connections
($$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$net
,
$connection_hashref
)
=
@_
;
my
$mod
=
$net
->
module
;
...
...
@@ -716,7 +716,7 @@ sub _get_net_connections ($$) {
#
sub
export
($;$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$filename
,
$id
)
=
@_
;
open
(
my
$fh_nl
,
"
>
",
$filename
);
...
...
@@ -755,7 +755,7 @@ sub _export_module($) {
# FIXME do we need any additional Verilog Syntax (Interface, Modport)?
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$mod
)
=
@_
;
$logger
->
info
(
"
Generating verilog text for module
"
.
$mod
->
name
);
...
...
@@ -878,7 +878,7 @@ sub _export_module($) {
# to the net object corresponding to "netname" in module "module2"
#
sub
splitnet
($)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$netpath
)
=
@_
;
my
$rv
=
{};
...
...
FIJI/Settings.pm
View file @
ce037e9e
...
...
@@ -50,7 +50,7 @@ my @base_resources;
# \returns The new settings instance or a string describing the reason
# why it could not be created.
sub
new
($;$$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$class
,
$phase
,
$fiji_ini_file
,
$existing_settings
)
=
@_
;
my
$fiji_settings_ref
;
...
...
@@ -91,7 +91,7 @@ sub new ($;$$) {
}
sub
_export_value
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$k
,
$v_ref
)
=
@_
;
if
(
defined
(
$map_ref
->
{
$k
}
->
{'
type
'}
)
)
{
...
...
@@ -115,7 +115,7 @@ sub _export_value {
#
# \param fiji_ini_file The file name to write the FIJI Settings to.
sub
save
($)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$fiji_ini_file
)
=
@_
;
return
"
No file name given
"
if
!
defined
(
$fiji_ini_file
);
...
...
@@ -199,7 +199,7 @@ sub save ($) {
#
# \returns a reference to the hash containing the read constants.
sub
read_settingsfile
($$$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$phase
,
$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
...
...
@@ -327,7 +327,7 @@ sub set_fiu_defaults ($) {
## @function _set_defaults (%$map_ref, %$consts_ref)
# @brief Set defaults according to FIJI.pm.
sub
_set_defaults
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$consts_ref
,
$phase
)
=
@_
;
foreach
my
$k
(
keys
(
%
{
$map_ref
}
)
)
{
if
(
exists
(
$map_ref
->
{
$k
}
->
{'
default
'}
)
)
{
...
...
@@ -367,7 +367,7 @@ sub validate_fiu_value {
# \param log_func (optional) the (log4perl) log function to use
# (defaul is \&Log::Log4perl::Logger::trace)
sub
validate_value
($$$;$$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$k
,
$v_ref
,
$old
,
$log_func
)
=
@_
;
$log_func
=
\
&
Log::Log4perl::Logger::
trace
if
!
defined
(
$log_func
);
if
(
defined
(
$map_ref
->
{
$k
}
->
{'
type
'}
)
)
{
...
...
@@ -465,7 +465,7 @@ sub validate_value ($$$;$$) {
#
# \returns $consts_ref, or undef on errors
sub
_rename_import
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$consts_ref
)
=
@_
;
if
(
ref
(
$consts_ref
)
ne
'
HASH
'
)
{
$logger
->
error
("
Parameter is not a reference to a hash (containing design constants).
");
...
...
@@ -501,7 +501,7 @@ sub _rename_import {
# \returns A new hash with all constants required in the FIU settings
# in sanitized form, or undef on errors.
sub
_sanitize_fiu
($;$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$fiu_ref
,
$phase
)
=
@_
;
if
(
ref
(
$fiu_ref
)
ne
'
HASH
'
)
{
my
$msg
=
"
Parameter is not a reference to a hash (containing FIU constants).
";
...
...
@@ -525,7 +525,7 @@ sub _disabled_via_dependency ($$$) {
}
sub
_validate_hashmap
($$;$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$consts_ref
,
$phase
)
=
@_
;
my
@map_keys
=
keys
(
%
{
$map_ref
}
);
foreach
my
$entry_key
(
keys
(
%
{
$consts_ref
}
)
)
{
...
...
@@ -600,7 +600,7 @@ sub _validate_hashmap ($$;$) {
# \returns The given hash with all constants required in the design
# settings in sanitized form, or an error message.
sub
_sanitize_design
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$consts_ref
,
$phase
)
=
@_
;
if
(
ref
(
$consts_ref
)
ne
'
HASH
'
)
{
my
$msg
=
"
Parameter is not a reference to a hash (containing design constants).
";
...
...
@@ -648,7 +648,7 @@ sub _log2 {
## Determined by experiment & fitted by scipy.optimize.curve_fit
#
sub
_est_resources
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$FREQUENCY
,
$BAUD
,
$TIMER_WIDTH
,
$RESET_CYCLES
,
$LFSR_WIDTH
,
$FIU_NUM
,
$algo
)
=
@_
;
# FIXME where do we put these values? they are likely to change if the VHDL
...
...
@@ -740,7 +740,7 @@ sub _est_resources {
}
sub
estimate_resources
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$settings_ref
)
=
@_
;
my
$consts_ref
=
$settings_ref
->
{'
design
'};
my
$fiu_ref
=
$settings_ref
->
{'
fius
'};
...
...
FIJI/Tests.pm
View file @
ce037e9e
...
...
@@ -53,7 +53,7 @@ use File::Spec;
# \returns The new settings instance or a string describing the reason
# why it could not be created.
sub
new
($;$$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$class
,
$phase
,
$cfgs_per_msg
,
$fiu_num
,
$fiji_ini_file
,
$existing_settings
,
$num_tests
)
=
@_
;
my
$fiji_settings_ref
=
{};
...
...
@@ -115,7 +115,7 @@ sub new ($;$$) {
}
sub
_export_value
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$k
,
$v_ref
)
=
@_
;
if
(
defined
(
$map_ref
->
{
$k
}
->
{'
type
'}
)
)
{
...
...
@@ -139,7 +139,7 @@ sub _export_value {
#
# \param fiji_ini_file The file name to write the FIJI Settings to.
sub
save
($)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$fiji_ini_file
)
=
@_
;
return
"
No file name given
"
if
!
defined
(
$fiji_ini_file
);
...
...
@@ -227,7 +227,7 @@ sub save ($) {
#
# \returns a reference to the hash containing the read constants.
sub
read_settingsfile
($$$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$phase
,
$fiji_ini_file
,
$existing_settings
,
$cfgs_per_msg
,
$fiu_num
)
=
@_
;
my
$fiji_ini
;
my
$global_settings_filename
;
...
...
@@ -394,7 +394,7 @@ sub set_test_defaults ($) {
## @function _set_defaults (%$map_ref, %$consts_ref)
# @brief Set defaults according to FIJI.pm.
sub
_set_defaults
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$consts_ref
,
$phase
)
=
@_
;
foreach
my
$k
(
keys
(
%
{
$map_ref
}
)
)
{
if
(
exists
(
$map_ref
->
{
$k
}
->
{'
default
'}
)
)
{
...
...
@@ -434,7 +434,7 @@ sub validate_test_value {
# \param log_func (optional) the (log4perl) log function to use
# (defaul is \&Log::Log4perl::Logger::trace)
sub
validate_value
($$$;$$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$k
,
$v_ref
,
$old
,
$log_func
)
=
@_
;
$log_func
=
\
&
Log::Log4perl::Logger::
trace
if
!
defined
(
$log_func
);
if
(
defined
(
$map_ref
->
{
$k
}
->
{'
type
'}
)
)
{
...
...
@@ -536,7 +536,7 @@ sub validate_value ($$$;$$) {
#
# \returns $consts_ref, or undef on errors
sub
_rename_import
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$consts_ref
)
=
@_
;
if
(
ref
(
$consts_ref
)
ne
'
HASH
'
)
{
$logger
->
error
("
Parameter is not a reference to a hash (containing design constants).
");
...
...
@@ -572,7 +572,7 @@ sub _rename_import {
# \returns A new hash with all constants required in the TEST settings
# in sanitized form, or undef on errors.
sub
_sanitize_test
($;$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$testpatmap
,
$test_ref
,
$phase
)
=
@_
;
if
(
ref
(
$test_ref
)
ne
'
HASH
'
)
{
my
$msg
=
"
Parameter is not a reference to a hash (containing TEST constants).
";
...
...
@@ -596,7 +596,7 @@ sub _disabled_via_dependency ($$$) {
}
sub
_validate_hashmap
($$;$) {
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$map_ref
,
$consts_ref
,
$phase
)
=
@_
;
my
@map_keys
=
keys
(
%
{
$map_ref
}
);
foreach
my
$entry_key
(
keys
(
%
{
$consts_ref
}
)
)
{
...
...
@@ -656,7 +656,7 @@ sub _validate_hashmap ($$;$) {
# \returns The given hash with all constants required in the design
# settings in sanitized form, or an error message.
sub
_sanitize_design
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$consts_ref
,
$phase
)
=
@_
;
if
(
ref
(
$consts_ref
)
ne
'
HASH
'
)
{
my
$msg
=
"
Parameter is not a reference to a hash (containing design constants).
";
...
...
@@ -692,7 +692,7 @@ sub _sanitize_design {
# TODO: validate generated sim script files in Questa
# makes use of random_force functionality.
sub
export_as_sim_script
($$$$)
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$sim_file_name
,
$last_test
,
$num_repetitions
,
$global_settings_ref
)
=
@_
;
my
$script_text
=
"
# Sim script generated
"
.
localtime
.
"
\n
source random_force.tcl
\n
";
...
...
FIJI/VHDL.pm
View file @
ce037e9e
...
...
@@ -85,7 +85,7 @@ use constant FIJI_DEFAULTS => \%FIJI_DEFAULTS;
sub
generate_config_package
($$)
{
my
(
$class
,
$fiji_settings_filename
,
$vhdl_filename
)
=
@_
;
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
$name
=
$
0
;
$name
=~
s/\.p[lm]//
;
$logger
->
debug
("
=== generate_config_package ===
");
...
...
@@ -256,7 +256,7 @@ sub generate_wrapper_module ($) {
my
$fiji_settings_filename
=
$wrapper_config
->
{'
fiji_settings_filename
'};
my
$vhdl_filename
=
$wrapper_config
->
{'
vhdl_filename
'};
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
$name
=
$
0
;
$name
=~
s/\.p[lm]//
;
$logger
->
debug
("
=== generate_wrapper_module ===
");
...
...
Log/Dispatch/TkText.pm
0 → 100644
View file @
ce037e9e
package
Log::Dispatch::
TkText
;
use
strict
;
use
warnings
;
our
$VERSION
=
'
0.1
';
use
Log::Dispatch::
Output
;
use
Tk::
Font
;
use
base
qw( Log::Dispatch::Output )
;
use
Data::
Dumper
;
use
Encode
qw( encode )
;
use
IO::
Handle
;
use
Params::
Validate
qw(validate BOOLEAN)
;
Params::Validate::
validation_options
(
allow_extra
=>
1
);
sub
new
{
my
$proto
=
shift
;
my
$class
=
ref
$proto
||
$proto
;
my
%p
=
validate
(
@
_
,
{
default_font
=>
{
default
=>
"
Courier 10
"
},
log4p_fonts
=>
{
isa
=>
'
HASH
',
default
=>
{
ERROR
=>
"
Courier 10 bold
",
TRACE
=>
"
Courier 10 italic
",
}
},
log4p_colors
=>
{
isa
=>
'
HASH
',
default
=>
{
TRACE
=>
"
black
",
DEBUG
=>
"
black
",
ERROR
=>
"
red
",
WARN
=>
"
red
",
INFO
=>
"
forest green
",
}
},
loglevel_fonts
=>
{
isa
=>
'
HASH
',
default
=>
{
ERROR
=>
"
Courier 10 bold
",
TRACE
=>
"
Courier 10 italic
",
}
},
loglevel_colors
=>
{
isa
=>
'
HASH
',
default
=>
{
0
=>
"
grey
",
1
=>
"
forest green
",
2
=>
"
red
",
3
=>
"
red
",
}
},
widget
=>
{
isa
=>
'
Tk::Text
',
},
utf8
=>
{
type
=>
BOOLEAN
,
default
=>
0
,
},
}
);
my
$self
=
bless
\
%p
,
$class
;
$self
->
_basic_init
(
%p
);
my
$font
=
$p
{'
widget
'}
->
configure
(
-
font
=>
$p
{'
default_font
'});
foreach
my
$k
(
keys
(
%
{
$p
{'
log4p_colors
'}}))
{
$p
{'
widget
'}
->
tagConfigure
(
$k
,
-
foreground
=>
$p
{'
log4p_colors
'}
->
{
$k
});
}
foreach
my
$k
(
keys
(
%
{
$p
{'
loglevel_colors
'}}))
{
$p
{'
widget
'}
->
tagConfigure
(
$k
,
-
foreground
=>
$p
{'
loglevel_colors
'}
->
{
$k
});
}
foreach
my
$k
(
keys
(
%
{
$p
{'
log4p_fonts
'}}))
{
$p
{'
widget
'}
->
tagConfigure
(
$k
,
-
font
=>
$p
{'
log4p_fonts
'}
->
{
$k
});
}
foreach
my
$k
(
keys
(
%
{
$p
{'
loglevel_fonts
'}}))
{
$p
{'
widget
'}
->
tagConfigure
(
$k
,
-
font
=>
$p
{'
loglevel_fonts
'}
->
{
$k
});
}
return
$self
;
}
sub
log_message
{
my
$self
=
shift
;
my
%p
=
@_
;
my
$message
=
$self
->
{'
utf8
'}
?
encode
(
'
UTF-8
',
$p
{'
message
'}
)
:
$p
{'
message
'};
if
(
defined
$p
{'
log4p_level
'}
&&
defined
$self
->
{'
log4p_colors
'}
->
{
$p
{'
log4p_level
'}})
{
$self
->
{'
widget
'}
->
insert
('
end
',
$p
{'
message
'},
$p
{'
log4p_level
'});
}
elsif
(
defined
$p
{'
level
'}
&&
defined
$self
->
{'
loglevel_colors
'}
->
{
$p
{'
level
'}})
{
$self
->
{'
widget
'}
->
insert
('
end
',
$p
{'
message
'},
$p
{'
level
'});
}
else
{
$self
->
{'
widget
'}
->
insert
('
end
',
$p
{'
message
'});
}
$self
->
{'
widget
'}
->
yview
('
end
');
}
1
;
# ABSTRACT: Object for logging to the specified Tk::Text widget
__END__
=pod
=head1 NAME
Log::Dispatch::TkText - Object for logging to the screen
\ No newline at end of file
Tk/FIJISettingsCanvas.pm
View file @
ce037e9e
...
...
@@ -69,7 +69,7 @@ my $fiu_dv_base_y = $fiu0_base_y - 0.8 * $fiu_height;
my
$fiu_lfsr_base_y
=
$fiu0_base_y
-
1.2
*
$fiu_height
;
sub
Populate
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$args
)
=
@_
;
my
$settings_ref
=
delete
$args
->
{'
-settings_ref
'};
...
...
@@ -94,7 +94,7 @@ sub Populate {
}
sub
settings_ref
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$settings_ref
)
=
@_
;
if
(
ref
(
$$settings_ref
)
eq
"
FIJI::Settings
"
)
{
...
...
Tk/FIJISettingsViewer.pm
View file @
ce037e9e
...
...
@@ -60,7 +60,7 @@ sub ClassInit {
}
sub
Populate
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$args
)
=
@_
;
my
$settings
=
delete
$args
->
{'
-settings
'};
$self
->
{'
documentation_path
'}
=
delete
$args
->
{'
-documentation_path
'};
...
...
@@ -92,7 +92,7 @@ sub Populate {
}
sub
netlist
{
my
$logger
=
get_logger
();
my
$logger
=
get_logger
(
""
);
my
(
$self
,
$netlist
)
=
@_
;
if
(
defined
(
$netlist
)
)
{
if
(
ref
(
$netlist
)
ne
'
FIJI::Netlist
'
)
{