Tk-MK
view release on metacpan or search on metacpan
lib/Tk/Treeplus.pm view on Meta::CPAN
"6 3 2 1",
". c none",
"X c black",
"XXXXXX",
".XXXX.",
"..XX..",
};
down_EOP
$IconData{Filter} = <<'filter_EOP';
/* XPM */
static char *Filter[] = {
"12 7 3 1",
". c none",
"X c black",
"X c grey",
"..XXXXXXXX..",
"...XXXXXX...",
"....XXXX....",
".....XX.....",
".....XX.....",
".....XX.....",
".....XX.....",
};
filter_EOP
#--------------------------------------------------------------------------------------------------
#--------------------------------------------------------------------------------------------------
sub ClassInit
{
my ($class, $window) = (@_);
$class->SUPER::ClassInit($window);
}
#--------------------------------------------------------------------------------------------------
sub Populate
{
my ($this, $args) = @_;
# Setup a default Headerstyle
$this->{__TP_HeaderInfo}{Style} = delete $args->{-headerstyle} ||
$this->ItemStyle('window', -padx => '0', -pady => '0', -anchor => 'nw');
# Create the movable ColumnBar
$this->{__TP_ResizeInfo}{ColumnBar} = $this->Frame(
-background => delete $args->{-trimbackground} || 'white',
-relief => 'raised',
-borderwidth => 2,
-width => 2,
);
$this->SUPER::Populate($args);
$this->ConfigSpecs(
#
-wrapsearch => ['PASSIVE', 'wrapsearch', 'Wrapsearch', 0 ],
#
-maxselhistory => ['PASSIVE', 'maxselhistory', 'Maxselhistory', MAX_HISTORY_SIZE ],
#
-clipboardseparator => ['PASSIVE', 'clipboardseparator', 'Clipboardseparator', DEFAULT_CLIPBOARD_SEPARATOR ],
#
-headerminwidth => ['PASSIVE', 'minwidth', 'MinWidth', 20 ],
-headerclosedwidth => ['PASSIVE', 'closedwidth', 'ClosedMinWidth', 5 ],
#
-headerforeground => ['PASSIVE', 'headerForeground', 'HeaderForeground', 'black'],
-headerbackground => ['PASSIVE', 'headerBackground', 'HeaderBackground', '#d9d9d9'],
-headeractiveforeground => ['PASSIVE', 'headerActiveforeground', 'HeaderActiveforeground', 'black'],
-headeractivebackground => ['PASSIVE', 'headerActivebackground', 'HeaderActivebackground', 'gray'],
#
# Internal, activates the headers for convenience
-header => ['SELF', 'header', 'Header', 1 ],
);
# Initialize the 'Auto-add-HeaderColumn' counter
$this->{__TP_LastColumn} = 0;
}
#----------------------------------------------------------------------
# Add-ons for misc functions
#----------------------------------------------------------------------
sub activateEntry
{
# Parameter
my ($this, $path) = @_;
# Locals
my ($sep_char, $parent, $browsecmd);
# Delete any previous selection
$this->selectionClear;
if ($this->infoExists($path)) {
# Take care of hidden parents
$sep_char = quotemeta($this->cget('-separator'));
if ($path =~ /$sep_char/o) {
$parent = $path;
while (($parent = $this->infoParent($parent))) {
$this->open($parent);
}
}
$this->see($path);
$this->selectionSet($path);
# avoid any secondary selection
$this->anchorClear;
# Finally continue with the official callback
$browsecmd = $this->cget('-browsecmd');
$browsecmd->Call($path) if $browsecmd;
}
# else {
# print "DBG: activateEntry() Called with >@_< by >", caller, "< , path [$path] is NOT a valid entry in this list.\n";
# }
}
#----------------------------------------------------------------------
# Add-ons for the new '_Sort & _Filter' Header function
#----------------------------------------------------------------------
lib/Tk/Treeplus.pm view on Meta::CPAN
my $column_name = $col_search->{$column};
my $var = $this->{__TP_ResizeInfo}{$column}{TrimActive}; # Closure !
my $column_curr = $column; # Closure !
if ($single_column) {
$submenu = $resize_submenu
}
else {
$submenu = $resize_submenu->cascade(
-label => ucfirst($column_name),
-tearoff => '0',
);
}
$submenu->checkbutton(
# -label => ($single_column ? 'Dynamic Column-Resizing' : ucfirst($column_name)),
-label => 'Dynamic Column-Resizing',
-command => sub { $this->{__TP_ResizeInfo}{$column_curr}{TrimActive} = $var;
$this->TrimEnable($column_curr, $var);
},
-variable => \$var,
);
$submenu2 = $submenu->cascade(
-label => 'Column Width',
-tearoff => '0',
-state => $this->{__TP_ResizeInfo}{$column}{TrimActive} ? 'normal' : 'disabled',
);
$submenu2->command(
-label => 'Auto',
-command => sub { $this->SetColumnWidth($column_curr, 'Auto') },
-accelerator => $accelerator1
);
$submenu2->command(
-label => 'Last',
-command => sub { $this->SetColumnWidth($column_curr, 'Last') },
);
$submenu2->command(
-label => 'Min',
-command => sub { $this->SetColumnWidth($column_curr, 'Min') },
);
$submenu2->command(
-label => 'Closed',
-command => sub { $this->SetColumnWidth($column_curr, 'Close') },
)
}
#-------------------------------------
unless ($single_column) {
$resize_submenu->separator;
$resize_submenu->command(
-label => 'Restore DEFAULT',
-command => sub { map { $this->SetColumnWidth($_, 'Auto') } @all_columns },
)
}
#------------------------------------------------------------------------
$menu->separator;
$xclip_submenu = $menu->cascade(
-label => 'X-ClipBoard',
-tearoff => '0',
);
$xclip_submenu->command(
-label => 'Export Selected Entry(ies)',
-command => sub { $this->__copy_selection_to_clipboard() },
-accelerator => 'Ctrl-c'
);
$xclip_submenu->command(
-label => 'Export Selection + Column Headers',
-command => sub { $this->__copy_selection_to_clipboard('use_header_info') },
-accelerator => 'Ctrl-C'
);
# Set some default bindings
$this->bind('<Control-c>' => sub { $this->__copy_selection_to_clipboard() } );
$this->bind('<Control-C>' => sub { $this->__copy_selection_to_clipboard('use_header_info') } );
$this->bind('<Control-f>' => sub { $this->__find_hlentry(0) } );
#------------------------------------------------------------------------
$menu->Popup(-popover => 'cursor', -popanchor => 'nw');
}
#--------------------------------------------------------------------------------------------------
#
# InitializeSelectHistory()
#
# IN : I<-listwidget => list-widget>, I<-event_binding => alternate pop-up-event>
#
# OUT: I<--->
#
# B<Description>:
# Add an interceptor for the browsecommand callback to store the last 10 selections
#
#--------------------------------------------------------------------------------------------------
sub InitializeSelectHistory
{
#print "called AddPopUpListOperations with >@_< from ", caller, "<\n";
# Parameter
my $this = $_[0];
# Locals
my ($browsecmd);
#------------------------------------------------------------------------
# Rough Check
return if $this->{__TP_SelectHistoryEngaged};
#------------------------------------------------------------------------
$browsecmd = $this->cget('-browsecmd'); #print "DBG: variable [\$browsecmd] = >$browsecmd<\n";
if ($browsecmd) {
$this->{__TP_SelectHistoryEngaged} = 1;
$this->configure(-browsecmd =>
sub { #print "DBG: reached function [browsecmd-interceptor] with >@_<, called by >", caller, "<\n";
#Parameters
my ($path, @args) = @_;
# Locals
my ($this_id, $select_history, $parent, @path, $entry_txt);
# FailSafe: Avoid circular invocations
return if $this->{BrowseCmdOngoing};
local $this->{BrowseCmdOngoing} = 1;
unless (@args) {
$this_id = $this->id;
$this->{__TP_SelectHistory} = [] unless $this->{__TP_SelectHistory};
$select_history = $this->{__TP_SelectHistory};
# Latch only different calls
unless (grep m/^$path$/, map {$_->[2]} @$select_history) {
$parent = $this->infoParent($path);
if ($parent) {
@path = $this->itemCget($path, 0, '-text');
while ($parent) {
push @path, $this->itemCget($parent, 0, '-text');
$parent = $this->infoParent($parent);
}
lib/Tk/Treeplus.pm view on Meta::CPAN
-value => $old_pattern,
-buttons => ['Set', ($fpinfo->{Active}{$column} ? ('Clear') : ()), 'Cancel'],
-title => 'Column Filter for [' . $column_name . ']',
-label => 'FilterPattern: ',
-validatecommand => sub { return $_[1] =~ /[\w\:?\*\.\-\+\^\$\[\]\(\)\{\}\\\|\s]/o },
);
# Filter out invalid keys that would be undeletable otherwise
$new_pattern =~ s/\'|\"//go;
if ($cmd =~ /Set/io) {
$fpinfo->{Active}{$column} = 1;
$fpinfo->{Pattern}{$column} = $new_pattern;
$fpinfo->{PatternRE}{$column} = qr/$new_pattern/;
#-------------------------------------------------
# Adopt the Column Headers
$this->RefreshColumnHeader($column);
#-------------------------------------------------
# Filter the displayed-List
$cmd = 'FILTER';
}
}
if ($cmd =~ /REMOVE|CLEAR/io) {
my ($del_column, @columns);
if ($cmd =~ /ALL/io) {
@columns = keys %{$fpinfo->{Active}}
}
else {
@columns = $column
}
foreach $del_column (@columns) {
# Clear the active -flag but keep the pattern for convenience
delete $fpinfo->{Active}{$del_column};
#-------------------------------------------------
# Adopt the Column Headers
$this->RefreshColumnHeader($del_column)
}
#-------------------------------------------------
# Filter the displayed-List
$cmd = 'FILTER';
}
# Second Cycle: Take care of the cmd-changes of ASK-/Remove-mode
if ($cmd =~ /FILTER|REFRESH/io) {
# Clear it to avoid accumulation of enabled filters
my $filter_info = $fpinfo->{Filter} = {};
# Rebuild the current pattern matrix
foreach $column (sort {$a<=>$b} keys %{$fpinfo->{Active}}) {
$filter_info->{$column} = $fpinfo->{PatternRE}{$column} if $fpinfo->{Active}{$column}
}
# Execute the filter
$this->__filter_hlentry_r($filter_info, '')
}
}
#-----------------------------------------------------------------
# Very internal related function, NOT to be invoked by user apps
#-----------------------------------------------------------------
# Transfers the current selected entries of the given
# widget into the common X11-Clipboard.
sub __copy_selection_to_clipboard
{
#print "DBG: reached function [__copy_selection_to_clipboard] with >@_<, called by >", caller, "<\n";
# Parameter
my ($this, $use_header_info) = @_;
# Locals
my (@selitems, $selectforeground, $selectbackground, $text, $clip_txt,
$wclass, $col_cnt, $clipboard_column_separator, $column, $entry);
return unless $this;
@selitems = $this->infoSelection();
if (@selitems) {
$selectforeground = $this->cget('-selectforeground');
$selectbackground = $this->cget('-selectbackground');
$wclass = ref $this; $clip_txt = '';
$col_cnt = $this->cget('-columns');
$clipboard_column_separator = $this->cget('-clipboardseparator');
if ($wclass =~ /HList|Tree/io and $use_header_info and $this->cget('-header')) {
for ($column = 0; $column < $col_cnt; $column++) {
$clip_txt .= $clipboard_column_separator if $clip_txt;
$clip_txt .= $this->headerCget($column, '-text');
}
#print "DBG: header: [\$clip_txt] = >$clip_txt<\n";
}
# REtrieve all selected items
foreach (@selitems) {
if ($wclass =~ /TList/io) {
$text = $this->entrycget($_, '-text');
}
elsif ($wclass =~ /HList|Tree/io) {
$text = '';
for ($column = 0; $column < $col_cnt; $column++) {
$text .= $clipboard_column_separator if length $text;
$entry = $this->itemCget($_, $column, '-text'); $entry = '' unless defined $entry;
$text .= $entry;
}
}
else {
last; # don't do anything on unspecific widget types
}
$clip_txt .= "\n" if $clip_txt;
$clip_txt .= $text;
}
if ($clip_txt) {
# Update the global (unix) Clipboard
$this->clipboardClear();
$this->clipboardAppend($clip_txt);
$this->configure( -selectforeground => 'black',
-selectbackground => ($use_header_info ? 'lawngreen' : 'darkgreen'),
);
#print "DBG: Copied Entries [$clip_txt] from Widget [$wclass] to global X-clipboard.\n"
}
else {
$this->clipboardClear();
$this->clipboardAppend($clip_txt);
$this->configure( -selectforeground => 'white',
-selectbackground => 'darkred',
);
carp "Internal Warning: Failed to copy Entries from Widget [$wclass] to global X-clipboard!\n"
}
$this->update;
usleep(900000);
$this->configure( -selectforeground => $this->cget('-foreground'),
-selectbackground => $this->cget('-background'),
);
$this->update;
usleep(300000);
# Restore original settings
$this->configure(
-selectforeground => $selectforeground,
-selectbackground => $selectbackground,
);
$this->update;
}
}
#-----------------------------------------------------------------
# Very internal related function, NOT to be invoked by user apps
#-----------------------------------------------------------------
sub __find_hlentry
{
# Parameter
my ($this, $column, $find_next_flag) = @_;
# Locals
my ($search_info, $is_numeric_col, $search_item, $path, $parent, $answer);
# Some shortcuts
$is_numeric_col = $this->{__TP_HeaderInfo}{$column}{SortNumeric};
$search_info = $this->{__TP_SearchInfo};
$search_item = $search_info->{SearchPattern}{$column};
#----------------------------------------------------------------------------------------------
if ($find_next_flag and $search_item) {
$answer = 'Find Next';
}
else {
my $column_name = $search_info->{Columns}{$column};
($search_item, $answer) = $this->EnterStringDlg(
-default_button => 'Find',
-value => $search_item,
-buttons => ['Find',
(($column_name and $search_item and not $is_numeric_col)
? ('Find Next') : ()), 'Cancel'],
-title => 'Enter Search Item [' . $column_name . ']',
-label => "Find '$column_name': ",
-validatecommand => sub { my $value = $_[1]||'';
if ($column_name eq 'ID') {
return $value =~ /[\d\-]/o
}
else {
return $value =~ /[\w\?\*\.\-\+\^\$\[\]\(\)\\\|\s]/o
}
},
);
return if $answer eq 'Cancel';
}
lib/Tk/Treeplus.pm view on Meta::CPAN
=item B<headerCget()>
=over 8
=item B<-command>
Retrieve the current I<custom command> assigned to the probed column header
=item B<-resize_column>
Retrieve the current I<resize status> (0/1) of the probed column (header)
=item B<-sort_numeric>
Retrieve the current I<sort_numeric status> (0/1) of the probed column (header)
=item B<-widget> (B<SPECIAL-purpose only>)
This command allows with B<-widget> to retrieve the Headerbutton-Widget Reference.
B<NOTE>: This is only useful for very experienced users!
=back
=item B<initSort()>
'initSort( [new_primary_column] )' refreshes the list/tree content
and sorts it according the current settings for the primary sort columns (B<PRIMARYCOLUMN>).
Additionally it takes current filter settings into consideration.
=item B<activateEntry()>
'activateEntry(path)' selects the given entry (if it is existing), opens it (and its parents)
incase it is hidden and executes a potential browsecmd callback on it.
(This is equivalent to clicking an entry in the GUI)
=item B<advancedHeaderCreate()>
This is an easy-to-use wrapper for
'headerCreate($col++, -itemtype => 'advancedheader', -<...> ... )', it avoids the app to
trace the column numbers and the '-itemtype => 'advancedheader' during headercreate().
Every invocation creates another column header for the next unused column (0,1,...I<n>)
(NB> Max column number I<n> must be set in advance during treeplus item-creation.
=back
=head1 OPTIONS (CreateTime)
=over 4
=item B<-wrapsearch> 0/1
Decides whether the I<Find> search will restart from the begin of the list in case it reaches the end.
=item B<-maxselhistory> nnn
Specifies the maximum number of I<chached> list-selection operations, which can be recalled via the pop-up-menu.
=item B<-clipboardseparator> CHAR
Specifies the B<colum separator character> which is used if the the current selection is export to the X11 Clipboard.
This operation can be done via CTRl-C or via the pop-up-menu. (default char: '|')
=item B<-headerminwidth> nnn
Specifies the minimum size of a column during custom column resizing operation (default: 20px)
=item B<-headerclosedwidth> nnn
Specifies the size of a I<closed> column (default: 5px)
=item B<-headerforeground> COLOR
The foreground color used for the column Header in normal state.
=item B<-headerbackground> COLOR
The background color used for the column Header in normal state.
=item B<-headeractiveforeground> COLOR
The foreground color used for the column Header during active state (Mouse over Header).
=item B<-headeractivebackground> COLOR
The background color used for the column Header during active state (Mouse over Header).
=back
=head1 AUTHORS
Michael Krause, KrauseM_AT_gmx_DOT_net
This code may be distributed under the same conditions as Perl.
V0.4 (C) February 2013
=cut
###
### EOF
###
( run in 2.911 seconds using v1.01-cache-2.11-cpan-84e82930d8c )