#!/usr/bin/perl
use
5.014;
my
$VERSION
=
'0.2'
;
my
$DEFAULT_DB_FILE
=
'.tkcsvcopy.db'
;
my
@encoding_choices
=
qw(utf-8 utf-16 utf-16le utf16-be utf32 utf-32le utf-32be iso-8859-1
iso-8859-2 iso-8859-3 iso-8859-4 iso-8859-5 iso-8859-6 iso-8859-7 iso-8859-8 iso-8859-9
iso-8859-10 iso-8859-11 iso-8859-12 iso-8859-13 iso-8859-14 iso-8859-15)
;
sub
usage {
print
( STDERR
<<"EOF" );
Usage:
tkcsvcopy.pl [OPTIONS...]
Perl/Tk GUI to detect settings of, and copy, CSV files.
-h, --help Display this help screen.
--db DB Enforce location of DB file to save options.
By default, store in ~/$DEFAULT_DB_FILE.
--nodb Don't use a db for options (options are not persistent).
--read F Upon start, display input information of file F.
--excel Tune output settings to make MS EXCEL happy.
Have , as separator, " as quote, " as escape,
UTF-8 encoding with BOM, and ymd/24h for datetime.
--excelfr Same as --excel, but ; as separator.
EOF
return
;
}
if
(
grep
{ /^--?h(elp)?$/i }
@ARGV
) {
usage();
exit
0;
}
my
%db
;
my
$read_it
=
''
;
my
$excel
=
''
;
my
$db_absolute_file_name
= catfile( my_home(),
$DEFAULT_DB_FILE
);
if
(
@ARGV
>= 2 and
$ARGV
[0] =~ /^--?db/i ) {
$db_absolute_file_name
=
$ARGV
[1];
splice
@ARGV
, 0, 2;
}
if
(
@ARGV
>= 1 and
$ARGV
[0] =~ /^--?nodb$/i ) {
$db_absolute_file_name
=
''
;
shift
@ARGV
;
}
if
(
@ARGV
>= 1 and
$ARGV
[0] =~ /^--?excel$/i ) {
$excel
=
'en'
;
shift
@ARGV
;
}
if
(
@ARGV
>= 1 and
$ARGV
[0] =~ /^--?excelfr$/i ) {
$excel
=
'fr'
;
shift
@ARGV
;
}
if
(
@ARGV
>= 2 and
$ARGV
[0] =~ /^--?
read
$/i ) {
$read_it
=
$ARGV
[1];
splice
@ARGV
, 0, 2;
}
if
(
@ARGV
) {
print
( STDERR (
$ARGV
[0] =~ /^-/ ?
"Unknown option.\n"
:
"Trailing option.\n"
)
);
usage();
exit
1;
}
tie
%db
=>
'DB_File'
,
$db_absolute_file_name
if
$db_absolute_file_name
ne
''
;
my
$init
=
"_initialized_$VERSION"
;
if
( !
$db
{
$init
} ) {
%db
= (
in_file
=>
''
,
sep_char
=>
','
,
sep_char_detect
=> 1,
quote_char
=>
'"'
,
escape_char
=>
'"'
,
escape_char_detect
=> 1,
encoding
=>
'utf-8, iso-8859-1'
,
encoding_detect
=> 1,
fields_dates_auto_optimize
=> 1,
dates_formats_to_try
=>
'%Y-%m-%d %H:%M:%S'
,
dates_formats_to_try_detect
=> 1,
dates_locales
=>
'en,fr'
,
dates_locales_detect
=> 1,
out_file
=>
''
,
out_sep_char
=>
','
,
out_sep_char_useinput
=> 1,
out_quote_char
=>
'"'
,
out_quote_char_useinput
=> 1,
out_escape_char
=>
'"'
,
out_escape_char_useinput
=> 1,
out_encoding
=>
'utf-8'
,
out_encoding_useinput
=> 1,
out_always_quote
=>
'no'
,
out_always_quote_useinput
=> 1,
out_dates_format
=>
'%Y-%m-%d %T'
,
out_dates_format_useinput
=> 1,
out_dates_locale
=>
'en'
,
out_dates_locale_useinput
=> 1,
out_utf8_bom
=> 0,
$init
=> 1
);
}
if
(
$read_it
ne
''
) {
$read_it
=~ s/^\s+|\s+$//g;
my
$w
=
$read_it
;
$db
{in_file} =
$read_it
;
$w
.=
'-copy'
unless
$w
=~ s/(\.[^.]+)$/-copy$1/;
$db
{out_file} =
$w
if
$read_it
ne
$w
;
}
if
(
$excel
ne
''
) {
$db
{out_sep_char} = (
$excel
eq
'fr'
?
';'
:
','
);
$db
{out_sep_char_useinput} = 0;
$db
{out_quote_char} =
'"'
;
$db
{out_quote_char_useinput} = 0;
$db
{out_escape_char} =
'"'
;
$db
{out_escape_char_useinput} = 0;
$db
{out_encoding} =
'utf-8'
;
$db
{out_encoding_useinput} = 0;
$db
{out_always_quote} =
'no'
;
$db
{out_always_quote_useinput} = 0;
$db
{out_dates_format} =
'%Y-%m-%d %T'
;
$db
{out_dates_format_useinput} = 0;
$db
{out_dates_locale} =
'en'
;
$db
{out_dates_locale_useinput} = 0;
$db
{out_utf8_bom} = 1;
}
my
$main_window
= MainWindow->new();
$main_window
->title(
'TK CSV COPY'
);
my
$menubar
=
$main_window
->Menu(
-type
=>
"menubar"
);
my
$menubar_file
=
$main_window
->Menu(
-type
=>
"normal"
);
$menubar_file
->add(
"command"
,
-label
=>
"Quit"
,
-command
=>
sub
{
exit
; } );
$menubar
->add(
"cascade"
,
-menu
=>
$menubar_file
,
-label
=>
"File"
);
my
$menubar_help
=
$main_window
->Menu(
-type
=>
"normal"
);
$menubar_help
->add(
"command"
,
-label
=>
"strptime help on Internet"
,
-command
=> \
&c_strptime
);
$menubar_help
->add(
"separator"
);
$menubar_help
->add(
"command"
,
-label
=>
"About..."
,
-command
=> \
&c_about
);
$menubar
->add(
"cascade"
,
-menu
=>
$menubar_help
,
-label
=>
"Help"
);
$main_window
->configure(
-menu
=>
$menubar
);
my
%fropts
= ();
my
$FONTSIZE
= 8;
my
$BUTTONPADX
= 2;
my
%butopts
= (
-font
=> [
-size
=>
$FONTSIZE
,
-weight
=>
'bold'
] );
my
%entopts
= (
-background
=>
'white'
,
-disabledbackground
=>
'dark grey'
,
-readonlybackground
=>
'dark gray'
,
-relief
=>
'flat'
,
-font
=> [
-size
=>
$FONTSIZE
,
-weight
=>
'normal'
]
);
my
%entcharwidth
= (
-width
=> 3 );
my
%labopts
= (
-font
=> [
-size
=>
$FONTSIZE
] );
my
%stdpad
= (
-padx
=> 2,
-pady
=> 2 );
my
%chkopts
= ();
my
@hlistopts
= {
-background
=>
'white'
,
-font
=> [
-size
=>
$FONTSIZE
,
-weight
=>
'normal'
]
};
push
@hlistopts
,
{
-background
=>
'#F6F6F6'
,
-font
=> [
-size
=>
$FONTSIZE
,
-weight
=>
'normal'
]
};
my
$frame_top
=
$main_window
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$frame_top_L
=
$frame_top
->Frame(
%fropts
)
->
pack
(
-side
=>
'left'
,
-expand
=> 1,
-fill
=>
'both'
);
my
$frame_top_R
=
$frame_top
->Frame(
%fropts
)
->
pack
(
-side
=>
'left'
,
-expand
=> 1,
-fill
=>
'both'
);
my
$frame_middle1
=
$main_window
->Frame(
%fropts
)
->
pack
(
-side
=>
'top'
,
-expand
=> 1,
-fill
=>
'both'
);
my
$frame_middle2
=
$main_window
->Frame(
%fropts
)
->
pack
(
-side
=>
'top'
,
-expand
=> 0,
-fill
=>
'x'
);
my
$frame_bottom
=
$main_window
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$PADLEFT
=
' '
x 8;
sub
cmd_update_enabled_disabled {
my
(
$widget_checkbutton
,
$conf_var_name
) =
@_
;
$widget_checkbutton
->configure(
-state
=> (
$db
{
$_
[1] } ?
'disabled'
:
'normal'
) );
return
;
}
$frame_top_L
->Label(
-text
=>
'input'
,
-background
=>
'dark gray'
,
-foreground
=>
'white'
,
%labopts
,
-font
=> [
-weight
=>
'bold'
]
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
,
-padx
=> 1 );
my
$frtopl_inp
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
$frtopl_inp
->Label(
-text
=>
'File '
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_in_file
=
$frtopl_inp
->Entry(
-textvariable
=> \
$db
{in_file},
%entopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
,
-expand
=> 1,
-fill
=>
"x"
);
$frtopl_inp
->Button(
-text
=>
'...'
,
-command
=> \
&c_browse_input
,
%butopts
)->
pack
(
-side
=>
'left'
,
-padx
=>
$BUTTONPADX
,
%stdpad
);
my
$frtopl_sep
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_sep_char
=
$frtopl_sep
->Entry(
-textvariable
=> \
$db
{sep_char},
%entcharwidth
,
-justify
=>
'right'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_sep
->Label(
-text
=>
'Separator char '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_sep
->Label(
-text
=>
"${PADLEFT}Detect"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_sep_char_detect
=
$frtopl_sep
->Checkbutton(
-variable
=> \
$db
{sep_char_detect},
-command
=>
[ \
&cmd_update_enabled_disabled
,
$ctrl_sep_char
,
'sep_char_detect'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopl_quo
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_quote_char
=
$frtopl_quo
->Entry(
-textvariable
=> \
$db
{quote_char},
%entcharwidth
,
-justify
=>
'right'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_quo
->Label(
-text
=>
'Quote char '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
my
$frtopl_esc
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_escape_char
=
$frtopl_esc
->Entry(
-textvariable
=> \
$db
{escape_char},
%entcharwidth
,
-justify
=>
'right'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_esc
->Label(
-text
=>
'Escape char '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_esc
->Label(
-text
=>
"${PADLEFT}Detect"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_escape_char_detect
=
$frtopl_esc
->Checkbutton(
-variable
=> \
$db
{escape_char_detect},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_escape_char
,
'escape_char_detect'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopl_enc
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_encoding
=
$frtopl_enc
->BrowseEntry(
-variable
=> \
$db
{encoding},
-width
=> 24,
-background
=>
'white'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_enc
->Label(
-text
=>
'Encoding(s) * '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$ctrl_encoding
->choices( [
''
,
@encoding_choices
] );
$frtopl_enc
->Label(
-text
=>
"${PADLEFT}Detect ** "
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_encoding_detect
=
$frtopl_enc
->Checkbutton(
-variable
=> \
$db
{encoding_detect},
-command
=>
[ \
&cmd_update_enabled_disabled
,
$ctrl_encoding
,
'encoding_detect'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopl_opt
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_fields_dates_auto_optimize
=
$frtopl_opt
->Checkbutton(
-variable
=> \
$db
{fields_dates_auto_optimize},
%chkopts
)->
pack
(
-side
=>
'right'
);
$frtopl_opt
->Label(
-text
=>
'Fast datetime format detection '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
my
$frtopl_dt
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_dates_formats_to_try
=
$frtopl_dt
->Entry(
-textvariable
=> \
$db
{dates_formats_to_try},
-width
=> 26,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_dt
->Label(
-text
=>
'Datetime format(s) * *** '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_dt
->Label(
-text
=>
"${PADLEFT}Default"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_dates_formats_to_try_detect
=
$frtopl_dt
->Checkbutton(
-variable
=> \
$db
{dates_formats_to_try_detect},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_dates_formats_to_try
,
'dates_formats_to_try_detect'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopl_loc
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_dates_locales
=
$frtopl_loc
->Entry(
-textvariable
=> \
$db
{dates_locales},
-width
=> 12,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_loc
->Label(
-text
=>
'Datetime locale(s) * **** '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopl_loc
->Label(
-text
=>
"${PADLEFT}Default"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_dates_locale_detect
=
$frtopl_loc
->Checkbutton(
-variable
=> \
$db
{dates_locales_detect},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_dates_locales
,
'dates_locales_detect'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopl_rea
=
$frame_top_L
->Frame(
%fropts
)->
pack
(
-side
=>
'bottom'
,
-fill
=>
'x'
);
my
$button_read
=
$frtopl_rea
->Button(
-text
=>
'Display input information'
,
-command
=> [ \
&c_execute
,
'read'
],
%butopts
)->
pack
(
-expand
=> 1,
-fill
=>
'x'
,
-padx
=>
$BUTTONPADX
,
%stdpad
);
$frame_top_R
->Label(
-text
=>
'output'
,
-background
=>
'dark gray'
,
-foreground
=>
'white'
,
%labopts
,
-font
=> [
-weight
=>
'bold'
]
)->
pack
(
-expand
=> 1,
-side
=>
'top'
,
-fill
=>
'x'
,
-padx
=> 1 );
my
$frtopr_1
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
$frtopr_1
->Label(
-text
=>
'File '
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$entry_output
=
$frtopr_1
->Entry(
-textvariable
=> \
$db
{out_file},
%entopts
)
->
pack
(
-side
=>
'left'
,
-expand
=> 1,
-fill
=>
'x'
,
%stdpad
);
$frtopr_1
->Button(
-text
=>
'...'
,
-command
=> \
&c_browse_output
,
%butopts
)->
pack
(
-side
=>
'left'
,
-padx
=>
$BUTTONPADX
,
%stdpad
);
my
$frtopr_sep
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_sep_char
=
$frtopr_sep
->Entry(
-textvariable
=> \
$db
{out_sep_char},
%entcharwidth
,
-justify
=>
'right'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_sep
->Label(
-text
=>
'Separator char '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_sep
->Label(
-text
=>
"${PADLEFT}Use input"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_out_sep_char_useinput
=
$frtopr_sep
->Checkbutton(
-variable
=> \
$db
{out_sep_char_useinput},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_out_sep_char
,
'out_sep_char_useinput'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopr_quo
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_quote_char
=
$frtopr_quo
->Entry(
-textvariable
=> \
$db
{out_quote_char},
%entcharwidth
,
-justify
=>
'right'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_quo
->Label(
-text
=>
'Quote char '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_quo
->Label(
-text
=>
"${PADLEFT}Use input"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_out_quote_char_useinput
=
$frtopr_quo
->Checkbutton(
-variable
=> \
$db
{out_quote_char_useinput},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_out_quote_char
,
'out_quote_char_useinput'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopr_esc
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_escape_char
=
$frtopr_esc
->Entry(
-textvariable
=> \
$db
{out_escape_char},
%entcharwidth
,
-justify
=>
'right'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_esc
->Label(
-text
=>
'Escape char '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_esc
->Label(
-text
=>
"${PADLEFT}Use input"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_out_escape_char_useinput
=
$frtopr_esc
->Checkbutton(
-variable
=> \
$db
{out_escape_char_useinput},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_out_escape_char
,
'out_escape_char_useinput'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopr_enc
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_encoding
=
$frtopr_enc
->BrowseEntry(
-variable
=> \
$db
{out_encoding},
-width
=> 14,
-background
=>
'white'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_enc
->Label(
-text
=>
'Encoding '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$ctrl_out_encoding
->choices( \
@encoding_choices
);
$frtopr_enc
->Label(
-text
=>
"${PADLEFT}Use input"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_out_encoding_useinput
=
$frtopr_enc
->Checkbutton(
-variable
=> \
$db
{out_encoding_useinput},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_out_encoding
,
'out_encoding_useinput'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopr_bom
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_utf8_bom
=
$frtopr_bom
->Checkbutton(
-variable
=> \
$db
{out_utf8_bom},
%chkopts
)->
pack
(
-side
=>
'right'
);
$frtopr_bom
->Label(
-text
=>
'If UTF-8, write UTF-8 BOM '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
my
$frtopr_iaq
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_always_quote
=
$frtopr_iaq
->BrowseEntry(
-variable
=> \
$db
{out_always_quote},
-width
=> 6,
-background
=>
'white'
,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_iaq
->Label(
-text
=>
'Always quote '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$ctrl_out_always_quote
->choices( [
''
,
'yes'
,
'no'
] );
$frtopr_iaq
->Label(
-text
=>
"${PADLEFT}Use input"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_out_always_quote_useinput
=
$frtopr_iaq
->Checkbutton(
-variable
=> \
$db
{out_always_quote_useinput},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_out_always_quote
,
'out_always_quote_useinput'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopr_dt
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_dates_format
=
$frtopr_dt
->Entry(
-textvariable
=> \
$db
{out_dates_format},
-width
=> 26,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_dt
->Label(
-text
=>
'Datetime format *** '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_dt
->Label(
-text
=>
"${PADLEFT}Use input"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_out_dates_format_useinput
=
$frtopr_dt
->Checkbutton(
-variable
=> \
$db
{out_dates_format_useinput},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_out_dates_format
,
'out_dates_format_useinput'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopr_loc
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$ctrl_out_dates_locale
=
$frtopr_loc
->Entry(
-textvariable
=> \
$db
{out_dates_locale},
-width
=> 6,
%entopts
)->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_loc
->Label(
-text
=>
'Datetime locale **** '
,
%labopts
)
->
pack
(
-side
=>
'right'
,
%stdpad
);
$frtopr_loc
->Label(
-text
=>
"${PADLEFT}Use input"
,
%labopts
)
->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$ctrl_out_dates_locale_useinput
=
$frtopr_loc
->Checkbutton(
-variable
=> \
$db
{out_dates_locale_useinput},
-command
=> [
\
&cmd_update_enabled_disabled
,
$ctrl_out_dates_locale
,
'out_dates_locale_useinput'
],
%chkopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
my
$frtopr_wri
=
$frame_top_R
->Frame(
%fropts
)->
pack
(
-side
=>
'top'
,
-fill
=>
'x'
);
my
$button_copy
=
$frtopr_wri
->Button(
-text
=>
'Copy input -> output'
,
-command
=> [ \
&c_execute
,
'write'
],
%butopts
)->
pack
(
-expand
=> 1,
-fill
=>
'x'
,
-padx
=>
$BUTTONPADX
,
%stdpad
);
my
$hl
=
$frame_middle1
->Scrolled(
'HList'
,
-scrollbars
=>
"se"
,
-relief
=>
'flat'
,
-header
=> 1,
-columns
=> 7,
-selectbackground
=>
'white'
,
%{
$hlistopts
[0] }
)->
pack
(
-expand
=> 1,
-fill
=>
'both'
,
%stdpad
);
my
$col
= 0;
for
(
'N'
,
'Field'
,
'Header'
,
'ML'
,
'Datetime format'
,
'Datetime locale'
) {
$hl
->header(
'create'
,
$col
++,
-text
=>
$_
);
}
my
$stdout_box
=
$frame_middle2
->Scrolled(
'ROText'
,
-scrollbars
=>
"e"
,
-relief
=>
'flat'
,
-font
=> [
-family
=>
'courier'
,
-size
=>
$FONTSIZE
,
-weight
=>
'normal'
],
-height
=> 8
)->
pack
(
-expand
=> 1,
-fill
=>
"x"
,
%stdpad
);
my
$trick
=
$stdout_box
->Subwidget(
'scrolled'
);
tie
*STDERR
,
ref
$trick
,
$stdout_box
;
$frame_middle1
->DropSite(
-dropcommand
=> [ \
&accept_drop
,
$frame_middle2
],
-droptypes
=> [
'Local'
],
);
$frame_middle2
->DropSite(
-dropcommand
=> [ \
&accept_drop
,
$frame_middle2
],
-droptypes
=> [
'Local'
],
);
sub
accept_drop {
my
$frame
=
shift
;
my
$file_name
=
$frame
->SelectionGet(
-selection
=>
'CLIPBOARD'
);
$file_name
=~ s/\n.*$//m;
set_text(
$ctrl_in_file
,
$file_name
);
c_execute(
'read'
);
return
;
}
$frame_bottom
->Label(
-text
=>
' * Comma-separated list ** Try UTF-8, fall back on iso-8859-1 '
.
'*** strptime format, see Help menu **** 2-letter country codes'
,
%labopts
)->
pack
(
-side
=>
'left'
,
%stdpad
);
cmd_update_enabled_disabled(
$ctrl_sep_char
,
'sep_char_detect'
);
cmd_update_enabled_disabled(
$ctrl_escape_char
,
'escape_char_detect'
);
cmd_update_enabled_disabled(
$ctrl_encoding
,
'encoding_detect'
);
cmd_update_enabled_disabled(
$ctrl_dates_formats_to_try
,
'dates_formats_to_try_detect'
);
cmd_update_enabled_disabled(
$ctrl_dates_locales
,
'dates_locales_detect'
);
cmd_update_enabled_disabled(
$ctrl_out_sep_char
,
'out_sep_char_useinput'
);
cmd_update_enabled_disabled(
$ctrl_out_quote_char
,
'out_quote_char_useinput'
);
cmd_update_enabled_disabled(
$ctrl_out_escape_char
,
'out_escape_char_useinput'
);
cmd_update_enabled_disabled(
$ctrl_out_encoding
,
'out_encoding_useinput'
);
cmd_update_enabled_disabled(
$ctrl_out_always_quote
,
'out_always_quote_useinput'
);
cmd_update_enabled_disabled(
$ctrl_out_dates_format
,
'out_dates_format_useinput'
);
cmd_update_enabled_disabled(
$ctrl_out_dates_locale
,
'out_dates_locale_useinput'
);
if
(
$read_it
ne
''
) {
c_execute(
'read'
);
}
MainLoop;
exit
;
sub
c_strptime {
open_browser(
"http://search.cpan.org/~drolsky/DateTime-Format-Strptime-1.74/lib/DateTime/Format/Strptime.pm#STRPTIME_PATTERN_TOKENS"
);
return
;
}
sub
window_center {
my
$w
=
shift
;
$w
->withdraw();
$w
->update();
my
$xpos
=
int
( (
$w
->screenwidth -
$w
->width ) / 2 );
my
$ypos
=
int
( (
$w
->screenheight -
$w
->height ) / 2 );
$w
->geometry(
"+$xpos+$ypos"
);
$w
->deiconify();
return
;
}
sub
c_about {
state
$count_about
= 0;
return
if
$count_about
;
$count_about
++;
my
$w
=
$main_window
->Toplevel;
$w
->title(
"About tkcsvcopy.pl"
);
$w
->Label(
-text
=>
<<"EOF" ,
TK CSV COPY version $VERSION
Copy CSV files, modifying some CSV-level (separator) or higher-level (date
format) throughout the copy.
Copyright 2017 Sébastien Millet <milletseb\@laposte.net>
EOF
-font
=> [
-size
=> 12 ]
)->
pack
(
-side
=>
"top"
,
-padx
=> 8 );
$w
->Button(
-text
=>
"Ok"
,
-font
=> [
-size
=> 12 ],
-command
=>
sub
{
$w
->destroy(); }
)->
pack
(
-side
=>
"bottom"
,
-pady
=> 8 );
$w
->resizable( 0, 0 );
$w
->OnDestroy(
sub
{
$count_about
--; } );
window_center(
$w
);
return
;
}
sub
set_text {
my
(
$text_widget
,
$new_value
) =
@_
;
$text_widget
->
delete
(
'0.0'
,
'end'
);
$text_widget
->insert(
'end'
,
$new_value
);
return
;
}
sub
c_browse_input {
my
$types
= [ [
'CSV Files'
,
'.csv'
], [
'All Files'
,
'*'
] ];
my
$file_name
=
$main_window
->getOpenFile(
-filetypes
=>
$types
);
return
if
( !
defined
$file_name
) or
$file_name
eq
''
;
set_text(
$ctrl_in_file
,
$file_name
);
return
;
}
sub
c_browse_output {
my
$types
= [ [
'CSV Files'
,
'.csv'
], [
'All Files'
,
'*'
] ];
my
$file_name
=
$main_window
->getSaveFile(
-filetypes
=>
$types
,
-defaultextension
=>
'csv'
);
return
if
( !
defined
$file_name
) or
$file_name
eq
''
;
set_text(
$entry_output
,
$file_name
);
return
;
}
sub
reset_display {
$stdout_box
->
delete
(
'0.0'
,
'end'
);
$hl
->
delete
(
'all'
);
return
;
}
sub
get_text_autocsv_opts {
my
%table
= (
'in_file'
=>
''
,
'sep_char'
=>
'sep_char_detect'
,
'quote_char'
=>
''
,
'escape_char'
=>
'escape_char_detect'
,
'encoding'
=>
'encoding_detect'
,
'dates_formats_to_try@'
=>
'dates_formats_to_try_detect'
,
'dates_locales'
=>
'dates_locales_detect'
,
'out_file'
=>
''
,
'out_sep_char'
=>
'out_sep_char_useinput'
,
'out_quote_char'
=>
'out_quote_char_useinput'
,
'out_escape_char'
=>
'out_escape_char_useinput'
,
'out_encoding'
=>
'out_encoding_useinput'
,
'out_always_quote!'
=>
'out_always_quote_useinput'
,
'out_dates_format'
=>
'out_dates_format_useinput'
,
'out_dates_locale'
=>
'out_dates_locale_useinput'
,
'out_utf8_bom'
=>
''
,
'fields_dates_auto_optimize'
=>
''
);
my
$e
= 0;
my
$what
=
$_
[0];
my
@senses
= [
'in_file'
,
'input'
];
push
@senses
, [
'out_file'
,
'output'
]
if
$what
eq
'write'
;
for
my
$i
(
@senses
) {
my
$val
=
$db
{
$i
->[0] };
if
( ( !
defined
$val
) or
$val
=~ /^\s*$/ ) {
print
( STDERR
"Error: you must specify an $i->[1].\n"
);
$e
++;
}
}
my
%opts
;
for
my
$k
(
sort
keys
%table
) {
my
$f
=
$k
;
$f
=~ s/[\@!]$//;
next
if
$table
{
$k
} ne
''
and
$db
{
$table
{
$k
} };
next
if
$what
eq
'read'
and
$f
=~ /^out_/;
my
$v
=
$db
{
$f
} //
''
;
$v
= [
split
( /\s*,\s*/,
$v
) ]
if
$k
=~ /\@$/;
if
(
$k
=~ /!$/ ) {
if
(
$v
=~ /^yes$/i ) {
$v
= 1;
}
elsif
(
$v
=~ /^
no
$/i ) {
$v
= 0;
}
else
{
print
( STDERR
"Error: $f must be either 'yes' or 'no'.\n"
);
$v
= 0;
$e
++;
}
}
if
( ( !
ref
$v
) and
length
(
$v
) == 2 and
substr
(
$v
, 0, 1 ) eq
"\\"
) {
$v
=
eval
"\"$v\""
or
die
$@;
}
$opts
{
$f
} =
$v
;
}
$opts
{dates_search_time} = 0
if
exists
$opts
{dates_formats_to_try};
return
if
$e
;
return
%opts
;
}
sub
update_table_fields {
my
$coldata
=
$_
[0];
my
@fields
;
@fields
=
@$coldata
if
defined
$coldata
;
my
@style_align_right
;
my
@style_align_left
;
for
( 0 .. 1 ) {
push
@style_align_right
,
$hl
->ItemStyle(
'text'
,
-anchor
=>
'e'
,
%{
$hlistopts
[
$_
] }
);
push
@style_align_left
,
$hl
->ItemStyle(
'text'
,
-anchor
=>
'w'
,
%{
$hlistopts
[
$_
] }
);
}
my
@correspondance
= ( 0, 1, 5, 3, 4 );
for
my
$if
( 0 ..
$#fields
) {
my
$f
=
$fields
[
$if
];
my
$e
=
$hl
->addchild(
""
);
$hl
->itemCreate(
$e
, 0,
-itemtype
=>
'text'
,
-text
=>
"$if"
,
-style
=>
$style_align_right
[
$if
% 2 ]
);
for
my
$i
( 0 .. 4 ) {
$hl
->itemCreate(
$e
,
$i
+ 1,
-itemtype
=>
'text'
,
-text
=>
$f
->[
$correspondance
[
$i
] ],
-style
=>
$style_align_left
[
$if
% 2 ]
);
}
}
return
;
}
sub
output_err {
my
$err
=
shift
;
return
0
if
!
$err
;
$err
=~ s/\n.*//sm;
$err
=~ s/(\S) at \S.* line \d+\.$/$1/;
print
( STDERR
"$err\n"
);
return
1;
}
my
$p_fw
;
my
$p_bar
;
my
(
$p_cur_row
,
$p_nb_rows
);
sub
c_execute {
my
$what
=
$_
[0];
die
"FATAL: internal error"
if
$what
!~ /^
read
|
write
$/;
my
$writing
= (
$what
eq
'write'
);
reset_display();
my
%opts
= get_text_autocsv_opts(
$what
);
return
if
!
%opts
;
$stdout_box
->insert(
'end'
,
"Reading...\n"
);
$main_window
->Busy();
$main_window
->update();
if
(
$writing
) {
$p_cur_row
= 0;
$p_fw
=
$main_window
->Toplevel(
-title
=>
'Copying...'
);
$p_fw
->geometry(
'250x20'
);
$p_fw
->resizable( 0, 0 );
window_center(
$p_fw
);
$p_bar
=
$p_fw
->ProgressBar(
-from
=> 0,
-to
=> 1,
-blocks
=> 1,
-troughcolor
=>
'white'
,
-foreground
=>
'dark blue'
)->
pack
(
-expand
=> 1,
-fill
=>
'both'
);
$p_fw
->focus();
$p_fw
->protocol(
'WM_DELETE_WINDOW'
, \
&Tk::NoOp
);
$p_fw
->stayOnTop();
p_bar_update();
}
reset_display();
my
$coldata
;
eval
{
my
$csv
= Text::AutoCSV->new(
fields_dates_auto
=> 1,
verbose
=> 1,
walker_hr
=> \
&p_bar_update
,
%opts
);
$coldata
= [
$csv
->get_coldata() ];
$p_nb_rows
=
$csv
->get_nb_rows() // 0;
$p_bar
->configure(
-to
=> (
$p_nb_rows
< 1 ? 1 :
$p_nb_rows
) )
if
$writing
;
$stdout_box
->insert(
'end'
,
'-- '
.
$csv
->get_in_file_disp() .
"\n"
);
$stdout_box
->insert(
'end'
,
'number of records: '
. (
$p_nb_rows
- 1 ) .
"\n"
);
my
$c
= Text::AutoCSV::_render(
$csv
->get_sep_char() );
$stdout_box
->insert(
'end'
,
'sep_char: '
.
$c
.
"\n"
);
$stdout_box
->insert(
'end'
,
'escape_char: '
.
$csv
->get_escape_char() .
"\n"
);
$stdout_box
->insert(
'end'
,
'encoding: '
.
$csv
->get_in_encoding() .
"\n"
);
$stdout_box
->insert(
'end'
,
'is always quoted: '
. (
$csv
->get_is_always_quoted() ?
'yes'
:
'no'
)
.
"\n"
);
if
(
$writing
) {
$stdout_box
->insert(
'end'
,
"\n"
);
update_table_fields(
$coldata
);
$csv
->
write
();
}
1;
};
output_err($@);
do
{
$p_fw
->destroy();
$p_fw
=
undef
;
}
if
$writing
;
update_table_fields(
$coldata
)
if
!
$writing
;
$main_window
->Unbusy();
return
;
}
sub
p_bar_update {
$p_cur_row
++;
if
(
$p_cur_row
% 50 == 0 ) {
$p_bar
->value(
$p_cur_row
);
$main_window
->update();
}
return
;
}